| 1 | ++ |
+ do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
+ |
+
| 2 | ++ |
+ ## cols = NULL, value) {
+ |
+
| 3 | ++ |
+ ## don't want this in the recursive function+ |
+
| 4 | ++ |
+ ## so thats why we have the do_ variant+ |
+
| 5 | +168x | +
+ if (is.character(path) && length(path) > 1) {
+ |
+
| 6 | +143x | +
+ path <- as.list(path)+ |
+
| 7 | ++ |
+ }+ |
+
| 8 | +168x | +
+ if (length(path) > 0 && path[[1]] == obj_name(tab)) {
+ |
+
| 9 | +144x | +
+ path <- path[-1]+ |
+
| 10 | ++ |
+ }+ |
+
| 11 | +168x | +
+ recursive_replace(tab, path, value) ## incontent, rows, cols,value)+ |
+
| 12 | ++ |
+ }+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ ## different cases we want to support:+ |
+
| 15 | ++ |
+ ## 1. Replace entire children for a particular node/position in the tree+ |
+
| 16 | ++ |
+ ## 2. Replace entire rows at a particular (ElementaryTable) position within the+ |
+
| 17 | ++ |
+ ## tree+ |
+
| 18 | ++ |
+ ## 3. Replace specific cell values within a set of row x column positions within+ |
+
| 19 | ++ |
+ ## an ElementaryTable at a particular position within the tree+ |
+
| 20 | ++ |
+ ## 3. replace entire content table at a node position+ |
+
| 21 | ++ |
+ ## 4. replace entire rows within the content table at a particular node position+ |
+
| 22 | ++ |
+ ## in the tree+ |
+
| 23 | ++ |
+ ## 5. replace data cell values for specific row/col positions within the content+ |
+
| 24 | ++ |
+ ## table at a particular position within the tree+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ ## XXX This is wrong, what happens if a split (or more accurately, value)+ |
+
| 27 | ++ |
+ ## happens more than once in the overall tree???+ |
+
| 28 | ++ |
+ recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
+ |
+
| 29 | +675x | +
+ if (length(path) == 0) { ## done recursing
+ |
+
| 30 | ++ |
+ ## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
+ |
+
| 31 | ++ |
+ ## if(incontent) {
+ |
+
| 32 | ++ |
+ ## newkid = tab+ |
+
| 33 | ++ |
+ ## content_table(newkid) = value+ |
+
| 34 | ++ |
+ ## } else+ |
+
| 35 | +171x | +
+ newkid <- value+ |
+
| 36 | ++ |
+ ## newkid has either thee content table+ |
+
| 37 | ++ |
+ ## replaced on the old kid or is the new+ |
+
| 38 | ++ |
+ ## kid+ |
+
| 39 | ++ |
+ # } ## else { ## rows or cols (or both) non-null
+ |
+
| 40 | ++ |
+ ## if(incontent) {
+ |
+
| 41 | ++ |
+ ## ctab = content_table(tab)+ |
+
| 42 | ++ |
+ ## ctab[rows, cols] = value+ |
+
| 43 | ++ |
+ ## content_table(tab) = ctab+ |
+
| 44 | ++ |
+ ## newkid = tab+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ ## } else {
+ |
+
| 47 | ++ |
+ ## allkids = tree_children(tab)+ |
+
| 48 | ++ |
+ ## stopifnot(are(allkids, "TableRow"))+ |
+
| 49 | ++ |
+ ## newkid = tab+ |
+
| 50 | ++ |
+ ## newkid[rows, cols] = value+ |
+
| 51 | ++ |
+ ## }+ |
+
| 52 | ++ |
+ ## }+ |
+
| 53 | +171x | +
+ return(newkid)+ |
+
| 54 | +504x | +
+ } else if (path[[1]] == "@content") {
+ |
+
| 55 | +25x | +
+ ctb <- content_table(tab)+ |
+
| 56 | +25x | +
+ ctb <- recursive_replace(ctb,+ |
+
| 57 | +25x | +
+ path = path[-1],+ |
+
| 58 | ++ |
+ ## rows = rows,+ |
+
| 59 | ++ |
+ ## cols = cols,+ |
+
| 60 | +25x | +
+ value = value+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | +25x | +
+ content_table(tab) <- ctb+ |
+
| 63 | +25x | +
+ tab+ |
+
| 64 | ++ |
+ } else { ## length(path) > 1, more recursing to do
+ |
+
| 65 | +479x | +
+ kidel <- path[[1]]+ |
+
| 66 | ++ |
+ ## broken up for debugabiliity, could be a single complex+ |
+
| 67 | ++ |
+ ## expression+ |
+
| 68 | ++ |
+ ## for now only the last step supports selecting+ |
+
| 69 | ++ |
+ ## multiple kids+ |
+
| 70 | +479x | +
+ stopifnot(+ |
+
| 71 | +479x | +
+ length(kidel) == 1,+ |
+
| 72 | +479x | +
+ is.character(kidel) || is.factor(kidel)+ |
+
| 73 | ++ |
+ )+ |
+
| 74 | +479x | +
+ knms <- names(tree_children(tab))+ |
+
| 75 | +479x | +
+ if (!(kidel %in% knms)) {
+ |
+
| 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 | ++ |
+ }+ |
+
| 80 | +! | +
+ if (is.factor(kidel)) kidel <- levels(kidel)[kidel]+ |
+
| 81 | +479x | +
+ newkid <- recursive_replace(+ |
+
| 82 | +479x | +
+ tree_children(tab)[[kidel]],+ |
+
| 83 | +479x | +
+ path[-1],+ |
+
| 84 | ++ |
+ ## incontent = incontent,+ |
+
| 85 | ++ |
+ ## rows = rows,+ |
+
| 86 | ++ |
+ ## cols = cols,+ |
+
| 87 | +479x | +
+ value+ |
+
| 88 | ++ |
+ )+ |
+
| 89 | +479x | +
+ tree_children(tab)[[kidel]] <- newkid+ |
+
| 90 | +479x | +
+ tab+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | ++ | + + | +
| 94 | +1x | +
+ coltree_split <- function(ctree) ctree@split+ |
+
| 95 | ++ | + + | +
| 96 | ++ |
+ col_fnotes_at_path <- function(ctree, path, fnotes) {
+ |
+
| 97 | +2x | +
+ if (length(path) == 0) {
+ |
+
| 98 | +1x | +
+ col_footnotes(ctree) <- fnotes+ |
+
| 99 | +1x | +
+ return(ctree)+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | +1x | +
+ if (identical(path[1], obj_name(coltree_split(ctree)))) {
+ |
+
| 103 | +1x | +
+ path <- path[-1]+ |
+
| 104 | ++ |
+ } else {
+ |
+
| 105 | +! | +
+ stop(paste("Path appears invalid at step:", path[1]))
+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | +1x | +
+ kids <- tree_children(ctree)+ |
+
| 109 | +1x | +
+ kidel <- path[[1]]+ |
+
| 110 | +1x | +
+ knms <- names(kids)+ |
+
| 111 | +1x | +
+ stopifnot(kidel %in% knms)+ |
+
| 112 | +1x | +
+ newkid <- col_fnotes_at_path(kids[[kidel]],+ |
+
| 113 | +1x | +
+ path[-1],+ |
+
| 114 | +1x | +
+ fnotes = fnotes+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | +1x | +
+ kids[[kidel]] <- newkid+ |
+
| 117 | +1x | +
+ tree_children(ctree) <- kids+ |
+
| 118 | +1x | +
+ ctree+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ | + + | +
| 121 | ++ |
+ #' Insert row at path+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and+ |
+
| 124 | ++ |
+ #' non-label) row, specified by its path.+ |
+
| 125 | ++ |
+ #'+ |
+
| 126 | ++ |
+ #' @inheritParams gen_args+ |
+
| 127 | ++ |
+ #' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after+ |
+
| 128 | ++ |
+ #' (`TRUE`) the row specified by `path`.+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' @seealso [DataRow()], [rrow()]+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @examples+ |
+
| 133 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 134 | ++ |
+ #' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
+ |
+
| 135 | ++ |
+ #' analyze("AGE")
+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' tbl2 <- insert_row_at_path(+ |
+
| 140 | ++ |
+ #' tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
+ |
+
| 141 | ++ |
+ #' rrow("new row", 555)
+ |
+
| 142 | ++ |
+ #' )+ |
+
| 143 | ++ |
+ #' tbl2+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
+ |
+
| 146 | ++ |
+ #' rrow("new row redux", 888),
+ |
+
| 147 | ++ |
+ #' after = TRUE+ |
+
| 148 | ++ |
+ #' )+ |
+
| 149 | ++ |
+ #' tbl3+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' @export+ |
+
| 152 | ++ |
+ setGeneric("insert_row_at_path",
+ |
+
| 153 | ++ |
+ signature = c("tt", "value"),
+ |
+
| 154 | ++ |
+ function(tt, path, value, after = FALSE) {
+ |
+
| 155 | +6x | +
+ standardGeneric("insert_row_at_path")
+ |
+
| 156 | ++ |
+ }+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ #' @rdname insert_row_at_path+ |
+
| 160 | ++ |
+ setMethod(+ |
+
| 161 | ++ |
+ "insert_row_at_path", c("VTableTree", "DataRow"),
+ |
+
| 162 | ++ |
+ function(tt, path, value, after = FALSE) {
+ |
+
| 163 | +6x | +
+ if (no_colinfo(value)) {
+ |
+
| 164 | +6x | +
+ col_info(value) <- col_info(tt)+ |
+
| 165 | ++ |
+ } else {
+ |
+
| 166 | +! | +
+ chk_compat_cinfos(tt, value)+ |
+
| 167 | ++ |
+ }+ |
+
| 168 | ++ |
+ ## retained for debugging+ |
+
| 169 | +6x | +
+ origpath <- path # nolint+ |
+
| 170 | +6x | +
+ idx_row <- tt_at_path(tt, path)+ |
+
| 171 | +6x | +
+ if (!is(idx_row, "DataRow")) {
+ |
+
| 172 | +4x | +
+ stop(+ |
+
| 173 | +4x | +
+ "path must resolve fully to a non-content data row. Insertion of ",+ |
+
| 174 | +4x | +
+ "rows elsewhere in the tree is not currently supported."+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ | + + | +
| 178 | +2x | +
+ posnm <- tail(path, 1)+ |
+
| 179 | ++ | + + | +
| 180 | +2x | +
+ path <- head(path, -1)+ |
+
| 181 | ++ | + + | +
| 182 | +2x | +
+ subtt <- tt_at_path(tt, path)+ |
+
| 183 | +2x | +
+ kids <- tree_children(subtt)+ |
+
| 184 | +2x | +
+ ind <- which(names(kids) == posnm)+ |
+
| 185 | +2x | +
+ if (length(ind) != 1L) {
+ |
+
| 186 | ++ |
+ ## nocov start+ |
+
| 187 | ++ |
+ stop(+ |
+
| 188 | ++ |
+ "table children do not appear to be named correctly at this ",+ |
+
| 189 | ++ |
+ "path. This should not happen, please contact the maintainer of ",+ |
+
| 190 | ++ |
+ "rtables."+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | ++ |
+ ## nocov end+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | +2x | +
+ if (after) {
+ |
+
| 195 | +1x | +
+ ind <- ind + 1+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ | + + | +
| 198 | +2x | +
+ sq <- seq_along(kids)+ |
+
| 199 | +2x | +
+ tree_children(subtt) <- c(+ |
+
| 200 | +2x | +
+ kids[sq < ind],+ |
+
| 201 | +2x | +
+ setNames(list(value), obj_name(value)),+ |
+
| 202 | +2x | +
+ kids[sq >= ind]+ |
+
| 203 | ++ |
+ )+ |
+
| 204 | +2x | +
+ tt_at_path(tt, path) <- subtt+ |
+
| 205 | +2x | +
+ tt+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ |
+ )+ |
+
| 208 | ++ |
+ #' @rdname insert_row_at_path+ |
+
| 209 | ++ |
+ setMethod(+ |
+
| 210 | ++ |
+ "insert_row_at_path", c("VTableTree", "ANY"),
+ |
+
| 211 | ++ |
+ function(tt, path, value) {
+ |
+
| 212 | +! | +
+ stop(+ |
+
| 213 | +! | +
+ "Currently only insertion of DataRow objects is supported. Got ",+ |
+
| 214 | +! | +
+ "object of class ", class(value), ". Please use rrow() or DataRow() ",+ |
+
| 215 | +! | +
+ "to construct your row before insertion."+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ #' Label at path+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' Accesses or sets the label at a path.+ |
+
| 223 | ++ |
+ #'+ |
+
| 224 | ++ |
+ #' @inheritParams gen_args+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' @details+ |
+
| 227 | ++ |
+ #' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a+ |
+
| 228 | ++ |
+ #' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the+ |
+
| 229 | ++ |
+ #' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly,+ |
+
| 230 | ++ |
+ #' if the label row text for a subtable is set to `NA`, the label row will bet set to non-visible, so the row will not+ |
+
| 231 | ++ |
+ #' appear at all when the table is printed.+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' @note When changing the row labels for content rows, it is important to path all the way to the *row*. Paths+ |
+
| 234 | ++ |
+ #' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help+ |
+
| 235 | ++ |
+ #' determining the full paths to content rows.+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' @examples+ |
+
| 238 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 239 | ++ |
+ #' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
+ |
+
| 240 | ++ |
+ #' analyze("AGE")
+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 243 | ++ |
+ #'+ |
+
| 244 | ++ |
+ #' label_at_path(tbl, c("COUNTRY", "CHN"))
+ |
+
| 245 | ++ |
+ #'+ |
+
| 246 | ++ |
+ #' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
+ |
+
| 247 | ++ |
+ #' tbl+ |
+
| 248 | ++ |
+ #'+ |
+
| 249 | ++ |
+ #' @export+ |
+
| 250 | ++ |
+ label_at_path <- function(tt, path) {
+ |
+
| 251 | +29x | +
+ obj_label(tt_at_path(tt, path))+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ | + + | +
| 254 | ++ |
+ #' @export+ |
+
| 255 | ++ |
+ #' @rdname label_at_path+ |
+
| 256 | ++ |
+ `label_at_path<-` <- function(tt, path, value) {
+ |
+
| 257 | +32x | +
+ if (!is(tt, "VTableTree")) {
+ |
+
| 258 | +! | +
+ stop("tt must be a TableTree or ElementaryTable object")
+ |
+
| 259 | ++ |
+ }+ |
+
| 260 | +32x | +
+ if (is.null(value) || is.na(value)) {
+ |
+
| 261 | +1x | +
+ value <- NA_character_+ |
+
| 262 | ++ |
+ }+ |
+
| 263 | +32x | +
+ subt <- tt_at_path(tt, path)+ |
+
| 264 | +32x | +
+ obj_label(subt) <- value+ |
+
| 265 | +32x | +
+ tt_at_path(tt, path) <- subt+ |
+
| 266 | +32x | +
+ tt+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ | + + | +
| 269 | ++ |
+ #' Access or set table elements at specified path+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @inheritParams gen_args+ |
+
| 272 | ++ |
+ #' @param ... unused.+ |
+
| 273 | ++ |
+ #'+ |
+
| 274 | ++ |
+ #' @export+ |
+
| 275 | ++ |
+ #' @rdname ttap+ |
+
| 276 | +348x | +
+ setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))
+ |
+
| 277 | ++ | + + | +
| 278 | ++ |
+ #' @inheritParams tt_at_path+ |
+
| 279 | ++ |
+ #'+ |
+
| 280 | ++ |
+ #' @export+ |
+
| 281 | ++ |
+ #' @rdname int_methods+ |
+
| 282 | ++ |
+ setMethod(+ |
+
| 283 | ++ |
+ "tt_at_path", "VTableTree",+ |
+
| 284 | ++ |
+ function(tt, path, ...) {
+ |
+
| 285 | +348x | +
+ stopifnot(+ |
+
| 286 | +348x | +
+ is(path, "character"),+ |
+
| 287 | +348x | +
+ length(path) > 0,+ |
+
| 288 | +348x | +
+ !anyNA(path)+ |
+
| 289 | ++ |
+ )+ |
+
| 290 | ++ | + + | +
| 291 | +348x | +
+ if (path[1] == "root" && obj_name(tt) != "root") {
+ |
+
| 292 | +3x | +
+ path <- path[-1]+ |
+
| 293 | ++ |
+ }+ |
+
| 294 | ++ |
+ ## handle pathing that hits the root split by name+ |
+
| 295 | +348x | +
+ if (obj_name(tt) == path[1]) {
+ |
+
| 296 | +318x | +
+ path <- path[-1]+ |
+
| 297 | ++ |
+ }+ |
+
| 298 | +348x | +
+ cur <- tt+ |
+
| 299 | +348x | +
+ curpath <- path+ |
+
| 300 | +348x | +
+ while (length(curpath > 0)) {
+ |
+
| 301 | +1163x | +
+ kids <- tree_children(cur)+ |
+
| 302 | +1163x | +
+ curname <- curpath[1]+ |
+
| 303 | +1163x | +
+ if (curname == "@content") {
+ |
+
| 304 | +65x | +
+ cur <- content_table(cur)+ |
+
| 305 | +1098x | +
+ } else if (curname %in% names(kids)) {
+ |
+
| 306 | +1097x | +
+ cur <- kids[[curname]]+ |
+
| 307 | ++ |
+ } else {
+ |
+
| 308 | +1x | +
+ stop("Path appears invalid for this tree at step ", curname)
+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | +1162x | +
+ curpath <- curpath[-1]+ |
+
| 311 | ++ |
+ }+ |
+
| 312 | +347x | +
+ cur+ |
+
| 313 | ++ |
+ }+ |
+
| 314 | ++ |
+ )+ |
+
| 315 | ++ | + + | +
| 316 | ++ |
+ #' @note Setting `NULL` at a defined path removes the corresponding sub-table.+ |
+
| 317 | ++ |
+ #'+ |
+
| 318 | ++ |
+ #' @examples+ |
+
| 319 | ++ |
+ #' # Accessing sub table.+ |
+
| 320 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 321 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 322 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 323 | ++ |
+ #' split_rows_by("BMRKR2") %>%
+ |
+
| 324 | ++ |
+ #' analyze("AGE")
+ |
+
| 325 | ++ |
+ #'+ |
+
| 326 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl) %>% prune_table()+ |
+
| 327 | ++ |
+ #' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2"))
+ |
+
| 328 | ++ |
+ #'+ |
+
| 329 | ++ |
+ #' # Removing sub table.+ |
+
| 330 | ++ |
+ #' tbl2 <- tbl+ |
+
| 331 | ++ |
+ #' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL
+ |
+
| 332 | ++ |
+ #' tbl2+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' # Setting sub table.+ |
+
| 335 | ++ |
+ #' lyt3 <- basic_table() %>%+ |
+
| 336 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 337 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 338 | ++ |
+ #' analyze("BMRKR2")
+ |
+
| 339 | ++ |
+ #'+ |
+
| 340 | ++ |
+ #' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table()+ |
+
| 341 | ++ |
+ #'+ |
+
| 342 | ++ |
+ #' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl
+ |
+
| 343 | ++ |
+ #' tbl3+ |
+
| 344 | ++ |
+ #'+ |
+
| 345 | ++ |
+ #' @export+ |
+
| 346 | ++ |
+ #' @rdname ttap+ |
+
| 347 | ++ |
+ setGeneric(+ |
+
| 348 | ++ |
+ "tt_at_path<-",+ |
+
| 349 | +168x | +
+ function(tt, path, ..., value) standardGeneric("tt_at_path<-")
+ |
+
| 350 | ++ |
+ )+ |
+
| 351 | ++ | + + | +
| 352 | ++ |
+ #' @export+ |
+
| 353 | ++ |
+ #' @keywords internal+ |
+
| 354 | ++ |
+ #' @rdname int_methods+ |
+
| 355 | ++ |
+ setMethod(+ |
+
| 356 | ++ |
+ "tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"),+ |
+
| 357 | ++ |
+ function(tt, path, ..., value) {
+ |
+
| 358 | +78x | +
+ do_recursive_replace(tt, path = path, value = value)+ |
+
| 359 | ++ |
+ }+ |
+
| 360 | ++ |
+ )+ |
+
| 361 | ++ | + + | +
| 362 | ++ |
+ ## this one removes the child at path from the parents list of children,+ |
+
| 363 | ++ |
+ ## because that is how lists behave.+ |
+
| 364 | ++ |
+ #' @export+ |
+
| 365 | ++ |
+ #' @keywords internal+ |
+
| 366 | ++ |
+ #' @rdname int_methods+ |
+
| 367 | ++ |
+ setMethod(+ |
+
| 368 | ++ |
+ "tt_at_path<-", c(tt = "VTableTree", value = "NULL"),+ |
+
| 369 | ++ |
+ function(tt, path, ..., value) {
+ |
+
| 370 | +2x | +
+ do_recursive_replace(tt, path = path, value = value)+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | ++ |
+ )+ |
+
| 373 | ++ | + + | +
| 374 | ++ |
+ #' @export+ |
+
| 375 | ++ |
+ #' @keywords internal+ |
+
| 376 | ++ |
+ #' @rdname int_methods+ |
+
| 377 | ++ |
+ setMethod(+ |
+
| 378 | ++ |
+ "tt_at_path<-", c(tt = "VTableTree", value = "TableRow"),+ |
+
| 379 | ++ |
+ function(tt, path, ..., value) {
+ |
+
| 380 | +88x | +
+ stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow"))+ |
+
| 381 | +88x | +
+ do_recursive_replace(tt, path = path, value = value)+ |
+
| 382 | ++ | + + | +
| 383 | ++ |
+ ## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW)+ |
+
| 384 | ++ |
+ ## i <- .path_to_pos(path = path, tt = tt)+ |
+
| 385 | ++ | + + | +
| 386 | ++ |
+ ## replace_rows(tt, i = i, value = list(value))+ |
+
| 387 | ++ |
+ }+ |
+
| 388 | ++ |
+ )+ |
+
| 389 | ++ | + + | +
| 390 | ++ |
+ #' Retrieve and assign elements of a `TableTree`+ |
+
| 391 | ++ |
+ #'+ |
+
| 392 | ++ |
+ #' @param x (`TableTree`)\cr a `TableTree` object.+ |
+
| 393 | ++ |
+ #' @param i (`numeric(1)`)\cr index.+ |
+
| 394 | ++ |
+ #' @param j (`numeric(1)`)\cr index.+ |
+
| 395 | ++ |
+ #' @param drop (`flag`)\cr whether the value in the cell should be returned if one cell is selected by the+ |
+
| 396 | ++ |
+ #' combination of `i` and `j`. It is not possible to return a vector of values. To do so please consider using+ |
+
| 397 | ++ |
+ #' [cell_values()]. Defaults to `FALSE`.+ |
+
| 398 | ++ |
+ #' @param ... additional arguments. Includes:+ |
+
| 399 | ++ |
+ #' \describe{
+ |
+
| 400 | ++ |
+ #' \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after
+ |
+
| 401 | ++ |
+ #' subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it+ |
+
| 402 | ++ |
+ #' otherwise.}+ |
+
| 403 | ++ |
+ #' \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.}
+ |
+
| 404 | ++ |
+ #' \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to
+ |
+
| 405 | ++ |
+ #' `keep_titles`.}+ |
+
| 406 | ++ |
+ #' \item{`reindex_refs`}{(`flag`) whether referential footnotes should be re-indexed as if the resulting subset is
+ |
+
| 407 | ++ |
+ #' the entire table. Defaults to `TRUE`.}+ |
+
| 408 | ++ |
+ #' }+ |
+
| 409 | ++ |
+ #' @param value (`list`, `TableRow`, or `TableTree`)\cr replacement value.+ |
+
| 410 | ++ |
+ #'+ |
+
| 411 | ++ |
+ #' @details+ |
+
| 412 | ++ |
+ #' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`.+ |
+
| 413 | ++ |
+ #' If only a column is selected and all rows are kept, the `topleft` information remains as default. Any referential+ |
+
| 414 | ++ |
+ #' footnote is kept whenever the subset table contains the referenced element.+ |
+
| 415 | ++ |
+ #'+ |
+
| 416 | ++ |
+ #' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which+ |
+
| 417 | ++ |
+ #' case the (possibly multi-valued) fully stripped raw value of the selected cell.+ |
+
| 418 | ++ |
+ #'+ |
+
| 419 | ++ |
+ #' @note+ |
+
| 420 | ++ |
+ #' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed,+ |
+
| 421 | ++ |
+ #' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of+ |
+
| 422 | ++ |
+ #' names in both `[` and `[<-`.+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' @seealso+ |
+
| 425 | ++ |
+ #' * [sort_at_path()] to understand sorting.+ |
+
| 426 | ++ |
+ #' * [summarize_row_groups()] to understand path structure.+ |
+
| 427 | ++ |
+ #'+ |
+
| 428 | ++ |
+ #' @examples+ |
+
| 429 | ++ |
+ #' lyt <- basic_table(+ |
+
| 430 | ++ |
+ #' title = "Title",+ |
+
| 431 | ++ |
+ #' subtitles = c("Sub", "titles"),
+ |
+
| 432 | ++ |
+ #' prov_footer = "prov footer",+ |
+
| 433 | ++ |
+ #' main_footer = "main footer"+ |
+
| 434 | ++ |
+ #' ) %>%+ |
+
| 435 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 436 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 437 | ++ |
+ #' analyze(c("AGE"))
+ |
+
| 438 | ++ |
+ #'+ |
+
| 439 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 440 | ++ |
+ #' top_left(tbl) <- "Info"+ |
+
| 441 | ++ |
+ #' tbl+ |
+
| 442 | ++ |
+ #'+ |
+
| 443 | ++ |
+ #' # As default header, footer, and topleft information is lost+ |
+
| 444 | ++ |
+ #' tbl[1, ]+ |
+
| 445 | ++ |
+ #' tbl[1:2, 2]+ |
+
| 446 | ++ |
+ #'+ |
+
| 447 | ++ |
+ #' # Also boolean filters can work+ |
+
| 448 | ++ |
+ #' tbl[, c(FALSE, TRUE, FALSE)]+ |
+
| 449 | ++ |
+ #'+ |
+
| 450 | ++ |
+ #' # If drop = TRUE, the content values are directly retrieved+ |
+
| 451 | ++ |
+ #' tbl[2, 1]+ |
+
| 452 | ++ |
+ #' tbl[2, 1, drop = TRUE]+ |
+
| 453 | ++ |
+ #'+ |
+
| 454 | ++ |
+ #' # Drop works also if vectors are selected, but not matrices+ |
+
| 455 | ++ |
+ #' tbl[, 1, drop = TRUE]+ |
+
| 456 | ++ |
+ #' tbl[2, , drop = TRUE]+ |
+
| 457 | ++ |
+ #' tbl[1, 1, drop = TRUE] # NULL because it is a label row+ |
+
| 458 | ++ |
+ #' tbl[2, 1:2, drop = TRUE] # vectors can be returned only with cell_values()+ |
+
| 459 | ++ |
+ #' tbl[1:2, 1:2, drop = TRUE] # no dropping because it is a matrix+ |
+
| 460 | ++ |
+ #'+ |
+
| 461 | ++ |
+ #' # If all rows are selected, topleft is kept by default+ |
+
| 462 | ++ |
+ #' tbl[, 2]+ |
+
| 463 | ++ |
+ #' tbl[, 1]+ |
+
| 464 | ++ |
+ #'+ |
+
| 465 | ++ |
+ #' # It is possible to deselect values+ |
+
| 466 | ++ |
+ #' tbl[-2, ]+ |
+
| 467 | ++ |
+ #' tbl[, -1]+ |
+
| 468 | ++ |
+ #'+ |
+
| 469 | ++ |
+ #' # Values can be reassigned+ |
+
| 470 | ++ |
+ #' tbl[2, 1] <- rcell(999)+ |
+
| 471 | ++ |
+ #' tbl[2, ] <- list(rrow("FFF", 888, 666, 777))
+ |
+
| 472 | ++ |
+ #' tbl[6, ] <- list(-111, -222, -333)+ |
+
| 473 | ++ |
+ #' tbl+ |
+
| 474 | ++ |
+ #'+ |
+
| 475 | ++ |
+ #' # We can keep some information from the original table if we need+ |
+
| 476 | ++ |
+ #' tbl[1, 2, keep_titles = TRUE]+ |
+
| 477 | ++ |
+ #' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE]+ |
+
| 478 | ++ |
+ #' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE]+ |
+
| 479 | ++ |
+ #' tbl[1, 2, keep_footers = TRUE]+ |
+
| 480 | ++ |
+ #' tbl[1, 2, keep_topleft = TRUE]+ |
+
| 481 | ++ |
+ #'+ |
+
| 482 | ++ |
+ #' # Keeps the referential footnotes when subset contains them+ |
+
| 483 | ++ |
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important"
+ |
+
| 484 | ++ |
+ #' tbl[4, 1]+ |
+
| 485 | ++ |
+ #' tbl[2, 1] # None present+ |
+
| 486 | ++ |
+ #'+ |
+
| 487 | ++ |
+ #' # We can reindex referential footnotes, so that the new table does not depend+ |
+
| 488 | ++ |
+ #' # on the original one+ |
+
| 489 | ++ |
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important"
+ |
+
| 490 | ++ |
+ #' tbl[, 1] # both present+ |
+
| 491 | ++ |
+ #' tbl[5:6, 1] # {1} because it has been indexed again
+ |
+
| 492 | ++ |
+ #' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed
+ |
+
| 493 | ++ |
+ #'+ |
+
| 494 | ++ |
+ #' # Note that order can not be changed with subsetting+ |
+
| 495 | ++ |
+ #' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection+ |
+
| 496 | ++ |
+ #'+ |
+
| 497 | ++ |
+ #' @name brackets+ |
+
| 498 | ++ |
+ NULL+ |
+
| 499 | ++ | + + | +
| 500 | ++ |
+ #' @exportMethod [<-+ |
+
| 501 | ++ |
+ #' @rdname brackets+ |
+
| 502 | ++ |
+ setMethod(+ |
+
| 503 | ++ |
+ "[<-", c("VTableTree", value = "list"),
+ |
+
| 504 | ++ |
+ function(x, i, j, ..., value) {
+ |
+
| 505 | +3x | +
+ nr <- nrow(x)+ |
+
| 506 | +3x | +
+ if (missing(i)) {
+ |
+
| 507 | +! | +
+ i <- seq_len(NROW(x))+ |
+
| 508 | +3x | +
+ } else if (is(i, "character")) {
+ |
+
| 509 | +! | +
+ i <- .path_to_pos(i, x)+ |
+
| 510 | ++ |
+ } else {
+ |
+
| 511 | +3x | +
+ i <- .j_to_posj(i, nr)+ |
+
| 512 | ++ |
+ }+ |
+
| 513 | ++ | + + | +
| 514 | +3x | +
+ if (missing(j)) {
+ |
+
| 515 | +1x | +
+ j <- seq_along(col_exprs(col_info(x)))+ |
+
| 516 | +2x | +
+ } else if (is(j, "character")) {
+ |
+
| 517 | +! | +
+ j <- .path_to_pos(j, x, cols = TRUE)+ |
+
| 518 | ++ |
+ } else {
+ |
+
| 519 | +2x | +
+ j <- .j_to_posj(j, ncol(x))+ |
+
| 520 | ++ |
+ }+ |
+
| 521 | ++ | + + | +
| 522 | +3x | +
+ if (length(i) > 1 && length(j) < ncol(x)) {
+ |
+
| 523 | +! | +
+ stop("cannot modify multiple rows in not all columns.")
+ |
+
| 524 | ++ |
+ }+ |
+
| 525 | ++ | + + | +
| 526 | +3x | +
+ if (are(value, "TableRow")) {
+ |
+
| 527 | +1x | +
+ value <- rep(value, length.out = length(i))+ |
+
| 528 | ++ |
+ } else {
+ |
+
| 529 | +2x | +
+ value <- rep(value, length.out = length(i) * length(j))+ |
+
| 530 | ++ |
+ }+ |
+
| 531 | ++ | + + | +
| 532 | +3x | +
+ counter <- 0+ |
+
| 533 | ++ |
+ ## this has access to value, i, and j by scoping+ |
+
| 534 | +3x | +
+ replace_rowsbynum <- function(x, i, valifnone = NULL) {
+ |
+
| 535 | +16x | +
+ maxi <- max(i)+ |
+
| 536 | +16x | +
+ if (counter >= maxi) {
+ |
+
| 537 | +! | +
+ return(valifnone)+ |
+
| 538 | ++ |
+ }+ |
+
| 539 | ++ | + + | +
| 540 | +16x | +
+ if (labelrow_visible(x)) {
+ |
+
| 541 | +3x | +
+ counter <<- counter + 1+ |
+
| 542 | +3x | +
+ if (counter %in% i) {
+ |
+
| 543 | +1x | +
+ nxtval <- value[[1]]+ |
+
| 544 | +1x | +
+ if (is(nxtval, "LabelRow")) {
+ |
+
| 545 | +1x | +
+ tt_labelrow(x) <- nxtval+ |
+
| 546 | ++ |
+ } else {
+ |
+
| 547 | +! | +
+ stop(+ |
+
| 548 | +! | +
+ "can't replace label with value of class",+ |
+
| 549 | +! | +
+ class(nxtval)+ |
+
| 550 | ++ |
+ )+ |
+
| 551 | ++ |
+ }+ |
+
| 552 | ++ |
+ ## we're done with this one move to+ |
+
| 553 | ++ |
+ ## the next+ |
+
| 554 | +1x | +
+ value <<- value[-1]+ |
+
| 555 | ++ |
+ }+ |
+
| 556 | ++ |
+ }+ |
+
| 557 | +16x | +
+ if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
+ |
+
| 558 | +3x | +
+ ctab <- content_table(x)+ |
+
| 559 | ++ | + + | +
| 560 | +3x | +
+ content_table(x) <- replace_rowsbynum(ctab, i)+ |
+
| 561 | ++ |
+ }+ |
+
| 562 | +16x | +
+ if (counter >= maxi) { # already done
+ |
+
| 563 | +2x | +
+ return(x)+ |
+
| 564 | ++ |
+ }+ |
+
| 565 | +14x | +
+ kids <- tree_children(x)+ |
+
| 566 | ++ | + + | +
| 567 | +14x | +
+ if (length(kids) > 0) {
+ |
+
| 568 | +14x | +
+ for (pos in seq_along(kids)) {
+ |
+
| 569 | +17x | +
+ curkid <- kids[[pos]]+ |
+
| 570 | +17x | +
+ if (is(curkid, "TableRow")) {
+ |
+
| 571 | +7x | +
+ counter <<- counter + 1+ |
+
| 572 | +7x | +
+ if (counter %in% i) {
+ |
+
| 573 | +3x | +
+ nxtval <- value[[1]]+ |
+
| 574 | +3x | +
+ if (is(nxtval, class(curkid))) {
+ |
+
| 575 | +1x | +
+ if (no_colinfo(nxtval) && length(row_values(nxtval)) == ncol(x)) {
+ |
+
| 576 | +1x | +
+ col_info(nxtval) <- col_info(x)+ |
+
| 577 | ++ |
+ }+ |
+
| 578 | +1x | +
+ stopifnot(identical(col_info(x), col_info(nxtval)))+ |
+
| 579 | +1x | +
+ curkid <- nxtval+ |
+
| 580 | +1x | +
+ value <- value[-1]+ |
+
| 581 | ++ |
+ } else {
+ |
+
| 582 | +2x | +
+ rvs <- row_values(curkid)+ |
+
| 583 | +2x | +
+ rvs[j] <- value[seq_along(j)]+ |
+
| 584 | +2x | +
+ row_values(curkid) <- rvs+ |
+
| 585 | +2x | +
+ value <- value[-(seq_along(j))]+ |
+
| 586 | ++ |
+ }+ |
+
| 587 | +3x | +
+ kids[[pos]] <- curkid+ |
+
| 588 | ++ |
+ }+ |
+
| 589 | ++ |
+ } else {
+ |
+
| 590 | +10x | +
+ kids[[pos]] <- replace_rowsbynum(curkid, i)+ |
+
| 591 | ++ |
+ }+ |
+
| 592 | +17x | +
+ if (counter >= maxi) {
+ |
+
| 593 | +7x | +
+ break+ |
+
| 594 | ++ |
+ }+ |
+
| 595 | ++ |
+ }+ |
+
| 596 | ++ |
+ }+ |
+
| 597 | +14x | +
+ tree_children(x) <- kids+ |
+
| 598 | +14x | +
+ x+ |
+
| 599 | ++ |
+ }+ |
+
| 600 | +3x | +
+ replace_rowsbynum(x, i, ...)+ |
+
| 601 | ++ |
+ }+ |
+
| 602 | ++ |
+ )+ |
+
| 603 | ++ | + + | +
| 604 | ++ |
+ #' @inheritParams brackets+ |
+
| 605 | ++ |
+ #'+ |
+
| 606 | ++ |
+ #' @exportMethod [<-+ |
+
| 607 | ++ |
+ #' @rdname int_methods+ |
+
| 608 | ++ |
+ #' @keywords internal+ |
+
| 609 | ++ |
+ setMethod(+ |
+
| 610 | ++ |
+ "[<-", c("VTableTree", value = "CellValue"),
+ |
+
| 611 | ++ |
+ function(x, i, j, ..., value) {
+ |
+
| 612 | +1x | +
+ x[i = i, j = j, ...] <- list(value)+ |
+
| 613 | +1x | +
+ x+ |
+
| 614 | ++ |
+ }+ |
+
| 615 | ++ |
+ )+ |
+
| 616 | ++ | + + | +
| 617 | ++ |
+ ## this is going to be hard :( :( :(+ |
+
| 618 | ++ | + + | +
| 619 | ++ |
+ ### selecting/removing columns+ |
+
| 620 | ++ | + + | +
| 621 | ++ |
+ ## we have two options here: path like we do with rows and positional+ |
+
| 622 | ++ |
+ ## in leaf space.+ |
+
| 623 | ++ | + + | +
| 624 | ++ |
+ setGeneric(+ |
+
| 625 | ++ |
+ "subset_cols",+ |
+
| 626 | ++ |
+ function(tt,+ |
+
| 627 | ++ |
+ j,+ |
+
| 628 | ++ |
+ newcinfo = NULL,+ |
+
| 629 | ++ |
+ keep_topleft = TRUE,+ |
+
| 630 | ++ |
+ keep_titles = TRUE,+ |
+
| 631 | ++ |
+ keep_footers = keep_titles,+ |
+
| 632 | ++ |
+ ...) {
+ |
+
| 633 | +9970x | +
+ standardGeneric("subset_cols")
+ |
+
| 634 | ++ |
+ }+ |
+
| 635 | ++ |
+ )+ |
+
| 636 | ++ | + + | +
| 637 | ++ |
+ setMethod(+ |
+
| 638 | ++ |
+ "subset_cols", c("TableTree", "numeric"),
+ |
+
| 639 | ++ |
+ function(tt, j, newcinfo = NULL,+ |
+
| 640 | ++ |
+ keep_topleft, keep_titles, keep_footers, ...) {
+ |
+
| 641 | +867x | +
+ j <- .j_to_posj(j, ncol(tt))+ |
+
| 642 | +867x | +
+ if (is.null(newcinfo)) {
+ |
+
| 643 | +161x | +
+ cinfo <- col_info(tt)+ |
+
| 644 | +161x | +
+ newcinfo <- subset_cols(cinfo, j,+ |
+
| 645 | +161x | +
+ keep_topleft = keep_topleft, ...+ |
+
| 646 | ++ |
+ )+ |
+
| 647 | ++ |
+ }+ |
+
| 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)+ |
+
| 652 | +867x | +
+ newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...)+ |
+
| 653 | +867x | +
+ tt2 <- tt+ |
+
| 654 | +867x | +
+ col_info(tt2) <- newcinfo+ |
+
| 655 | +867x | +
+ content_table(tt2) <- newcont+ |
+
| 656 | +867x | +
+ tree_children(tt2) <- newkids+ |
+
| 657 | +867x | +
+ tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)+ |
+
| 658 | ++ | + + | +
| 659 | +867x | +
+ tt2 <- .h_copy_titles_footers_topleft(+ |
+
| 660 | +867x | +
+ tt2, tt,+ |
+
| 661 | +867x | +
+ keep_titles,+ |
+
| 662 | +867x | +
+ keep_footers,+ |
+
| 663 | +867x | +
+ keep_topleft+ |
+
| 664 | ++ |
+ )+ |
+
| 665 | +867x | +
+ tt2+ |
+
| 666 | ++ |
+ }+ |
+
| 667 | ++ |
+ )+ |
+
| 668 | ++ | + + | +
| 669 | ++ |
+ setMethod(+ |
+
| 670 | ++ |
+ "subset_cols", c("ElementaryTable", "numeric"),
+ |
+
| 671 | ++ |
+ function(tt, j, newcinfo = NULL,+ |
+
| 672 | ++ |
+ keep_topleft, keep_titles, keep_footers, ...) {
+ |
+
| 673 | +1829x | +
+ j <- .j_to_posj(j, ncol(tt))+ |
+
| 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,+ |
+
| 678 | +97x | +
+ keep_titles = keep_titles,+ |
+
| 679 | +97x | +
+ keep_footers = keep_footers, ...+ |
+
| 680 | ++ |
+ )+ |
+
| 681 | ++ |
+ }+ |
+
| 682 | ++ |
+ ## topleft handled in creation of newcinfo+ |
+
| 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+ |
+
| 687 | +1829x | +
+ tree_children(tt2) <- newkids+ |
+
| 688 | +1829x | +
+ tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)+ |
+
| 689 | +1829x | +
+ tt2 <- .h_copy_titles_footers_topleft(+ |
+
| 690 | +1829x | +
+ tt2, tt,+ |
+
| 691 | +1829x | +
+ keep_titles,+ |
+
| 692 | +1829x | +
+ keep_footers,+ |
+
| 693 | +1829x | +
+ keep_topleft+ |
+
| 694 | ++ |
+ )+ |
+
| 695 | +1829x | +
+ tt2+ |
+
| 696 | ++ |
+ }+ |
+
| 697 | ++ |
+ )+ |
+
| 698 | ++ | + + | +
| 699 | ++ |
+ ## small utility to transform any negative+ |
+
| 700 | ++ |
+ ## indices into positive ones, given j+ |
+
| 701 | ++ |
+ ## and total length+ |
+
| 702 | ++ | + + | +
| 703 | ++ |
+ .j_to_posj <- function(j, n) {
+ |
+
| 704 | ++ |
+ ## This will work for logicals, numerics, integers+ |
+
| 705 | +15040x | +
+ j <- seq_len(n)[j]+ |
+
| 706 | +15040x | +
+ j+ |
+
| 707 | ++ |
+ }+ |
+
| 708 | ++ | + + | +
| 709 | ++ |
+ path_collapse_sep <- "`"+ |
+
| 710 | ++ |
+ escape_name_padding <- function(x) {
+ |
+
| 711 | +141x | +
+ ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE)
+ |
+
| 712 | +141x | +
+ ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE)
+ |
+
| 713 | +141x | +
+ ret+ |
+
| 714 | ++ |
+ }+ |
+
| 715 | ++ |
+ path_to_regex <- function(path) {
+ |
+
| 716 | +51x | +
+ paste(vapply(path, function(x) {
+ |
+
| 717 | +142x | +
+ if (identical(x, "*")) {
+ |
+
| 718 | +1x | +
+ paste0("[^", path_collapse_sep, "]+")
+ |
+
| 719 | ++ |
+ } else {
+ |
+
| 720 | +141x | +
+ escape_name_padding(x)+ |
+
| 721 | ++ |
+ }+ |
+
| 722 | +51x | +
+ }, ""), collapse = path_collapse_sep)+ |
+
| 723 | ++ |
+ }+ |
+
| 724 | ++ | + + | +
| 725 | ++ |
+ .path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) {
+ |
+
| 726 | +51x | +
+ path <- path[!grepl("^(|root)$", path)]
+ |
+
| 727 | +51x | +
+ if (cols) {
+ |
+
| 728 | +51x | +
+ rowdf <- make_col_df(tt)+ |
+
| 729 | ++ |
+ } else {
+ |
+
| 730 | +! | +
+ rowdf <- make_row_df(tt)+ |
+
| 731 | ++ |
+ }+ |
+
| 732 | +51x | +
+ if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
+ |
+
| 733 | +! | +
+ return(seq(1, nrow(rowdf)))+ |
+
| 734 | ++ |
+ }+ |
+
| 735 | ++ | + + | +
| 736 | +51x | +
+ paths <- rowdf$path+ |
+
| 737 | +51x | +
+ pathregex <- path_to_regex(path)+ |
+
| 738 | +51x | +
+ pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep)+ |
+
| 739 | +51x | +
+ allmatchs <- grep(pathregex, pathstrs)+ |
+
| 740 | +51x | +
+ if (length(allmatchs) == 0) {
+ |
+
| 741 | +! | +
+ stop(+ |
+
| 742 | +! | +
+ if (cols) "column path [" else "row path [",+ |
+
| 743 | +! | +
+ paste(path, collapse = "->"),+ |
+
| 744 | +! | +
+ "] does not appear valid for this table"+ |
+
| 745 | ++ |
+ )+ |
+
| 746 | ++ |
+ }+ |
+
| 747 | ++ | + + | +
| 748 | +51x | +
+ idxdiffs <- diff(allmatchs)+ |
+
| 749 | +51x | +
+ if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
+ |
+
| 750 | +! | +
+ firstnon <- min(which(idxdiffs > 1))+ |
+
| 751 | ++ |
+ ## its firstnon here because we would want firstnon-1 but+ |
+
| 752 | ++ |
+ ## the diffs are actually shifted 1 so they cancel out+ |
+
| 753 | +! | +
+ allmatchs <- allmatchs[seq(1, firstnon)]+ |
+
| 754 | ++ |
+ }+ |
+
| 755 | +51x | +
+ allmatchs+ |
+
| 756 | ++ |
+ }+ |
+
| 757 | ++ | + + | +
| 758 | ++ |
+ ## fix column spans that would be invalid+ |
+
| 759 | ++ |
+ ## after some columns are no longer there+ |
+
| 760 | ++ |
+ .fix_rowcspans <- function(rw, j) {
+ |
+
| 761 | +3974x | +
+ cspans <- row_cspans(rw)+ |
+
| 762 | +3974x | +
+ nc <- sum(cspans)+ |
+
| 763 | +3974x | +
+ j <- .j_to_posj(j, nc)+ |
+
| 764 | ++ |
+ ## this is overly complicated+ |
+
| 765 | ++ |
+ ## we need the starting indices+ |
+
| 766 | ++ |
+ ## but the first span might not be 1, so+ |
+
| 767 | ++ |
+ ## we pad with 1 and then take off the last+ |
+
| 768 | +3974x | +
+ start <- cumsum(c(1, head(cspans, -1)))+ |
+
| 769 | +3974x | +
+ ends <- c(tail(start, -1) - 1, nc)+ |
+
| 770 | +3974x | +
+ res <- mapply(function(st, en) {
+ |
+
| 771 | +22905x | +
+ sum(j >= st & j <= en)+ |
+
| 772 | +3974x | +
+ }, st = start, en = ends)+ |
+
| 773 | +3974x | +
+ res <- res[res > 0]+ |
+
| 774 | +3974x | +
+ stopifnot(sum(res) == length(j))+ |
+
| 775 | +3974x | +
+ res+ |
+
| 776 | ++ |
+ }+ |
+
| 777 | ++ | + + | +
| 778 | ++ |
+ select_cells_j <- function(cells, j) {
+ |
+
| 779 | +3974x | +
+ if (length(j) != length(unique(j))) {
+ |
+
| 780 | +! | +
+ stop("duplicate column selections is not currently supported")
+ |
+
| 781 | ++ |
+ }+ |
+
| 782 | +3974x | +
+ spans <- vapply(+ |
+
| 783 | +3974x | +
+ cells, function(x) cell_cspan(x),+ |
+
| 784 | +3974x | +
+ integer(1)+ |
+
| 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)+ |
+
| 793 | ++ |
+ )+ |
+
| 794 | ++ | + + | +
| 795 | +3974x | +
+ mapply(function(cl, sp) {
+ |
+
| 796 | +6891x | +
+ cell_cspan(cl) <- sp+ |
+
| 797 | +6891x | +
+ cl+ |
+
| 798 | +3974x | +
+ }, cl = retcells, sp = newspans, SIMPLIFY = FALSE)+ |
+
| 799 | ++ |
+ }+ |
+
| 800 | ++ | + + | +
| 801 | ++ |
+ setMethod(+ |
+
| 802 | ++ |
+ "subset_cols", c("ANY", "character"),
+ |
+
| 803 | ++ |
+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ |
+
| 804 | +42x | +
+ j <- .path_to_pos(path = j, tt = tt, cols = TRUE)+ |
+
| 805 | +42x | +
+ subset_cols(tt, j, newcinfo = newcinfo, keep_topleft = keep_topleft, ...)+ |
+
| 806 | ++ |
+ }+ |
+
| 807 | ++ |
+ )+ |
+
| 808 | ++ | + + | +
| 809 | ++ |
+ setMethod(+ |
+
| 810 | ++ |
+ "subset_cols", c("TableRow", "numeric"),
+ |
+
| 811 | ++ |
+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ |
+
| 812 | +3974x | +
+ j <- .j_to_posj(j, ncol(tt))+ |
+
| 813 | +3974x | +
+ if (is.null(newcinfo)) {
+ |
+
| 814 | +16x | +
+ cinfo <- col_info(tt)+ |
+
| 815 | +16x | +
+ newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)+ |
+
| 816 | ++ |
+ }+ |
+
| 817 | +3974x | +
+ tt2 <- tt+ |
+
| 818 | +3974x | +
+ row_cells(tt2) <- select_cells_j(row_cells(tt2), j)+ |
+
| 819 | ++ | + + | +
| 820 | +3974x | +
+ if (length(row_cspans(tt2)) > 0) {
+ |
+
| 821 | +3974x | +
+ row_cspans(tt2) <- .fix_rowcspans(tt2, j)+ |
+
| 822 | ++ |
+ }+ |
+
| 823 | +3974x | +
+ col_info(tt2) <- newcinfo+ |
+
| 824 | +3974x | +
+ tt2+ |
+
| 825 | ++ |
+ }+ |
+
| 826 | ++ |
+ )+ |
+
| 827 | ++ | + + | +
| 828 | ++ |
+ setMethod(+ |
+
| 829 | ++ |
+ "subset_cols", c("LabelRow", "numeric"),
+ |
+
| 830 | ++ |
+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ |
+
| 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, ...)+ |
+
| 835 | ++ |
+ }+ |
+
| 836 | +2702x | +
+ col_info(tt) <- newcinfo+ |
+
| 837 | +2702x | +
+ tt+ |
+
| 838 | ++ |
+ }+ |
+
| 839 | ++ |
+ )+ |
+
| 840 | ++ | + + | +
| 841 | ++ |
+ setMethod(+ |
+
| 842 | ++ |
+ "subset_cols", c("InstantiatedColumnInfo", "numeric"),
+ |
+
| 843 | ++ |
+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ |
+
| 844 | +278x | +
+ if (!is.null(newcinfo)) {
+ |
+
| 845 | +! | +
+ return(newcinfo)+ |
+
| 846 | ++ |
+ }+ |
+
| 847 | +278x | +
+ j <- .j_to_posj(j, length(col_exprs(tt)))+ |
+
| 848 | +278x | +
+ newctree <- subset_cols(coltree(tt), j, NULL)+ |
+
| 849 | +278x | +
+ newcextra <- col_extra_args(tt)[j]+ |
+
| 850 | +278x | +
+ newcsubs <- col_exprs(tt)[j]+ |
+
| 851 | +278x | +
+ newcounts <- col_counts(tt)[j]+ |
+
| 852 | +278x | +
+ tl <- if (keep_topleft) top_left(tt) else character()+ |
+
| 853 | +278x | +
+ InstantiatedColumnInfo(+ |
+
| 854 | +278x | +
+ treelyt = newctree,+ |
+
| 855 | +278x | +
+ csubs = newcsubs,+ |
+
| 856 | +278x | +
+ extras = newcextra,+ |
+
| 857 | +278x | +
+ cnts = newcounts,+ |
+
| 858 | +278x | +
+ dispcounts = disp_ccounts(tt),+ |
+
| 859 | +278x | +
+ countformat = colcount_format(tt),+ |
+
| 860 | +278x | +
+ topleft = tl+ |
+
| 861 | ++ |
+ )+ |
+
| 862 | ++ |
+ }+ |
+
| 863 | ++ |
+ )+ |
+
| 864 | ++ | + + | +
| 865 | ++ |
+ setMethod(+ |
+
| 866 | ++ |
+ "subset_cols", c("LayoutColTree", "numeric"),
+ |
+
| 867 | ++ |
+ function(tt, j, newcinfo = NULL, ...) {
+ |
+
| 868 | +278x | +
+ lst <- collect_leaves(tt)+ |
+
| 869 | +278x | +
+ j <- .j_to_posj(j, length(lst))+ |
+
| 870 | ++ | + + | +
| 871 | ++ |
+ ## j has only non-negative values from+ |
+
| 872 | ++ |
+ ## this point on+ |
+
| 873 | +278x | +
+ counter <- 0+ |
+
| 874 | +278x | +
+ prune_children <- function(x, j) {
+ |
+
| 875 | +674x | +
+ kids <- tree_children(x)+ |
+
| 876 | +674x | +
+ newkids <- kids+ |
+
| 877 | +674x | +
+ for (i in seq_along(newkids)) {
+ |
+
| 878 | +1813x | +
+ 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+ |
+
| 883 | ++ |
+ } else {
+ |
+
| 884 | +396x | +
+ newkids[[i]] <- prune_children(newkids[[i]], j)+ |
+
| 885 | ++ |
+ }+ |
+
| 886 | ++ |
+ }+ |
+
| 887 | ++ | + + | +
| 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+ |
+
| 892 | ++ |
+ } else {
+ |
+
| 893 | +200x | +
+ list()+ |
+
| 894 | ++ |
+ }+ |
+
| 895 | ++ |
+ }+ |
+
| 896 | +278x | +
+ prune_children(tt, j)+ |
+
| 897 | ++ |
+ }+ |
+
| 898 | ++ |
+ )+ |
+
| 899 | ++ | + + | +
| 900 | ++ |
+ ## label rows ARE included in the count+ |
+
| 901 | ++ |
+ subset_by_rownum <- function(tt,+ |
+
| 902 | ++ |
+ i,+ |
+
| 903 | ++ |
+ keep_topleft = FALSE,+ |
+
| 904 | ++ |
+ keep_titles = TRUE,+ |
+
| 905 | ++ |
+ keep_footers = keep_titles,+ |
+
| 906 | ++ |
+ ...) {
+ |
+
| 907 | +184x | +
+ stopifnot(is(tt, "VTableNodeInfo"))+ |
+
| 908 | +184x | +
+ counter <- 0+ |
+
| 909 | +184x | +
+ nr <- nrow(tt)+ |
+
| 910 | +184x | +
+ i <- .j_to_posj(i, nr)+ |
+
| 911 | +184x | +
+ if (length(i) == 0) {
+ |
+
| 912 | +3x | +
+ ret <- TableTree(cinfo = col_info(tt))+ |
+
| 913 | +3x | +
+ if (isTRUE(keep_topleft)) {
+ |
+
| 914 | +1x | +
+ top_left(ret) <- top_left(tt)+ |
+
| 915 | ++ |
+ }+ |
+
| 916 | +3x | +
+ return(ret)+ |
+
| 917 | ++ |
+ }+ |
+
| 918 | ++ | + + | +
| 919 | +181x | +
+ prune_rowsbynum <- function(x, i, valifnone = NULL) {
+ |
+
| 920 | +1321x | +
+ maxi <- max(i)+ |
+
| 921 | +1321x | +
+ if (counter > maxi) {
+ |
+
| 922 | +137x | +
+ return(valifnone)+ |
+
| 923 | ++ |
+ }+ |
+
| 924 | ++ | + + | +
| 925 | +1184x | +
+ if (labelrow_visible(x)) {
+ |
+
| 926 | +489x | +
+ counter <<- counter + 1+ |
+
| 927 | +489x | +
+ if (!(counter %in% i)) {
+ |
+
| 928 | ++ |
+ ## XXX this should do whatever+ |
+
| 929 | ++ |
+ ## is required to 'remove' the Label Row+ |
+
| 930 | ++ |
+ ## (currently implicit based on+ |
+
| 931 | ++ |
+ ## the value of the label but+ |
+
| 932 | ++ |
+ ## that shold really probably change)+ |
+
| 933 | +177x | +
+ labelrow_visible(x) <- FALSE+ |
+
| 934 | ++ |
+ }+ |
+
| 935 | ++ |
+ }+ |
+
| 936 | +1184x | +
+ if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
+ |
+
| 937 | +90x | +
+ ctab <- content_table(x)+ |
+
| 938 | ++ | + + | +
| 939 | +90x | +
+ content_table(x) <- prune_rowsbynum(ctab, i,+ |
+
| 940 | +90x | +
+ valifnone = ElementaryTable(+ |
+
| 941 | +90x | +
+ cinfo = col_info(ctab),+ |
+
| 942 | +90x | +
+ iscontent = TRUE+ |
+
| 943 | ++ |
+ )+ |
+
| 944 | ++ |
+ )+ |
+
| 945 | ++ |
+ }+ |
+
| 946 | +1184x | +
+ kids <- tree_children(x)+ |
+
| 947 | +1184x | +
+ if (counter > maxi) { # already done
+ |
+
| 948 | +49x | +
+ kids <- list()+ |
+
| 949 | +1135x | +
+ } else if (length(kids) > 0) {
+ |
+
| 950 | +1133x | +
+ for (pos in seq_along(kids)) {
+ |
+
| 951 | +4102x | +
+ if (is(kids[[pos]], "TableRow")) {
+ |
+
| 952 | +3052x | +
+ counter <<- counter + 1+ |
+
| 953 | +3052x | +
+ if (!(counter %in% i)) {
+ |
+
| 954 | +2144x | +
+ kids[[pos]] <- list()+ |
+
| 955 | ++ |
+ }+ |
+
| 956 | ++ |
+ } else {
+ |
+
| 957 | +1050x | +
+ kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list())+ |
+
| 958 | ++ |
+ }+ |
+
| 959 | ++ |
+ }+ |
+
| 960 | +1133x | +
+ kids <- kids[sapply(kids, function(x) NROW(x) > 0)]+ |
+
| 961 | ++ |
+ }+ |
+
| 962 | +1184x | +
+ if (length(kids) == 0 && NROW(content_table(x)) == 0 && !labelrow_visible(x)) {
+ |
+
| 963 | +359x | +
+ return(valifnone)+ |
+
| 964 | ++ |
+ } else {
+ |
+
| 965 | +825x | +
+ tree_children(x) <- kids+ |
+
| 966 | +825x | +
+ x+ |
+
| 967 | ++ |
+ }+ |
+
| 968 | ++ |
+ ## ## if(length(kids) == 0) {
+ |
+
| 969 | ++ |
+ ## ## if(!is(x, "TableTree"))+ |
+
| 970 | ++ |
+ ## ## return(valifnone)+ |
+
| 971 | ++ |
+ ## ## }+ |
+
| 972 | ++ |
+ ## if(is(x, "VTableTree") && nrow(x) > 0) {
+ |
+
| 973 | ++ |
+ ## x+ |
+
| 974 | ++ |
+ ## } else {
+ |
+
| 975 | ++ |
+ ## valifnone+ |
+
| 976 | ++ |
+ ## }+ |
+
| 977 | ++ |
+ }+ |
+
| 978 | +181x | +
+ ret <- prune_rowsbynum(tt, i)+ |
+
| 979 | ++ | + + | +
| 980 | +181x | +
+ ret <- .h_copy_titles_footers_topleft(+ |
+
| 981 | +181x | +
+ ret, tt,+ |
+
| 982 | +181x | +
+ keep_titles,+ |
+
| 983 | +181x | +
+ keep_footers,+ |
+
| 984 | +181x | +
+ keep_topleft+ |
+
| 985 | ++ |
+ )+ |
+
| 986 | ++ | + + | +
| 987 | +181x | +
+ ret+ |
+
| 988 | ++ |
+ }+ |
+
| 989 | ++ | + + | +
| 990 | ++ |
+ #' @exportMethod [+ |
+
| 991 | ++ |
+ #' @rdname brackets+ |
+
| 992 | ++ |
+ setMethod(+ |
+
| 993 | ++ |
+ "[", c("VTableTree", "logical", "logical"),
+ |
+
| 994 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 995 | +1x | +
+ i <- .j_to_posj(i, nrow(x))+ |
+
| 996 | +1x | +
+ j <- .j_to_posj(j, ncol(x))+ |
+
| 997 | +1x | +
+ x[i, j, ..., drop = drop]+ |
+
| 998 | ++ |
+ }+ |
+
| 999 | ++ |
+ )+ |
+
| 1000 | ++ | + + | +
| 1001 | ++ |
+ #' @exportMethod [+ |
+
| 1002 | ++ |
+ #' @rdname int_methods+ |
+
| 1003 | ++ |
+ #' @keywords internal+ |
+
| 1004 | ++ |
+ setMethod(+ |
+
| 1005 | ++ |
+ "[", c("VTableTree", "logical", "ANY"),
+ |
+
| 1006 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1007 | +! | +
+ i <- .j_to_posj(i, nrow(x))+ |
+
| 1008 | +! | +
+ x[i, j, ..., drop = drop]+ |
+
| 1009 | ++ |
+ }+ |
+
| 1010 | ++ |
+ )+ |
+
| 1011 | ++ | + + | +
| 1012 | ++ |
+ #' @exportMethod [+ |
+
| 1013 | ++ |
+ #' @rdname int_methods+ |
+
| 1014 | ++ |
+ #' @keywords internal+ |
+
| 1015 | ++ |
+ setMethod(+ |
+
| 1016 | ++ |
+ "[", c("VTableTree", "logical", "missing"),
+ |
+
| 1017 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1018 | +4x | +
+ j <- seq_len(ncol(x))+ |
+
| 1019 | +4x | +
+ i <- .j_to_posj(i, nrow(x))+ |
+
| 1020 | +4x | +
+ x[i, j, ..., drop = drop]+ |
+
| 1021 | ++ |
+ }+ |
+
| 1022 | ++ |
+ )+ |
+
| 1023 | ++ | + + | +
| 1024 | ++ |
+ #' @exportMethod [+ |
+
| 1025 | ++ |
+ #' @rdname int_methods+ |
+
| 1026 | ++ |
+ #' @keywords internal+ |
+
| 1027 | ++ |
+ setMethod(+ |
+
| 1028 | ++ |
+ "[", c("VTableTree", "ANY", "logical"),
+ |
+
| 1029 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1030 | +1x | +
+ j <- .j_to_posj(j, ncol(x))+ |
+
| 1031 | +1x | +
+ x[i, j, ..., drop = drop]+ |
+
| 1032 | ++ |
+ }+ |
+
| 1033 | ++ |
+ )+ |
+
| 1034 | ++ | + + | +
| 1035 | ++ |
+ #' @exportMethod [+ |
+
| 1036 | ++ |
+ #' @rdname int_methods+ |
+
| 1037 | ++ |
+ #' @keywords internal+ |
+
| 1038 | ++ |
+ setMethod(+ |
+
| 1039 | ++ |
+ "[", c("VTableTree", "ANY", "missing"),
+ |
+
| 1040 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1041 | +146x | +
+ j <- seq_len(ncol(x))+ |
+
| 1042 | +146x | +
+ x[i = i, j = j, ..., drop = drop]+ |
+
| 1043 | ++ |
+ }+ |
+
| 1044 | ++ |
+ )+ |
+
| 1045 | ++ | + + | +
| 1046 | ++ |
+ #' @exportMethod [+ |
+
| 1047 | ++ |
+ #' @rdname int_methods+ |
+
| 1048 | ++ |
+ #' @keywords internal+ |
+
| 1049 | ++ |
+ setMethod(+ |
+
| 1050 | ++ |
+ "[", c("VTableTree", "missing", "ANY"),
+ |
+
| 1051 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1052 | +4x | +
+ i <- seq_len(nrow(x))+ |
+
| 1053 | +4x | +
+ x[i = i, j = j, ..., drop = drop]+ |
+
| 1054 | ++ |
+ }+ |
+
| 1055 | ++ |
+ )+ |
+
| 1056 | ++ | + + | +
| 1057 | ++ |
+ #' @exportMethod [+ |
+
| 1058 | ++ |
+ #' @rdname int_methods+ |
+
| 1059 | ++ |
+ #' @keywords internal+ |
+
| 1060 | ++ |
+ setMethod(+ |
+
| 1061 | ++ |
+ "[", c("VTableTree", "ANY", "character"),
+ |
+
| 1062 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1063 | ++ |
+ ## j <- .colpath_to_j(j, coltree(x))+ |
+
| 1064 | +3x | +
+ j <- .path_to_pos(path = j, tt = x, cols = TRUE)+ |
+
| 1065 | +3x | +
+ x[i = i, j = j, ..., drop = drop]+ |
+
| 1066 | ++ |
+ }+ |
+
| 1067 | ++ |
+ )+ |
+
| 1068 | ++ | + + | +
| 1069 | ++ |
+ #' @exportMethod [+ |
+
| 1070 | ++ |
+ #' @rdname int_methods+ |
+
| 1071 | ++ |
+ #' @keywords internal+ |
+
| 1072 | ++ |
+ setMethod(+ |
+
| 1073 | ++ |
+ "[", c("VTableTree", "character", "ANY"),
+ |
+
| 1074 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1075 | ++ |
+ ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)+ |
+
| 1076 | +! | +
+ i <- .path_to_pos(i, x)+ |
+
| 1077 | +! | +
+ x[i = i, j = j, ..., drop = drop]+ |
+
| 1078 | ++ |
+ }+ |
+
| 1079 | ++ |
+ )+ |
+
| 1080 | ++ | + + | +
| 1081 | ++ |
+ ## to avoid dispatch ambiguity. Not necessary, possibly not a good idea at all+ |
+
| 1082 | ++ |
+ #' @exportMethod [+ |
+
| 1083 | ++ |
+ #' @rdname int_methods+ |
+
| 1084 | ++ |
+ #' @keywords internal+ |
+
| 1085 | ++ |
+ setMethod(+ |
+
| 1086 | ++ |
+ "[", c("VTableTree", "character", "character"),
+ |
+
| 1087 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1088 | ++ |
+ ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)+ |
+
| 1089 | +! | +
+ i <- .path_to_pos(i, x)+ |
+
| 1090 | ++ |
+ ## j <- .colpath_to_j(j, coltree(x))+ |
+
| 1091 | +! | +
+ j <- .path_to_pos(path = j, tt = x, cols = TRUE)+ |
+
| 1092 | +! | +
+ x[i = i, j = j, ..., drop = drop]+ |
+
| 1093 | ++ |
+ }+ |
+
| 1094 | ++ |
+ )+ |
+
| 1095 | ++ | + + | +
| 1096 | ++ |
+ #' @exportMethod [+ |
+
| 1097 | ++ |
+ #' @rdname int_methods+ |
+
| 1098 | ++ |
+ #' @keywords internal+ |
+
| 1099 | ++ |
+ setMethod(+ |
+
| 1100 | ++ |
+ "[", c("VTableTree", "missing", "numeric"),
+ |
+
| 1101 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1102 | +238x | +
+ i <- seq_len(nrow(x))+ |
+
| 1103 | +238x | +
+ x[i, j, ..., drop = drop]+ |
+
| 1104 | ++ |
+ }+ |
+
| 1105 | ++ |
+ )+ |
+
| 1106 | ++ | + + | +
| 1107 | ++ |
+ #' @exportMethod [+ |
+
| 1108 | ++ |
+ #' @rdname int_methods+ |
+
| 1109 | ++ |
+ #' @keywords internal+ |
+
| 1110 | ++ |
+ setMethod(+ |
+
| 1111 | ++ |
+ "[", c("VTableTree", "numeric", "numeric"),
+ |
+
| 1112 | ++ |
+ function(x, i, j, ..., drop = FALSE) {
+ |
+
| 1113 | ++ |
+ ## have to do it this way because we can't add an argument since we don't+ |
+
| 1114 | ++ |
+ ## own the generic declaration+ |
+
| 1115 | +471x | +
+ keep_topleft <- list(...)[["keep_topleft"]] %||% NA+ |
+
| 1116 | +471x | +
+ keep_titles <- list(...)[["keep_titles"]] %||% FALSE+ |
+
| 1117 | +471x | +
+ keep_footers <- list(...)[["keep_footers"]] %||% keep_titles+ |
+
| 1118 | +471x | +
+ reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE+ |
+
| 1119 | ++ | + + | +
| 1120 | +471x | +
+ nr <- nrow(x)+ |
+
| 1121 | +471x | +
+ nc <- ncol(x)+ |
+
| 1122 | +471x | +
+ i <- .j_to_posj(i, nr)+ |
+
| 1123 | +471x | +
+ j <- .j_to_posj(j, nc)+ |
+
| 1124 | ++ | + + | +
| 1125 | ++ |
+ ## if(!missing(i) && length(i) < nr) {
+ |
+
| 1126 | +471x | +
+ if (length(i) < nr) { ## already populated by .j_to_posj
+ |
+
| 1127 | +184x | +
+ keep_topleft <- isTRUE(keep_topleft)+ |
+
| 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+ |
+
| 1132 | ++ |
+ )+ |
+
| 1133 | +287x | +
+ } else if (is.na(keep_topleft)) {
+ |
+
| 1134 | +49x | +
+ keep_topleft <- TRUE+ |
+
| 1135 | ++ |
+ }+ |
+
| 1136 | ++ | + + | +
| 1137 | ++ |
+ ## if(!missing(j) && length(j) < nc)+ |
+
| 1138 | +471x | +
+ if (length(j) < nc) {
+ |
+
| 1139 | +232x | +
+ x <- subset_cols(x, j,+ |
+
| 1140 | +232x | +
+ keep_topleft = keep_topleft,+ |
+
| 1141 | +232x | +
+ keep_titles = keep_titles,+ |
+
| 1142 | +232x | +
+ keep_footers = keep_footers+ |
+
| 1143 | ++ |
+ )+ |
+
| 1144 | ++ |
+ }+ |
+
| 1145 | ++ | + + | +
| 1146 | ++ |
+ # Dropping everything+ |
+
| 1147 | +471x | +
+ if (drop) {
+ |
+
| 1148 | +35x | +
+ if (length(j) == 1L && length(i) == 1L) {
+ |
+
| 1149 | +30x | +
+ rw <- collect_leaves(x, TRUE, TRUE)[[1]]+ |
+
| 1150 | +30x | +
+ if (is(rw, "LabelRow")) {
+ |
+
| 1151 | +2x | +
+ warning(+ |
+
| 1152 | +2x | +
+ "The value selected with drop = TRUE belongs ",+ |
+
| 1153 | +2x | +
+ "to a label row. NULL will be returned"+ |
+
| 1154 | ++ |
+ )+ |
+
| 1155 | +2x | +
+ x <- NULL+ |
+
| 1156 | ++ |
+ } else {
+ |
+
| 1157 | +28x | +
+ x <- row_values(rw)[[1]]+ |
+
| 1158 | ++ |
+ }+ |
+
| 1159 | ++ |
+ } else {
+ |
+
| 1160 | +5x | +
+ warning(+ |
+
| 1161 | +5x | +
+ "Trying to drop more than one subsetted value. ",+ |
+
| 1162 | +5x | +
+ "We support this only with accessor function `cell_values()`. ",+ |
+
| 1163 | +5x | +
+ "No drop will be done at this time."+ |
+
| 1164 | ++ |
+ )+ |
+
| 1165 | +5x | +
+ drop <- FALSE+ |
+
| 1166 | ++ |
+ }+ |
+
| 1167 | ++ |
+ }+ |
+
| 1168 | +471x | +
+ if (!drop) {
+ |
+
| 1169 | +441x | +
+ if (!keep_topleft) {
+ |
+
| 1170 | +61x | +
+ top_left(x) <- character()+ |
+
| 1171 | ++ |
+ }+ |
+
| 1172 | +441x | +
+ if (reindex_refs) {
+ |
+
| 1173 | +105x | +
+ x <- update_ref_indexing(x)+ |
+
| 1174 | ++ |
+ }+ |
+
| 1175 | ++ |
+ }+ |
+
| 1176 | +471x | +
+ x+ |
+
| 1177 | ++ |
+ }+ |
+
| 1178 | ++ |
+ )+ |
+
| 1179 | ++ | + + | +
| 1180 | ++ |
+ #' @importFrom utils compareVersion+ |
+
| 1181 | ++ | + + | +
| 1182 | ++ |
+ setGeneric("tail", tail)
+ |
+
| 1183 | ++ | + + | +
| 1184 | ++ |
+ setMethod(+ |
+
| 1185 | ++ |
+ "tail", "VTableTree",+ |
+
| 1186 | ++ |
+ function(x, n = 6L, ...) {
+ |
+
| 1187 | ++ |
+ if (compareVersion("4.0.0", as.character(getRversion())) <= 0) {
+ |
+
| 1188 | ++ |
+ tail.matrix(x, n, keepnums = FALSE)+ |
+
| 1189 | ++ |
+ } else {
+ |
+
| 1190 | ++ |
+ tail.matrix(x, n, addrownums = FALSE)+ |
+
| 1191 | ++ |
+ }+ |
+
| 1192 | ++ |
+ }+ |
+
| 1193 | ++ |
+ )+ |
+
| 1194 | ++ | + + | +
| 1195 | ++ |
+ setGeneric("head", head)
+ |
+
| 1196 | ++ | + + | +
| 1197 | ++ |
+ setMethod(+ |
+
| 1198 | ++ |
+ "head", "VTableTree",+ |
+
| 1199 | ++ |
+ function(x, n = 6L, ...) {
+ |
+
| 1200 | ++ |
+ head.matrix(x, n)+ |
+
| 1201 | ++ |
+ }+ |
+
| 1202 | ++ |
+ )+ |
+
| 1203 | ++ | + + | +
| 1204 | ++ |
+ #' Retrieve cell values by row and column path+ |
+
| 1205 | ++ |
+ #'+ |
+
| 1206 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1207 | ++ |
+ #' @param rowpath (`character`)\cr path in row-split space to the desired row(s). Can include `"@content"`.+ |
+
| 1208 | ++ |
+ #' @param colpath (`character`)\cr path in column-split space to the desired column(s). Can include `"*"`.+ |
+
| 1209 | ++ |
+ #' @param omit_labrows (`flag`)\cr whether label rows underneath `rowpath` should be omitted (`TRUE`, the default),+ |
+
| 1210 | ++ |
+ #' or return empty lists of cell "values" (`FALSE`).+ |
+
| 1211 | ++ |
+ #'+ |
+
| 1212 | ++ |
+ #' @return+ |
+
| 1213 | ++ |
+ #' * `cell_values` returns a `list` (regardless of the type of value the cells hold). If `rowpath` defines a path to+ |
+
| 1214 | ++ |
+ #' a single row, `cell_values` returns the list of cell values for that row, otherwise a list of such lists, one for+ |
+
| 1215 | ++ |
+ #' each row captured underneath `rowpath`. This occurs after subsetting to `colpath` has occurred.+ |
+
| 1216 | ++ |
+ #' * `value_at` returns the "unwrapped" value of a single cell, or an error, if the combination of `rowpath` and+ |
+
| 1217 | ++ |
+ #' `colpath` do not define the location of a single cell in `tt`.+ |
+
| 1218 | ++ |
+ #'+ |
+
| 1219 | ++ |
+ #' @note `cell_values` will return a single cell's value wrapped in a list. Use `value_at` to receive the "bare" cell+ |
+
| 1220 | ++ |
+ #' value.+ |
+
| 1221 | ++ |
+ #'+ |
+
| 1222 | ++ |
+ #' @examples+ |
+
| 1223 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1224 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1225 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 1226 | ++ |
+ #' split_rows_by("RACE") %>%
+ |
+
| 1227 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 1228 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+
| 1229 | ++ |
+ #' analyze("AGE")
+ |
+
| 1230 | ++ |
+ #'+ |
+
| 1231 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 1232 | ++ |
+ #' library(dplyr) ## for mutate+ |
+
| 1233 | ++ |
+ #' tbl <- build_table(lyt, DM %>%+ |
+
| 1234 | ++ |
+ #' mutate(SEX = droplevels(SEX), RACE = droplevels(RACE)))+ |
+
| 1235 | ++ |
+ #'+ |
+
| 1236 | ++ |
+ #' row_paths_summary(tbl)+ |
+
| 1237 | ++ |
+ #' col_paths_summary(tbl)+ |
+
| 1238 | ++ |
+ #'+ |
+
| 1239 | ++ |
+ #' cell_values(+ |
+
| 1240 | ++ |
+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B"),
+ |
+
| 1241 | ++ |
+ #' c("ARM", "A: Drug X", "SEX", "F")
+ |
+
| 1242 | ++ |
+ #' )+ |
+
| 1243 | ++ |
+ #'+ |
+
| 1244 | ++ |
+ #' # it's also possible to access multiple values by being less specific+ |
+
| 1245 | ++ |
+ #' cell_values(+ |
+
| 1246 | ++ |
+ #' tbl, c("RACE", "ASIAN", "STRATA1"),
+ |
+
| 1247 | ++ |
+ #' c("ARM", "A: Drug X", "SEX", "F")
+ |
+
| 1248 | ++ |
+ #' )+ |
+
| 1249 | ++ |
+ #' cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M"))
+ |
+
| 1250 | ++ |
+ #'+ |
+
| 1251 | ++ |
+ #' ## any arm, male columns from the ASIAN content (i.e. summary) row+ |
+
| 1252 | ++ |
+ #' cell_values(+ |
+
| 1253 | ++ |
+ #' tbl, c("RACE", "ASIAN", "@content"),
+ |
+
| 1254 | ++ |
+ #' c("ARM", "B: Placebo", "SEX", "M")
+ |
+
| 1255 | ++ |
+ #' )+ |
+
| 1256 | ++ |
+ #' cell_values(+ |
+
| 1257 | ++ |
+ #' tbl, c("RACE", "ASIAN", "@content"),
+ |
+
| 1258 | ++ |
+ #' c("ARM", "*", "SEX", "M")
+ |
+
| 1259 | ++ |
+ #' )+ |
+
| 1260 | ++ |
+ #'+ |
+
| 1261 | ++ |
+ #' ## all columns+ |
+
| 1262 | ++ |
+ #' cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B"))
+ |
+
| 1263 | ++ |
+ #'+ |
+
| 1264 | ++ |
+ #' ## all columns for the Combination arm+ |
+
| 1265 | ++ |
+ #' cell_values(+ |
+
| 1266 | ++ |
+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B"),
+ |
+
| 1267 | ++ |
+ #' c("ARM", "C: Combination")
+ |
+
| 1268 | ++ |
+ #' )+ |
+
| 1269 | ++ |
+ #'+ |
+
| 1270 | ++ |
+ #' cvlist <- cell_values(+ |
+
| 1271 | ++ |
+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
+ |
+
| 1272 | ++ |
+ #' c("ARM", "B: Placebo", "SEX", "M")
+ |
+
| 1273 | ++ |
+ #' )+ |
+
| 1274 | ++ |
+ #' cvnolist <- value_at(+ |
+
| 1275 | ++ |
+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
+ |
+
| 1276 | ++ |
+ #' c("ARM", "B: Placebo", "SEX", "M")
+ |
+
| 1277 | ++ |
+ #' )+ |
+
| 1278 | ++ |
+ #' stopifnot(identical(cvlist[[1]], cvnolist))+ |
+
| 1279 | ++ |
+ #'+ |
+
| 1280 | ++ |
+ #' @rdname cell_values+ |
+
| 1281 | ++ |
+ #' @export+ |
+
| 1282 | ++ |
+ setGeneric("cell_values", function(tt, rowpath = NULL, colpath = NULL, omit_labrows = TRUE) {
+ |
+
| 1283 | +163x | +
+ standardGeneric("cell_values")
+ |
+
| 1284 | ++ |
+ })+ |
+
| 1285 | ++ | + + | +
| 1286 | ++ |
+ #' @rdname int_methods+ |
+
| 1287 | ++ |
+ #' @keywords internal+ |
+
| 1288 | ++ |
+ #' @exportMethod cell_values+ |
+
| 1289 | ++ |
+ setMethod(+ |
+
| 1290 | ++ |
+ "cell_values", "VTableTree",+ |
+
| 1291 | ++ |
+ function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
+ |
+
| 1292 | +160x | +
+ .inner_cell_value(tt,+ |
+
| 1293 | +160x | +
+ rowpath = rowpath, colpath = colpath,+ |
+
| 1294 | +160x | +
+ omit_labrows = omit_labrows, value_at = FALSE+ |
+
| 1295 | ++ |
+ )+ |
+
| 1296 | ++ |
+ }+ |
+
| 1297 | ++ |
+ )+ |
+
| 1298 | ++ | + + | +
| 1299 | ++ |
+ #' @rdname int_methods+ |
+
| 1300 | ++ |
+ #' @keywords internal+ |
+
| 1301 | ++ |
+ #' @exportMethod cell_values+ |
+
| 1302 | ++ |
+ setMethod(+ |
+
| 1303 | ++ |
+ "cell_values", "TableRow",+ |
+
| 1304 | ++ |
+ function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
+ |
+
| 1305 | +2x | +
+ if (!is.null(rowpath)) {
+ |
+
| 1306 | +1x | +
+ stop("cell_values on TableRow objects must have NULL rowpath")
+ |
+
| 1307 | ++ |
+ }+ |
+
| 1308 | +1x | +
+ .inner_cell_value(tt,+ |
+
| 1309 | +1x | +
+ rowpath = rowpath, colpath = colpath,+ |
+
| 1310 | +1x | +
+ omit_labrows = omit_labrows, value_at = FALSE+ |
+
| 1311 | ++ |
+ )+ |
+
| 1312 | ++ |
+ }+ |
+
| 1313 | ++ |
+ )+ |
+
| 1314 | ++ | + + | +
| 1315 | ++ |
+ #' @rdname int_methods+ |
+
| 1316 | ++ |
+ #' @keywords internal+ |
+
| 1317 | ++ |
+ #' @exportMethod cell_values+ |
+
| 1318 | ++ |
+ setMethod(+ |
+
| 1319 | ++ |
+ "cell_values", "LabelRow",+ |
+
| 1320 | ++ |
+ function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
+ |
+
| 1321 | +1x | +
+ stop("calling cell_values on LabelRow is not meaningful")
+ |
+
| 1322 | ++ |
+ }+ |
+
| 1323 | ++ |
+ )+ |
+
| 1324 | ++ | + + | +
| 1325 | ++ |
+ #' @rdname cell_values+ |
+
| 1326 | ++ |
+ #' @export+ |
+
| 1327 | ++ |
+ setGeneric("value_at", function(tt, rowpath = NULL, colpath = NULL) {
+ |
+
| 1328 | +8x | +
+ standardGeneric("value_at")
+ |
+
| 1329 | ++ |
+ })+ |
+
| 1330 | ++ | + + | +
| 1331 | ++ |
+ #' @rdname cell_values+ |
+
| 1332 | ++ |
+ #' @exportMethod value_at+ |
+
| 1333 | ++ |
+ setMethod(+ |
+
| 1334 | ++ |
+ "value_at", "VTableTree",+ |
+
| 1335 | ++ |
+ function(tt, rowpath, colpath = NULL) {
+ |
+
| 1336 | +7x | +
+ .inner_cell_value(tt,+ |
+
| 1337 | +7x | +
+ rowpath = rowpath, colpath = colpath,+ |
+
| 1338 | +7x | +
+ omit_labrows = FALSE, value_at = TRUE+ |
+
| 1339 | ++ |
+ )+ |
+
| 1340 | ++ |
+ }+ |
+
| 1341 | ++ |
+ )+ |
+
| 1342 | ++ | + + | +
| 1343 | ++ |
+ #' @rdname int_methods+ |
+
| 1344 | ++ |
+ #' @keywords internal+ |
+
| 1345 | ++ |
+ #' @exportMethod value_at+ |
+
| 1346 | ++ |
+ setMethod(+ |
+
| 1347 | ++ |
+ "value_at", "TableRow",+ |
+
| 1348 | ++ |
+ function(tt, rowpath, colpath = NULL) {
+ |
+
| 1349 | +1x | +
+ .inner_cell_value(tt,+ |
+
| 1350 | +1x | +
+ rowpath = rowpath, colpath = colpath,+ |
+
| 1351 | +1x | +
+ omit_labrows = FALSE, value_at = TRUE+ |
+
| 1352 | ++ |
+ )+ |
+
| 1353 | ++ |
+ }+ |
+
| 1354 | ++ |
+ )+ |
+
| 1355 | ++ | + + | +
| 1356 | ++ |
+ #' @rdname int_methods+ |
+
| 1357 | ++ |
+ #' @keywords internal+ |
+
| 1358 | ++ |
+ #' @exportMethod value_at+ |
+
| 1359 | ++ |
+ setMethod(+ |
+
| 1360 | ++ |
+ "value_at", "LabelRow",+ |
+
| 1361 | ++ |
+ function(tt, rowpath, colpath = NULL) {
+ |
+
| 1362 | +! | +
+ stop("calling value_at for LabelRow objects is not meaningful")
+ |
+
| 1363 | ++ |
+ }+ |
+
| 1364 | ++ |
+ )+ |
+
| 1365 | ++ | + + | +
| 1366 | ++ |
+ .inner_cell_value <- function(tt,+ |
+
| 1367 | ++ |
+ rowpath,+ |
+
| 1368 | ++ |
+ colpath = NULL,+ |
+
| 1369 | ++ |
+ omit_labrows = TRUE,+ |
+
| 1370 | ++ |
+ value_at = FALSE) {
+ |
+
| 1371 | +169x | +
+ if (is.null(rowpath)) {
+ |
+
| 1372 | +90x | +
+ subtree <- tt+ |
+
| 1373 | ++ |
+ } else {
+ |
+
| 1374 | +79x | +
+ subtree <- tt_at_path(tt, rowpath)+ |
+
| 1375 | ++ |
+ }+ |
+
| 1376 | +168x | +
+ if (!is.null(colpath)) {
+ |
+
| 1377 | +28x | +
+ subtree <- subset_cols(subtree, colpath)+ |
+
| 1378 | ++ |
+ }+ |
+
| 1379 | ++ | + + | +
| 1380 | +168x | +
+ rows <- collect_leaves(subtree, TRUE, !omit_labrows)+ |
+
| 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",
+ |
+
| 1383 | +3x | +
+ " To retrieve more than one cell value at a time use cell_values().",+ |
+
| 1384 | +3x | +
+ call. = FALSE+ |
+
| 1385 | ++ |
+ )+ |
+
| 1386 | ++ |
+ }+ |
+
| 1387 | +165x | +
+ if (length(rows) == 1) {
+ |
+
| 1388 | +92x | +
+ ret <- row_values(rows[[1]])+ |
+
| 1389 | +92x | +
+ if (value_at && ncol(subtree) == 1) {
+ |
+
| 1390 | +5x | +
+ ret <- ret[[1]]+ |
+
| 1391 | ++ |
+ }+ |
+
| 1392 | +92x | +
+ ret+ |
+
| 1393 | ++ |
+ } else {
+ |
+
| 1394 | +73x | +
+ lapply(rows, row_values)+ |
+
| 1395 | ++ |
+ }+ |
+
| 1396 | ++ |
+ }+ |
+
| 1397 | ++ | + + | +
| 1398 | ++ |
+ ## empty_table is created in onLoad because it depends on other things there.+ |
+
| 1399 | ++ | + + | +
| 1400 | ++ |
+ # Helper function to copy or not header, footer, and topleft information+ |
+
| 1401 | ++ |
+ .h_copy_titles_footers_topleft <- function(new,+ |
+
| 1402 | ++ |
+ old,+ |
+
| 1403 | ++ |
+ keep_titles,+ |
+
| 1404 | ++ |
+ keep_footers,+ |
+
| 1405 | ++ |
+ keep_topleft,+ |
+
| 1406 | ++ |
+ reindex_refs = FALSE,+ |
+
| 1407 | ++ |
+ empt_tbl = empty_table) {
+ |
+
| 1408 | ++ |
+ ## Please note that the standard adopted come from an empty table+ |
+
| 1409 | ++ | + + | +
| 1410 | ++ |
+ # titles+ |
+
| 1411 | +2886x | +
+ if (isTRUE(keep_titles)) {
+ |
+
| 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)+ |
+
| 1416 | +174x | +
+ subtitles(new) <- subtitles(empt_tbl)+ |
+
| 1417 | ++ |
+ }+ |
+
| 1418 | ++ | + + | +
| 1419 | ++ |
+ # fnotes+ |
+
| 1420 | +2886x | +
+ if (isTRUE(keep_footers)) {
+ |
+
| 1421 | +2718x | +
+ main_footer(new) <- main_footer(old)+ |
+
| 1422 | +2718x | +
+ prov_footer(new) <- prov_footer(old)+ |
+
| 1423 | ++ |
+ } else {
+ |
+
| 1424 | +168x | +
+ main_footer(new) <- main_footer(empt_tbl)+ |
+
| 1425 | +168x | +
+ prov_footer(new) <- prov_footer(empt_tbl)+ |
+
| 1426 | ++ |
+ }+ |
+
| 1427 | ++ | + + | +
| 1428 | ++ |
+ # topleft+ |
+
| 1429 | +2886x | +
+ if (isTRUE(keep_topleft)) {
+ |
+
| 1430 | +2738x | +
+ top_left(new) <- top_left(old)+ |
+
| 1431 | ++ |
+ } else {
+ |
+
| 1432 | +148x | +
+ top_left(new) <- top_left(empt_tbl)+ |
+
| 1433 | ++ |
+ }+ |
+
| 1434 | ++ | + + | +
| 1435 | ++ |
+ # reindex references+ |
+
| 1436 | +2886x | +
+ if (reindex_refs) {
+ |
+
| 1437 | +! | +
+ new <- update_ref_indexing(new)+ |
+
| 1438 | ++ |
+ }+ |
+
| 1439 | ++ | + + | +
| 1440 | +2886x | +
+ new+ |
+
| 1441 | ++ |
+ }+ |
+
| 1442 | ++ | + + | +
| 1443 | ++ |
+ #' 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+ |
+
| 1472 | +5x | +
+ res <- callNextMethod()+ |
+
| 1473 | +5x | +
+ res <- .h_copy_titles_footers_topleft(+ |
+
| 1474 | +5x | +
+ old = x, new = res,+ |
+
| 1475 | +5x | +
+ keep_topleft = keep_topleft,+ |
+
| 1476 | +5x | +
+ keep_titles = keep_titles,+ |
+
| 1477 | +5x | +
+ keep_footers = keep_footers,+ |
+
| 1478 | +5x | +
+ reindex_refs = reindex_refs+ |
+
| 1479 | ++ |
+ )+ |
+
| 1480 | +5x | +
+ res+ |
+
| 1481 | ++ |
+ }+ |
+
| 1482 | ++ |
+ )+ |
+
| 1483 | ++ | + + | +
| 1484 | ++ |
+ #' @docType methods+ |
+
| 1485 | ++ |
+ #' @export+ |
+
| 1486 | ++ |
+ #' @rdname head_tail+ |
+
| 1487 | ++ |
+ setGeneric("tail")
+ |
+
| 1488 | ++ | + + | +
| 1489 | ++ |
+ #' @docType methods+ |
+
| 1490 | ++ |
+ #' @export+ |
+
| 1491 | ++ |
+ #' @rdname head_tail+ |
+
| 1492 | ++ |
+ setMethod(+ |
+
| 1493 | ++ |
+ "tail", "VTableTree",+ |
+
| 1494 | ++ |
+ function(x, n = 6, ..., keep_topleft = TRUE,+ |
+
| 1495 | ++ |
+ keep_titles = TRUE,+ |
+
| 1496 | ++ |
+ keep_footers = keep_titles,+ |
+
| 1497 | ++ |
+ ## FALSE because this is a glance+ |
+
| 1498 | ++ |
+ ## more often than a subset op+ |
+
| 1499 | ++ |
+ reindex_refs = FALSE) {
+ |
+
| 1500 | +4x | +
+ res <- callNextMethod()+ |
+
| 1501 | +4x | +
+ res <- .h_copy_titles_footers_topleft(+ |
+
| 1502 | +4x | +
+ old = x, new = res,+ |
+
| 1503 | +4x | +
+ keep_topleft = keep_topleft,+ |
+
| 1504 | +4x | +
+ keep_titles = keep_titles,+ |
+
| 1505 | +4x | +
+ keep_footers = keep_footers,+ |
+
| 1506 | +4x | +
+ reindex_refs = reindex_refs+ |
+
| 1507 | ++ |
+ )+ |
+
| 1508 | +4x | +
+ res+ |
+
| 1509 | ++ |
+ }+ |
+
| 1510 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @import formatters+ |
+
| 2 | ++ |
+ #' @importMethodsFrom formatters toString matrix_form nlines+ |
+
| 3 | ++ |
+ NULL+ |
+
| 4 | ++ | + + | +
| 5 | ++ |
+ # toString ----+ |
+
| 6 | ++ | + + | +
| 7 | ++ |
+ ## #' @export+ |
+
| 8 | ++ |
+ ## setGeneric("toString", function(x,...) standardGeneric("toString"))
+ |
+
| 9 | ++ | + + | +
| 10 | ++ |
+ ## ## preserve S3 behavior+ |
+
| 11 | ++ |
+ ## setMethod("toString", "ANY", base::toString)
+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ ## #' @export+ |
+
| 14 | ++ |
+ ## setMethod("print", "ANY", base::print)
+ |
+
| 15 | ++ | + + | +
| 16 | ++ |
+ #' Convert an `rtable` object to a string+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @inheritParams formatters::toString+ |
+
| 19 | ++ |
+ #' @inheritParams gen_args+ |
+
| 20 | ++ |
+ #' @inherit formatters::toString+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @return A string representation of `x` as it appears when printed.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 25 | ++ |
+ #' library(dplyr)+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' iris2 <- iris %>%+ |
+
| 28 | ++ |
+ #' group_by(Species) %>%+ |
+
| 29 | ++ |
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ |
+
| 30 | ++ |
+ #' ungroup()+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 33 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 34 | ++ |
+ #' split_cols_by("group") %>%
+ |
+
| 35 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' tbl <- build_table(lyt, iris2)+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' cat(toString(tbl, col_gap = 3))+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @rdname tostring+ |
+
| 42 | ++ |
+ #' @aliases tostring toString,VTableTree-method+ |
+
| 43 | ++ |
+ #' @exportMethod toString+ |
+
| 44 | ++ |
+ setMethod("toString", "VTableTree", function(x,
+ |
+
| 45 | ++ |
+ widths = NULL,+ |
+
| 46 | ++ |
+ col_gap = 3,+ |
+
| 47 | ++ |
+ hsep = horizontal_sep(x),+ |
+
| 48 | ++ |
+ indent_size = 2,+ |
+
| 49 | ++ |
+ tf_wrap = FALSE,+ |
+
| 50 | ++ |
+ max_width = NULL,+ |
+
| 51 | ++ |
+ fontspec = font_spec(),+ |
+
| 52 | ++ |
+ ttype_ok = FALSE) {
+ |
+
| 53 | +40x | +
+ toString(+ |
+
| 54 | +40x | +
+ matrix_form(x,+ |
+
| 55 | +40x | +
+ indent_rownames = TRUE,+ |
+
| 56 | +40x | +
+ indent_size = indent_size,+ |
+
| 57 | +40x | +
+ fontspec = fontspec,+ |
+
| 58 | +40x | +
+ col_gap = col_gap+ |
+
| 59 | ++ |
+ ),+ |
+
| 60 | +40x | +
+ widths = widths, col_gap = col_gap,+ |
+
| 61 | +40x | +
+ hsep = hsep,+ |
+
| 62 | +40x | +
+ tf_wrap = tf_wrap,+ |
+
| 63 | +40x | +
+ max_width = max_width,+ |
+
| 64 | +40x | +
+ fontspec = fontspec,+ |
+
| 65 | +40x | +
+ ttype_ok = ttype_ok+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | ++ |
+ })+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ #' Table shells+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' 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 | ++ |
+ #' @inheritParams formatters::toString+ |
+
| 75 | ++ |
+ #' @inheritParams gen_args+ |
+
| 76 | ++ |
+ #'+ |
+
| 77 | ++ |
+ #' @return+ |
+
| 78 | ++ |
+ #' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console.+ |
+
| 79 | ++ |
+ #' * `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 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 84 | ++ |
+ #' library(dplyr)+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' iris2 <- iris %>%+ |
+
| 87 | ++ |
+ #' group_by(Species) %>%+ |
+
| 88 | ++ |
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ |
+
| 89 | ++ |
+ #' ungroup()+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 92 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 93 | ++ |
+ #' split_cols_by("group") %>%
+ |
+
| 94 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' tbl <- build_table(lyt, iris2)+ |
+
| 97 | ++ |
+ #' table_shell(tbl)+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @export+ |
+
| 100 | ++ |
+ table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),+ |
+
| 101 | ++ |
+ tf_wrap = FALSE, max_width = NULL) {
+ |
+
| 102 | +2x | +
+ 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 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ ## XXX consider moving to formatters, its really just a function+ |
+
| 109 | ++ |
+ ## of the MatrixPrintForm+ |
+
| 110 | ++ |
+ #' @rdname table_shell+ |
+
| 111 | ++ |
+ #' @export+ |
+
| 112 | ++ |
+ table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),+ |
+
| 113 | ++ |
+ tf_wrap = FALSE, max_width = NULL) {
+ |
+
| 114 | +2x | +
+ matform <- matrix_form(tt, indent_rownames = TRUE)+ |
+
| 115 | +2x | +
+ format_strs <- vapply(+ |
+
| 116 | +2x | +
+ as.vector(matform$formats),+ |
+
| 117 | +2x | +
+ function(x) {
+ |
+
| 118 | +18x | +
+ if (inherits(x, "function")) {
+ |
+
| 119 | +1x | +
+ "<fnc>"+ |
+
| 120 | +17x | +
+ } else if (inherits(x, "character")) {
+ |
+
| 121 | +17x | +
+ x+ |
+
| 122 | ++ |
+ } else {
+ |
+
| 123 | +! | +
+ stop("Don't know how to make a shell with formats of class: ", class(x))
+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ |
+ }, ""+ |
+
| 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 | +
+ nlh <- mf_nlheader(matform)+ |
+
| 131 | +2x | +
+ format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ]+ |
+
| 132 | ++ | + + | +
| 133 | +2x | +
+ matform$strings <- format_strs_mat+ |
+
| 134 | +2x | +
+ if (is.null(widths)) {
+ |
+
| 135 | +2x | +
+ widths <- propose_column_widths(matform)+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | +2x | +
+ toString(matform,+ |
+
| 138 | +2x | +
+ widths = widths, col_gap = col_gap, hsep = hsep,+ |
+
| 139 | +2x | +
+ tf_wrap = tf_wrap, max_width = max_width+ |
+
| 140 | ++ |
+ )+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | ++ |
+ #' Transform an `rtable` to a list of matrices which can be used for outputting+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML+ |
+
| 146 | ++ |
+ #' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form.+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @inheritParams gen_args+ |
+
| 149 | ++ |
+ #' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output+ |
+
| 150 | ++ |
+ #' has indented row names (strings pre-fixed).+ |
+
| 151 | ++ |
+ #' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain+ |
+
| 152 | ++ |
+ #' newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`.+ |
+
| 153 | ++ |
+ #' @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 | ++ |
+ #' by `fontspec`) that should be placed between columns when the table+ |
+
| 157 | ++ |
+ #' is rendered directly to text (e.g., by `toString` or `export_as_txt`). Defaults+ |
+
| 158 | ++ |
+ #' to `3`.+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @details+ |
+
| 161 | ++ |
+ #' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell+ |
+
| 162 | ++ |
+ #' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal+ |
+
| 163 | ++ |
+ #' function.+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @return A list with the following elements:+ |
+
| 166 | ++ |
+ #' \describe{
+ |
+
| 167 | ++ |
+ #' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
+ |
+
| 168 | ++ |
+ #' and cell values of `tt`.}+ |
+
| 169 | ++ |
+ #' \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 | ++ |
+ #' \item{`display`}{Whether each print-string in the strings matrix should be printed.}
+ |
+
| 172 | ++ |
+ #' \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
+ |
+
| 173 | ++ |
+ #' }+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ #' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines.+ |
+
| 176 | ++ |
+ #'+ |
+
| 177 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 178 | ++ |
+ #' library(dplyr)+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' iris2 <- iris %>%+ |
+
| 181 | ++ |
+ #' group_by(Species) %>%+ |
+
| 182 | ++ |
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ |
+
| 183 | ++ |
+ #' ungroup()+ |
+
| 184 | ++ |
+ #'+ |
+
| 185 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 186 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 187 | ++ |
+ #' split_cols_by("group") %>%
+ |
+
| 188 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"),
+ |
+
| 189 | ++ |
+ #' afun = list_wrap_x(summary), format = "xx.xx"+ |
+
| 190 | ++ |
+ #' )+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' lyt+ |
+
| 193 | ++ |
+ #'+ |
+
| 194 | ++ |
+ #' tbl <- build_table(lyt, iris2)+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ #' matrix_form(tbl)+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @export+ |
+
| 199 | ++ |
+ setMethod(+ |
+
| 200 | ++ |
+ "matrix_form", "VTableTree",+ |
+
| 201 | ++ |
+ function(obj,+ |
+
| 202 | ++ |
+ indent_rownames = FALSE,+ |
+
| 203 | ++ |
+ expand_newlines = TRUE,+ |
+
| 204 | ++ |
+ indent_size = 2,+ |
+
| 205 | ++ |
+ fontspec = NULL,+ |
+
| 206 | ++ |
+ col_gap = 3L) {
+ |
+
| 207 | +300x | +
+ stopifnot(is(obj, "VTableTree"))+ |
+
| 208 | +300x | +
+ check_ccount_vis_ok(obj)+ |
+
| 209 | +299x | +
+ header_content <- .tbl_header_mat(obj) # first col are for row.names+ |
+
| 210 | ++ | + + | +
| 211 | +297x | +
+ sr <- make_row_df(obj, fontspec = fontspec)+ |
+
| 212 | ++ | + + | +
| 213 | +297x | +
+ body_content_strings <- if (NROW(sr) == 0) {
+ |
+
| 214 | +5x | +
+ character()+ |
+
| 215 | ++ |
+ } else {
+ |
+
| 216 | +292x | +
+ cbind(as.character(sr$label), get_formatted_cells(obj))+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | +297x | +
+ formats_strings <- if (NROW(sr) == 0) {
+ |
+
| 220 | +5x | +
+ character()+ |
+
| 221 | ++ |
+ } else {
+ |
+
| 222 | +292x | +
+ cbind("", get_formatted_cells(obj, shell = TRUE))
+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | ++ | + + | +
| 225 | +297x | +
+ tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
+ |
+
| 226 | +6575x | +
+ sp <- row_cspans(rr)+ |
+
| 227 | +6575x | +
+ rep(sp, times = sp)+ |
+
| 228 | ++ |
+ })+ |
+
| 229 | ++ | + + | +
| 230 | ++ |
+ ## the 1 is for row labels+ |
+
| 231 | +297x | +
+ body_spans <- if (nrow(obj) > 0) {
+ |
+
| 232 | +292x | +
+ cbind(1L, do.call(rbind, tsptmp))+ |
+
| 233 | ++ |
+ } else {
+ |
+
| 234 | +5x | +
+ matrix(1, nrow = 0, ncol = ncol(obj) + 1)+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ | + + | +
| 237 | +297x | +
+ body_aligns <- if (NROW(sr) == 0) {
+ |
+
| 238 | +5x | +
+ character()+ |
+
| 239 | ++ |
+ } else {
+ |
+
| 240 | +292x | +
+ cbind("left", get_cell_aligns(obj))
+ |
+
| 241 | ++ |
+ }+ |
+
| 242 | ++ | + + | +
| 243 | +297x | +
+ body <- rbind(header_content$body, body_content_strings)+ |
+
| 244 | ++ | + + | +
| 245 | +297x | +
+ hdr_fmt_blank <- matrix("",
+ |
+
| 246 | +297x | +
+ nrow = nrow(header_content$body),+ |
+
| 247 | +297x | +
+ ncol = ncol(header_content$body)+ |
+
| 248 | ++ |
+ )+ |
+
| 249 | +297x | +
+ if (disp_ccounts(obj)) {
+ |
+
| 250 | +36x | +
+ hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
+ |
+
| 251 | ++ |
+ }+ |
+
| 252 | ++ | + + | +
| 253 | +297x | +
+ formats <- rbind(hdr_fmt_blank, formats_strings)+ |
+
| 254 | ++ | + + | +
| 255 | +297x | +
+ spans <- rbind(header_content$span, body_spans)+ |
+
| 256 | +297x | +
+ row.names(spans) <- NULL+ |
+
| 257 | ++ | + + | +
| 258 | +297x | +
+ aligns <- rbind(+ |
+
| 259 | +297x | +
+ matrix(rep("center", length(header_content$body)),
+ |
+
| 260 | +297x | +
+ nrow = nrow(header_content$body)+ |
+
| 261 | ++ |
+ ),+ |
+
| 262 | +297x | +
+ body_aligns+ |
+
| 263 | ++ |
+ )+ |
+
| 264 | ++ | + + | +
| 265 | +297x | +
+ aligns[, 1] <- "left" # row names and topleft (still needed for topleft)+ |
+
| 266 | ++ | + + | +
| 267 | +297x | +
+ nr_header <- nrow(header_content$body)+ |
+
| 268 | +297x | +
+ if (indent_rownames) {
+ |
+
| 269 | +222x | +
+ body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent),+ |
+
| 270 | +222x | +
+ incr = indent_size+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ |
+ # why also formats?+ |
+
| 273 | +222x | +
+ formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent),+ |
+
| 274 | +222x | +
+ incr = indent_size+ |
+
| 275 | ++ |
+ )+ |
+
| 276 | +75x | +
+ } else if (NROW(sr) > 0) {
+ |
+
| 277 | +71x | +
+ sr$indent <- rep(0, NROW(sr))+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | ++ | + + | +
| 280 | +297x | +
+ col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
+ |
+
| 281 | +2765x | +
+ if (length(x) == 0) {
+ |
+
| 282 | ++ |
+ ""+ |
+
| 283 | ++ |
+ } else {
+ |
+
| 284 | +5x | +
+ paste(vapply(x, format_fnote_ref, ""), collapse = " ")+ |
+
| 285 | ++ |
+ }+ |
+
| 286 | +297x | +
+ }, ""), ncol = ncol(body))+ |
+
| 287 | +297x | +
+ body_ref_strs <- get_ref_matrix(obj)+ |
+
| 288 | ++ | + + | +
| 289 | +297x | +
+ body <- matrix(+ |
+
| 290 | +297x | +
+ paste0(+ |
+
| 291 | +297x | +
+ body,+ |
+
| 292 | +297x | +
+ rbind(+ |
+
| 293 | +297x | +
+ col_ref_strs,+ |
+
| 294 | +297x | +
+ body_ref_strs+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ |
+ ),+ |
+
| 297 | +297x | +
+ nrow = nrow(body),+ |
+
| 298 | +297x | +
+ ncol = ncol(body)+ |
+
| 299 | ++ |
+ )+ |
+
| 300 | ++ | + + | +
| 301 | +297x | +
+ ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here+ |
+
| 302 | +297x | +
+ pag_titles <- page_titles(obj)+ |
+
| 303 | ++ | + + | +
| 304 | +297x | +
+ MatrixPrintForm(+ |
+
| 305 | +297x | +
+ strings = body,+ |
+
| 306 | +297x | +
+ spans = spans,+ |
+
| 307 | +297x | +
+ aligns = aligns,+ |
+
| 308 | +297x | +
+ formats = formats,+ |
+
| 309 | ++ |
+ ## display = display, purely a function of spans, handled in constructor now+ |
+
| 310 | +297x | +
+ row_info = sr,+ |
+
| 311 | +297x | +
+ colpaths = make_col_df(obj)[["path"]],+ |
+
| 312 | ++ |
+ ## line_grouping handled internally now line_grouping = 1:nrow(body),+ |
+
| 313 | +297x | +
+ ref_fnotes = ref_fnotes,+ |
+
| 314 | +297x | +
+ nlines_header = nr_header, ## this is fixed internally+ |
+
| 315 | +297x | +
+ nrow_header = nr_header,+ |
+
| 316 | +297x | +
+ expand_newlines = expand_newlines,+ |
+
| 317 | +297x | +
+ has_rowlabs = TRUE,+ |
+
| 318 | +297x | +
+ has_topleft = TRUE,+ |
+
| 319 | +297x | +
+ main_title = main_title(obj),+ |
+
| 320 | +297x | +
+ subtitles = subtitles(obj),+ |
+
| 321 | +297x | +
+ page_titles = pag_titles,+ |
+
| 322 | +297x | +
+ main_footer = main_footer(obj),+ |
+
| 323 | +297x | +
+ prov_footer = prov_footer(obj),+ |
+
| 324 | +297x | +
+ table_inset = table_inset(obj),+ |
+
| 325 | +297x | +
+ header_section_div = header_section_div(obj),+ |
+
| 326 | +297x | +
+ horizontal_sep = horizontal_sep(obj),+ |
+
| 327 | +297x | +
+ indent_size = indent_size,+ |
+
| 328 | +297x | +
+ fontspec = fontspec,+ |
+
| 329 | +297x | +
+ col_gap = col_gap+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | ++ |
+ }+ |
+
| 332 | ++ |
+ )+ |
+
| 333 | ++ | + + | +
| 334 | ++ | + + | +
| 335 | ++ |
+ check_ccount_vis_ok <- function(tt) {
+ |
+
| 336 | +300x | +
+ ctree <- coltree(tt)+ |
+
| 337 | +300x | +
+ tlkids <- tree_children(ctree)+ |
+
| 338 | +300x | +
+ lapply(tlkids, ccvis_check_subtree)+ |
+
| 339 | +299x | +
+ invisible(NULL)+ |
+
| 340 | ++ |
+ }+ |
+
| 341 | ++ | + + | +
| 342 | ++ |
+ ccvis_check_subtree <- function(ctree) {
+ |
+
| 343 | +1505x | +
+ kids <- tree_children(ctree)+ |
+
| 344 | +1505x | +
+ if (is.null(kids)) {
+ |
+
| 345 | +! | +
+ return(invisible(NULL))+ |
+
| 346 | ++ |
+ }+ |
+
| 347 | +1505x | +
+ vals <- vapply(kids, disp_ccounts, TRUE)+ |
+
| 348 | +1505x | +
+ if (length(unique(vals)) > 1) {
+ |
+
| 349 | +1x | +
+ unmatch <- which(!duplicated(vals))[1:2]+ |
+
| 350 | +1x | +
+ stop(+ |
+
| 351 | +1x | +
+ "Detected different colcount visibility among sibling facets (those ",+ |
+
| 352 | +1x | +
+ "arising from the same split_cols_by* layout instruction). This is ",+ |
+
| 353 | +1x | +
+ "not supported.\n",+ |
+
| 354 | +1x | +
+ "Set count values to NA if you want a blank space to appear as the ",+ |
+
| 355 | +1x | +
+ "displayed count for particular facets.\n",+ |
+
| 356 | +1x | +
+ "First disagreement occured at paths:\n",+ |
+
| 357 | +1x | +
+ .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 | ++ |
+ }+ |
+
| 361 | +1504x | +
+ lapply(kids, ccvis_check_subtree)+ |
+
| 362 | +1504x | +
+ invisible(NULL)+ |
+
| 363 | ++ |
+ }+ |
+
| 364 | ++ | + + | +
| 365 | ++ |
+ .resolve_fn_symbol <- function(fn) {
+ |
+
| 366 | +440x | +
+ if (!is(fn, "RefFootnote")) {
+ |
+
| 367 | +! | +
+ return(NULL)+ |
+
| 368 | ++ |
+ }+ |
+
| 369 | +440x | +
+ ret <- ref_symbol(fn)+ |
+
| 370 | +440x | +
+ if (is.na(ret)) {
+ |
+
| 371 | +440x | +
+ ret <- as.character(ref_index(fn))+ |
+
| 372 | ++ |
+ }+ |
+
| 373 | +440x | +
+ ret+ |
+
| 374 | ++ |
+ }+ |
+
| 375 | ++ | + + | +
| 376 | ++ |
+ format_fnote_ref <- function(fn) {
+ |
+
| 377 | +40210x | +
+ if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
+ |
+
| 378 | +40147x | +
+ return("")
+ |
+
| 379 | +63x | +
+ } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
+ |
+
| 380 | +! | +
+ return(vapply(fn, format_fnote_ref, ""))+ |
+
| 381 | ++ |
+ }+ |
+
| 382 | +63x | +
+ if (is.list(fn)) {
+ |
+
| 383 | +58x | +
+ inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol))+ |
+
| 384 | ++ |
+ } else {
+ |
+
| 385 | +5x | +
+ inds <- .resolve_fn_symbol(fn)+ |
+
| 386 | ++ |
+ }+ |
+
| 387 | +63x | +
+ if (length(inds) > 0) {
+ |
+
| 388 | +63x | +
+ paste0(" {", paste(unique(inds), collapse = ", "), "}")
+ |
+
| 389 | ++ |
+ } else {
+ |
+
| 390 | ++ |
+ ""+ |
+
| 391 | ++ |
+ }+ |
+
| 392 | ++ |
+ }+ |
+
| 393 | ++ | + + | +
| 394 | ++ |
+ format_fnote_note <- function(fn) {
+ |
+
| 395 | +367x | +
+ if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
+ |
+
| 396 | +! | +
+ return(character())+ |
+
| 397 | ++ |
+ }+ |
+
| 398 | +367x | +
+ if (is.list(fn)) {
+ |
+
| 399 | +! | +
+ return(unlist(lapply(unlist(fn), format_fnote_note)))+ |
+
| 400 | ++ |
+ }+ |
+
| 401 | ++ | + + | +
| 402 | +367x | +
+ if (is(fn, "RefFootnote")) {
+ |
+
| 403 | +367x | +
+ paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
+ |
+
| 404 | ++ |
+ } else {
+ |
+
| 405 | +! | +
+ NULL+ |
+
| 406 | ++ |
+ }+ |
+
| 407 | ++ |
+ }+ |
+
| 408 | ++ | + + | +
| 409 | ++ |
+ .fn_ind_extractor <- function(strs) {
+ |
+
| 410 | +! | +
+ res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
+ |
+
| 411 | +! | +
+ res[res == "NA"] <- NA_character_+ |
+
| 412 | ++ |
+ ## these mixing is allowed now with symbols+ |
+
| 413 | ++ |
+ ## if(!(sum(is.na(res)) %in% c(0L, length(res))))+ |
+
| 414 | ++ |
+ ## stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
+ |
+
| 415 | +! | +
+ res+ |
+
| 416 | ++ |
+ }+ |
+
| 417 | ++ | + + | +
| 418 | ++ |
+ get_ref_matrix <- function(tt) {
+ |
+
| 419 | +297x | +
+ if (ncol(tt) == 0 || nrow(tt) == 0) {
+ |
+
| 420 | +5x | +
+ return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
+ |
+
| 421 | ++ |
+ }+ |
+
| 422 | +292x | +
+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)+ |
+
| 423 | +292x | +
+ lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE)+ |
+
| 424 | +292x | +
+ cstrs <- unlist(lapply(lst, format_fnote_ref))+ |
+
| 425 | +292x | +
+ bodymat <- matrix(cstrs,+ |
+
| 426 | +292x | +
+ byrow = TRUE,+ |
+
| 427 | +292x | +
+ nrow = nrow(tt),+ |
+
| 428 | +292x | +
+ ncol = ncol(tt)+ |
+
| 429 | ++ |
+ )+ |
+
| 430 | +292x | +
+ cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat)+ |
+
| 431 | ++ |
+ }+ |
+
| 432 | ++ | + + | +
| 433 | ++ |
+ get_formatted_fnotes <- function(tt) {
+ |
+
| 434 | +297x | +
+ colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes)+ |
+
| 435 | +297x | +
+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)+ |
+
| 436 | +297x | +
+ lst <- c(+ |
+
| 437 | +297x | +
+ colresfs,+ |
+
| 438 | +297x | +
+ unlist(+ |
+
| 439 | +297x | +
+ lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)),+ |
+
| 440 | +297x | +
+ recursive = FALSE+ |
+
| 441 | ++ |
+ )+ |
+
| 442 | ++ |
+ )+ |
+
| 443 | ++ | + + | +
| 444 | +297x | +
+ inds <- vapply(lst, ref_index, 1L)+ |
+
| 445 | +297x | +
+ ord <- order(inds)+ |
+
| 446 | +297x | +
+ lst <- lst[ord]+ |
+
| 447 | +297x | +
+ syms <- vapply(lst, ref_symbol, "")+ |
+
| 448 | +297x | +
+ keep <- is.na(syms) | !duplicated(syms)+ |
+
| 449 | +297x | +
+ lst <- lst[keep]+ |
+
| 450 | +297x | +
+ unique(vapply(lst, format_fnote_note, ""))+ |
+
| 451 | ++ | + + | +
| 452 | ++ |
+ ## , recursive = FALSE)+ |
+
| 453 | ++ |
+ ## rlst <- unlist(lapply(rows, row_footnotes))+ |
+
| 454 | ++ |
+ ## lst <-+ |
+
| 455 | ++ |
+ ## syms <- vapply(lst, ref_symbol, "")+ |
+
| 456 | ++ |
+ ## keep <- is.na(syms) | !duplicated(syms)+ |
+
| 457 | ++ |
+ ## lst <- lst[keep]+ |
+
| 458 | ++ |
+ ## inds <- vapply(lst, ref_index, 1L)+ |
+
| 459 | ++ |
+ ## cellstrs <- unlist(lapply(lst, format_fnote_note))+ |
+
| 460 | ++ |
+ ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw))))+ |
+
| 461 | ++ |
+ ## allstrs <- c(colstrs, rstrs, cellstrs)+ |
+
| 462 | ++ |
+ ## inds <- .fn_ind_extractor(allstrs)+ |
+
| 463 | ++ |
+ ## allstrs[order(inds)]+ |
+
| 464 | ++ |
+ }+ |
+
| 465 | ++ | + + | +
| 466 | ++ |
+ .do_tbl_h_piece2 <- function(tt) {
+ |
+
| 467 | +305x | +
+ coldf <- make_col_df(tt, visible_only = FALSE)+ |
+
| 468 | +305x | +
+ remain <- seq_len(nrow(coldf))+ |
+
| 469 | +305x | +
+ chunks <- list()+ |
+
| 470 | +305x | +
+ cur <- 1+ |
+
| 471 | +305x | +
+ na_str <- colcount_na_str(tt)+ |
+
| 472 | ++ | + + | +
| 473 | ++ |
+ ## XXX this would be better as the facet-associated+ |
+
| 474 | ++ |
+ ## format but I don't know that we need to+ |
+
| 475 | ++ |
+ ## support that level of differentiation anyway...+ |
+
| 476 | +305x | +
+ cc_format <- colcount_format(tt)+ |
+
| 477 | ++ |
+ ## each iteration of this loop identifies+ |
+
| 478 | ++ |
+ ## all rows corresponding to one top-level column+ |
+
| 479 | ++ |
+ ## label and its children, then processes those+ |
+
| 480 | ++ |
+ ## with .do_header_chunk+ |
+
| 481 | +305x | +
+ while (length(remain) > 0) {
+ |
+
| 482 | +822x | +
+ rw <- remain[1]+ |
+
| 483 | +822x | +
+ inds <- coldf$leaf_indices[[rw]]+ |
+
| 484 | +822x | +
+ endblock <- which(coldf$abs_pos == max(inds))+ |
+
| 485 | ++ | + + | +
| 486 | +822x | +
+ stopifnot(endblock >= rw)+ |
+
| 487 | +822x | +
+ chunk_res <- .do_header_chunk(coldf[rw:endblock, ], cc_format, na_str = na_str)+ |
+
| 488 | +820x | +
+ chunk_res <- unlist(chunk_res, recursive = FALSE)+ |
+
| 489 | +820x | +
+ chunks[[cur]] <- chunk_res+ |
+
| 490 | +820x | +
+ remain <- remain[remain > endblock]+ |
+
| 491 | +820x | +
+ cur <- cur + 1+ |
+
| 492 | ++ |
+ }+ |
+
| 493 | +303x | +
+ chunks <- .pad_tops(chunks)+ |
+
| 494 | +303x | +
+ lapply(+ |
+
| 495 | +303x | +
+ seq_len(length(chunks[[1]])),+ |
+
| 496 | +303x | +
+ function(i) {
+ |
+
| 497 | +464x | +
+ DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE))+ |
+
| 498 | ++ |
+ }+ |
+
| 499 | ++ |
+ )+ |
+
| 500 | ++ |
+ }+ |
+
| 501 | ++ | + + | +
| 502 | ++ |
+ .pad_end <- function(lst, padto, ncols) {
+ |
+
| 503 | +1257x | +
+ curcov <- sum(vapply(lst, cell_cspan, 0L))+ |
+
| 504 | +1257x | +
+ if (curcov == padto) {
+ |
+
| 505 | +1257x | +
+ return(lst)+ |
+
| 506 | ++ |
+ }+ |
+
| 507 | ++ | + + | +
| 508 | +! | +
+ c(lst, list(rcell("", colspan = padto - curcov)))
+ |
+
| 509 | ++ |
+ }+ |
+
| 510 | ++ | + + | +
| 511 | ++ |
+ .pad_tops <- function(chunks) {
+ |
+
| 512 | +303x | +
+ lens <- vapply(chunks, length, 1L)+ |
+
| 513 | +303x | +
+ padto <- max(lens)+ |
+
| 514 | +303x | +
+ needpad <- lens != padto+ |
+
| 515 | +303x | +
+ if (all(!needpad)) {
+ |
+
| 516 | +297x | +
+ return(chunks)+ |
+
| 517 | ++ |
+ }+ |
+
| 518 | ++ | + + | +
| 519 | +6x | +
+ for (i in seq_along(lens)) {
+ |
+
| 520 | +25x | +
+ if (lens[i] < padto) {
+ |
+
| 521 | +10x | +
+ chk <- chunks[[i]]+ |
+
| 522 | +10x | +
+ span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L))+ |
+
| 523 | +10x | +
+ chunks[[i]] <- c(+ |
+
| 524 | +10x | +
+ replicate(list(list(rcell("", colspan = span))),
+ |
+
| 525 | +10x | +
+ n = padto - lens[i]+ |
+
| 526 | ++ |
+ ),+ |
+
| 527 | +10x | +
+ chk+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | ++ |
+ }+ |
+
| 530 | ++ |
+ }+ |
+
| 531 | +6x | +
+ chunks+ |
+
| 532 | ++ |
+ }+ |
+
| 533 | ++ | + + | +
| 534 | ++ |
+ .do_header_chunk <- function(coldf, cc_format, na_str) {
+ |
+
| 535 | ++ |
+ ## hard assumption that coldf is a section+ |
+
| 536 | ++ |
+ ## of a column dataframe summary that was+ |
+
| 537 | ++ |
+ ## created with visible_only=FALSE+ |
+
| 538 | +822x | +
+ nleafcols <- length(coldf$leaf_indices[[1]])+ |
+
| 539 | ++ | + + | +
| 540 | +822x | +
+ spldfs <- split(coldf, lengths(coldf$path))+ |
+
| 541 | +822x | +
+ toret <- lapply(+ |
+
| 542 | +822x | +
+ seq_along(spldfs),+ |
+
| 543 | +822x | +
+ function(i) {
+ |
+
| 544 | +1120x | +
+ rws <- spldfs[[i]]+ |
+
| 545 | +1120x | +
+ thisbit_vals <- lapply(+ |
+
| 546 | +1120x | +
+ seq_len(nrow(rws)),+ |
+
| 547 | +1120x | +
+ function(ri) {
+ |
+
| 548 | +1517x | +
+ cellii <- rcell(rws[ri, "label", drop = TRUE],+ |
+
| 549 | +1517x | +
+ colspan = rws$total_span[ri],+ |
+
| 550 | +1517x | +
+ footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]]+ |
+
| 551 | ++ |
+ )+ |
+
| 552 | +1517x | +
+ cellii+ |
+
| 553 | ++ |
+ }+ |
+
| 554 | ++ |
+ )+ |
+
| 555 | +1120x | +
+ ret <- list(.pad_end(thisbit_vals, padto = nleafcols))+ |
+
| 556 | +1120x | +
+ anycounts <- any(rws$ccount_visible)+ |
+
| 557 | +1120x | +
+ if (anycounts) {
+ |
+
| 558 | +139x | +
+ thisbit_ns <- lapply(+ |
+
| 559 | +139x | +
+ seq_len(nrow(rws)),+ |
+
| 560 | +139x | +
+ function(ri) {
+ |
+
| 561 | +287x | +
+ vis_ri <- rws$ccount_visible[ri]+ |
+
| 562 | +287x | +
+ val <- if (vis_ri) rws$col_count[ri] else NULL+ |
+
| 563 | +287x | +
+ fmt <- rws$ccount_format[ri]+ |
+
| 564 | +287x | +
+ if (is.character(fmt)) {
+ |
+
| 565 | +287x | +
+ cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == fmt))))+ |
+
| 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...+ |
+
| 569 | ++ |
+ } else {
+ |
+
| 570 | +1x | +
+ stop(+ |
+
| 571 | +1x | +
+ "This 2d format is not supported for column counts. ",+ |
+
| 572 | +1x | +
+ "Please choose a 1d format or a 2d format that includes a % value."+ |
+
| 573 | ++ |
+ )+ |
+
| 574 | ++ |
+ }+ |
+
| 575 | +280x | +
+ } else if (cfmt_dim == "3d") {
+ |
+
| 576 | +1x | +
+ stop("3d formats are not supported for column counts.")
+ |
+
| 577 | ++ |
+ }+ |
+
| 578 | ++ |
+ }+ |
+
| 579 | +285x | +
+ cellii <- rcell(+ |
+
| 580 | +285x | +
+ val,+ |
+
| 581 | +285x | +
+ colspan = rws$total_span[ri],+ |
+
| 582 | +285x | +
+ format = fmt, # cc_format,+ |
+
| 583 | +285x | +
+ format_na_str = na_str+ |
+
| 584 | ++ |
+ )+ |
+
| 585 | +285x | +
+ cellii+ |
+
| 586 | ++ |
+ }+ |
+
| 587 | ++ |
+ )+ |
+
| 588 | +137x | +
+ ret <- c(ret, list(.pad_end(thisbit_ns, padto = nleafcols)))+ |
+
| 589 | ++ |
+ }+ |
+
| 590 | +1118x | +
+ ret+ |
+
| 591 | ++ |
+ }+ |
+
| 592 | ++ |
+ )+ |
+
| 593 | +820x | +
+ toret+ |
+
| 594 | ++ |
+ }+ |
+
| 595 | ++ | + + | +
| 596 | ++ |
+ .tbl_header_mat <- function(tt) {
+ |
+
| 597 | +299x | +
+ rows <- .do_tbl_h_piece2(tt) ## (clyt)+ |
+
| 598 | +297x | +
+ cinfo <- col_info(tt)+ |
+
| 599 | ++ | + + | +
| 600 | +297x | +
+ nc <- ncol(tt)+ |
+
| 601 | +297x | +
+ body <- matrix(rapply(rows, function(x) {
+ |
+
| 602 | +454x | +
+ cs <- row_cspans(x)+ |
+
| 603 | +454x | +
+ strs <- get_formatted_cells(x)+ |
+
| 604 | +454x | +
+ strs+ |
+
| 605 | +297x | +
+ }), ncol = nc, byrow = TRUE)+ |
+
| 606 | ++ | + + | +
| 607 | +297x | +
+ span <- matrix(rapply(rows, function(x) {
+ |
+
| 608 | +454x | +
+ cs <- row_cspans(x)+ |
+
| 609 | +! | +
+ if (is.null(cs)) cs <- rep(1, ncol(x))+ |
+
| 610 | +454x | +
+ rep(cs, cs)+ |
+
| 611 | +297x | +
+ }), ncol = nc, byrow = TRUE)+ |
+
| 612 | ++ | + + | +
| 613 | +297x | +
+ fnote <- do.call(+ |
+
| 614 | +297x | +
+ rbind,+ |
+
| 615 | +297x | +
+ lapply(rows, function(x) {
+ |
+
| 616 | +454x | +
+ cell_footnotes(x)+ |
+
| 617 | ++ |
+ })+ |
+
| 618 | ++ |
+ )+ |
+
| 619 | ++ | + + | +
| 620 | +297x | +
+ tl <- top_left(cinfo)+ |
+
| 621 | +297x | +
+ lentl <- length(tl)+ |
+
| 622 | +297x | +
+ nli <- nrow(body)+ |
+
| 623 | +297x | +
+ if (lentl == 0) {
+ |
+
| 624 | +262x | +
+ tl <- rep("", nli)
+ |
+
| 625 | +35x | +
+ } else if (lentl > nli) {
+ |
+
| 626 | +19x | +
+ tl_tmp <- paste0(tl, collapse = "\n")+ |
+
| 627 | +19x | +
+ tl <- rep("", nli)
+ |
+
| 628 | +19x | +
+ tl[length(tl)] <- tl_tmp+ |
+
| 629 | +16x | +
+ } else if (lentl < nli) {
+ |
+
| 630 | ++ |
+ # We want topleft alignment that goes to the bottom!+ |
+
| 631 | +7x | +
+ tl <- c(rep("", nli - lentl), tl)
+ |
+
| 632 | ++ |
+ }+ |
+
| 633 | +297x | +
+ list(+ |
+
| 634 | +297x | +
+ body = cbind(tl, body, deparse.level = 0), span = cbind(1, span),+ |
+
| 635 | +297x | +
+ footnotes = cbind(list(list()), fnote)+ |
+
| 636 | ++ |
+ )+ |
+
| 637 | ++ |
+ }+ |
+
| 638 | ++ | + + | +
| 639 | ++ |
+ # get formatted cells ----+ |
+
| 640 | ++ | + + | +
| 641 | ++ |
+ #' Get formatted cells+ |
+
| 642 | ++ |
+ #'+ |
+
| 643 | ++ |
+ #' @inheritParams gen_args+ |
+
| 644 | ++ |
+ #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats+ |
+
| 645 | ++ |
+ #' applied. Defaults to `FALSE`.+ |
+
| 646 | ++ |
+ #'+ |
+
| 647 | ++ |
+ #' @return The formatted print-strings for all (body) cells in `obj`.+ |
+
| 648 | ++ |
+ #'+ |
+
| 649 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 650 | ++ |
+ #' library(dplyr)+ |
+
| 651 | ++ |
+ #'+ |
+
| 652 | ++ |
+ #' iris2 <- iris %>%+ |
+
| 653 | ++ |
+ #' group_by(Species) %>%+ |
+
| 654 | ++ |
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ |
+
| 655 | ++ |
+ #' ungroup()+ |
+
| 656 | ++ |
+ #'+ |
+
| 657 | ++ |
+ #' tbl <- basic_table() %>%+ |
+
| 658 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 659 | ++ |
+ #' split_cols_by("group") %>%
+ |
+
| 660 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
+ |
+
| 661 | ++ |
+ #' build_table(iris2)+ |
+
| 662 | ++ |
+ #'+ |
+
| 663 | ++ |
+ #' get_formatted_cells(tbl)+ |
+
| 664 | ++ |
+ #'+ |
+
| 665 | ++ |
+ #' @export+ |
+
| 666 | ++ |
+ #' @rdname gfc+ |
+
| 667 | +37325x | +
+ setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells"))
+ |
+
| 668 | ++ | + + | +
| 669 | ++ |
+ #' @rdname gfc+ |
+
| 670 | ++ |
+ setMethod(+ |
+
| 671 | ++ |
+ "get_formatted_cells", "TableTree",+ |
+
| 672 | ++ |
+ function(obj, shell = FALSE) {
+ |
+
| 673 | +2722x | +
+ lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ |
+
| 674 | ++ | + + | +
| 675 | +2722x | +
+ ct <- get_formatted_cells(content_table(obj), shell = shell)+ |
+
| 676 | ++ | + + | +
| 677 | +2722x | +
+ els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ |
+
| 678 | ++ | + + | +
| 679 | ++ |
+ ## TODO fix ncol problem for rrow()+ |
+
| 680 | +2722x | +
+ if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
+ |
+
| 681 | +749x | +
+ ct <- lr[NULL, ]+ |
+
| 682 | ++ |
+ }+ |
+
| 683 | ++ | + + | +
| 684 | +2722x | +
+ do.call(rbind, c(list(lr), list(ct), els))+ |
+
| 685 | ++ |
+ }+ |
+
| 686 | ++ |
+ )+ |
+
| 687 | ++ | + + | +
| 688 | ++ |
+ #' @rdname gfc+ |
+
| 689 | ++ |
+ setMethod(+ |
+
| 690 | ++ |
+ "get_formatted_cells", "ElementaryTable",+ |
+
| 691 | ++ |
+ function(obj, shell = FALSE) {
+ |
+
| 692 | +5415x | +
+ lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ |
+
| 693 | +5415x | +
+ els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ |
+
| 694 | +5415x | +
+ do.call(rbind, c(list(lr), els))+ |
+
| 695 | ++ |
+ }+ |
+
| 696 | ++ |
+ )+ |
+
| 697 | ++ | + + | +
| 698 | ++ |
+ #' @rdname gfc+ |
+
| 699 | ++ |
+ setMethod(+ |
+
| 700 | ++ |
+ "get_formatted_cells", "TableRow",+ |
+
| 701 | ++ |
+ function(obj, shell = FALSE) {
+ |
+
| 702 | ++ |
+ # Parent row format and na_str+ |
+
| 703 | +21023x | +
+ pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj)+ |
+
| 704 | +21023x | +
+ pr_row_na_str <- obj_na_str(obj) %||% "NA"+ |
+
| 705 | ++ | + + | +
| 706 | +21023x | +
+ matrix(+ |
+
| 707 | +21023x | +
+ unlist(Map(function(val, spn, shelli) {
+ |
+
| 708 | +100791x | +
+ stopifnot(is(spn, "integer"))+ |
+
| 709 | ++ | + + | +
| 710 | +100791x | +
+ out <- format_rcell(val,+ |
+
| 711 | +100791x | +
+ pr_row_format = pr_row_format,+ |
+
| 712 | +100791x | +
+ pr_row_na_str = pr_row_na_str,+ |
+
| 713 | +100791x | +
+ shell = shelli+ |
+
| 714 | ++ |
+ )+ |
+
| 715 | +100791x | +
+ if (!is.function(out) && is.character(out)) {
+ |
+
| 716 | +100783x | +
+ out <- paste(out, collapse = ", ")+ |
+
| 717 | ++ |
+ }+ |
+
| 718 | ++ | + + | +
| 719 | +100791x | +
+ rep(list(out), spn)+ |
+
| 720 | +21023x | +
+ }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)),+ |
+
| 721 | +21023x | +
+ ncol = ncol(obj)+ |
+
| 722 | ++ |
+ )+ |
+
| 723 | ++ |
+ }+ |
+
| 724 | ++ |
+ )+ |
+
| 725 | ++ | + + | +
| 726 | ++ |
+ #' @rdname gfc+ |
+
| 727 | ++ |
+ setMethod(+ |
+
| 728 | ++ |
+ "get_formatted_cells", "LabelRow",+ |
+
| 729 | ++ |
+ function(obj, shell = FALSE) {
+ |
+
| 730 | +8165x | +
+ nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
+ |
+
| 731 | +8165x | +
+ vstr <- if (shell) "-" else ""+ |
+
| 732 | +8165x | +
+ if (labelrow_visible(obj)) {
+ |
+
| 733 | +2978x | +
+ matrix(rep(vstr, nc), ncol = nc)+ |
+
| 734 | ++ |
+ } else {
+ |
+
| 735 | +5187x | +
+ matrix(character(0), ncol = nc)+ |
+
| 736 | ++ |
+ }+ |
+
| 737 | ++ |
+ }+ |
+
| 738 | ++ |
+ )+ |
+
| 739 | ++ | + + | +
| 740 | ++ |
+ #' @rdname gfc+ |
+
| 741 | +13224x | +
+ setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))
+ |
+
| 742 | ++ | + + | +
| 743 | ++ |
+ #' @rdname gfc+ |
+
| 744 | ++ |
+ setMethod(+ |
+
| 745 | ++ |
+ "get_cell_aligns", "TableTree",+ |
+
| 746 | ++ |
+ function(obj) {
+ |
+
| 747 | +1359x | +
+ lr <- get_cell_aligns(tt_labelrow(obj))+ |
+
| 748 | ++ | + + | +
| 749 | +1359x | +
+ ct <- get_cell_aligns(content_table(obj))+ |
+
| 750 | ++ | + + | +
| 751 | +1359x | +
+ els <- lapply(tree_children(obj), get_cell_aligns)+ |
+
| 752 | ++ | + + | +
| 753 | ++ |
+ ## TODO fix ncol problem for rrow()+ |
+
| 754 | +1359x | +
+ if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
+ |
+
| 755 | +374x | +
+ ct <- lr[NULL, ]+ |
+
| 756 | ++ |
+ }+ |
+
| 757 | ++ | + + | +
| 758 | +1359x | +
+ do.call(rbind, c(list(lr), list(ct), els))+ |
+
| 759 | ++ |
+ }+ |
+
| 760 | ++ |
+ )+ |
+
| 761 | ++ | + + | +
| 762 | ++ |
+ #' @rdname gfc+ |
+
| 763 | ++ |
+ setMethod(+ |
+
| 764 | ++ |
+ "get_cell_aligns", "ElementaryTable",+ |
+
| 765 | ++ |
+ function(obj) {
+ |
+
| 766 | +2703x | +
+ lr <- get_cell_aligns(tt_labelrow(obj))+ |
+
| 767 | +2703x | +
+ els <- lapply(tree_children(obj), get_cell_aligns)+ |
+
| 768 | +2703x | +
+ do.call(rbind, c(list(lr), els))+ |
+
| 769 | ++ |
+ }+ |
+
| 770 | ++ |
+ )+ |
+
| 771 | ++ | + + | +
| 772 | ++ |
+ #' @rdname gfc+ |
+
| 773 | ++ |
+ setMethod(+ |
+
| 774 | ++ |
+ "get_cell_aligns", "TableRow",+ |
+
| 775 | ++ |
+ function(obj) {
+ |
+
| 776 | +5086x | +
+ als <- vapply(row_cells(obj), cell_align, "")+ |
+
| 777 | +5086x | +
+ spns <- row_cspans(obj)+ |
+
| 778 | ++ | + + | +
| 779 | +5086x | +
+ matrix(rep(als, times = spns),+ |
+
| 780 | +5086x | +
+ ncol = ncol(obj)+ |
+
| 781 | ++ |
+ )+ |
+
| 782 | ++ |
+ }+ |
+
| 783 | ++ |
+ )+ |
+
| 784 | ++ | + + | +
| 785 | ++ |
+ #' @rdname gfc+ |
+
| 786 | ++ |
+ setMethod(+ |
+
| 787 | ++ |
+ "get_cell_aligns", "LabelRow",+ |
+
| 788 | ++ |
+ function(obj) {
+ |
+
| 789 | +4076x | +
+ nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
+ |
+
| 790 | +4076x | +
+ if (labelrow_visible(obj)) {
+ |
+
| 791 | +1489x | +
+ matrix(rep("center", nc), ncol = nc)
+ |
+
| 792 | ++ |
+ } else {
+ |
+
| 793 | +2587x | +
+ matrix(character(0), ncol = nc)+ |
+
| 794 | ++ |
+ }+ |
+
| 795 | ++ |
+ }+ |
+
| 796 | ++ |
+ )+ |
+
| 797 | ++ | + + | +
| 798 | ++ |
+ # utility functions ----+ |
+
| 799 | ++ | + + | +
| 800 | ++ |
+ #' From a sorted sequence of numbers, remove numbers where diff == 1+ |
+
| 801 | ++ |
+ #'+ |
+
| 802 | ++ |
+ #' @examples+ |
+
| 803 | ++ |
+ #' remove_consecutive_numbers(x = c(2, 4, 9))+ |
+
| 804 | ++ |
+ #' remove_consecutive_numbers(x = c(2, 4, 5, 9))+ |
+
| 805 | ++ |
+ #' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9))+ |
+
| 806 | ++ |
+ #' remove_consecutive_numbers(x = 4:9)+ |
+
| 807 | ++ |
+ #'+ |
+
| 808 | ++ |
+ #' @noRd+ |
+
| 809 | ++ |
+ remove_consecutive_numbers <- function(x) {
+ |
+
| 810 | ++ |
+ # actually should be integer+ |
+
| 811 | +! | +
+ stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x))+ |
+
| 812 | ++ | + + | +
| 813 | +! | +
+ if (length(x) == 0) {
+ |
+
| 814 | +! | +
+ return(integer(0))+ |
+
| 815 | ++ |
+ }+ |
+
| 816 | +! | +
+ if (!is.integer(x)) x <- as.integer(x)+ |
+
| 817 | ++ | + + | +
| 818 | +! | +
+ x[c(TRUE, diff(x) != 1)]+ |
+
| 819 | ++ |
+ }+ |
+
| 820 | ++ | + + | +
| 821 | ++ |
+ #' Insert an empty string+ |
+
| 822 | ++ |
+ #'+ |
+
| 823 | ++ |
+ #' @examples+ |
+
| 824 | ++ |
+ #' empty_string_after(letters[1:5], 2)+ |
+
| 825 | ++ |
+ #' empty_string_after(letters[1:5], c(2, 4))+ |
+
| 826 | ++ |
+ #'+ |
+
| 827 | ++ |
+ #' @noRd+ |
+
| 828 | ++ |
+ empty_string_after <- function(x, indices) {
+ |
+
| 829 | +! | +
+ if (length(indices) > 0) {
+ |
+
| 830 | +! | +
+ offset <- 0+ |
+
| 831 | +! | +
+ for (i in sort(indices)) {
+ |
+
| 832 | +! | +
+ x <- append(x, "", i + offset)+ |
+
| 833 | +! | +
+ offset <- offset + 1+ |
+
| 834 | ++ |
+ }+ |
+
| 835 | ++ |
+ }+ |
+
| 836 | +! | +
+ x+ |
+
| 837 | ++ |
+ }+ |
+
| 838 | ++ | + + | +
| 839 | ++ |
+ #' Indent strings+ |
+
| 840 | ++ |
+ #'+ |
+
| 841 | ++ |
+ #' Used in rtables to indent row names for the ASCII output.+ |
+
| 842 | ++ |
+ #'+ |
+
| 843 | ++ |
+ #' @param x (`character`)\cr a character vector.+ |
+
| 844 | ++ |
+ #' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`.+ |
+
| 845 | ++ |
+ #' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level.+ |
+
| 846 | ++ |
+ #' @param including_newline (`flag`)\cr whether newlines should also be indented.+ |
+
| 847 | ++ |
+ #'+ |
+
| 848 | ++ |
+ #' @return `x`, indented with left-padding with `indent * incr` white-spaces.+ |
+
| 849 | ++ |
+ #'+ |
+
| 850 | ++ |
+ #' @examples+ |
+
| 851 | ++ |
+ #' indent_string("a", 0)
+ |
+
| 852 | ++ |
+ #' indent_string("a", 1)
+ |
+
| 853 | ++ |
+ #' indent_string(letters[1:3], 0:2)+ |
+
| 854 | ++ |
+ #' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2)+ |
+
| 855 | ++ |
+ #'+ |
+
| 856 | ++ |
+ #' @export+ |
+
| 857 | ++ |
+ indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
+ |
+
| 858 | +596x | +
+ if (length(x) > 0) {
+ |
+
| 859 | +596x | +
+ indent <- rep_len(indent, length.out = length(x))+ |
+
| 860 | +596x | +
+ incr <- rep_len(incr, length.out = length(x))+ |
+
| 861 | ++ |
+ }+ |
+
| 862 | ++ | + + | +
| 863 | +596x | +
+ indent_str <- strrep(" ", (indent > 0) * indent * incr)
+ |
+
| 864 | ++ | + + | +
| 865 | +596x | +
+ if (including_newline) {
+ |
+
| 866 | +596x | +
+ x <- unlist(mapply(function(xi, stri) {
+ |
+
| 867 | +12774x | +
+ gsub("\n", stri, xi, fixed = TRUE)
+ |
+
| 868 | +596x | +
+ }, x, paste0("\n", indent_str)))
+ |
+
| 869 | ++ |
+ }+ |
+
| 870 | ++ | + + | +
| 871 | +596x | +
+ paste0(indent_str, x)+ |
+
| 872 | ++ |
+ }+ |
+
| 873 | ++ | + + | +
| 874 | ++ |
+ ## .paste_no_na <- function(x, ...) {
+ |
+
| 875 | ++ |
+ ## paste(na.omit(x), ...)+ |
+
| 876 | ++ |
+ ## }+ |
+
| 877 | ++ | + + | +
| 878 | ++ |
+ ## #' Pad a string and align within string+ |
+
| 879 | ++ |
+ ## #'+ |
+
| 880 | ++ |
+ ## #' @param x string+ |
+
| 881 | ++ |
+ ## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown+ |
+
| 882 | ++ |
+ ## #'+ |
+
| 883 | ++ |
+ ## #' @noRd+ |
+
| 884 | ++ |
+ ## #'+ |
+
| 885 | ++ |
+ ## #' @examples+ |
+
| 886 | ++ |
+ ## #'+ |
+
| 887 | ++ |
+ ## #' padstr("abc", 3)
+ |
+
| 888 | ++ |
+ ## #' padstr("abc", 4)
+ |
+
| 889 | ++ |
+ ## #' padstr("abc", 5)
+ |
+
| 890 | ++ |
+ ## #' padstr("abc", 5, "left")
+ |
+
| 891 | ++ |
+ ## #' padstr("abc", 5, "right")
+ |
+
| 892 | ++ |
+ ## #'+ |
+
| 893 | ++ |
+ ## #' if(interactive()){
+ |
+
| 894 | ++ |
+ ## #' padstr("abc", 1)
+ |
+
| 895 | ++ |
+ ## #' }+ |
+
| 896 | ++ |
+ ## #'+ |
+
| 897 | ++ |
+ ## padstr <- function(x, n, just = c("center", "left", "right")) {
+ |
+
| 898 | ++ | + + | +
| 899 | ++ |
+ ## just <- match.arg(just)+ |
+
| 900 | ++ | + + | +
| 901 | ++ |
+ ## if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
+ |
+
| 902 | ++ |
+ ## if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
+ |
+
| 903 | ++ | + + | +
| 904 | ++ |
+ ## if (is.na(x)) x <- "<NA>"+ |
+
| 905 | ++ | + + | +
| 906 | ++ |
+ ## nc <- nchar(x)+ |
+
| 907 | ++ | + + | +
| 908 | ++ |
+ ## if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
+ |
+
| 909 | ++ | + + | +
| 910 | ++ |
+ ## switch(+ |
+
| 911 | ++ |
+ ## just,+ |
+
| 912 | ++ |
+ ## center = {
+ |
+
| 913 | ++ |
+ ## pad <- (n - nc)/2+ |
+
| 914 | ++ |
+ ## paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))+ |
+
| 915 | ++ |
+ ## },+ |
+
| 916 | ++ |
+ ## left = paste0(x, spaces(n - nc)),+ |
+
| 917 | ++ |
+ ## right = paste0(spaces(n - nc), x)+ |
+
| 918 | ++ |
+ ## )+ |
+
| 919 | ++ |
+ ## }+ |
+
| 920 | ++ | + + | +
| 921 | ++ |
+ ## spaces <- function(n) {
+ |
+
| 922 | ++ |
+ ## strrep(" ", n)
+ |
+
| 923 | ++ |
+ ## }+ |
+
| 924 | ++ | + + | +
| 925 | ++ |
+ #' Convert matrix of strings into a string with aligned columns+ |
+
| 926 | ++ |
+ #'+ |
+
| 927 | ++ |
+ #' Note that this function is intended to print simple rectangular matrices and not `rtable`s.+ |
+
| 928 | ++ |
+ #'+ |
+
| 929 | ++ |
+ #' @param mat (`matrix`)\cr a matrix of strings.+ |
+
| 930 | ++ |
+ #' @param nheader (`integer(1)`)\cr number of header rows.+ |
+
| 931 | ++ |
+ #' @param colsep (`string`)\cr a string that separates the columns.+ |
+
| 932 | ++ |
+ #' @param hsep (`character(1)`)\cr character to build line separator.+ |
+
| 933 | ++ |
+ #'+ |
+
| 934 | ++ |
+ #' @return A string.+ |
+
| 935 | ++ |
+ #'+ |
+
| 936 | ++ |
+ #' @examples+ |
+
| 937 | ++ |
+ #' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
+ |
+
| 938 | ++ |
+ #' cat(mat_as_string(mat))+ |
+
| 939 | ++ |
+ #' cat("\n")
+ |
+
| 940 | ++ |
+ #'+ |
+
| 941 | ++ |
+ #' @noRd+ |
+
| 942 | ++ |
+ mat_as_string <- function(mat, nheader = 1, colsep = " ", hsep = default_hsep()) {
+ |
+
| 943 | +2x | +
+ colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max)+ |
+
| 944 | ++ | + + | +
| 945 | +2x | +
+ rows_formatted <- apply(mat, 1, function(row) {
+ |
+
| 946 | +36x | +
+ paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep)+ |
+
| 947 | ++ |
+ })+ |
+
| 948 | ++ | + + | +
| 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")+ |
+
| 956 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create an `rtable` row+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @inheritParams compat_args+ |
+
| 4 | ++ |
+ #' @param ... cell values.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @return A row object of the context-appropriate type (label or data).+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
+ |
+
| 10 | ++ |
+ #' rrow("")
+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @family compatibility+ |
+
| 13 | ++ |
+ #' @export+ |
+
| 14 | ++ |
+ rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L) {
+ |
+
| 15 | +258x | +
+ vals <- list(...)+ |
+
| 16 | +258x | +
+ if (is.null(row.name)) {
+ |
+
| 17 | +40x | +
+ row.name <- ""+ |
+
| 18 | +218x | +
+ } else if (!is(row.name, "character")) {
+ |
+
| 19 | +! | +
+ stop("row.name must be NULL or a character string")
+ |
+
| 20 | ++ |
+ }+ |
+
| 21 | +258x | +
+ if (length(vals) == 0L) {
+ |
+
| 22 | +22x | +
+ LabelRow(+ |
+
| 23 | +22x | +
+ lev = as.integer(indent),+ |
+
| 24 | +22x | +
+ label = row.name,+ |
+
| 25 | +22x | +
+ name = row.name,+ |
+
| 26 | +22x | +
+ vis = TRUE,+ |
+
| 27 | +22x | +
+ table_inset = 0L+ |
+
| 28 | ++ |
+ )+ |
+
| 29 | ++ |
+ } else {
+ |
+
| 30 | +236x | +
+ csps <- as.integer(sapply(vals, function(x) {
+ |
+
| 31 | +1391x | +
+ attr(x, "colspan", exact = TRUE) %||% 1L+ |
+
| 32 | ++ |
+ }))+ |
+
| 33 | ++ |
+ ## we have to leave the formats on the cells and NOT the row unless we were+ |
+
| 34 | ++ |
+ ## already told to do so, because row formats get clobbered when cbinding+ |
+
| 35 | ++ |
+ ## but cell formats do not.+ |
+
| 36 | ++ |
+ ## formats = sapply(vals, obj_format)+ |
+
| 37 | ++ |
+ ## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format))+ |
+
| 38 | ++ |
+ ## format = unique(formats)+ |
+
| 39 | +236x | +
+ DataRow(+ |
+
| 40 | +236x | +
+ vals = vals, lev = as.integer(indent), label = row.name,+ |
+
| 41 | +236x | +
+ name = row.name, ## XXX TODO+ |
+
| 42 | +236x | +
+ cspan = csps,+ |
+
| 43 | +236x | +
+ format = format,+ |
+
| 44 | +236x | +
+ table_inset = as.integer(inset)+ |
+
| 45 | ++ |
+ )+ |
+
| 46 | ++ |
+ }+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ #' Create an `rtable` row from a vector or list of values+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @inheritParams compat_args+ |
+
| 52 | ++ |
+ #' @param ... values in vector/list form.+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' @inherit rrow return+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @examples+ |
+
| 57 | ++ |
+ #' rrowl("a", c(1, 2, 3), format = "xx")
+ |
+
| 58 | ++ |
+ #' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' rrowl("N", table(iris$Species))
+ |
+
| 62 | ++ |
+ #' rrowl("N", table(iris$Species), format = "xx")
+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE)+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' rrow(row.name = "row 1", x)+ |
+
| 67 | ++ |
+ #' rrow("ABC", 2, 3)
+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' rrowl(row.name = "row 1", c(1, 2), c(3, 4))+ |
+
| 70 | ++ |
+ #' rrow(row.name = "row 2", c(1, 2), c(3, 4))+ |
+
| 71 | ++ |
+ #'+ |
+
| 72 | ++ |
+ #' @family compatibility+ |
+
| 73 | ++ |
+ #' @export+ |
+
| 74 | ++ |
+ rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) {
+ |
+
| 75 | +38x | +
+ dots <- list(...)+ |
+
| 76 | +38x | +
+ args_list <- c(list(+ |
+
| 77 | +38x | +
+ row.name = row.name, format = format,+ |
+
| 78 | +38x | +
+ indent = indent, inset = inset+ |
+
| 79 | +38x | +
+ ), val = unlist(lapply(dots, as.list), recursive = FALSE))+ |
+
| 80 | +38x | +
+ do.call(rrow, args_list)+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ ## rcell moved to tt_afun_utils.R+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ ## inefficient trash+ |
+
| 86 | ++ |
+ paste_em_n <- function(lst, n, sep = ".") {
+ |
+
| 87 | +9x | +
+ ret <- lst[[1]]+ |
+
| 88 | +9x | +
+ if (n > 1) {
+ |
+
| 89 | +4x | +
+ for (i in 2:n) {
+ |
+
| 90 | +4x | +
+ ret <- paste(ret, lst[[i]], sep = sep)+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | +9x | +
+ ret+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ | + + | +
| 96 | ++ |
+ hrows_to_colinfo <- function(rows) {
+ |
+
| 97 | +34x | +
+ nr <- length(rows)+ |
+
| 98 | +34x | +
+ stopifnot(nr > 0)+ |
+
| 99 | +34x | +
+ cspans <- lapply(rows, row_cspans)+ |
+
| 100 | +34x | +
+ vals <- lapply(rows, function(x) unlist(row_values(x)))+ |
+
| 101 | +34x | +
+ unqvals <- lapply(vals, unique)+ |
+
| 102 | +34x | +
+ formats <- lapply(rows, obj_format)+ |
+
| 103 | +34x | +
+ counts <- NULL+ |
+
| 104 | +34x | +
+ if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
+ |
+
| 105 | +1x | +
+ counts <- vals[[nr]]+ |
+
| 106 | +1x | +
+ vals <- vals[-nr]+ |
+
| 107 | +1x | +
+ cspans <- cspans[-nr]+ |
+
| 108 | +1x | +
+ nr <- nr - 1+ |
+
| 109 | ++ |
+ }+ |
+
| 110 | ++ |
+ ## easiest case, one header row no counts. we're done+ |
+
| 111 | ++ |
+ ## XXX could one row but cspan ever make sense????+ |
+
| 112 | ++ |
+ ## I don't think so?+ |
+
| 113 | +34x | +
+ if (nr == 1) { ## && all(cspans == 1L)) {
+ |
+
| 114 | +29x | +
+ ret <- manual_cols(unlist(vals[[1]]))+ |
+
| 115 | +29x | +
+ if (!is.null(counts)) {
+ |
+
| 116 | +1x | +
+ col_counts(ret) <- counts+ |
+
| 117 | +1x | +
+ disp_ccounts(ret) <- TRUE+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | +29x | +
+ return(ret)+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ |
+ ## second easiest case full repeated nestin+ |
+
| 122 | +5x | +
+ repvals <- mapply(function(v, csp) rep(v, times = csp),+ |
+
| 123 | +5x | +
+ v = vals, csp = cspans, SIMPLIFY = FALSE+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ ## nr > 1 here+ |
+
| 127 | +5x | +
+ fullnest <- TRUE+ |
+
| 128 | +5x | +
+ for (i in 2:nr) {
+ |
+
| 129 | +5x | +
+ psted <- paste_em_n(repvals, i - 1)+ |
+
| 130 | +5x | +
+ spl <- split(repvals[[i]], psted)+ |
+
| 131 | +5x | +
+ if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
+ |
+
| 132 | +4x | +
+ fullnest <- FALSE+ |
+
| 133 | +4x | +
+ break+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ ## if its full nesting we're done, so put+ |
+
| 138 | ++ |
+ ## the counts on as necessary and return.+ |
+
| 139 | +5x | +
+ if (fullnest) {
+ |
+
| 140 | +1x | +
+ ret <- manual_cols(.lst = unqvals)+ |
+
| 141 | +1x | +
+ if (!is.null(counts)) {
+ |
+
| 142 | +! | +
+ col_counts(ret) <- counts+ |
+
| 143 | +! | +
+ disp_ccounts(ret) <- TRUE+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | +1x | +
+ return(ret)+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ ## booo. the fully complex case where the multiple rows+ |
+
| 149 | ++ |
+ ## really don't represent nesting at all, each top level+ |
+
| 150 | ++ |
+ ## can have different sub labels+ |
+
| 151 | ++ | + + | +
| 152 | ++ |
+ ## we will build it up as if it were full nesting and then prune+ |
+
| 153 | ++ |
+ ## based on the columns we actually want.+ |
+
| 154 | ++ | + + | +
| 155 | +4x | +
+ fullcolinfo <- manual_cols(.lst = unqvals)+ |
+
| 156 | +4x | +
+ fullbusiness <- names(collect_leaves(coltree(fullcolinfo)))+ |
+
| 157 | +4x | +
+ wanted <- paste_em_n(repvals, nr)+ |
+
| 158 | +4x | +
+ wantcols <- match(wanted, fullbusiness)+ |
+
| 159 | +4x | +
+ stopifnot(all(!is.na(wantcols)))+ |
+
| 160 | ++ | + + | +
| 161 | +4x | +
+ subset_cols(fullcolinfo, wantcols)+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | ++ | + + | +
| 164 | ++ |
+ #' Create a header+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' @inheritParams compat_args+ |
+
| 167 | ++ |
+ #' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()],+ |
+
| 168 | ++ |
+ #' [LabelRow()], etc.+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @return A `InstantiatedColumnInfo` object.+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @examples+ |
+
| 173 | ++ |
+ #' h1 <- rheader(c("A", "B", "C"))
+ |
+
| 174 | ++ |
+ #' h1+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' h2 <- rheader(+ |
+
| 177 | ++ |
+ #' rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
+ |
+
| 178 | ++ |
+ #' rrow(NULL, "A", "B", "A", "B")+ |
+
| 179 | ++ |
+ #' )+ |
+
| 180 | ++ |
+ #' h2+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' @family compatibility+ |
+
| 183 | ++ |
+ #' @export+ |
+
| 184 | ++ |
+ rheader <- function(..., format = "xx", .lst = NULL) {
+ |
+
| 185 | +3x | +
+ if (!is.null(.lst)) {
+ |
+
| 186 | +! | +
+ args <- .lst+ |
+
| 187 | ++ |
+ } else {
+ |
+
| 188 | +3x | +
+ args <- list(...)+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | +3x | +
+ rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
+ |
+
| 191 | +! | +
+ list(rrowl(row.name = NULL, val = args[[1]], format = format))+ |
+
| 192 | +3x | +
+ } else if (are(args, "TableRow")) {
+ |
+
| 193 | +3x | +
+ args+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ | + + | +
| 196 | +3x | +
+ hrows_to_colinfo(rrows)+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | ++ | + + | +
| 199 | ++ |
+ .char_to_hrows <- function(hdr) {
+ |
+
| 200 | +31x | +
+ nlfnd <- grep("\n", hdr, fixed = TRUE)
+ |
+
| 201 | +31x | +
+ if (length(nlfnd) == 0) {
+ |
+
| 202 | +27x | +
+ return(list(rrowl(NULL, hdr)))+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ | + + | +
| 205 | +4x | +
+ stopifnot(length(nlfnd) == length(hdr))+ |
+
| 206 | +4x | +
+ raw <- strsplit(hdr, "\n", fixed = TRUE)+ |
+
| 207 | +4x | +
+ lens <- unique(sapply(raw, length))+ |
+
| 208 | +4x | +
+ stopifnot(length(lens) == 1L)+ |
+
| 209 | +4x | +
+ lapply(+ |
+
| 210 | +4x | +
+ seq(1, lens),+ |
+
| 211 | +4x | +
+ function(i) {
+ |
+
| 212 | +8x | +
+ rrowl(NULL, vapply(raw, `[`, NA_character_, i = i))+ |
+
| 213 | ++ |
+ }+ |
+
| 214 | ++ |
+ )+ |
+
| 215 | ++ |
+ }+ |
+
| 216 | ++ | + + | +
| 217 | ++ |
+ #' Create a table+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' @inheritParams compat_args+ |
+
| 220 | ++ |
+ #' @inheritParams gen_args+ |
+
| 221 | ++ |
+ #' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header+ |
+
| 222 | ++ |
+ #' (column structure) of the table. This can be as row objects (legacy), character vectors, or an+ |
+
| 223 | ++ |
+ #' `InstantiatedColumnInfo` object.+ |
+
| 224 | ++ |
+ #' @param ... rows to place in the table.+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`).+ |
+
| 227 | ++ |
+ #'+ |
+
| 228 | ++ |
+ #' @examples+ |
+
| 229 | ++ |
+ #' rtable(+ |
+
| 230 | ++ |
+ #' header = LETTERS[1:3],+ |
+
| 231 | ++ |
+ #' rrow("one to three", 1, 2, 3),
+ |
+
| 232 | ++ |
+ #' rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
+ |
+
| 233 | ++ |
+ #' )+ |
+
| 234 | ++ |
+ #'+ |
+
| 235 | ++ |
+ #' # Table with multirow header+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' sel <- iris$Species == "setosa"+ |
+
| 238 | ++ |
+ #' mtbl <- rtable(+ |
+
| 239 | ++ |
+ #' header = rheader(+ |
+
| 240 | ++ |
+ #' rrow(+ |
+
| 241 | ++ |
+ #' row.name = NULL, rcell("Sepal.Length", colspan = 2),
+ |
+
| 242 | ++ |
+ #' rcell("Petal.Length", colspan = 2)
+ |
+
| 243 | ++ |
+ #' ),+ |
+
| 244 | ++ |
+ #' rrow(NULL, "mean", "median", "mean", "median")+ |
+
| 245 | ++ |
+ #' ),+ |
+
| 246 | ++ |
+ #' rrow(+ |
+
| 247 | ++ |
+ #' row.name = "All Species",+ |
+
| 248 | ++ |
+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ |
+
| 249 | ++ |
+ #' mean(iris$Petal.Length), median(iris$Petal.Length),+ |
+
| 250 | ++ |
+ #' format = "xx.xx"+ |
+
| 251 | ++ |
+ #' ),+ |
+
| 252 | ++ |
+ #' rrow(+ |
+
| 253 | ++ |
+ #' row.name = "Setosa",+ |
+
| 254 | ++ |
+ #' mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]),+ |
+
| 255 | ++ |
+ #' mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel])+ |
+
| 256 | ++ |
+ #' )+ |
+
| 257 | ++ |
+ #' )+ |
+
| 258 | ++ |
+ #'+ |
+
| 259 | ++ |
+ #' mtbl+ |
+
| 260 | ++ |
+ #'+ |
+
| 261 | ++ |
+ #' names(mtbl) # always first row of header+ |
+
| 262 | ++ |
+ #'+ |
+
| 263 | ++ |
+ #' # Single row header+ |
+
| 264 | ++ |
+ #'+ |
+
| 265 | ++ |
+ #' tbl <- rtable(+ |
+
| 266 | ++ |
+ #' header = c("Treatement\nN=100", "Comparison\nN=300"),
+ |
+
| 267 | ++ |
+ #' format = "xx (xx.xx%)",+ |
+
| 268 | ++ |
+ #' rrow("A", c(104, .2), c(100, .4)),
+ |
+
| 269 | ++ |
+ #' rrow("B", c(23, .4), c(43, .5)),
+ |
+
| 270 | ++ |
+ #' rrow(""),
+ |
+
| 271 | ++ |
+ #' rrow("this is a very long section header"),
+ |
+
| 272 | ++ |
+ #' rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
+ |
+
| 273 | ++ |
+ #' rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
+ |
+
| 274 | ++ |
+ #' )+ |
+
| 275 | ++ |
+ #' tbl+ |
+
| 276 | ++ |
+ #'+ |
+
| 277 | ++ |
+ #' row.names(tbl)+ |
+
| 278 | ++ |
+ #' names(tbl)+ |
+
| 279 | ++ |
+ #'+ |
+
| 280 | ++ |
+ #' # Subsetting+ |
+
| 281 | ++ |
+ #'+ |
+
| 282 | ++ |
+ #' tbl[1, ]+ |
+
| 283 | ++ |
+ #' tbl[, 1]+ |
+
| 284 | ++ |
+ #'+ |
+
| 285 | ++ |
+ #' tbl[1, 2]+ |
+
| 286 | ++ |
+ #' tbl[2, 1]+ |
+
| 287 | ++ |
+ #'+ |
+
| 288 | ++ |
+ #' tbl[3, 2]+ |
+
| 289 | ++ |
+ #' tbl[5, 1]+ |
+
| 290 | ++ |
+ #' tbl[5, 2]+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' # Data Structure methods+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ #' dim(tbl)+ |
+
| 295 | ++ |
+ #' nrow(tbl)+ |
+
| 296 | ++ |
+ #' ncol(tbl)+ |
+
| 297 | ++ |
+ #' names(tbl)+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' # Colspans+ |
+
| 300 | ++ |
+ #'+ |
+
| 301 | ++ |
+ #' tbl2 <- rtable(+ |
+
| 302 | ++ |
+ #' c("A", "B", "C", "D", "E"),
+ |
+
| 303 | ++ |
+ #' format = "xx",+ |
+
| 304 | ++ |
+ #' rrow("r1", 1, 2, 3, 4, 5),
+ |
+
| 305 | ++ |
+ #' rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
+ |
+
| 306 | ++ |
+ #' )+ |
+
| 307 | ++ |
+ #' tbl2+ |
+
| 308 | ++ |
+ #'+ |
+
| 309 | ++ |
+ #' @family compatibility+ |
+
| 310 | ++ |
+ #' @export+ |
+
| 311 | ++ |
+ rtable <- function(header, ..., format = NULL, hsep = default_hsep(),+ |
+
| 312 | ++ |
+ inset = 0L) {
+ |
+
| 313 | +34x | +
+ if (is.character(header)) {
+ |
+
| 314 | +31x | +
+ header <- .char_to_hrows(header)+ |
+
| 315 | ++ |
+ } # list(rrowl(NULL, header))+ |
+
| 316 | +34x | +
+ if (is.list(header)) {
+ |
+
| 317 | +31x | +
+ if (are(header, "TableRow")) {
+ |
+
| 318 | +31x | +
+ colinfo <- hrows_to_colinfo(header)+ |
+
| 319 | +! | +
+ } else if (are(header, "list")) {
+ |
+
| 320 | +! | +
+ colinfo <- do.call(rheader, header)+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | +3x | +
+ } else if (is(header, "InstantiatedColumnInfo")) {
+ |
+
| 323 | +3x | +
+ colinfo <- header+ |
+
| 324 | +! | +
+ } else if (is(header, "TableRow")) {
+ |
+
| 325 | +! | +
+ colinfo <- hrows_to_colinfo(list(header))+ |
+
| 326 | ++ |
+ } else {
+ |
+
| 327 | +! | +
+ stop("problems")
+ |
+
| 328 | ++ |
+ }+ |
+
| 329 | ++ | + + | +
| 330 | +34x | +
+ body <- list(...)+ |
+
| 331 | ++ |
+ ## XXX this shouldn't be needed. hacky+ |
+
| 332 | +34x | +
+ if (length(body) == 1 && is.list(body[[1]])) {
+ |
+
| 333 | +! | +
+ body <- body[[1]]+ |
+
| 334 | ++ |
+ }+ |
+
| 335 | +34x | +
+ if (are(body, "ElementaryTable") &&+ |
+
| 336 | +34x | +
+ all(sapply(body, function(tb) {
+ |
+
| 337 | +! | +
+ nrow(tb) == 1 && obj_name(tb) == ""+ |
+
| 338 | ++ |
+ }))) {
+ |
+
| 339 | +1x | +
+ body <- lapply(body, function(tb) tree_children(tb)[[1]])+ |
+
| 340 | ++ |
+ }+ |
+
| 341 | ++ | + + | +
| 342 | +34x | +
+ TableTree(+ |
+
| 343 | +34x | +
+ kids = body, format = format, cinfo = colinfo,+ |
+
| 344 | +34x | +
+ labelrow = LabelRow(lev = 0L, label = "", vis = FALSE),+ |
+
| 345 | +34x | +
+ hsep = hsep, inset = inset+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | ++ | + + | +
| 349 | ++ |
+ #' @rdname rtable+ |
+
| 350 | ++ |
+ #' @export+ |
+
| 351 | ++ |
+ rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
+ |
+
| 352 | +1x | +
+ dots <- list(...)+ |
+
| 353 | +1x | +
+ args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply(+ |
+
| 354 | +1x | +
+ dots,+ |
+
| 355 | +1x | +
+ as.list+ |
+
| 356 | +1x | +
+ ), recursive = FALSE))+ |
+
| 357 | +1x | +
+ do.call(rtable, args_list)+ |
+
| 358 | ++ |
+ }+ |
+
| 359 | ++ | + + | +
| 360 | ++ |
+ # All object annotations are identical (and exist)+ |
+
| 361 | ++ |
+ all_annots_identical <- function(all_annots) {
+ |
+
| 362 | +60x | +
+ if (!is.list(all_annots)) {
+ |
+
| 363 | +15x | +
+ all_annots[1] != "" && length(unique(all_annots)) == 1+ |
+
| 364 | ++ |
+ } else {
+ |
+
| 365 | +45x | +
+ length(all_annots[[1]]) > 0 && Reduce(identical, all_annots)+ |
+
| 366 | ++ |
+ }+ |
+
| 367 | ++ |
+ }+ |
+
| 368 | ++ | + + | +
| 369 | ++ |
+ # Only first object has annotations+ |
+
| 370 | ++ |
+ only_first_annot <- function(all_annots) {
+ |
+
| 371 | +56x | +
+ if (!is.list(all_annots)) {
+ |
+
| 372 | +14x | +
+ all_annots[1] != "" && all(all_annots[-1] == "")+ |
+
| 373 | ++ |
+ } else {
+ |
+
| 374 | +42x | +
+ length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0)+ |
+
| 375 | ++ |
+ }+ |
+
| 376 | ++ |
+ }+ |
+
| 377 | ++ | + + | +
| 378 | ++ |
+ #' @param gap `r lifecycle::badge("deprecated")` ignored.
+ |
+
| 379 | ++ |
+ #' @param check_headers `r lifecycle::badge("deprecated")` ignored.
+ |
+
| 380 | ++ |
+ #'+ |
+
| 381 | ++ |
+ #' @return A formal table object.+ |
+
| 382 | ++ |
+ #'+ |
+
| 383 | ++ |
+ #' @rdname rbind+ |
+
| 384 | ++ |
+ #' @aliases rbind+ |
+
| 385 | ++ |
+ #' @export+ |
+
| 386 | ++ |
+ rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
+ |
+
| 387 | ++ |
+ ## nocov start+ |
+
| 388 | ++ |
+ if (lifecycle::is_present(gap)) {
+ |
+
| 389 | ++ |
+ lifecycle::deprecate_warn(+ |
+
| 390 | ++ |
+ when = "0.3.2",+ |
+
| 391 | ++ |
+ what = "rbindl_rtables(gap)"+ |
+
| 392 | ++ |
+ )+ |
+
| 393 | ++ |
+ }+ |
+
| 394 | ++ |
+ if (lifecycle::is_present(check_headers)) {
+ |
+
| 395 | ++ |
+ lifecycle::deprecate_warn(+ |
+
| 396 | ++ |
+ when = "0.3.2",+ |
+
| 397 | ++ |
+ what = "rbindl_rtables(check_headers)"+ |
+
| 398 | ++ |
+ )+ |
+
| 399 | ++ |
+ }+ |
+
| 400 | ++ |
+ ## nocov end+ |
+
| 401 | ++ | + + | +
| 402 | +16x | +
+ firstcols <- col_info(x[[1]])+ |
+
| 403 | +16x | +
+ i <- 1+ |
+
| 404 | +16x | +
+ while (no_colinfo(firstcols) && i <= length(x)) {
+ |
+
| 405 | +2x | +
+ firstcols <- col_info(x[[i]])+ |
+
| 406 | +2x | +
+ i <- i + 1+ |
+
| 407 | ++ |
+ }+ |
+
| 408 | ++ | + + | +
| 409 | +16x | +
+ lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi)))+ |
+
| 410 | ++ | + + | +
| 411 | +15x | +
+ rbind_annot <- list(+ |
+
| 412 | +15x | +
+ main_title = "",+ |
+
| 413 | +15x | +
+ subtitles = character(),+ |
+
| 414 | +15x | +
+ main_footer = character(),+ |
+
| 415 | +15x | +
+ prov_footer = character()+ |
+
| 416 | ++ |
+ )+ |
+
| 417 | ++ | + + | +
| 418 | ++ |
+ # Titles/footer info are (independently) retained from first object if+ |
+
| 419 | ++ |
+ # identical or missing in all other objects+ |
+
| 420 | +15x | +
+ all_titles <- sapply(x, main_title)+ |
+
| 421 | +15x | +
+ if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
+ |
+
| 422 | +2x | +
+ rbind_annot[["main_title"]] <- all_titles[[1]]+ |
+
| 423 | ++ |
+ }+ |
+
| 424 | ++ | + + | +
| 425 | +15x | +
+ all_sts <- lapply(x, subtitles)+ |
+
| 426 | +15x | +
+ if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
+ |
+
| 427 | +2x | +
+ rbind_annot[["subtitles"]] <- all_sts[[1]]+ |
+
| 428 | ++ |
+ }+ |
+
| 429 | ++ | + + | +
| 430 | +15x | +
+ 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]]+ |
+
| 433 | ++ |
+ }+ |
+
| 434 | ++ | + + | +
| 435 | +15x | +
+ all_pfs <- lapply(x, prov_footer)+ |
+
| 436 | +15x | +
+ if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
+ |
+
| 437 | +2x | +
+ rbind_annot[["prov_footer"]] <- all_pfs[[1]]+ |
+
| 438 | ++ |
+ }+ |
+
| 439 | ++ | + + | +
| 440 | ++ |
+ ## if we got only ElementaryTable and+ |
+
| 441 | ++ |
+ ## TableRow objects, construct a new+ |
+
| 442 | ++ |
+ ## elementary table with all the rows+ |
+
| 443 | ++ |
+ ## instead of adding nesting.+ |
+
| 444 | ++ | + + | +
| 445 | ++ |
+ ## we used to check for xi not being a lable row, why?? XXX+ |
+
| 446 | +15x | +
+ if (all(sapply(x, function(xi) {
+ |
+
| 447 | +30x | +
+ (is(xi, "ElementaryTable") && !labelrow_visible(xi)) ||+ |
+
| 448 | +30x | +
+ is(xi, "TableRow")+ |
+
| 449 | +15x | +
+ }))) { ## && !is(xi, "LabelRow")}))) {
+ |
+
| 450 | +8x | +
+ x <- unlist(lapply(x, function(xi) {
+ |
+
| 451 | +16x | +
+ if (is(xi, "TableRow")) {
+ |
+
| 452 | +4x | +
+ xi+ |
+
| 453 | ++ |
+ } else {
+ |
+
| 454 | +12x | +
+ lst <- tree_children(xi)+ |
+
| 455 | +12x | +
+ lapply(lst, indent,+ |
+
| 456 | +12x | +
+ by = indent_mod(xi)+ |
+
| 457 | ++ |
+ )+ |
+
| 458 | ++ |
+ }+ |
+
| 459 | ++ |
+ }))+ |
+
| 460 | ++ |
+ }+ |
+
| 461 | ++ | + + | +
| 462 | +15x | +
+ TableTree(+ |
+
| 463 | +15x | +
+ kids = x,+ |
+
| 464 | +15x | +
+ cinfo = firstcols,+ |
+
| 465 | +15x | +
+ name = "rbind_root",+ |
+
| 466 | +15x | +
+ label = "",+ |
+
| 467 | +15x | +
+ title = rbind_annot[["main_title"]],+ |
+
| 468 | +15x | +
+ subtitles = rbind_annot[["subtitles"]],+ |
+
| 469 | +15x | +
+ main_footer = rbind_annot[["main_footer"]],+ |
+
| 470 | +15x | +
+ prov_footer = rbind_annot[["prov_footer"]]+ |
+
| 471 | ++ |
+ )+ |
+
| 472 | ++ |
+ }+ |
+
| 473 | ++ | + + | +
| 474 | ++ |
+ #' Row-bind `TableTree` and related objects+ |
+
| 475 | ++ |
+ #'+ |
+
| 476 | ++ |
+ #' @param deparse.level (`numeric(1)`)\cr currently ignored.+ |
+
| 477 | ++ |
+ #' @param ... (`ANY`)\cr elements to be stacked.+ |
+
| 478 | ++ |
+ #'+ |
+
| 479 | ++ |
+ #' @note+ |
+
| 480 | ++ |
+ #' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all+ |
+
| 481 | ++ |
+ #' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed+ |
+
| 482 | ++ |
+ #' and must be set for the bound table via the [formatters::main_title()], [formatters::subtitles()],+ |
+
| 483 | ++ |
+ #' [formatters::main_footer()], and [formatters::prov_footer()] functions.+ |
+
| 484 | ++ |
+ #'+ |
+
| 485 | ++ |
+ #' @examples+ |
+
| 486 | ++ |
+ #' mtbl <- rtable(+ |
+
| 487 | ++ |
+ #' header = rheader(+ |
+
| 488 | ++ |
+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ |
+
| 489 | ++ |
+ #' rrow(NULL, "mean", "median", "mean", "median")+ |
+
| 490 | ++ |
+ #' ),+ |
+
| 491 | ++ |
+ #' rrow(+ |
+
| 492 | ++ |
+ #' row.name = "All Species",+ |
+
| 493 | ++ |
+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ |
+
| 494 | ++ |
+ #' mean(iris$Petal.Length), median(iris$Petal.Length),+ |
+
| 495 | ++ |
+ #' format = "xx.xx"+ |
+
| 496 | ++ |
+ #' )+ |
+
| 497 | ++ |
+ #' )+ |
+
| 498 | ++ |
+ #'+ |
+
| 499 | ++ |
+ #' mtbl2 <- with(subset(iris, Species == "setosa"), rtable(+ |
+
| 500 | ++ |
+ #' header = rheader(+ |
+
| 501 | ++ |
+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ |
+
| 502 | ++ |
+ #' rrow(NULL, "mean", "median", "mean", "median")+ |
+
| 503 | ++ |
+ #' ),+ |
+
| 504 | ++ |
+ #' rrow(+ |
+
| 505 | ++ |
+ #' row.name = "Setosa",+ |
+
| 506 | ++ |
+ #' mean(Sepal.Length), median(Sepal.Length),+ |
+
| 507 | ++ |
+ #' mean(Petal.Length), median(Petal.Length),+ |
+
| 508 | ++ |
+ #' format = "xx.xx"+ |
+
| 509 | ++ |
+ #' )+ |
+
| 510 | ++ |
+ #' ))+ |
+
| 511 | ++ |
+ #'+ |
+
| 512 | ++ |
+ #' rbind(mtbl, mtbl2)+ |
+
| 513 | ++ |
+ #' rbind(mtbl, rrow(), mtbl2)+ |
+
| 514 | ++ |
+ #' rbind(mtbl, rrow("aaa"), indent(mtbl2))
+ |
+
| 515 | ++ |
+ #'+ |
+
| 516 | ++ |
+ #' @exportMethod rbind+ |
+
| 517 | ++ |
+ #' @rdname rbind+ |
+
| 518 | ++ |
+ setMethod(+ |
+
| 519 | ++ |
+ "rbind", "VTableNodeInfo",+ |
+
| 520 | ++ |
+ function(..., deparse.level = 1) {
+ |
+
| 521 | +! | +
+ rbindl_rtables(list(...))+ |
+
| 522 | ++ |
+ }+ |
+
| 523 | ++ |
+ )+ |
+
| 524 | ++ | + + | +
| 525 | ++ |
+ #' @param y (`ANY`)\cr second element to be row-bound via `rbind2`.+ |
+
| 526 | ++ |
+ #'+ |
+
| 527 | ++ |
+ #' @exportMethod rbind2+ |
+
| 528 | ++ |
+ #' @rdname int_methods+ |
+
| 529 | ++ |
+ setMethod(+ |
+
| 530 | ++ |
+ "rbind2", c("VTableNodeInfo", "missing"),
+ |
+
| 531 | ++ |
+ function(x, y) {
+ |
+
| 532 | +2x | +
+ TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "")+ |
+
| 533 | ++ |
+ }+ |
+
| 534 | ++ |
+ )+ |
+
| 535 | ++ | + + | +
| 536 | ++ |
+ #' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.+ |
+
| 537 | ++ |
+ #' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.+ |
+
| 538 | ++ |
+ #'+ |
+
| 539 | ++ |
+ #' @exportMethod rbind2+ |
+
| 540 | ++ |
+ #' @rdname rbind+ |
+
| 541 | ++ |
+ setMethod(+ |
+
| 542 | ++ |
+ "rbind2", "VTableNodeInfo",+ |
+
| 543 | ++ |
+ function(x, y) {
+ |
+
| 544 | +12x | +
+ rbindl_rtables(list(x, y))+ |
+
| 545 | ++ |
+ }+ |
+
| 546 | ++ |
+ )+ |
+
| 547 | ++ | + + | +
| 548 | ++ |
+ EmptyTreePos <- TreePos()+ |
+
| 549 | ++ | + + | +
| 550 | ++ |
+ ## this is painful to do right but we were doing it wrong+ |
+
| 551 | ++ |
+ ## before and it now matters because count display information+ |
+
| 552 | ++ |
+ ## is in the tree which means all points in the structure+ |
+
| 553 | ++ |
+ ## must be pathable, which they aren't if siblings have+ |
+
| 554 | ++ |
+ ## identical names+ |
+
| 555 | ++ |
+ fix_col_nm_recursive <- function(ct, newname, rename_obj = TRUE, oldnm) {
+ |
+
| 556 | +120x | +
+ if (rename_obj) {
+ |
+
| 557 | +19x | +
+ obj_name(ct) <- newname+ |
+
| 558 | ++ |
+ }+ |
+
| 559 | +120x | +
+ if (is(ct, "LayoutColTree")) {
+ |
+
| 560 | +45x | +
+ kids <- tree_children(ct)+ |
+
| 561 | +45x | +
+ kidnms <- names(kids)+ |
+
| 562 | +45x | +
+ newkids <- lapply(kids, fix_col_nm_recursive,+ |
+
| 563 | +45x | +
+ newname = newname,+ |
+
| 564 | +45x | +
+ rename_obj = FALSE,+ |
+
| 565 | +45x | +
+ oldnm = oldnm+ |
+
| 566 | ++ |
+ )+ |
+
| 567 | +45x | +
+ names(newkids) <- kidnms+ |
+
| 568 | +45x | +
+ tree_children(ct) <- newkids+ |
+
| 569 | ++ |
+ }+ |
+
| 570 | +120x | +
+ mypos <- tree_pos(ct)+ |
+
| 571 | +120x | +
+ if (!identical(mypos, EmptyTreePos)) {
+ |
+
| 572 | +97x | +
+ spls <- pos_splits(mypos)+ |
+
| 573 | +97x | +
+ firstspl <- spls[[1]]+ |
+
| 574 | +97x | +
+ if (obj_name(firstspl) == oldnm) {
+ |
+
| 575 | +! | +
+ obj_name(firstspl) <- newname+ |
+
| 576 | +! | +
+ spls[[1]] <- firstspl+ |
+
| 577 | +! | +
+ pos_splits(mypos) <- spls+ |
+
| 578 | +! | +
+ tree_pos(ct) <- mypos+ |
+
| 579 | ++ |
+ }+ |
+
| 580 | ++ |
+ }+ |
+
| 581 | +120x | +
+ if (!rename_obj) {
+ |
+
| 582 | +101x | +
+ spls <- pos_splits(mypos)+ |
+
| 583 | +101x | +
+ splvals <- pos_splvals(mypos)+ |
+
| 584 | +101x | +
+ pos_splits(mypos) <- c(+ |
+
| 585 | +101x | +
+ list(AllSplit(split_name = newname)),+ |
+
| 586 | +101x | +
+ spls+ |
+
| 587 | ++ |
+ )+ |
+
| 588 | +101x | +
+ pos_splvals(mypos) <- c(+ |
+
| 589 | +101x | +
+ list(SplitValue(NA_character_,+ |
+
| 590 | +101x | +
+ sub_expr = quote(TRUE)+ |
+
| 591 | ++ |
+ )),+ |
+
| 592 | +101x | +
+ splvals+ |
+
| 593 | ++ |
+ )+ |
+
| 594 | +101x | +
+ tree_pos(ct) <- mypos+ |
+
| 595 | ++ |
+ }+ |
+
| 596 | +120x | +
+ ct+ |
+
| 597 | ++ |
+ }+ |
+
| 598 | ++ | + + | +
| 599 | ++ |
+ fix_nms <- function(ct) {
+ |
+
| 600 | +129x | +
+ if (is(ct, "LayoutColLeaf")) {
+ |
+
| 601 | +75x | +
+ return(ct)+ |
+
| 602 | ++ |
+ }+ |
+
| 603 | +54x | +
+ kids <- lapply(tree_children(ct), fix_nms)+ |
+
| 604 | +54x | +
+ names(kids) <- vapply(kids, obj_name, "")+ |
+
| 605 | +54x | +
+ tree_children(ct) <- kids+ |
+
| 606 | +54x | +
+ ct+ |
+
| 607 | ++ |
+ }+ |
+
| 608 | ++ | + + | +
| 609 | ++ |
+ make_cbind_names <- function(num, tokens) {
+ |
+
| 610 | +9x | +
+ cbind_tokens <- grep("^(new_)*cbind_tbl", tokens, value = TRUE)
+ |
+
| 611 | +9x | +
+ ret <- paste0("cbind_tbl_", seq_len(num))
+ |
+
| 612 | +9x | +
+ if (length(cbind_tokens) == 0) {
+ |
+
| 613 | +9x | +
+ return(ret)+ |
+
| 614 | ++ |
+ }+ |
+
| 615 | +! | +
+ oldprefixes <- gsub("cbind_tbl.*", "", cbind_tokens)
+ |
+
| 616 | +! | +
+ oldprefix <- oldprefixes[which.max(nchar(oldprefixes))]+ |
+
| 617 | +! | +
+ paste0("new_", oldprefix, ret)
+ |
+
| 618 | ++ |
+ }+ |
+
| 619 | ++ | + + | +
| 620 | ++ |
+ combine_cinfo <- function(..., new_total = NULL, sync_count_vis) {
+ |
+
| 621 | +10x | +
+ tabs <- list(...)+ |
+
| 622 | +10x | +
+ chk_cbindable_many(tabs)+ |
+
| 623 | +9x | +
+ cinfs <- lapply(tabs, col_info)+ |
+
| 624 | +9x | +
+ stopifnot(are(cinfs, "InstantiatedColumnInfo"))+ |
+
| 625 | ++ | + + | +
| 626 | +9x | +
+ ctrees <- lapply(cinfs, coltree)+ |
+
| 627 | +9x | +
+ oldnms <- nms <- vapply(ctrees, obj_name, "")+ |
+
| 628 | +9x | +
+ path_els <- unique(unlist(lapply(ctrees, col_paths), recursive = TRUE))+ |
+
| 629 | +9x | +
+ nms <- make_cbind_names(num = length(oldnms), tokens = path_els)+ |
+
| 630 | ++ | + + | +
| 631 | +9x | +
+ ctrees <- mapply(function(ct, nm, oldnm) {
+ |
+
| 632 | +19x | +
+ ct <- fix_col_nm_recursive(ct, nm, rename_obj = TRUE, oldnm = "") # oldnm)+ |
+
| 633 | +19x | +
+ ct+ |
+
| 634 | +9x | +
+ }, ct = ctrees, nm = nms, oldnm = oldnms, SIMPLIFY = FALSE)+ |
+
| 635 | +9x | +
+ names(ctrees) <- nms+ |
+
| 636 | ++ | + + | +
| 637 | +9x | +
+ newctree <- LayoutColTree(kids = ctrees, colcount = NA_integer_, name = "cbind_root")+ |
+
| 638 | +9x | +
+ newctree <- fix_nms(newctree)+ |
+
| 639 | +9x | +
+ newcounts <- unlist(lapply(cinfs, col_counts))+ |
+
| 640 | +9x | +
+ if (is.null(new_total)) {
+ |
+
| 641 | +9x | +
+ new_total <- sum(newcounts)+ |
+
| 642 | ++ |
+ }+ |
+
| 643 | +9x | +
+ newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE)+ |
+
| 644 | +9x | +
+ newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
+ |
+
| 645 | +9x | +
+ if (!sync_count_vis) {
+ |
+
| 646 | +1x | +
+ newdisp <- NA+ |
+
| 647 | ++ |
+ } else {
+ |
+
| 648 | +8x | +
+ newdisp <- any(vapply(cinfs, disp_ccounts, NA))+ |
+
| 649 | ++ |
+ }+ |
+
| 650 | +9x | +
+ alltls <- lapply(cinfs, top_left)+ |
+
| 651 | +9x | +
+ newtl <- character()+ |
+
| 652 | +9x | +
+ if (!are(tabs, "TableRow")) {
+ |
+
| 653 | +9x | +
+ alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same+ |
+
| 654 | +9x | +
+ if (length(alltls) > 0) {
+ |
+
| 655 | +! | +
+ newtl <- alltls[[1]]+ |
+
| 656 | ++ |
+ }+ |
+
| 657 | ++ |
+ }+ |
+
| 658 | +9x | +
+ InstantiatedColumnInfo(+ |
+
| 659 | +9x | +
+ treelyt = newctree,+ |
+
| 660 | +9x | +
+ csubs = newexprs,+ |
+
| 661 | +9x | +
+ extras = newexargs,+ |
+
| 662 | +9x | +
+ cnts = newcounts,+ |
+
| 663 | +9x | +
+ dispcounts = newdisp,+ |
+
| 664 | +9x | +
+ countformat = colcount_format(cinfs[[1]]),+ |
+
| 665 | +9x | +
+ total_cnt = new_total,+ |
+
| 666 | +9x | +
+ topleft = newtl+ |
+
| 667 | ++ |
+ )+ |
+
| 668 | ++ |
+ }+ |
+
| 669 | ++ | + + | +
| 670 | ++ |
+ nz_len_els <- function(lst) {
+ |
+
| 671 | +100x | +
+ if (is(lst, "list")) {
+ |
+
| 672 | +13x | +
+ lst[vapply(lst, function(x) length(x) > 0, NA)]+ |
+
| 673 | +87x | +
+ } else if (is(lst, "character")) {
+ |
+
| 674 | +74x | +
+ lst[nzchar(lst)]+ |
+
| 675 | ++ |
+ } else {
+ |
+
| 676 | +13x | +
+ lst+ |
+
| 677 | ++ |
+ }+ |
+
| 678 | ++ |
+ }+ |
+
| 679 | ++ | + + | +
| 680 | ++ |
+ has_one_unq <- function(x) {
+ |
+
| 681 | +100x | +
+ length(unique(nz_len_els(x))) <= 1+ |
+
| 682 | ++ |
+ }+ |
+
| 683 | ++ | + + | +
| 684 | ++ |
+ classvec <- function(lst, enforce_one = TRUE) {
+ |
+
| 685 | +26x | +
+ if (enforce_one) {
+ |
+
| 686 | +26x | +
+ vapply(lst, class, "")+ |
+
| 687 | ++ |
+ } else {
+ |
+
| 688 | +! | +
+ lapply(lst, class)+ |
+
| 689 | ++ |
+ }+ |
+
| 690 | ++ |
+ }+ |
+
| 691 | ++ | + + | +
| 692 | ++ |
+ chk_cbindable_many <- function(lst) {
+ |
+
| 693 | ++ |
+ ## we actually want is/inherits there but no easy way+ |
+
| 694 | ++ |
+ ## to figure out what the lowest base class is+ |
+
| 695 | ++ |
+ ## that I can think of right now, so we do the+ |
+
| 696 | ++ |
+ ## broken wrong thing instead :(+ |
+
| 697 | +15x | +
+ if (are(lst, "TableRow")) {
+ |
+
| 698 | +2x | +
+ if (!has_one_unq(classvec(lst))) {
+ |
+
| 699 | +1x | +
+ stop("Cannot cbind different types of TableRow objects together")
+ |
+
| 700 | ++ |
+ }+ |
+
| 701 | +1x | +
+ return(TRUE)+ |
+
| 702 | ++ |
+ }+ |
+
| 703 | ++ |
+ ## if(!are(lst, "VTableTree")+ |
+
| 704 | ++ |
+ ## stop("Not all elements to be bound are TableTrees or TableRows")
+ |
+
| 705 | ++ | + + | +
| 706 | +13x | +
+ nrs <- vapply(lst, NROW, 1L)+ |
+
| 707 | +13x | +
+ if (!has_one_unq(nrs)) {
+ |
+
| 708 | +! | +
+ stop("Not all elements to be bound have matching numbers of rows")
+ |
+
| 709 | ++ |
+ }+ |
+
| 710 | ++ | + + | +
| 711 | +13x | +
+ tls <- lapply(lst, top_left)+ |
+
| 712 | +13x | +
+ if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
+ |
+
| 713 | +2x | +
+ stop(+ |
+
| 714 | +2x | +
+ "Elements to be bound have differing top-left content: ",+ |
+
| 715 | +2x | +
+ paste(which(!duplicated(tls)), collapse = " ")+ |
+
| 716 | ++ |
+ )+ |
+
| 717 | ++ |
+ }+ |
+
| 718 | ++ | + + | +
| 719 | +11x | +
+ if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
+ |
+
| 720 | +1x | +
+ return(TRUE)+ |
+
| 721 | ++ |
+ }+ |
+
| 722 | ++ | + + | +
| 723 | +10x | +
+ rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
+ |
+
| 724 | +10x | +
+ nrow = nrs[[1]]+ |
+
| 725 | ++ |
+ )+ |
+
| 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 = " ")+ |
+
| 731 | ++ |
+ )+ |
+
| 732 | ++ |
+ }+ |
+
| 733 | ++ | + + | +
| 734 | +10x | +
+ rws <- lapply(lst, collect_leaves, add.labrows = TRUE)+ |
+
| 735 | +10x | +
+ rwclsmat <- matrix(unlist(lapply(rws, classvec)),+ |
+
| 736 | +10x | +
+ ncol = length(lst)+ |
+
| 737 | ++ |
+ )+ |
+
| 738 | ++ | + + | +
| 739 | +10x | +
+ rwsok <- apply(rwclsmat, 1, has_one_unq)+ |
+
| 740 | +10x | +
+ if (!all(rwsok)) {
+ |
+
| 741 | +! | +
+ stop(+ |
+
| 742 | +! | +
+ "Mismatching row classes found for rows: ",+ |
+
| 743 | +! | +
+ paste(which(!rwsok), collapse = " ")+ |
+
| 744 | ++ |
+ )+ |
+
| 745 | ++ |
+ }+ |
+
| 746 | +10x | +
+ TRUE+ |
+
| 747 | ++ |
+ }+ |
+
| 748 | ++ | + + | +
| 749 | ++ |
+ #' Column-bind two `TableTree` objects+ |
+
| 750 | ++ |
+ #'+ |
+
| 751 | ++ |
+ #' @param x (`TableTree` or `TableRow`)\cr a table or row object.+ |
+
| 752 | ++ |
+ #' @param ... one or more further objects of the same class as `x`.+ |
+
| 753 | ++ |
+ #' @param sync_count_vis (`logical(1)`)\cr should column count+ |
+
| 754 | ++ |
+ #' visibility be synced across the new and existing columns.+ |
+
| 755 | ++ |
+ #' Currently defaults to `TRUE` for backwards compatibility but+ |
+
| 756 | ++ |
+ #' this may change in future releases.+ |
+
| 757 | ++ |
+ #'+ |
+
| 758 | ++ |
+ #' @inherit rbindl_rtables return+ |
+
| 759 | ++ |
+ #'+ |
+
| 760 | ++ |
+ #' @examples+ |
+
| 761 | ++ |
+ #' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
+ |
+
| 762 | ++ |
+ #' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
+ |
+
| 763 | ++ |
+ #' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
+ |
+
| 764 | ++ |
+ #'+ |
+
| 765 | ++ |
+ #' t1 <- cbind_rtables(x, y)+ |
+
| 766 | ++ |
+ #' t1+ |
+
| 767 | ++ |
+ #'+ |
+
| 768 | ++ |
+ #' t2 <- cbind_rtables(x, y, z)+ |
+
| 769 | ++ |
+ #' t2+ |
+
| 770 | ++ |
+ #'+ |
+
| 771 | ++ |
+ #' col_paths_summary(t1)+ |
+
| 772 | ++ |
+ #' col_paths_summary(t2)+ |
+
| 773 | ++ |
+ #'+ |
+
| 774 | ++ |
+ #' @export+ |
+
| 775 | ++ |
+ cbind_rtables <- function(x, ..., sync_count_vis = TRUE) {
+ |
+
| 776 | +10x | +
+ lst <- list(...)+ |
+
| 777 | +10x | +
+ newcinfo <- combine_cinfo(x, ..., sync_count_vis = sync_count_vis)+ |
+
| 778 | +9x | +
+ recurse_cbindl(x, cinfo = newcinfo, .list = lst)+ |
+
| 779 | ++ |
+ }+ |
+
| 780 | ++ | + + | +
| 781 | +89x | +
+ setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))
+ |
+
| 782 | ++ | + + | +
| 783 | ++ |
+ setMethod(+ |
+
| 784 | ++ |
+ "recurse_cbindl", c(+ |
+
| 785 | ++ |
+ x = "VTableNodeInfo",+ |
+
| 786 | ++ |
+ cinfo = "NULL"+ |
+
| 787 | ++ |
+ ),+ |
+
| 788 | ++ |
+ function(x, cinfo, .list = NULL) {
+ |
+
| 789 | +! | +
+ recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list)+ |
+
| 790 | ++ |
+ }+ |
+
| 791 | ++ |
+ )+ |
+
| 792 | ++ | + + | +
| 793 | ++ |
+ setMethod(+ |
+
| 794 | ++ |
+ "recurse_cbindl", c(+ |
+
| 795 | ++ |
+ x = "TableTree",+ |
+
| 796 | ++ |
+ cinfo = "InstantiatedColumnInfo"+ |
+
| 797 | ++ |
+ ),+ |
+
| 798 | ++ |
+ function(x, cinfo, .list = NULL) {
+ |
+
| 799 | +18x | +
+ stopifnot(are(.list, "VTableTree"))+ |
+
| 800 | ++ |
+ ## chk_cbindable(x, y)+ |
+
| 801 | +18x | +
+ xcont <- content_table(x)+ |
+
| 802 | +18x | +
+ lstconts <- lapply(.list, content_table)+ |
+
| 803 | +18x | +
+ lcontnrows <- vapply(lstconts, NROW, 1L)+ |
+
| 804 | +18x | +
+ unqnrcont <- unique(c(NROW(xcont), lcontnrows))+ |
+
| 805 | +18x | +
+ if (length(unqnrcont) > 1) {
+ |
+
| 806 | +! | +
+ stop(+ |
+
| 807 | +! | +
+ "Got differing numbers of content rows [",+ |
+
| 808 | +! | +
+ paste(unqnrcont, collapse = ", "),+ |
+
| 809 | +! | +
+ "]. Unable to cbind these rtables"+ |
+
| 810 | ++ |
+ )+ |
+
| 811 | ++ |
+ }+ |
+
| 812 | ++ | + + | +
| 813 | +18x | +
+ if (unqnrcont == 0) {
+ |
+
| 814 | +18x | +
+ cont <- ElementaryTable(cinfo = cinfo)+ |
+
| 815 | ++ |
+ } else {
+ |
+
| 816 | +! | +
+ cont <- recurse_cbindl(xcont,+ |
+
| 817 | +! | +
+ .list = lstconts,+ |
+
| 818 | +! | +
+ cinfo = cinfo+ |
+
| 819 | ++ |
+ )+ |
+
| 820 | ++ |
+ }+ |
+
| 821 | ++ | + + | +
| 822 | +18x | +
+ kids <- lapply(+ |
+
| 823 | +18x | +
+ seq_along(tree_children(x)),+ |
+
| 824 | +18x | +
+ function(i) {
+ |
+
| 825 | +27x | +
+ recurse_cbindl(+ |
+
| 826 | +27x | +
+ x = tree_children(x)[[i]],+ |
+
| 827 | +27x | +
+ cinfo = cinfo,+ |
+
| 828 | +27x | +
+ .list = lapply(.list, function(tt) tree_children(tt)[[i]])+ |
+
| 829 | ++ |
+ )+ |
+
| 830 | ++ |
+ }+ |
+
| 831 | ++ |
+ )+ |
+
| 832 | +18x | +
+ names(kids) <- names(tree_children(x))+ |
+
| 833 | +18x | +
+ TableTree(+ |
+
| 834 | +18x | +
+ kids = kids, labelrow = recurse_cbindl(tt_labelrow(x),+ |
+
| 835 | +18x | +
+ cinfo = cinfo,+ |
+
| 836 | +18x | +
+ .list = lapply(.list, tt_labelrow)+ |
+
| 837 | ++ |
+ ),+ |
+
| 838 | +18x | +
+ cont = cont,+ |
+
| 839 | +18x | +
+ name = obj_name(x),+ |
+
| 840 | +18x | +
+ lev = tt_level(x),+ |
+
| 841 | +18x | +
+ cinfo = cinfo,+ |
+
| 842 | +18x | +
+ format = obj_format(x)+ |
+
| 843 | ++ |
+ )+ |
+
| 844 | ++ |
+ }+ |
+
| 845 | ++ |
+ )+ |
+
| 846 | ++ | + + | +
| 847 | ++ |
+ setMethod(+ |
+
| 848 | ++ |
+ "recurse_cbindl", c(+ |
+
| 849 | ++ |
+ x = "ElementaryTable",+ |
+
| 850 | ++ |
+ cinfo = "InstantiatedColumnInfo"+ |
+
| 851 | ++ |
+ ),+ |
+
| 852 | ++ |
+ function(x, cinfo, .list) {
+ |
+
| 853 | +18x | +
+ stopifnot(are(.list, class(x)))+ |
+
| 854 | ++ |
+ ## chk_cbindable(x,y)+ |
+
| 855 | +18x | +
+ if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
+ |
+
| 856 | +1x | +
+ col_info(x) <- cinfo+ |
+
| 857 | +1x | +
+ return(x) ## this needs testing... I was right, it did #136+ |
+
| 858 | ++ |
+ }+ |
+
| 859 | +17x | +
+ kids <- lapply(+ |
+
| 860 | +17x | +
+ seq_along(tree_children(x)),+ |
+
| 861 | +17x | +
+ function(i) {
+ |
+
| 862 | +18x | +
+ recurse_cbindl(+ |
+
| 863 | +18x | +
+ x = tree_children(x)[[i]],+ |
+
| 864 | +18x | +
+ cinfo = cinfo,+ |
+
| 865 | +18x | +
+ .list = lapply(.list, function(tt) tree_children(tt)[[i]])+ |
+
| 866 | ++ |
+ )+ |
+
| 867 | ++ |
+ }+ |
+
| 868 | ++ |
+ )+ |
+
| 869 | +17x | +
+ names(kids) <- names(tree_children(x))+ |
+
| 870 | ++ | + + | +
| 871 | +17x | +
+ ElementaryTable(+ |
+
| 872 | +17x | +
+ kids = kids,+ |
+
| 873 | +17x | +
+ labelrow = recurse_cbindl(tt_labelrow(x),+ |
+
| 874 | +17x | +
+ .list = lapply(.list, tt_labelrow),+ |
+
| 875 | +17x | +
+ cinfo+ |
+
| 876 | ++ |
+ ),+ |
+
| 877 | +17x | +
+ name = obj_name(x),+ |
+
| 878 | +17x | +
+ lev = tt_level(x),+ |
+
| 879 | +17x | +
+ cinfo = cinfo,+ |
+
| 880 | +17x | +
+ format = obj_format(x),+ |
+
| 881 | +17x | +
+ var = obj_avar(x)+ |
+
| 882 | ++ |
+ )+ |
+
| 883 | ++ |
+ }+ |
+
| 884 | ++ |
+ )+ |
+
| 885 | ++ | + + | +
| 886 | ++ |
+ .combine_rows <- function(x, cinfo = NULL, .list) {
+ |
+
| 887 | +18x | +
+ stopifnot(are(.list, class(x)))+ |
+
| 888 | ++ | + + | +
| 889 | +18x | +
+ avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE))+ |
+
| 890 | +18x | +
+ avars <- avars[!is.na(avars)]+ |
+
| 891 | ++ | + + | +
| 892 | +18x | +
+ if (length(unique(avars)) > 1) {
+ |
+
| 893 | +! | +
+ stop("Got rows that don't analyze the same variable")
+ |
+
| 894 | ++ |
+ }+ |
+
| 895 | ++ | + + | +
| 896 | +18x | +
+ xlst <- c(list(x), .list)+ |
+
| 897 | ++ | + + | +
| 898 | +18x | +
+ ncols <- vapply(xlst, ncol, 1L)+ |
+
| 899 | +18x | +
+ totcols <- sum(ncols)+ |
+
| 900 | +18x | +
+ cumncols <- cumsum(ncols)+ |
+
| 901 | +18x | +
+ strtncols <- c(0L, head(cumncols, -1)) + 1L+ |
+
| 902 | +18x | +
+ vals <- vector("list", totcols)
+ |
+
| 903 | +18x | +
+ cspans <- integer(totcols)+ |
+
| 904 | ++ |
+ ## vals[1:ncol(x)] <- row_values(x)+ |
+
| 905 | ++ |
+ ## cpans[1:ncol(x)] <- row_cspans(x)+ |
+
| 906 | ++ | + + | +
| 907 | +18x | +
+ for (i in seq_along(xlst)) {
+ |
+
| 908 | +37x | +
+ strt <- strtncols[i]+ |
+
| 909 | +37x | +
+ end <- cumncols[i]+ |
+
| 910 | ++ |
+ ## full vars are here for debugging purposes+ |
+
| 911 | +37x | +
+ fullvy <- vy <- row_cells(xlst[[i]]) # nolint+ |
+
| 912 | +37x | +
+ fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint+ |
+
| 913 | ++ | + + | +
| 914 | ++ |
+ if (+ |
+
| 915 | +37x | +
+ i > 1 &&+ |
+
| 916 | +37x | +
+ identical(rawvalues(vy[[1]]), rawvalues(lastval)) &&+ |
+
| 917 | ++ |
+ ## cspy[1] == lastspn &&+ |
+
| 918 | +37x | +
+ lastspn > 1+ |
+
| 919 | ++ |
+ ) {
+ |
+
| 920 | +! | +
+ vy <- vy[-1]+ |
+
| 921 | +! | +
+ cspans[strt - 1L] <- lastspn + cspy[1]+ |
+
| 922 | +! | +
+ cspy <- cspy[-1]+ |
+
| 923 | +! | +
+ strt <- strt + 1L+ |
+
| 924 | ++ |
+ }+ |
+
| 925 | +37x | +
+ if (length(vy) > 0) {
+ |
+
| 926 | +37x | +
+ vals[strt:end] <- vy+ |
+
| 927 | +37x | +
+ cspans[strt:end] <- cspy+ |
+
| 928 | +37x | +
+ lastval <- vy[[length(vy)]]+ |
+
| 929 | +37x | +
+ lastspn <- cspy[[length(cspy)]]+ |
+
| 930 | ++ |
+ } else {
+ |
+
| 931 | ++ |
+ ## lastval stays the same+ |
+
| 932 | +! | +
+ lastspn <- cspans[strtncols[i] - 1] ## already updated+ |
+
| 933 | ++ |
+ }+ |
+
| 934 | ++ |
+ }+ |
+
| 935 | ++ | + + | +
| 936 | ++ |
+ ## Could be DataRow or ContentRow+ |
+
| 937 | ++ |
+ ## This is ok because LabelRow is special cased+ |
+
| 938 | +18x | +
+ constr_fun <- get(class(x), mode = "function")+ |
+
| 939 | +18x | +
+ constr_fun(+ |
+
| 940 | +18x | +
+ vals = vals,+ |
+
| 941 | +18x | +
+ cspan = cspans,+ |
+
| 942 | +18x | +
+ cinfo = cinfo,+ |
+
| 943 | +18x | +
+ var = obj_avar(x),+ |
+
| 944 | +18x | +
+ format = obj_format(x),+ |
+
| 945 | +18x | +
+ name = obj_name(x),+ |
+
| 946 | +18x | +
+ label = obj_label(x)+ |
+
| 947 | ++ |
+ )+ |
+
| 948 | ++ |
+ }+ |
+
| 949 | ++ | + + | +
| 950 | ++ |
+ setMethod(+ |
+
| 951 | ++ |
+ "recurse_cbindl", c(+ |
+
| 952 | ++ |
+ "TableRow",+ |
+
| 953 | ++ |
+ "InstantiatedColumnInfo"+ |
+
| 954 | ++ |
+ ),+ |
+
| 955 | ++ |
+ function(x, cinfo = NULL, .list) {
+ |
+
| 956 | +18x | +
+ .combine_rows(x, cinfo, .list)+ |
+
| 957 | ++ |
+ }+ |
+
| 958 | ++ |
+ )+ |
+
| 959 | ++ | + + | +
| 960 | ++ |
+ setMethod(+ |
+
| 961 | ++ |
+ "recurse_cbindl", c(+ |
+
| 962 | ++ |
+ x = "LabelRow",+ |
+
| 963 | ++ |
+ cinfo = "InstantiatedColumnInfo"+ |
+
| 964 | ++ |
+ ),+ |
+
| 965 | ++ |
+ function(x, cinfo = NULL, .list) {
+ |
+
| 966 | +35x | +
+ col_info(x) <- cinfo+ |
+
| 967 | +35x | +
+ x+ |
+
| 968 | ++ |
+ }+ |
+
| 969 | ++ |
+ )+ |
+
| 970 | ++ | + + | +
| 971 | ++ |
+ ## we don't care about the following discrepencies:+ |
+
| 972 | ++ |
+ ## - ci2 having NA counts when ci1 doesn't+ |
+
| 973 | ++ |
+ ## - mismatching display_ccounts values+ |
+
| 974 | ++ |
+ ## - mismatching colcount formats+ |
+
| 975 | ++ |
+ ##+ |
+
| 976 | ++ | + + | +
| 977 | ++ |
+ # chk_compat_cinfos <- function(ci1, ci2) {
+ |
+
| 978 | ++ |
+ chk_compat_cinfos <- function(tt1, tt2) {
+ |
+
| 979 | +41x | +
+ nc1 <- ncol(tt1)+ |
+
| 980 | +41x | +
+ nc2 <- ncol(tt2)+ |
+
| 981 | +41x | +
+ if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
+ |
+
| 982 | +1x | +
+ stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
+ |
+
| 983 | ++ |
+ }+ |
+
| 984 | +40x | +
+ if (no_colinfo(tt1) || no_colinfo(tt2)) {
+ |
+
| 985 | +10x | +
+ return(TRUE)+ |
+
| 986 | ++ |
+ }+ |
+
| 987 | +30x | +
+ ci1 <- col_info(tt1)+ |
+
| 988 | +30x | +
+ ci2 <- col_info(tt2)+ |
+
| 989 | ++ |
+ ## this will enforce same length and+ |
+
| 990 | ++ |
+ ## same names, in addition to same+ |
+
| 991 | ++ |
+ ## expressions so we dont need+ |
+
| 992 | ++ |
+ ## to check those separateley+ |
+
| 993 | +30x | +
+ if (!identical(col_exprs(ci1), col_exprs(ci2))) {
+ |
+
| 994 | +! | +
+ stop("Column structures not compatible: subset expression lists not identical")
+ |
+
| 995 | ++ |
+ }+ |
+
| 996 | ++ | + + | +
| 997 | +30x | +
+ if (any(!is.na(col_counts(ci2))) &&+ |
+
| 998 | +30x | +
+ !identical(+ |
+
| 999 | +30x | +
+ col_counts(ci1),+ |
+
| 1000 | +30x | +
+ col_counts(ci2)+ |
+
| 1001 | ++ |
+ )) {
+ |
+
| 1002 | +! | +
+ stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
+ |
+
| 1003 | ++ |
+ }+ |
+
| 1004 | ++ | + + | +
| 1005 | +30x | +
+ if (any(sapply(+ |
+
| 1006 | +30x | +
+ col_extra_args(ci2),+ |
+
| 1007 | +30x | +
+ function(x) length(x) > 0+ |
+
| 1008 | ++ |
+ )) &&+ |
+
| 1009 | +30x | +
+ !identical(+ |
+
| 1010 | +30x | +
+ col_extra_args(ci1),+ |
+
| 1011 | +30x | +
+ col_extra_args(ci2)+ |
+
| 1012 | ++ |
+ )) {
+ |
+
| 1013 | +! | +
+ stop(+ |
+
| 1014 | +! | +
+ "Column structures not compatible: 2nd column structure has ",+ |
+
| 1015 | +! | +
+ "non-matching, non-null extra args"+ |
+
| 1016 | ++ |
+ )+ |
+
| 1017 | ++ |
+ }+ |
+
| 1018 | ++ | + + | +
| 1019 | +30x | +
+ if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
+ |
+
| 1020 | +1x | +
+ stop(+ |
+
| 1021 | +1x | +
+ "Top-left materials not compatible: Got non-empty, non-matching ",+ |
+
| 1022 | +1x | +
+ "top-left materials. Clear them using top_left(x)<-character() ",+ |
+
| 1023 | +1x | +
+ "before binding to force compatibility."+ |
+
| 1024 | ++ |
+ )+ |
+
| 1025 | ++ |
+ }+ |
+
| 1026 | +29x | +
+ TRUE+ |
+
| 1027 | ++ |
+ }+ |
+
| 1028 | ++ | + + | +
| 1029 | ++ | + + | +
| 1030 | ++ |
+ #' Insert `rrow`s at (before) a specific location+ |
+
| 1031 | ++ |
+ #'+ |
+
| 1032 | ++ |
+ #' `r lifecycle::badge("deprecated")`
+ |
+
| 1033 | ++ |
+ #'+ |
+
| 1034 | ++ |
+ #' This function is deprecated and will be removed in a future release of `rtables`. Please use+ |
+
| 1035 | ++ |
+ #' [insert_row_at_path()] or [label_at_path()] instead.+ |
+
| 1036 | ++ |
+ #'+ |
+
| 1037 | ++ |
+ #' @param tbl (`VTableTree`)\cr a `rtable` object.+ |
+
| 1038 | ++ |
+ #' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`.+ |
+
| 1039 | ++ |
+ #' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1).+ |
+
| 1040 | ++ |
+ #' @param ascontent (`flag`)\cr currently ignored.+ |
+
| 1041 | ++ |
+ #'+ |
+
| 1042 | ++ |
+ #' @return A `TableTree` of the same specific class as `tbl`.+ |
+
| 1043 | ++ |
+ #'+ |
+
| 1044 | ++ |
+ #' @note+ |
+
| 1045 | ++ |
+ #' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do+ |
+
| 1046 | ++ |
+ #' not already contain a label row when there is a non-trivial nested row structure in `tbl`.+ |
+
| 1047 | ++ |
+ #'+ |
+
| 1048 | ++ |
+ #' @examples+ |
+
| 1049 | ++ |
+ #' o <- options(warn = 0)+ |
+
| 1050 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1051 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 1052 | ++ |
+ #' analyze("Sepal.Length")
+ |
+
| 1053 | ++ |
+ #'+ |
+
| 1054 | ++ |
+ #' tbl <- build_table(lyt, iris)+ |
+
| 1055 | ++ |
+ #'+ |
+
| 1056 | ++ |
+ #' insert_rrow(tbl, rrow("Hello World"))
+ |
+
| 1057 | ++ |
+ #' insert_rrow(tbl, rrow("Hello World"), at = 2)
+ |
+
| 1058 | ++ |
+ #'+ |
+
| 1059 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 1060 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 1061 | ++ |
+ #' split_rows_by("Species") %>%
+ |
+
| 1062 | ++ |
+ #' analyze("Sepal.Length")
+ |
+
| 1063 | ++ |
+ #'+ |
+
| 1064 | ++ |
+ #' tbl2 <- build_table(lyt2, iris)+ |
+
| 1065 | ++ |
+ #'+ |
+
| 1066 | ++ |
+ #' insert_rrow(tbl2, rrow("Hello World"))
+ |
+
| 1067 | ++ |
+ #' insert_rrow(tbl2, rrow("Hello World"), at = 2)
+ |
+
| 1068 | ++ |
+ #' insert_rrow(tbl2, rrow("Hello World"), at = 4)
+ |
+
| 1069 | ++ |
+ #'+ |
+
| 1070 | ++ |
+ #' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
+ |
+
| 1071 | ++ |
+ #'+ |
+
| 1072 | ++ |
+ #' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
+ |
+
| 1073 | ++ |
+ #'+ |
+
| 1074 | ++ |
+ #' options(o)+ |
+
| 1075 | ++ |
+ #'+ |
+
| 1076 | ++ |
+ #' @export+ |
+
| 1077 | ++ |
+ insert_rrow <- function(tbl, rrow, at = 1,+ |
+
| 1078 | ++ |
+ ascontent = FALSE) {
+ |
+
| 1079 | +9x | +
+ lifecycle::deprecate_warn(+ |
+
| 1080 | +9x | +
+ when = "0.4.0",+ |
+
| 1081 | +9x | +
+ what = "insert_rrow()",+ |
+
| 1082 | +9x | +
+ with = I("insert_row_at_path() or label_at_path()")
+ |
+
| 1083 | ++ |
+ )+ |
+
| 1084 | +9x | +
+ stopifnot(+ |
+
| 1085 | +9x | +
+ is(tbl, "VTableTree"),+ |
+
| 1086 | +9x | +
+ is(rrow, "TableRow"),+ |
+
| 1087 | +9x | +
+ at >= 1 && at <= nrow(tbl) + 1+ |
+
| 1088 | ++ |
+ )+ |
+
| 1089 | +9x | +
+ chk_compat_cinfos(tbl, rrow)+ |
+
| 1090 | +8x | +
+ if (no_colinfo(rrow)) {
+ |
+
| 1091 | +8x | +
+ col_info(rrow) <- col_info(tbl)+ |
+
| 1092 | ++ |
+ }+ |
+
| 1093 | ++ | + + | +
| 1094 | +8x | +
+ if (at == 1) {
+ |
+
| 1095 | +4x | +
+ return(rbindl_rtables(list(rrow, tbl)))+ |
+
| 1096 | +4x | +
+ } else if (at == nrow(tbl) + 1) {
+ |
+
| 1097 | +1x | +
+ return(rbind2(tbl, rrow))+ |
+
| 1098 | ++ |
+ }+ |
+
| 1099 | ++ | + + | +
| 1100 | +3x | +
+ ret <- recurse_insert(tbl, rrow,+ |
+
| 1101 | +3x | +
+ at = at,+ |
+
| 1102 | +3x | +
+ pos = 0,+ |
+
| 1103 | +3x | +
+ ascontent = ascontent+ |
+
| 1104 | ++ |
+ )+ |
+
| 1105 | +3x | +
+ ret+ |
+
| 1106 | ++ |
+ }+ |
+
| 1107 | ++ | + + | +
| 1108 | ++ |
+ .insert_helper <- function(tt, row, at, pos,+ |
+
| 1109 | ++ |
+ ascontent = FALSE) {
+ |
+
| 1110 | +9x | +
+ islab <- is(row, "LabelRow")+ |
+
| 1111 | +9x | +
+ kids <- tree_children(tt)+ |
+
| 1112 | +9x | +
+ numkids <- length(kids)+ |
+
| 1113 | +9x | +
+ kidnrs <- sapply(kids, nrow)+ |
+
| 1114 | +9x | +
+ cumpos <- pos + cumsum(kidnrs)+ |
+
| 1115 | +9x | +
+ contnr <- if (is(tt, "TableTree")) {
+ |
+
| 1116 | +6x | +
+ nrow(content_table(tt))+ |
+
| 1117 | ++ |
+ } else {
+ |
+
| 1118 | +3x | +
+ 0+ |
+
| 1119 | ++ |
+ }+ |
+
| 1120 | +9x | +
+ contnr <- contnr + as.numeric(labelrow_visible(tt))+ |
+
| 1121 | ++ | + + | +
| 1122 | +9x | +
+ totnr <- nrow(tt)+ |
+
| 1123 | +9x | +
+ endpos <- pos + totnr+ |
+
| 1124 | +9x | +
+ atend <- !islab && endpos == at - 1+ |
+
| 1125 | +9x | +
+ if (at == pos + 1 && islab) {
+ |
+
| 1126 | +2x | +
+ if (labelrow_visible(tt)) {
+ |
+
| 1127 | +! | +
+ stop("Inserting a label row at a position that already has a label row is not currently supported")
+ |
+
| 1128 | ++ |
+ }+ |
+
| 1129 | +2x | +
+ tt_labelrow(tt) <- row+ |
+
| 1130 | +2x | +
+ return(tt)+ |
+
| 1131 | ++ |
+ }+ |
+
| 1132 | ++ | + + | +
| 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 | ++ |
+ } 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]),+ |
+
| 1144 | +1x | +
+ ascontent = ascontent+ |
+
| 1145 | ++ |
+ )+ |
+
| 1146 | ++ |
+ }+ |
+
| 1147 | ++ |
+ } else { # have >0 kids
+ |
+
| 1148 | +5x | +
+ kidnrs <- sapply(kids, nrow)+ |
+
| 1149 | +5x | +
+ cumpos <- pos + cumsum(kidnrs)+ |
+
| 1150 | ++ | + + | +
| 1151 | ++ |
+ ## data rows go in the end of the+ |
+
| 1152 | ++ |
+ ## preceding subtable (if applicable)+ |
+
| 1153 | ++ |
+ ## label rows go in the beginning of+ |
+
| 1154 | ++ |
+ ## one at at+ |
+
| 1155 | +5x | +
+ ind <- min(+ |
+
| 1156 | +5x | +
+ which((cumpos + !islab) >= at),+ |
+
| 1157 | +5x | +
+ numkids+ |
+
| 1158 | ++ |
+ )+ |
+
| 1159 | +5x | +
+ thekid <- kids[[ind]]+ |
+
| 1160 | ++ | + + | +
| 1161 | +5x | +
+ if (is(thekid, "TableRow")) {
+ |
+
| 1162 | +! | +
+ tt_level(row) <- tt_level(thekid)+ |
+
| 1163 | +! | +
+ if (ind == 1) {
+ |
+
| 1164 | +! | +
+ bef <- integer()+ |
+
| 1165 | +! | +
+ aft <- 1:numkids+ |
+
| 1166 | +! | +
+ } else if (ind == numkids) {
+ |
+
| 1167 | +! | +
+ bef <- 1:(ind - 1)+ |
+
| 1168 | +! | +
+ aft <- ind+ |
+
| 1169 | ++ |
+ } else {
+ |
+
| 1170 | +! | +
+ bef <- 1:ind+ |
+
| 1171 | +! | +
+ aft <- (ind + 1):numkids+ |
+
| 1172 | ++ |
+ }+ |
+
| 1173 | +! | +
+ kids <- c(+ |
+
| 1174 | +! | +
+ kids[bef], list(row),+ |
+
| 1175 | +! | +
+ kids[aft]+ |
+
| 1176 | ++ |
+ )+ |
+
| 1177 | ++ |
+ } else { # kid is not a table row
+ |
+
| 1178 | +5x | +
+ newpos <- if (ind == 1) {
+ |
+
| 1179 | +4x | +
+ pos + contnr+ |
+
| 1180 | ++ |
+ } else {
+ |
+
| 1181 | +1x | +
+ cumpos[ind - 1]+ |
+
| 1182 | ++ |
+ }+ |
+
| 1183 | ++ | + + | +
| 1184 | +5x | +
+ kids[[ind]] <- recurse_insert(thekid,+ |
+
| 1185 | +5x | +
+ row,+ |
+
| 1186 | +5x | +
+ at,+ |
+
| 1187 | +5x | +
+ pos = newpos,+ |
+
| 1188 | +5x | +
+ ascontent = ascontent+ |
+
| 1189 | ++ |
+ )+ |
+
| 1190 | ++ |
+ } # end kid is not table row+ |
+
| 1191 | ++ |
+ }+ |
+
| 1192 | +7x | +
+ tree_children(tt) <- kids+ |
+
| 1193 | +7x | +
+ tt+ |
+
| 1194 | ++ |
+ }+ |
+
| 1195 | ++ | + + | +
| 1196 | +9x | +
+ setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))
+ |
+
| 1197 | ++ | + + | +
| 1198 | ++ |
+ setMethod(+ |
+
| 1199 | ++ |
+ "recurse_insert", "TableTree",+ |
+
| 1200 | ++ |
+ function(tt, row, at, pos, ascontent = FALSE) {
+ |
+
| 1201 | +6x | +
+ ctab <- content_table(tt)+ |
+
| 1202 | +6x | +
+ contnr <- nrow(ctab)+ |
+
| 1203 | +6x | +
+ contpos <- pos + contnr+ |
+
| 1204 | +6x | +
+ islab <- is(row, "LabelRow")+ |
+
| 1205 | ++ |
+ ## this will NOT insert it as+ |
+
| 1206 | +6x | +
+ if ((contnr > 0 || islab) && contpos > at) {
+ |
+
| 1207 | +! | +
+ content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE)+ |
+
| 1208 | +! | +
+ return(tt)+ |
+
| 1209 | ++ |
+ }+ |
+
| 1210 | ++ | + + | +
| 1211 | +6x | +
+ .insert_helper(tt, row,+ |
+
| 1212 | +6x | +
+ at = at, pos = pos + contnr,+ |
+
| 1213 | +6x | +
+ ascontent = ascontent+ |
+
| 1214 | ++ |
+ )+ |
+
| 1215 | ++ |
+ }+ |
+
| 1216 | ++ |
+ )+ |
+
| 1217 | ++ | + + | +
| 1218 | ++ |
+ setMethod(+ |
+
| 1219 | ++ |
+ "recurse_insert", "ElementaryTable",+ |
+
| 1220 | ++ |
+ function(tt, row, at, pos, ascontent = FALSE) {
+ |
+
| 1221 | +3x | +
+ .insert_helper(tt, row,+ |
+
| 1222 | +3x | +
+ at = at, pos = pos,+ |
+
| 1223 | +3x | +
+ ascontent = FALSE+ |
+
| 1224 | ++ |
+ )+ |
+
| 1225 | ++ |
+ }+ |
+
| 1226 | ++ |
+ )+ |
+
| 1 | ++ |
+ label_pos_values <- c("hidden", "visible", "topleft")
+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' @name internal_methods+ |
+
| 4 | ++ |
+ #' @rdname int_methods+ |
+
| 5 | ++ |
+ NULL+ |
+
| 6 | ++ | + + | +
| 7 | ++ |
+ #' Combine `SplitVector` objects+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @param x (`SplitVector`)\cr a `SplitVector` object.+ |
+
| 10 | ++ |
+ #' @param ... splits or `SplitVector` objects.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return Various, but should be considered implementation details.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @rdname int_methods+ |
+
| 15 | ++ |
+ #' @exportMethod c+ |
+
| 16 | ++ |
+ setMethod("c", "SplitVector", function(x, ...) {
+ |
+
| 17 | +408x | +
+ arglst <- list(...)+ |
+
| 18 | +408x | +
+ stopifnot(all(sapply(arglst, is, "Split")))+ |
+
| 19 | +408x | +
+ tmp <- c(unclass(x), arglst)+ |
+
| 20 | +408x | +
+ SplitVector(lst = tmp)+ |
+
| 21 | ++ |
+ })+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ ## split_rows and split_cols are "recursive method stacks" which follow+ |
+
| 24 | ++ |
+ ## the general pattern of accept object -> call add_*_split on slot of object ->+ |
+
| 25 | ++ |
+ ## update object with value returned from slot method, return object.+ |
+
| 26 | ++ |
+ ##+ |
+
| 27 | ++ |
+ ## Thus each of the methods is idempotent, returning an updated object of the+ |
+
| 28 | ++ |
+ ## same class it was passed. The exception for idempotency is the NULL method+ |
+
| 29 | ++ |
+ ## which constructs a PreDataTableLayouts object with the specified split in the+ |
+
| 30 | ++ |
+ ## correct place.+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ ## The cascading (by class) in this case is as follows for the row case:+ |
+
| 33 | ++ |
+ ## PreDataTableLayouts -> PreDataRowLayout -> SplitVector+ |
+
| 34 | ++ |
+ #' @param cmpnd_fun (`function`)\cr intended for internal use.+ |
+
| 35 | ++ |
+ #' @param pos (`numeric(1)`)\cr intended for internal use.+ |
+
| 36 | ++ |
+ #' @param spl (`Split`)\cr the split.+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @rdname int_methods+ |
+
| 39 | ++ |
+ setGeneric(+ |
+
| 40 | ++ |
+ "split_rows",+ |
+
| 41 | ++ |
+ function(lyt = NULL, spl, pos,+ |
+
| 42 | ++ |
+ cmpnd_fun = AnalyzeMultiVars) {
+ |
+
| 43 | +1638x | +
+ standardGeneric("split_rows")
+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ |
+ )+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ #' @rdname int_methods+ |
+
| 48 | ++ |
+ setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ |
+
| 49 | +1x | +
+ lifecycle::deprecate_warn(+ |
+
| 50 | +1x | +
+ when = "0.3.8",+ |
+
| 51 | +1x | +
+ what = I("split_rows(NULL)"),
+ |
+
| 52 | +1x | +
+ with = "basic_table()",+ |
+
| 53 | +1x | +
+ details = "Initializing layouts via `NULL` is no longer supported."+ |
+
| 54 | ++ |
+ )+ |
+
| 55 | +1x | +
+ rl <- PreDataRowLayout(SplitVector(spl))+ |
+
| 56 | +1x | +
+ cl <- PreDataColLayout()+ |
+
| 57 | +1x | +
+ PreDataTableLayouts(rlayout = rl, clayout = cl)+ |
+
| 58 | ++ |
+ })+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ #' @rdname int_methods+ |
+
| 61 | ++ |
+ setMethod(+ |
+
| 62 | ++ |
+ "split_rows", "PreDataRowLayout",+ |
+
| 63 | ++ |
+ function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ |
+
| 64 | +554x | +
+ stopifnot(pos > 0 && pos <= length(lyt) + 1)+ |
+
| 65 | +554x | +
+ tmp <- if (pos <= length(lyt)) {
+ |
+
| 66 | +529x | +
+ split_rows(lyt[[pos]], spl, pos, cmpnd_fun)+ |
+
| 67 | ++ |
+ } else {
+ |
+
| 68 | +25x | +
+ if (pos != 1 && has_force_pag(spl)) {
+ |
+
| 69 | +1x | +
+ stop("page_by splits cannot have top-level siblings",
+ |
+
| 70 | +1x | +
+ call. = FALSE+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | +24x | +
+ SplitVector(spl)+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | +552x | +
+ lyt[[pos]] <- tmp+ |
+
| 76 | +552x | +
+ lyt+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ is_analysis_spl <- function(spl) {
+ |
+
| 81 | +! | +
+ is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars")+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ ## note "pos" is ignored here because it is for which nest-chain+ |
+
| 85 | ++ |
+ ## spl should be placed in, NOIT for where in that chain it should go+ |
+
| 86 | ++ |
+ #' @rdname int_methods+ |
+
| 87 | ++ |
+ setMethod(+ |
+
| 88 | ++ |
+ "split_rows", "SplitVector",+ |
+
| 89 | ++ |
+ function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ |
+
| 90 | ++ |
+ ## if(is_analysis_spl(spl) &&+ |
+
| 91 | ++ |
+ ## is_analysis_spl(last_rowsplit(lyt))) {
+ |
+
| 92 | ++ |
+ ## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun))+ |
+
| 93 | ++ |
+ ## }+ |
+
| 94 | ++ | + + | +
| 95 | +529x | +
+ if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
+ |
+
| 96 | +1x | +
+ stop("page_by splits cannot be nested within non-page_by splits",
+ |
+
| 97 | +1x | +
+ call. = FALSE+ |
+
| 98 | ++ |
+ )+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | +528x | +
+ tmp <- c(unclass(lyt), spl)+ |
+
| 101 | +528x | +
+ SplitVector(lst = tmp)+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ #' @rdname int_methods+ |
+
| 106 | ++ |
+ setMethod(+ |
+
| 107 | ++ |
+ "split_rows", "PreDataTableLayouts",+ |
+
| 108 | ++ |
+ function(lyt, spl, pos) {
+ |
+
| 109 | +554x | +
+ rlyt <- rlayout(lyt)+ |
+
| 110 | +554x | +
+ addtl <- FALSE+ |
+
| 111 | +554x | +
+ split_label <- obj_label(spl)+ |
+
| 112 | ++ |
+ if (+ |
+
| 113 | +554x | +
+ is(spl, "Split") && ## exclude existing tables that are being tacked in+ |
+
| 114 | +554x | +
+ identical(label_position(spl), "topleft") &&+ |
+
| 115 | +554x | +
+ length(split_label) == 1 && nzchar(split_label)+ |
+
| 116 | ++ |
+ ) {
+ |
+
| 117 | +17x | +
+ addtl <- TRUE+ |
+
| 118 | ++ |
+ ## label_position(spl) <- "hidden"+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ | + + | +
| 121 | +554x | +
+ rlyt <- split_rows(rlyt, spl, pos)+ |
+
| 122 | +552x | +
+ rlayout(lyt) <- rlyt+ |
+
| 123 | +552x | +
+ if (addtl) {
+ |
+
| 124 | +17x | +
+ lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt)))+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | +552x | +
+ lyt+ |
+
| 127 | ++ |
+ }+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ #' @rdname int_methods+ |
+
| 131 | ++ |
+ setMethod(+ |
+
| 132 | ++ |
+ "split_rows", "ANY",+ |
+
| 133 | ++ |
+ function(lyt, spl, pos) {
+ |
+
| 134 | +! | +
+ stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ |
+ )+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ ## cmpnd_last_rowsplit =====+ |
+
| 139 | ++ | + + | +
| 140 | ++ |
+ #' @rdname int_methods+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' @param constructor (`function`)\cr constructor function.+ |
+
| 143 | +79x | +
+ setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))
+ |
+
| 144 | ++ | + + | +
| 145 | ++ |
+ #' @rdname int_methods+ |
+
| 146 | ++ |
+ setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
+ |
+
| 147 | ++ |
+ stop("no existing splits to compound with. contact the maintainer") # nocov
+ |
+
| 148 | ++ |
+ })+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ #' @rdname int_methods+ |
+
| 151 | ++ |
+ setMethod(+ |
+
| 152 | ++ |
+ "cmpnd_last_rowsplit", "PreDataRowLayout",+ |
+
| 153 | ++ |
+ function(lyt, spl, constructor) {
+ |
+
| 154 | +26x | +
+ pos <- length(lyt)+ |
+
| 155 | +26x | +
+ tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor)+ |
+
| 156 | +26x | +
+ lyt[[pos]] <- tmp+ |
+
| 157 | +26x | +
+ lyt+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ #' @rdname int_methods+ |
+
| 161 | ++ |
+ setMethod(+ |
+
| 162 | ++ |
+ "cmpnd_last_rowsplit", "SplitVector",+ |
+
| 163 | ++ |
+ function(lyt, spl, constructor) {
+ |
+
| 164 | +27x | +
+ pos <- length(lyt)+ |
+
| 165 | +27x | +
+ lst <- lyt[[pos]]+ |
+
| 166 | +27x | +
+ tmp <- if (is(lst, "CompoundSplit")) {
+ |
+
| 167 | +3x | +
+ spl_payload(lst) <- c(+ |
+
| 168 | +3x | +
+ .uncompound(spl_payload(lst)),+ |
+
| 169 | +3x | +
+ .uncompound(spl)+ |
+
| 170 | ++ |
+ )+ |
+
| 171 | +3x | +
+ obj_name(lst) <- make_ma_name(spl = lst)+ |
+
| 172 | +3x | +
+ lst+ |
+
| 173 | ++ |
+ ## XXX never reached because AnalzyeMultiVars inherits from+ |
+
| 174 | ++ |
+ ## CompoundSplit???+ |
+
| 175 | ++ |
+ } else {
+ |
+
| 176 | +24x | +
+ constructor(.payload = list(lst, spl))+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | +27x | +
+ lyt[[pos]] <- tmp+ |
+
| 179 | +27x | +
+ lyt+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ | + + | +
| 183 | ++ |
+ #' @rdname int_methods+ |
+
| 184 | ++ |
+ setMethod(+ |
+
| 185 | ++ |
+ "cmpnd_last_rowsplit", "PreDataTableLayouts",+ |
+
| 186 | ++ |
+ function(lyt, spl, constructor) {
+ |
+
| 187 | +26x | +
+ rlyt <- rlayout(lyt)+ |
+
| 188 | +26x | +
+ rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor)+ |
+
| 189 | +26x | +
+ rlayout(lyt) <- rlyt+ |
+
| 190 | +26x | +
+ lyt+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ #' @rdname int_methods+ |
+
| 194 | ++ |
+ setMethod(+ |
+
| 195 | ++ |
+ "cmpnd_last_rowsplit", "ANY",+ |
+
| 196 | ++ |
+ function(lyt, spl, constructor) {
+ |
+
| 197 | +! | +
+ stop(+ |
+
| 198 | +! | +
+ "nope. can't do cmpnd_last_rowsplit to that (",
+ |
+
| 199 | +! | +
+ class(lyt), "). contact the maintaner."+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ |
+ )+ |
+
| 203 | ++ | + + | +
| 204 | ++ |
+ ## split_cols ====+ |
+
| 205 | ++ | + + | +
| 206 | ++ |
+ #' @rdname int_methods+ |
+
| 207 | ++ |
+ setGeneric(+ |
+
| 208 | ++ |
+ "split_cols",+ |
+
| 209 | ++ |
+ function(lyt = NULL, spl, pos) {
+ |
+
| 210 | +1031x | +
+ standardGeneric("split_cols")
+ |
+
| 211 | ++ |
+ }+ |
+
| 212 | ++ |
+ )+ |
+
| 213 | ++ | + + | +
| 214 | ++ |
+ #' @rdname int_methods+ |
+
| 215 | ++ |
+ setMethod("split_cols", "NULL", function(lyt, spl, pos) {
+ |
+
| 216 | +1x | +
+ lifecycle::deprecate_warn(+ |
+
| 217 | +1x | +
+ when = "0.3.8",+ |
+
| 218 | +1x | +
+ what = I("split_cols(NULL)"),
+ |
+
| 219 | +1x | +
+ with = "basic_table()",+ |
+
| 220 | +1x | +
+ details = "Initializing layouts via `NULL` is no longer supported."+ |
+
| 221 | ++ |
+ )+ |
+
| 222 | +1x | +
+ cl <- PreDataColLayout(SplitVector(spl))+ |
+
| 223 | +1x | +
+ rl <- PreDataRowLayout()+ |
+
| 224 | +1x | +
+ PreDataTableLayouts(rlayout = rl, clayout = cl)+ |
+
| 225 | ++ |
+ })+ |
+
| 226 | ++ | + + | +
| 227 | ++ |
+ #' @rdname int_methods+ |
+
| 228 | ++ |
+ setMethod(+ |
+
| 229 | ++ |
+ "split_cols", "PreDataColLayout",+ |
+
| 230 | ++ |
+ function(lyt, spl, pos) {
+ |
+
| 231 | +311x | +
+ stopifnot(pos > 0 && pos <= length(lyt) + 1)+ |
+
| 232 | +311x | +
+ tmp <- if (pos <= length(lyt)) {
+ |
+
| 233 | +303x | +
+ split_cols(lyt[[pos]], spl, pos)+ |
+
| 234 | ++ |
+ } else {
+ |
+
| 235 | +8x | +
+ SplitVector(spl)+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | ++ | + + | +
| 238 | +311x | +
+ lyt[[pos]] <- tmp+ |
+
| 239 | +311x | +
+ lyt+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ |
+ )+ |
+
| 242 | ++ | + + | +
| 243 | ++ |
+ #' @rdname int_methods+ |
+
| 244 | ++ |
+ setMethod(+ |
+
| 245 | ++ |
+ "split_cols", "SplitVector",+ |
+
| 246 | ++ |
+ function(lyt, spl, pos) {
+ |
+
| 247 | +408x | +
+ tmp <- c(lyt, spl)+ |
+
| 248 | +408x | +
+ SplitVector(lst = tmp)+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ | + + | +
| 252 | ++ |
+ #' @rdname int_methods+ |
+
| 253 | ++ |
+ setMethod(+ |
+
| 254 | ++ |
+ "split_cols", "PreDataTableLayouts",+ |
+
| 255 | ++ |
+ function(lyt, spl, pos) {
+ |
+
| 256 | +311x | +
+ rlyt <- lyt@col_layout+ |
+
| 257 | +311x | +
+ rlyt <- split_cols(rlyt, spl, pos)+ |
+
| 258 | +311x | +
+ lyt@col_layout <- rlyt+ |
+
| 259 | +311x | +
+ lyt+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ |
+ )+ |
+
| 262 | ++ | + + | +
| 263 | ++ |
+ #' @rdname int_methods+ |
+
| 264 | ++ |
+ setMethod(+ |
+
| 265 | ++ |
+ "split_cols", "ANY",+ |
+
| 266 | ++ |
+ function(lyt, spl, pos) {
+ |
+
| 267 | +! | +
+ stop(+ |
+
| 268 | +! | +
+ "nope. can't add a col split to that (", class(lyt),
+ |
+
| 269 | +! | +
+ "). contact the maintaner."+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | ++ |
+ )+ |
+
| 273 | ++ | + + | +
| 274 | ++ |
+ # Constructors =====+ |
+
| 275 | ++ | + + | +
| 276 | ++ |
+ ## Pipe-able functions to add the various types of splits to the current layout+ |
+
| 277 | ++ |
+ ## for both row and column. These all act as wrappers to the split_cols and+ |
+
| 278 | ++ |
+ ## split_rows method stacks.+ |
+
| 279 | ++ | + + | +
| 280 | ++ |
+ #' Declaring a column-split based on levels of a variable+ |
+
| 281 | ++ |
+ #'+ |
+
| 282 | ++ |
+ #' Will generate children for each subset of a categorical variable.+ |
+
| 283 | ++ |
+ #'+ |
+
| 284 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 285 | ++ |
+ #' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference.+ |
+
| 286 | ++ |
+ #'+ |
+
| 287 | ++ |
+ #' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()].+ |
+
| 288 | ++ |
+ #'+ |
+
| 289 | ++ |
+ #' @inheritSection custom_split_funs Custom Splitting Function Details+ |
+
| 290 | ++ |
+ #'+ |
+
| 291 | ++ |
+ #' @examples+ |
+
| 292 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 293 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 294 | ++ |
+ #' analyze(c("AGE", "BMRKR2"))
+ |
+
| 295 | ++ |
+ #'+ |
+
| 296 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 297 | ++ |
+ #' tbl+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' # Let's look at the splits in more detail+ |
+
| 300 | ++ |
+ #'+ |
+
| 301 | ++ |
+ #' lyt1 <- basic_table() %>% split_cols_by("ARM")
+ |
+
| 302 | ++ |
+ #' lyt1+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' # add an analysis (summary)+ |
+
| 305 | ++ |
+ #' lyt2 <- lyt1 %>%+ |
+
| 306 | ++ |
+ #' analyze(c("AGE", "COUNTRY"),
+ |
+
| 307 | ++ |
+ #' afun = list_wrap_x(summary),+ |
+
| 308 | ++ |
+ #' format = "xx.xx"+ |
+
| 309 | ++ |
+ #' )+ |
+
| 310 | ++ |
+ #' lyt2+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' tbl2 <- build_table(lyt2, DM)+ |
+
| 313 | ++ |
+ #' tbl2+ |
+
| 314 | ++ |
+ #'+ |
+
| 315 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 316 | ++ |
+ #' # By default sequentially adding layouts results in nesting+ |
+
| 317 | ++ |
+ #' library(dplyr)+ |
+
| 318 | ++ |
+ #'+ |
+
| 319 | ++ |
+ #' DM_MF <- DM %>%+ |
+
| 320 | ++ |
+ #' filter(SEX %in% c("M", "F")) %>%
+ |
+
| 321 | ++ |
+ #' mutate(SEX = droplevels(SEX))+ |
+
| 322 | ++ |
+ #'+ |
+
| 323 | ++ |
+ #' lyt3 <- basic_table() %>%+ |
+
| 324 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 325 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 326 | ++ |
+ #' analyze(c("AGE", "COUNTRY"),
+ |
+
| 327 | ++ |
+ #' afun = list_wrap_x(summary),+ |
+
| 328 | ++ |
+ #' format = "xx.xx"+ |
+
| 329 | ++ |
+ #' )+ |
+
| 330 | ++ |
+ #' lyt3+ |
+
| 331 | ++ |
+ #'+ |
+
| 332 | ++ |
+ #' tbl3 <- build_table(lyt3, DM_MF)+ |
+
| 333 | ++ |
+ #' tbl3+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' # nested=TRUE vs not+ |
+
| 336 | ++ |
+ #' lyt4 <- basic_table() %>%+ |
+
| 337 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 338 | ++ |
+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ |
+
| 339 | ++ |
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ |
+
| 340 | ++ |
+ #' analyze("AGE")
+ |
+
| 341 | ++ |
+ #' lyt4+ |
+
| 342 | ++ |
+ #'+ |
+
| 343 | ++ |
+ #' tbl4 <- build_table(lyt4, DM)+ |
+
| 344 | ++ |
+ #' tbl4+ |
+
| 345 | ++ |
+ #'+ |
+
| 346 | ++ |
+ #' lyt5 <- basic_table() %>%+ |
+
| 347 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 348 | ++ |
+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ |
+
| 349 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 350 | ++ |
+ #' split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
+ |
+
| 351 | ++ |
+ #' analyze("AGE")
+ |
+
| 352 | ++ |
+ #' lyt5+ |
+
| 353 | ++ |
+ #'+ |
+
| 354 | ++ |
+ #' tbl5 <- build_table(lyt5, DM)+ |
+
| 355 | ++ |
+ #' tbl5+ |
+
| 356 | ++ |
+ #'+ |
+
| 357 | ++ |
+ #' @author Gabriel Becker+ |
+
| 358 | ++ |
+ #' @export+ |
+
| 359 | ++ |
+ split_cols_by <- function(lyt,+ |
+
| 360 | ++ |
+ var,+ |
+
| 361 | ++ |
+ labels_var = var,+ |
+
| 362 | ++ |
+ split_label = var,+ |
+
| 363 | ++ |
+ split_fun = NULL,+ |
+
| 364 | ++ |
+ format = NULL,+ |
+
| 365 | ++ |
+ nested = TRUE,+ |
+
| 366 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 367 | ++ |
+ extra_args = list(),+ |
+
| 368 | ++ |
+ ref_group = NULL,+ |
+
| 369 | ++ |
+ show_colcounts = FALSE,+ |
+
| 370 | ++ |
+ colcount_format = NULL) { ## ,
+ |
+
| 371 | +276x | +
+ if (is.null(ref_group)) {
+ |
+
| 372 | +267x | +
+ spl <- VarLevelSplit(+ |
+
| 373 | +267x | +
+ var = var,+ |
+
| 374 | +267x | +
+ split_label = split_label,+ |
+
| 375 | +267x | +
+ labels_var = labels_var,+ |
+
| 376 | +267x | +
+ split_format = format,+ |
+
| 377 | +267x | +
+ child_labels = child_labels,+ |
+
| 378 | +267x | +
+ split_fun = split_fun,+ |
+
| 379 | +267x | +
+ extra_args = extra_args,+ |
+
| 380 | +267x | +
+ show_colcounts = show_colcounts,+ |
+
| 381 | +267x | +
+ colcount_format = colcount_format+ |
+
| 382 | ++ |
+ )+ |
+
| 383 | ++ |
+ } else {
+ |
+
| 384 | +9x | +
+ spl <- VarLevWBaselineSplit(+ |
+
| 385 | +9x | +
+ var = var,+ |
+
| 386 | +9x | +
+ ref_group = ref_group,+ |
+
| 387 | +9x | +
+ split_label = split_label,+ |
+
| 388 | +9x | +
+ split_fun = split_fun,+ |
+
| 389 | +9x | +
+ labels_var = labels_var,+ |
+
| 390 | +9x | +
+ split_format = format,+ |
+
| 391 | +9x | +
+ show_colcounts = show_colcounts,+ |
+
| 392 | +9x | +
+ colcount_format = colcount_format+ |
+
| 393 | ++ |
+ )+ |
+
| 394 | ++ |
+ }+ |
+
| 395 | +276x | +
+ pos <- next_cpos(lyt, nested)+ |
+
| 396 | +276x | +
+ split_cols(lyt, spl, pos)+ |
+
| 397 | ++ |
+ }+ |
+
| 398 | ++ | + + | +
| 399 | ++ |
+ ## .tl_indent ====+ |
+
| 400 | ++ | + + | +
| 401 | +51x | +
+ setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))
+ |
+
| 402 | ++ | + + | +
| 403 | ++ |
+ setMethod(+ |
+
| 404 | ++ |
+ ".tl_indent_inner", "PreDataTableLayouts",+ |
+
| 405 | +17x | +
+ function(lyt) .tl_indent_inner(rlayout(lyt))+ |
+
| 406 | ++ |
+ )+ |
+
| 407 | ++ |
+ setMethod(+ |
+
| 408 | ++ |
+ ".tl_indent_inner", "PreDataRowLayout",+ |
+
| 409 | ++ |
+ function(lyt) {
+ |
+
| 410 | +17x | +
+ if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
+ |
+
| 411 | +! | +
+ 0L+ |
+
| 412 | ++ |
+ } else {
+ |
+
| 413 | +17x | +
+ .tl_indent_inner(lyt[[length(lyt)]])+ |
+
| 414 | ++ |
+ }+ |
+
| 415 | ++ |
+ }+ |
+
| 416 | ++ |
+ )+ |
+
| 417 | ++ | + + | +
| 418 | ++ |
+ setMethod(+ |
+
| 419 | ++ |
+ ".tl_indent_inner", "SplitVector",+ |
+
| 420 | ++ |
+ function(lyt) {
+ |
+
| 421 | +17x | +
+ sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L+ |
+
| 422 | ++ |
+ }+ |
+
| 423 | ++ |
+ ) ## length(lyt) - 1L)+ |
+
| 424 | ++ | + + | +
| 425 | ++ |
+ .tl_indent <- function(lyt, nested = TRUE) {
+ |
+
| 426 | +17x | +
+ if (!nested) {
+ |
+
| 427 | +! | +
+ 0L+ |
+
| 428 | ++ |
+ } else {
+ |
+
| 429 | +17x | +
+ .tl_indent_inner(lyt)+ |
+
| 430 | ++ |
+ }+ |
+
| 431 | ++ |
+ }+ |
+
| 432 | ++ | + + | +
| 433 | ++ |
+ #' Add rows according to levels of a variable+ |
+
| 434 | ++ |
+ #'+ |
+
| 435 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 436 | ++ |
+ #'+ |
+
| 437 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 438 | ++ |
+ #'+ |
+
| 439 | ++ |
+ #' @inheritSection custom_split_funs Custom Splitting Function Details+ |
+
| 440 | ++ |
+ #'+ |
+
| 441 | ++ |
+ #' @note+ |
+
| 442 | ++ |
+ #' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor+ |
+
| 443 | ++ |
+ #' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very+ |
+
| 444 | ++ |
+ #' informative, but that will change in the future.+ |
+
| 445 | ++ |
+ #'+ |
+
| 446 | ++ |
+ #' @examples+ |
+
| 447 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 448 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 449 | ++ |
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ |
+
| 450 | ++ |
+ #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
+ |
+
| 451 | ++ |
+ #'+ |
+
| 452 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 453 | ++ |
+ #' tbl+ |
+
| 454 | ++ |
+ #'+ |
+
| 455 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 456 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 457 | ++ |
+ #' split_rows_by("RACE") %>%
+ |
+
| 458 | ++ |
+ #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
+ |
+
| 459 | ++ |
+ #'+ |
+
| 460 | ++ |
+ #' tbl2 <- build_table(lyt2, DM)+ |
+
| 461 | ++ |
+ #' tbl2+ |
+
| 462 | ++ |
+ #'+ |
+
| 463 | ++ |
+ #' lyt3 <- basic_table() %>%+ |
+
| 464 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 465 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 466 | ++ |
+ #' summarize_row_groups(label_fstr = "Overall (N)") %>%+ |
+
| 467 | ++ |
+ #' split_rows_by("RACE",
+ |
+
| 468 | ++ |
+ #' split_label = "Ethnicity", labels_var = "ethn_lab",+ |
+
| 469 | ++ |
+ #' split_fun = drop_split_levels+ |
+
| 470 | ++ |
+ #' ) %>%+ |
+
| 471 | ++ |
+ #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
+ |
+
| 472 | ++ |
+ #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
+ |
+
| 473 | ++ |
+ #'+ |
+
| 474 | ++ |
+ #' lyt3+ |
+
| 475 | ++ |
+ #'+ |
+
| 476 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 477 | ++ |
+ #' library(dplyr)+ |
+
| 478 | ++ |
+ #'+ |
+
| 479 | ++ |
+ #' DM2 <- DM %>%+ |
+
| 480 | ++ |
+ #' filter(SEX %in% c("M", "F")) %>%
+ |
+
| 481 | ++ |
+ #' mutate(+ |
+
| 482 | ++ |
+ #' SEX = droplevels(SEX),+ |
+
| 483 | ++ |
+ #' gender_lab = c(+ |
+
| 484 | ++ |
+ #' "F" = "Female", "M" = "Male",+ |
+
| 485 | ++ |
+ #' "U" = "Unknown",+ |
+
| 486 | ++ |
+ #' "UNDIFFERENTIATED" = "Undifferentiated"+ |
+
| 487 | ++ |
+ #' )[SEX],+ |
+
| 488 | ++ |
+ #' ethn_lab = c(+ |
+
| 489 | ++ |
+ #' "ASIAN" = "Asian",+ |
+
| 490 | ++ |
+ #' "BLACK OR AFRICAN AMERICAN" = "Black or African American",+ |
+
| 491 | ++ |
+ #' "WHITE" = "White",+ |
+
| 492 | ++ |
+ #' "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native",+ |
+
| 493 | ++ |
+ #' "MULTIPLE" = "Multiple",+ |
+
| 494 | ++ |
+ #' "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" =+ |
+
| 495 | ++ |
+ #' "Native Hawaiian or Other Pacific Islander",+ |
+
| 496 | ++ |
+ #' "OTHER" = "Other", "UNKNOWN" = "Unknown"+ |
+
| 497 | ++ |
+ #' )[RACE]+ |
+
| 498 | ++ |
+ #' )+ |
+
| 499 | ++ |
+ #'+ |
+
| 500 | ++ |
+ #' tbl3 <- build_table(lyt3, DM2)+ |
+
| 501 | ++ |
+ #' tbl3+ |
+
| 502 | ++ |
+ #'+ |
+
| 503 | ++ |
+ #' @author Gabriel Becker+ |
+
| 504 | ++ |
+ #' @export+ |
+
| 505 | ++ |
+ split_rows_by <- function(lyt,+ |
+
| 506 | ++ |
+ var,+ |
+
| 507 | ++ |
+ labels_var = var,+ |
+
| 508 | ++ |
+ split_label = var,+ |
+
| 509 | ++ |
+ split_fun = NULL,+ |
+
| 510 | ++ |
+ format = NULL,+ |
+
| 511 | ++ |
+ na_str = NA_character_,+ |
+
| 512 | ++ |
+ nested = TRUE,+ |
+
| 513 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 514 | ++ |
+ label_pos = "hidden",+ |
+
| 515 | ++ |
+ indent_mod = 0L,+ |
+
| 516 | ++ |
+ page_by = FALSE,+ |
+
| 517 | ++ |
+ page_prefix = split_label,+ |
+
| 518 | ++ |
+ section_div = NA_character_) {
+ |
+
| 519 | +249x | +
+ label_pos <- match.arg(label_pos, label_pos_values)+ |
+
| 520 | +249x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 521 | +249x | +
+ spl <- VarLevelSplit(+ |
+
| 522 | +249x | +
+ var = var,+ |
+
| 523 | +249x | +
+ split_label = split_label,+ |
+
| 524 | +249x | +
+ label_pos = label_pos,+ |
+
| 525 | +249x | +
+ labels_var = labels_var,+ |
+
| 526 | +249x | +
+ split_fun = split_fun,+ |
+
| 527 | +249x | +
+ split_format = format,+ |
+
| 528 | +249x | +
+ split_na_str = na_str,+ |
+
| 529 | +249x | +
+ child_labels = child_labels,+ |
+
| 530 | +249x | +
+ indent_mod = indent_mod,+ |
+
| 531 | +249x | +
+ page_prefix = if (page_by) page_prefix else NA_character_,+ |
+
| 532 | +249x | +
+ section_div = section_div+ |
+
| 533 | ++ |
+ )+ |
+
| 534 | ++ | + + | +
| 535 | +249x | +
+ pos <- next_rpos(lyt, nested)+ |
+
| 536 | +249x | +
+ ret <- split_rows(lyt, spl, pos)+ |
+
| 537 | ++ | + + | +
| 538 | +247x | +
+ ret+ |
+
| 539 | ++ |
+ }+ |
+
| 540 | ++ | + + | +
| 541 | ++ |
+ #' Associate multiple variables with columns+ |
+
| 542 | ++ |
+ #'+ |
+
| 543 | ++ |
+ #' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis.+ |
+
| 544 | ++ |
+ #' When we need columns to reflect different variables entirely, rather than different levels of a single+ |
+
| 545 | ++ |
+ #' variable, we use `split_cols_by_multivar`.+ |
+
| 546 | ++ |
+ #'+ |
+
| 547 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 548 | ++ |
+ #'+ |
+
| 549 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 550 | ++ |
+ #'+ |
+
| 551 | ++ |
+ #' @seealso [analyze_colvars()]+ |
+
| 552 | ++ |
+ #'+ |
+
| 553 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 554 | ++ |
+ #' library(dplyr)+ |
+
| 555 | ++ |
+ #'+ |
+
| 556 | ++ |
+ #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))+ |
+
| 557 | ++ |
+ #'+ |
+
| 558 | ++ |
+ #' ## toy example where we take the mean of the first variable and the+ |
+
| 559 | ++ |
+ #' ## count of >.5 for the second.+ |
+
| 560 | ++ |
+ #' colfuns <- list(+ |
+
| 561 | ++ |
+ #' function(x) in_rows(mean = mean(x), .formats = "xx.x"),+ |
+
| 562 | ++ |
+ #' function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
+ |
+
| 563 | ++ |
+ #' )+ |
+
| 564 | ++ |
+ #'+ |
+
| 565 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 566 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 567 | ++ |
+ #' split_cols_by_multivar(c("value", "pctdiff")) %>%
+ |
+
| 568 | ++ |
+ #' split_rows_by("RACE",
+ |
+
| 569 | ++ |
+ #' split_label = "ethnicity",+ |
+
| 570 | ++ |
+ #' split_fun = drop_split_levels+ |
+
| 571 | ++ |
+ #' ) %>%+ |
+
| 572 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 573 | ++ |
+ #' analyze_colvars(afun = colfuns)+ |
+
| 574 | ++ |
+ #' lyt+ |
+
| 575 | ++ |
+ #'+ |
+
| 576 | ++ |
+ #' tbl <- build_table(lyt, ANL)+ |
+
| 577 | ++ |
+ #' tbl+ |
+
| 578 | ++ |
+ #'+ |
+
| 579 | ++ |
+ #' @author Gabriel Becker+ |
+
| 580 | ++ |
+ #' @export+ |
+
| 581 | ++ |
+ split_cols_by_multivar <- function(lyt,+ |
+
| 582 | ++ |
+ vars,+ |
+
| 583 | ++ |
+ split_fun = NULL,+ |
+
| 584 | ++ |
+ varlabels = vars,+ |
+
| 585 | ++ |
+ varnames = NULL,+ |
+
| 586 | ++ |
+ nested = TRUE,+ |
+
| 587 | ++ |
+ extra_args = list(),+ |
+
| 588 | ++ |
+ ## for completeness even though it doesn't make sense+ |
+
| 589 | ++ |
+ show_colcounts = FALSE,+ |
+
| 590 | ++ |
+ colcount_format = NULL) {
+ |
+
| 591 | +24x | +
+ spl <- MultiVarSplit(+ |
+
| 592 | +24x | +
+ vars = vars, split_label = "",+ |
+
| 593 | +24x | +
+ varlabels = varlabels,+ |
+
| 594 | +24x | +
+ varnames = varnames,+ |
+
| 595 | +24x | +
+ split_fun = split_fun,+ |
+
| 596 | +24x | +
+ extra_args = extra_args,+ |
+
| 597 | +24x | +
+ show_colcounts = show_colcounts,+ |
+
| 598 | +24x | +
+ colcount_format = colcount_format+ |
+
| 599 | ++ |
+ )+ |
+
| 600 | +24x | +
+ pos <- next_cpos(lyt, nested)+ |
+
| 601 | +24x | +
+ split_cols(lyt, spl, pos)+ |
+
| 602 | ++ |
+ }+ |
+
| 603 | ++ | + + | +
| 604 | ++ |
+ #' Associate multiple variables with rows+ |
+
| 605 | ++ |
+ #'+ |
+
| 606 | ++ |
+ #' When we need rows to reflect different variables rather than different+ |
+
| 607 | ++ |
+ #' levels of a single variable, we use `split_rows_by_multivar`.+ |
+
| 608 | ++ |
+ #'+ |
+
| 609 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 610 | ++ |
+ #'+ |
+
| 611 | ++ |
+ #' @inherit split_rows_by return+ |
+
| 612 | ++ |
+ #'+ |
+
| 613 | ++ |
+ #' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of+ |
+
| 614 | ++ |
+ #' split on a column basis.+ |
+
| 615 | ++ |
+ #'+ |
+
| 616 | ++ |
+ #' @examples+ |
+
| 617 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 618 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 619 | ++ |
+ #' split_rows_by_multivar(c("SEX", "STRATA1")) %>%
+ |
+
| 620 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 621 | ++ |
+ #' analyze(c("AGE", "SEX"))
+ |
+
| 622 | ++ |
+ #'+ |
+
| 623 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 624 | ++ |
+ #' tbl+ |
+
| 625 | ++ |
+ #'+ |
+
| 626 | ++ |
+ #' @export+ |
+
| 627 | ++ |
+ split_rows_by_multivar <- function(lyt,+ |
+
| 628 | ++ |
+ vars,+ |
+
| 629 | ++ |
+ split_fun = NULL,+ |
+
| 630 | ++ |
+ split_label = "",+ |
+
| 631 | ++ |
+ varlabels = vars,+ |
+
| 632 | ++ |
+ format = NULL,+ |
+
| 633 | ++ |
+ na_str = NA_character_,+ |
+
| 634 | ++ |
+ nested = TRUE,+ |
+
| 635 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 636 | ++ |
+ indent_mod = 0L,+ |
+
| 637 | ++ |
+ section_div = NA_character_,+ |
+
| 638 | ++ |
+ extra_args = list()) {
+ |
+
| 639 | +3x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 640 | +3x | +
+ spl <- MultiVarSplit(+ |
+
| 641 | +3x | +
+ vars = vars, split_label = split_label, varlabels,+ |
+
| 642 | +3x | +
+ split_format = format,+ |
+
| 643 | +3x | +
+ split_na_str = na_str,+ |
+
| 644 | +3x | +
+ child_labels = child_labels,+ |
+
| 645 | +3x | +
+ indent_mod = indent_mod,+ |
+
| 646 | +3x | +
+ split_fun = split_fun,+ |
+
| 647 | +3x | +
+ section_div = section_div,+ |
+
| 648 | +3x | +
+ extra_args = extra_args+ |
+
| 649 | ++ |
+ )+ |
+
| 650 | +3x | +
+ pos <- next_rpos(lyt, nested)+ |
+
| 651 | +3x | +
+ split_rows(lyt, spl, pos)+ |
+
| 652 | ++ |
+ }+ |
+
| 653 | ++ | + + | +
| 654 | ++ |
+ #' Split on static or dynamic cuts of the data+ |
+
| 655 | ++ |
+ #'+ |
+
| 656 | ++ |
+ #' Create columns (or row splits) based on values (such as quartiles) of `var`.+ |
+
| 657 | ++ |
+ #'+ |
+
| 658 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 659 | ++ |
+ #'+ |
+
| 660 | ++ |
+ #' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*,+ |
+
| 661 | ++ |
+ #' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect+ |
+
| 662 | ++ |
+ #' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under.+ |
+
| 663 | ++ |
+ #'+ |
+
| 664 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 665 | ++ |
+ #'+ |
+
| 666 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 667 | ++ |
+ #' library(dplyr)+ |
+
| 668 | ++ |
+ #'+ |
+
| 669 | ++ |
+ #' # split_cols_by_cuts+ |
+
| 670 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 671 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 672 | ++ |
+ #' split_cols_by_cuts("AGE",
+ |
+
| 673 | ++ |
+ #' split_label = "Age",+ |
+
| 674 | ++ |
+ #' cuts = c(0, 25, 35, 1000),+ |
+
| 675 | ++ |
+ #' cutlabels = c("young", "medium", "old")
+ |
+
| 676 | ++ |
+ #' ) %>%+ |
+
| 677 | ++ |
+ #' analyze(c("BMRKR2", "STRATA2")) %>%
+ |
+
| 678 | ++ |
+ #' append_topleft("counts")
+ |
+
| 679 | ++ |
+ #'+ |
+
| 680 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 681 | ++ |
+ #' tbl+ |
+
| 682 | ++ |
+ #'+ |
+
| 683 | ++ |
+ #' # split_rows_by_cuts+ |
+
| 684 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 685 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 686 | ++ |
+ #' split_rows_by_cuts("AGE",
+ |
+
| 687 | ++ |
+ #' split_label = "Age",+ |
+
| 688 | ++ |
+ #' cuts = c(0, 25, 35, 1000),+ |
+
| 689 | ++ |
+ #' cutlabels = c("young", "medium", "old")
+ |
+
| 690 | ++ |
+ #' ) %>%+ |
+
| 691 | ++ |
+ #' analyze(c("BMRKR2", "STRATA2")) %>%
+ |
+
| 692 | ++ |
+ #' append_topleft("counts")
+ |
+
| 693 | ++ |
+ #'+ |
+
| 694 | ++ |
+ #'+ |
+
| 695 | ++ |
+ #' tbl2 <- build_table(lyt2, ex_adsl)+ |
+
| 696 | ++ |
+ #' tbl2+ |
+
| 697 | ++ |
+ #'+ |
+
| 698 | ++ |
+ #' # split_cols_by_quartiles+ |
+
| 699 | ++ |
+ #'+ |
+
| 700 | ++ |
+ #' lyt3 <- basic_table() %>%+ |
+
| 701 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 702 | ++ |
+ #' split_cols_by_quartiles("AGE", split_label = "Age") %>%
+ |
+
| 703 | ++ |
+ #' analyze(c("BMRKR2", "STRATA2")) %>%
+ |
+
| 704 | ++ |
+ #' append_topleft("counts")
+ |
+
| 705 | ++ |
+ #'+ |
+
| 706 | ++ |
+ #' tbl3 <- build_table(lyt3, ex_adsl)+ |
+
| 707 | ++ |
+ #' tbl3+ |
+
| 708 | ++ |
+ #'+ |
+
| 709 | ++ |
+ #' # split_rows_by_quartiles+ |
+
| 710 | ++ |
+ #' lyt4 <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 711 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 712 | ++ |
+ #' split_rows_by_quartiles("AGE", split_label = "Age") %>%
+ |
+
| 713 | ++ |
+ #' analyze("BMRKR2") %>%
+ |
+
| 714 | ++ |
+ #' append_topleft(c("Age Quartiles", " Counts BMRKR2"))
+ |
+
| 715 | ++ |
+ #'+ |
+
| 716 | ++ |
+ #' tbl4 <- build_table(lyt4, ex_adsl)+ |
+
| 717 | ++ |
+ #' tbl4+ |
+
| 718 | ++ |
+ #'+ |
+
| 719 | ++ |
+ #' # split_cols_by_cutfun+ |
+
| 720 | ++ |
+ #' cutfun <- function(x) {
+ |
+
| 721 | ++ |
+ #' cutpoints <- c(+ |
+
| 722 | ++ |
+ #' min(x),+ |
+
| 723 | ++ |
+ #' mean(x),+ |
+
| 724 | ++ |
+ #' max(x)+ |
+
| 725 | ++ |
+ #' )+ |
+
| 726 | ++ |
+ #'+ |
+
| 727 | ++ |
+ #' names(cutpoints) <- c("", "Younger", "Older")
+ |
+
| 728 | ++ |
+ #' cutpoints+ |
+
| 729 | ++ |
+ #' }+ |
+
| 730 | ++ |
+ #'+ |
+
| 731 | ++ |
+ #' lyt5 <- basic_table() %>%+ |
+
| 732 | ++ |
+ #' split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
+ |
+
| 733 | ++ |
+ #' analyze("SEX")
+ |
+
| 734 | ++ |
+ #'+ |
+
| 735 | ++ |
+ #' tbl5 <- build_table(lyt5, ex_adsl)+ |
+
| 736 | ++ |
+ #' tbl5+ |
+
| 737 | ++ |
+ #'+ |
+
| 738 | ++ |
+ #' # split_rows_by_cutfun+ |
+
| 739 | ++ |
+ #' lyt6 <- basic_table() %>%+ |
+
| 740 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 741 | ++ |
+ #' split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
+ |
+
| 742 | ++ |
+ #' analyze("BMRKR2")
+ |
+
| 743 | ++ |
+ #'+ |
+
| 744 | ++ |
+ #' tbl6 <- build_table(lyt6, ex_adsl)+ |
+
| 745 | ++ |
+ #' tbl6+ |
+
| 746 | ++ |
+ #'+ |
+
| 747 | ++ |
+ #' @author Gabriel Becker+ |
+
| 748 | ++ |
+ #' @export+ |
+
| 749 | ++ |
+ #' @rdname varcuts+ |
+
| 750 | ++ |
+ split_cols_by_cuts <- function(lyt, var, cuts,+ |
+
| 751 | ++ |
+ cutlabels = NULL,+ |
+
| 752 | ++ |
+ split_label = var,+ |
+
| 753 | ++ |
+ nested = TRUE,+ |
+
| 754 | ++ |
+ cumulative = FALSE,+ |
+
| 755 | ++ |
+ show_colcounts = FALSE,+ |
+
| 756 | ++ |
+ colcount_format = NULL) {
+ |
+
| 757 | +3x | +
+ spl <- make_static_cut_split(+ |
+
| 758 | +3x | +
+ var = var,+ |
+
| 759 | +3x | +
+ split_label = split_label,+ |
+
| 760 | +3x | +
+ cuts = cuts,+ |
+
| 761 | +3x | +
+ cutlabels = cutlabels,+ |
+
| 762 | +3x | +
+ cumulative = cumulative,+ |
+
| 763 | +3x | +
+ show_colcounts = show_colcounts,+ |
+
| 764 | +3x | +
+ colcount_format = colcount_format+ |
+
| 765 | ++ |
+ )+ |
+
| 766 | ++ |
+ ## if(cumulative)+ |
+
| 767 | ++ |
+ ## spl = as(spl, "CumulativeCutSplit")+ |
+
| 768 | +3x | +
+ pos <- next_cpos(lyt, nested)+ |
+
| 769 | +3x | +
+ split_cols(lyt, spl, pos)+ |
+
| 770 | ++ |
+ }+ |
+
| 771 | ++ | + + | +
| 772 | ++ |
+ #' @export+ |
+
| 773 | ++ |
+ #' @rdname varcuts+ |
+
| 774 | ++ |
+ split_rows_by_cuts <- function(lyt, var, cuts,+ |
+
| 775 | ++ |
+ cutlabels = NULL,+ |
+
| 776 | ++ |
+ split_label = var,+ |
+
| 777 | ++ |
+ format = NULL,+ |
+
| 778 | ++ |
+ na_str = NA_character_,+ |
+
| 779 | ++ |
+ nested = TRUE,+ |
+
| 780 | ++ |
+ cumulative = FALSE,+ |
+
| 781 | ++ |
+ label_pos = "hidden",+ |
+
| 782 | ++ |
+ section_div = NA_character_) {
+ |
+
| 783 | +2x | +
+ label_pos <- match.arg(label_pos, label_pos_values)+ |
+
| 784 | ++ |
+ ## VarStaticCutSplit(+ |
+
| 785 | +2x | +
+ spl <- make_static_cut_split(var, split_label,+ |
+
| 786 | +2x | +
+ cuts = cuts,+ |
+
| 787 | +2x | +
+ cutlabels = cutlabels,+ |
+
| 788 | +2x | +
+ split_format = format,+ |
+
| 789 | +2x | +
+ split_na_str = na_str,+ |
+
| 790 | +2x | +
+ label_pos = label_pos,+ |
+
| 791 | +2x | +
+ cumulative = cumulative,+ |
+
| 792 | +2x | +
+ section_div = section_div+ |
+
| 793 | ++ |
+ )+ |
+
| 794 | ++ |
+ ## if(cumulative)+ |
+
| 795 | ++ |
+ ## spl = as(spl, "CumulativeCutSplit")+ |
+
| 796 | +2x | +
+ pos <- next_rpos(lyt, nested)+ |
+
| 797 | +2x | +
+ split_rows(lyt, spl, pos)+ |
+
| 798 | ++ |
+ }+ |
+
| 799 | ++ | + + | +
| 800 | ++ |
+ #' @export+ |
+
| 801 | ++ |
+ #' @rdname varcuts+ |
+
| 802 | ++ |
+ split_cols_by_cutfun <- function(lyt, var,+ |
+
| 803 | ++ |
+ cutfun = qtile_cuts,+ |
+
| 804 | ++ |
+ cutlabelfun = function(x) NULL,+ |
+
| 805 | ++ |
+ split_label = var,+ |
+
| 806 | ++ |
+ nested = TRUE,+ |
+
| 807 | ++ |
+ extra_args = list(),+ |
+
| 808 | ++ |
+ cumulative = FALSE,+ |
+
| 809 | ++ |
+ show_colcounts = FALSE,+ |
+
| 810 | ++ |
+ colcount_format = NULL) {
+ |
+
| 811 | +3x | +
+ spl <- VarDynCutSplit(var, split_label,+ |
+
| 812 | +3x | +
+ cutfun = cutfun,+ |
+
| 813 | +3x | +
+ cutlabelfun = cutlabelfun,+ |
+
| 814 | +3x | +
+ extra_args = extra_args,+ |
+
| 815 | +3x | +
+ cumulative = cumulative,+ |
+
| 816 | +3x | +
+ label_pos = "hidden",+ |
+
| 817 | +3x | +
+ show_colcounts = show_colcounts,+ |
+
| 818 | +3x | +
+ colcount_format = colcount_format+ |
+
| 819 | ++ |
+ )+ |
+
| 820 | +3x | +
+ pos <- next_cpos(lyt, nested)+ |
+
| 821 | +3x | +
+ split_cols(lyt, spl, pos)+ |
+
| 822 | ++ |
+ }+ |
+
| 823 | ++ | + + | +
| 824 | ++ |
+ #' @export+ |
+
| 825 | ++ |
+ #' @rdname varcuts+ |
+
| 826 | ++ |
+ split_cols_by_quartiles <- function(lyt, var, split_label = var,+ |
+
| 827 | ++ |
+ nested = TRUE,+ |
+
| 828 | ++ |
+ extra_args = list(),+ |
+
| 829 | ++ |
+ cumulative = FALSE,+ |
+
| 830 | ++ |
+ show_colcounts = FALSE,+ |
+
| 831 | ++ |
+ colcount_format = NULL) {
+ |
+
| 832 | +2x | +
+ split_cols_by_cutfun(+ |
+
| 833 | +2x | +
+ lyt = lyt,+ |
+
| 834 | +2x | +
+ var = var,+ |
+
| 835 | +2x | +
+ split_label = split_label,+ |
+
| 836 | +2x | +
+ cutfun = qtile_cuts,+ |
+
| 837 | +2x | +
+ cutlabelfun = function(x) {
+ |
+
| 838 | +2x | +
+ c(+ |
+
| 839 | +2x | +
+ "[min, Q1]",+ |
+
| 840 | +2x | +
+ "(Q1, Q2]",+ |
+
| 841 | +2x | +
+ "(Q2, Q3]",+ |
+
| 842 | +2x | +
+ "(Q3, max]"+ |
+
| 843 | ++ |
+ )+ |
+
| 844 | ++ |
+ },+ |
+
| 845 | +2x | +
+ nested = nested,+ |
+
| 846 | +2x | +
+ extra_args = extra_args,+ |
+
| 847 | +2x | +
+ cumulative = cumulative,+ |
+
| 848 | +2x | +
+ show_colcounts = show_colcounts,+ |
+
| 849 | +2x | +
+ colcount_format = colcount_format+ |
+
| 850 | ++ |
+ )+ |
+
| 851 | ++ |
+ ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,+ |
+
| 852 | ++ |
+ ## cutlabelfun = function(x) c("[min, Q1]",
+ |
+
| 853 | ++ |
+ ## "(Q1, Q2]",+ |
+
| 854 | ++ |
+ ## "(Q2, Q3]",+ |
+
| 855 | ++ |
+ ## "(Q3, max]"),+ |
+
| 856 | ++ |
+ ## split_format = format,+ |
+
| 857 | ++ |
+ ## extra_args = extra_args,+ |
+
| 858 | ++ |
+ ## cumulative = cumulative,+ |
+
| 859 | ++ |
+ ## label_pos = "hidden")+ |
+
| 860 | ++ |
+ ## pos = next_cpos(lyt, nested)+ |
+
| 861 | ++ |
+ ## split_cols(lyt, spl, pos)+ |
+
| 862 | ++ |
+ }+ |
+
| 863 | ++ | + + | +
| 864 | ++ |
+ #' @export+ |
+
| 865 | ++ |
+ #' @rdname varcuts+ |
+
| 866 | ++ |
+ split_rows_by_quartiles <- function(lyt, var, split_label = var,+ |
+
| 867 | ++ |
+ format = NULL,+ |
+
| 868 | ++ |
+ na_str = NA_character_,+ |
+
| 869 | ++ |
+ nested = TRUE,+ |
+
| 870 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 871 | ++ |
+ extra_args = list(),+ |
+
| 872 | ++ |
+ cumulative = FALSE,+ |
+
| 873 | ++ |
+ indent_mod = 0L,+ |
+
| 874 | ++ |
+ label_pos = "hidden",+ |
+
| 875 | ++ |
+ section_div = NA_character_) {
+ |
+
| 876 | +2x | +
+ split_rows_by_cutfun(+ |
+
| 877 | +2x | +
+ lyt = lyt,+ |
+
| 878 | +2x | +
+ var = var,+ |
+
| 879 | +2x | +
+ split_label = split_label,+ |
+
| 880 | +2x | +
+ format = format,+ |
+
| 881 | +2x | +
+ na_str = na_str,+ |
+
| 882 | +2x | +
+ cutfun = qtile_cuts,+ |
+
| 883 | +2x | +
+ cutlabelfun = function(x) {
+ |
+
| 884 | +2x | +
+ c(+ |
+
| 885 | +2x | +
+ "[min, Q1]",+ |
+
| 886 | +2x | +
+ "(Q1, Q2]",+ |
+
| 887 | +2x | +
+ "(Q2, Q3]",+ |
+
| 888 | +2x | +
+ "(Q3, max]"+ |
+
| 889 | ++ |
+ )+ |
+
| 890 | ++ |
+ },+ |
+
| 891 | +2x | +
+ nested = nested,+ |
+
| 892 | +2x | +
+ child_labels = child_labels,+ |
+
| 893 | +2x | +
+ extra_args = extra_args,+ |
+
| 894 | +2x | +
+ cumulative = cumulative,+ |
+
| 895 | +2x | +
+ indent_mod = indent_mod,+ |
+
| 896 | +2x | +
+ label_pos = label_pos,+ |
+
| 897 | +2x | +
+ section_div = section_div+ |
+
| 898 | ++ |
+ )+ |
+
| 899 | ++ | + + | +
| 900 | ++ |
+ ## label_pos <- match.arg(label_pos, label_pos_values)+ |
+
| 901 | ++ |
+ ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,+ |
+
| 902 | ++ |
+ ## cutlabelfun = ,+ |
+
| 903 | ++ |
+ ## split_format = format,+ |
+
| 904 | ++ |
+ ## child_labels = child_labels,+ |
+
| 905 | ++ |
+ ## extra_args = extra_args,+ |
+
| 906 | ++ |
+ ## cumulative = cumulative,+ |
+
| 907 | ++ |
+ ## indent_mod = indent_mod,+ |
+
| 908 | ++ |
+ ## label_pos = label_pos)+ |
+
| 909 | ++ |
+ ## pos = next_rpos(lyt, nested)+ |
+
| 910 | ++ |
+ ## split_rows(lyt, spl, pos)+ |
+
| 911 | ++ |
+ }+ |
+
| 912 | ++ | + + | +
| 913 | ++ |
+ qtile_cuts <- function(x) {
+ |
+
| 914 | +6x | +
+ ret <- quantile(x)+ |
+
| 915 | +6x | +
+ names(ret) <- c(+ |
+
| 916 | ++ |
+ "",+ |
+
| 917 | +6x | +
+ "1st qrtile",+ |
+
| 918 | +6x | +
+ "2nd qrtile",+ |
+
| 919 | +6x | +
+ "3rd qrtile",+ |
+
| 920 | +6x | +
+ "4th qrtile"+ |
+
| 921 | ++ |
+ )+ |
+
| 922 | +6x | +
+ ret+ |
+
| 923 | ++ |
+ }+ |
+
| 924 | ++ | + + | +
| 925 | ++ |
+ #' @export+ |
+
| 926 | ++ |
+ #' @rdname varcuts+ |
+
| 927 | ++ |
+ split_rows_by_cutfun <- function(lyt, var,+ |
+
| 928 | ++ |
+ cutfun = qtile_cuts,+ |
+
| 929 | ++ |
+ cutlabelfun = function(x) NULL,+ |
+
| 930 | ++ |
+ split_label = var,+ |
+
| 931 | ++ |
+ format = NULL,+ |
+
| 932 | ++ |
+ na_str = NA_character_,+ |
+
| 933 | ++ |
+ nested = TRUE,+ |
+
| 934 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 935 | ++ |
+ extra_args = list(),+ |
+
| 936 | ++ |
+ cumulative = FALSE,+ |
+
| 937 | ++ |
+ indent_mod = 0L,+ |
+
| 938 | ++ |
+ label_pos = "hidden",+ |
+
| 939 | ++ |
+ 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 | +
+ split_na_str = na_str,+ |
+
| 947 | +2x | +
+ child_labels = child_labels,+ |
+
| 948 | +2x | +
+ extra_args = extra_args,+ |
+
| 949 | +2x | +
+ cumulative = cumulative,+ |
+
| 950 | +2x | +
+ indent_mod = indent_mod,+ |
+
| 951 | +2x | +
+ label_pos = label_pos,+ |
+
| 952 | +2x | +
+ section_div = section_div+ |
+
| 953 | ++ |
+ )+ |
+
| 954 | +2x | +
+ pos <- next_rpos(lyt, nested)+ |
+
| 955 | +2x | +
+ split_rows(lyt, spl, pos)+ |
+
| 956 | ++ |
+ }+ |
+
| 957 | ++ | + + | +
| 958 | ++ |
+ #' .spl_context within analysis and split functions+ |
+
| 959 | ++ |
+ #'+ |
+
| 960 | ++ |
+ #' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function+ |
+
| 961 | ++ |
+ #' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for+ |
+
| 962 | ++ |
+ #' [split_rows_by()]).+ |
+
| 963 | ++ |
+ #'+ |
+
| 964 | ++ |
+ #' @details+ |
+
| 965 | ++ |
+ #' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within+ |
+
| 966 | ++ |
+ #' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set+ |
+
| 967 | ++ |
+ #' of) rows the analysis function is creating, although the information is in a slightly different form. Each split+ |
+
| 968 | ++ |
+ #' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented+ |
+
| 969 | ++ |
+ #' via the following columns:+ |
+
| 970 | ++ |
+ #'+ |
+
| 971 | ++ |
+ #' \describe{
+ |
+
| 972 | ++ |
+ #' \item{split}{The name of the split (often the variable being split).}
+ |
+
| 973 | ++ |
+ #' \item{value}{The string representation of the value at that split (`split`).}
+ |
+
| 974 | ++ |
+ #' \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
+ |
+
| 975 | ++ |
+ #' defined by the combination of `split` and `value` of this row *and all rows above this row*.}+ |
+
| 976 | ++ |
+ #' \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
+ |
+
| 977 | ++ |
+ #' \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
+ |
+
| 978 | ++ |
+ #' (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's+ |
+
| 979 | ++ |
+ #' `full_parent_df` corresponding to the column.}+ |
+
| 980 | ++ |
+ #' \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
+ |
+
| 981 | ++ |
+ #' column path together.}+ |
+
| 982 | ++ |
+ #' \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
+ |
+
| 983 | ++ |
+ #' for the column currently being created by the analysis function.}+ |
+
| 984 | ++ |
+ #' \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
+ |
+
| 985 | ++ |
+ #' data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.}+ |
+
| 986 | ++ |
+ #' \item{cur_col_n}{Integer column containing the observation counts for that split.}
+ |
+
| 987 | ++ |
+ #' \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
+ |
+
| 988 | ++ |
+ #' \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
+ |
+
| 989 | ++ |
+ #' }+ |
+
| 990 | ++ |
+ #'+ |
+
| 991 | ++ |
+ #' @note+ |
+
| 992 | ++ |
+ #' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame+ |
+
| 993 | ++ |
+ #' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the+ |
+
| 994 | ++ |
+ #' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the+ |
+
| 995 | ++ |
+ #' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()].+ |
+
| 996 | ++ |
+ #'+ |
+
| 997 | ++ |
+ #' @name spl_context+ |
+
| 998 | ++ |
+ NULL+ |
+
| 999 | ++ | + + | +
| 1000 | ++ |
+ #' Additional parameters within analysis and content functions (`afun`/`cfun`)+ |
+
| 1001 | ++ |
+ #'+ |
+
| 1002 | ++ |
+ #' @description+ |
+
| 1003 | ++ |
+ #' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()],+ |
+
| 1004 | ++ |
+ #' respectively. These parameters grant access to relevant information like the row split structure (see+ |
+
| 1005 | ++ |
+ #' [spl_context]) and the predefined baseline (`.ref_group`).+ |
+
| 1006 | ++ |
+ #'+ |
+
| 1007 | ++ |
+ #' @details+ |
+
| 1008 | ++ |
+ #' We list and describe all the parameters that can be added to a custom analysis function below:+ |
+
| 1009 | ++ |
+ #'+ |
+
| 1010 | ++ |
+ #' \describe{
+ |
+
| 1011 | ++ |
+ #' \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
+ |
+
| 1012 | ++ |
+ #' \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
+ |
+
| 1013 | ++ |
+ #' \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
+ |
+
| 1014 | ++ |
+ #' column-based subsetting).}+ |
+
| 1015 | ++ |
+ #' \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
+ |
+
| 1016 | ++ |
+ #' subsetting).}+ |
+
| 1017 | ++ |
+ #' \item{.var}{Variable being analyzed.}
+ |
+
| 1018 | ++ |
+ #' \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
+ |
+
| 1019 | ++ |
+ #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}+ |
+
| 1020 | ++ |
+ #' \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
+ |
+
| 1021 | ++ |
+ #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}+ |
+
| 1022 | ++ |
+ #' \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
+ |
+
| 1023 | ++ |
+ #' \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
+ |
+
| 1024 | ++ |
+ #' See [spl_context].}+ |
+
| 1025 | ++ |
+ #' \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with
+ |
+
| 1026 | ++ |
+ #' `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`.+ |
+
| 1027 | ++ |
+ #' It can be an empty table if all the entries are filtered out.}+ |
+
| 1028 | ++ |
+ #' \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
+ |
+
| 1029 | ++ |
+ #' faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs`+ |
+
| 1030 | ++ |
+ #' in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.}+ |
+
| 1031 | ++ |
+ #' \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
+ |
+
| 1032 | ++ |
+ #' \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
+ |
+
| 1033 | ++ |
+ #' if `alt_counts_df` is used (see [build_table()]).}+ |
+
| 1034 | ++ |
+ #' }+ |
+
| 1035 | ++ |
+ #'+ |
+
| 1036 | ++ |
+ #' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be+ |
+
| 1037 | ++ |
+ #' treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during+ |
+
| 1038 | ++ |
+ #' data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is+ |
+
| 1039 | ++ |
+ #' provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present.+ |
+
| 1040 | ++ |
+ #'+ |
+
| 1041 | ++ |
+ #' @name additional_fun_params+ |
+
| 1042 | ++ |
+ NULL+ |
+
| 1043 | ++ | + + | +
| 1044 | ++ |
+ #' Generate rows analyzing variables across columns+ |
+
| 1045 | ++ |
+ #'+ |
+
| 1046 | ++ |
+ #' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by+ |
+
| 1047 | ++ |
+ #' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting,+ |
+
| 1048 | ++ |
+ #' the tabulation will occur at the current/next level of nesting by default.+ |
+
| 1049 | ++ |
+ #'+ |
+
| 1050 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1051 | ++ |
+ #'+ |
+
| 1052 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 1053 | ++ |
+ #'+ |
+
| 1054 | ++ |
+ #' @details+ |
+
| 1055 | ++ |
+ #' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a+ |
+
| 1056 | ++ |
+ #' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the+ |
+
| 1057 | ++ |
+ #' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`.+ |
+
| 1058 | ++ |
+ #'+ |
+
| 1059 | ++ |
+ #' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the+ |
+
| 1060 | ++ |
+ #' function accepts will change the behavior when tabulation is performed as follows:+ |
+
| 1061 | ++ |
+ #'+ |
+
| 1062 | ++ |
+ #' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant+ |
+
| 1063 | ++ |
+ #' column (from `var` here) of the raw data being used to build the table.+ |
+
| 1064 | ++ |
+ #' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of+ |
+
| 1065 | ++ |
+ #' the raw data being tabulated.+ |
+
| 1066 | ++ |
+ #'+ |
+
| 1067 | ++ |
+ #' In addition to differentiation on the first argument, the analysis function can optionally accept a number of+ |
+
| 1068 | ++ |
+ #' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation+ |
+
| 1069 | ++ |
+ #' machinery. These are listed and described in [additional_fun_params].+ |
+
| 1070 | ++ |
+ #'+ |
+
| 1071 | ++ |
+ #' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling+ |
+
| 1072 | ++ |
+ #' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()].+ |
+
| 1073 | ++ |
+ #' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and+ |
+
| 1074 | ++ |
+ #' the unmodified values provided by the tabulation framework.+ |
+
| 1075 | ++ |
+ #'+ |
+
| 1076 | ++ |
+ #' @examples+ |
+
| 1077 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1078 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1079 | ++ |
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
+ |
+
| 1080 | ++ |
+ #' lyt+ |
+
| 1081 | ++ |
+ #'+ |
+
| 1082 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 1083 | ++ |
+ #' tbl+ |
+
| 1084 | ++ |
+ #'+ |
+
| 1085 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 1086 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 1087 | ++ |
+ #' analyze(head(names(iris), -1), afun = function(x) {
+ |
+
| 1088 | ++ |
+ #' list(+ |
+
| 1089 | ++ |
+ #' "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ |
+
| 1090 | ++ |
+ #' "range" = rcell(diff(range(x)), format = "xx.xx")+ |
+
| 1091 | ++ |
+ #' )+ |
+
| 1092 | ++ |
+ #' })+ |
+
| 1093 | ++ |
+ #' lyt2+ |
+
| 1094 | ++ |
+ #'+ |
+
| 1095 | ++ |
+ #' tbl2 <- build_table(lyt2, iris)+ |
+
| 1096 | ++ |
+ #' tbl2+ |
+
| 1097 | ++ |
+ #'+ |
+
| 1098 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1099 | ++ |
+ #' @export+ |
+
| 1100 | ++ |
+ analyze <- function(lyt,+ |
+
| 1101 | ++ |
+ vars,+ |
+
| 1102 | ++ |
+ afun = simple_analysis,+ |
+
| 1103 | ++ |
+ var_labels = vars,+ |
+
| 1104 | ++ |
+ table_names = vars,+ |
+
| 1105 | ++ |
+ format = NULL,+ |
+
| 1106 | ++ |
+ na_str = NA_character_,+ |
+
| 1107 | ++ |
+ nested = TRUE,+ |
+
| 1108 | ++ |
+ ## can't name this na_rm symbol conflict with possible afuns!!+ |
+
| 1109 | ++ |
+ inclNAs = FALSE,+ |
+
| 1110 | ++ |
+ extra_args = list(),+ |
+
| 1111 | ++ |
+ show_labels = c("default", "visible", "hidden"),
+ |
+
| 1112 | ++ |
+ indent_mod = 0L,+ |
+
| 1113 | ++ |
+ section_div = NA_character_) {
+ |
+
| 1114 | +304x | +
+ show_labels <- match.arg(show_labels)+ |
+
| 1115 | +304x | +
+ subafun <- substitute(afun)+ |
+
| 1116 | ++ |
+ if (+ |
+
| 1117 | +304x | +
+ is.name(subafun) &&+ |
+
| 1118 | +304x | +
+ is.function(afun) &&+ |
+
| 1119 | ++ |
+ ## this is gross. basically testing+ |
+
| 1120 | ++ |
+ ## if the symbol we have corresponds+ |
+
| 1121 | ++ |
+ ## in some meaningful way to the function+ |
+
| 1122 | ++ |
+ ## we will be calling.+ |
+
| 1123 | +304x | +
+ identical(+ |
+
| 1124 | +304x | +
+ mget(+ |
+
| 1125 | +304x | +
+ as.character(subafun),+ |
+
| 1126 | +304x | +
+ mode = "function",+ |
+
| 1127 | +304x | +
+ ifnotfound = list(NULL),+ |
+
| 1128 | +304x | +
+ inherits = TRUE+ |
+
| 1129 | +304x | +
+ )[[1]], afun+ |
+
| 1130 | ++ |
+ )+ |
+
| 1131 | ++ |
+ ) {
+ |
+
| 1132 | +172x | +
+ defrowlab <- as.character(subafun)+ |
+
| 1133 | ++ |
+ } else {
+ |
+
| 1134 | +132x | +
+ defrowlab <- var_labels+ |
+
| 1135 | ++ |
+ }+ |
+
| 1136 | ++ | + + | +
| 1137 | +304x | +
+ spl <- AnalyzeMultiVars(vars, var_labels,+ |
+
| 1138 | +304x | +
+ afun = afun,+ |
+
| 1139 | +304x | +
+ split_format = format,+ |
+
| 1140 | +304x | +
+ split_na_str = na_str,+ |
+
| 1141 | +304x | +
+ defrowlab = defrowlab,+ |
+
| 1142 | +304x | +
+ inclNAs = inclNAs,+ |
+
| 1143 | +304x | +
+ extra_args = extra_args,+ |
+
| 1144 | +304x | +
+ indent_mod = indent_mod,+ |
+
| 1145 | +304x | +
+ child_names = table_names,+ |
+
| 1146 | +304x | +
+ child_labels = show_labels,+ |
+
| 1147 | +304x | +
+ section_div = section_div+ |
+
| 1148 | ++ |
+ )+ |
+
| 1149 | ++ | + + | +
| 1150 | +304x | +
+ if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
+ |
+
| 1151 | +26x | +
+ cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars)+ |
+
| 1152 | ++ |
+ } else {
+ |
+
| 1153 | ++ |
+ ## analysis compounding now done in split_rows+ |
+
| 1154 | +276x | +
+ pos <- next_rpos(lyt, nested)+ |
+
| 1155 | +276x | +
+ split_rows(lyt, spl, pos)+ |
+
| 1156 | ++ |
+ }+ |
+
| 1157 | ++ |
+ }+ |
+
| 1158 | ++ | + + | +
| 1159 | ++ |
+ get_acolvar_name <- function(lyt) {
+ |
+
| 1160 | ++ |
+ ## clyt <- clayout(lyt)+ |
+
| 1161 | ++ |
+ ## stopifnot(length(clyt) == 1L)+ |
+
| 1162 | ++ |
+ ## vec = clyt[[1]]+ |
+
| 1163 | ++ |
+ ## vcls = vapply(vec, class, "")+ |
+
| 1164 | ++ |
+ ## pos = max(which(vcls == "MultiVarSplit"))+ |
+
| 1165 | +22x | +
+ paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
+ |
+
| 1166 | ++ |
+ }+ |
+
| 1167 | ++ | + + | +
| 1168 | ++ |
+ get_acolvar_vars <- function(lyt) {
+ |
+
| 1169 | +35x | +
+ clyt <- clayout(lyt)+ |
+
| 1170 | +35x | +
+ stopifnot(length(clyt) == 1L)+ |
+
| 1171 | +35x | +
+ vec <- clyt[[1]]+ |
+
| 1172 | +35x | +
+ vcls <- vapply(vec, class, "")+ |
+
| 1173 | +35x | +
+ pos <- which(vcls == "MultiVarSplit")+ |
+
| 1174 | +35x | +
+ if (length(pos) > 0) {
+ |
+
| 1175 | +35x | +
+ spl_payload(vec[[pos]])+ |
+
| 1176 | ++ |
+ } else {
+ |
+
| 1177 | +! | +
+ "non_multivar"+ |
+
| 1178 | ++ |
+ }+ |
+
| 1179 | ++ |
+ }+ |
+
| 1180 | ++ | + + | +
| 1181 | ++ |
+ #' Generate rows analyzing different variables across columns+ |
+
| 1182 | ++ |
+ #'+ |
+
| 1183 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1184 | ++ |
+ #' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list+ |
+
| 1185 | ++ |
+ #' will be repped out as needed and matched by position with the columns during tabulation. This functions+ |
+
| 1186 | ++ |
+ #' accepts the same parameters as [analyze()] like `afun` and `format`. For further information see+ |
+
| 1187 | ++ |
+ #' [additional_fun_params].+ |
+
| 1188 | ++ |
+ #'+ |
+
| 1189 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 1190 | ++ |
+ #'+ |
+
| 1191 | ++ |
+ #' @seealso [split_cols_by_multivar()]+ |
+
| 1192 | ++ |
+ #'+ |
+
| 1193 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 1194 | ++ |
+ #' library(dplyr)+ |
+
| 1195 | ++ |
+ #'+ |
+
| 1196 | ++ |
+ #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))+ |
+
| 1197 | ++ |
+ #'+ |
+
| 1198 | ++ |
+ #' ## toy example where we take the mean of the first variable and the+ |
+
| 1199 | ++ |
+ #' ## count of >.5 for the second.+ |
+
| 1200 | ++ |
+ #' colfuns <- list(+ |
+
| 1201 | ++ |
+ #' function(x) rcell(mean(x), format = "xx.x"),+ |
+
| 1202 | ++ |
+ #' function(x) rcell(sum(x > .5), format = "xx")+ |
+
| 1203 | ++ |
+ #' )+ |
+
| 1204 | ++ |
+ #'+ |
+
| 1205 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1206 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1207 | ++ |
+ #' split_cols_by_multivar(c("value", "pctdiff")) %>%
+ |
+
| 1208 | ++ |
+ #' split_rows_by("RACE",
+ |
+
| 1209 | ++ |
+ #' split_label = "ethnicity",+ |
+
| 1210 | ++ |
+ #' split_fun = drop_split_levels+ |
+
| 1211 | ++ |
+ #' ) %>%+ |
+
| 1212 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 1213 | ++ |
+ #' analyze_colvars(afun = colfuns)+ |
+
| 1214 | ++ |
+ #' lyt+ |
+
| 1215 | ++ |
+ #'+ |
+
| 1216 | ++ |
+ #' tbl <- build_table(lyt, ANL)+ |
+
| 1217 | ++ |
+ #' tbl+ |
+
| 1218 | ++ |
+ #'+ |
+
| 1219 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 1220 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1221 | ++ |
+ #' split_cols_by_multivar(c("value", "pctdiff"),
+ |
+
| 1222 | ++ |
+ #' varlabels = c("Measurement", "Pct Diff")
+ |
+
| 1223 | ++ |
+ #' ) %>%+ |
+
| 1224 | ++ |
+ #' split_rows_by("RACE",
+ |
+
| 1225 | ++ |
+ #' split_label = "ethnicity",+ |
+
| 1226 | ++ |
+ #' split_fun = drop_split_levels+ |
+
| 1227 | ++ |
+ #' ) %>%+ |
+
| 1228 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 1229 | ++ |
+ #' analyze_colvars(afun = mean, format = "xx.xx")+ |
+
| 1230 | ++ |
+ #'+ |
+
| 1231 | ++ |
+ #' tbl2 <- build_table(lyt2, ANL)+ |
+
| 1232 | ++ |
+ #' tbl2+ |
+
| 1233 | ++ |
+ #'+ |
+
| 1234 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1235 | ++ |
+ #' @export+ |
+
| 1236 | ++ |
+ analyze_colvars <- function(lyt,+ |
+
| 1237 | ++ |
+ afun,+ |
+
| 1238 | ++ |
+ format = NULL,+ |
+
| 1239 | ++ |
+ na_str = NA_character_,+ |
+
| 1240 | ++ |
+ nested = TRUE,+ |
+
| 1241 | ++ |
+ extra_args = list(),+ |
+
| 1242 | ++ |
+ indent_mod = 0L,+ |
+
| 1243 | ++ |
+ inclNAs = FALSE) {
+ |
+
| 1244 | +22x | +
+ if (is.function(afun)) {
+ |
+
| 1245 | +13x | +
+ subafun <- substitute(afun)+ |
+
| 1246 | ++ |
+ if (+ |
+
| 1247 | +13x | +
+ is.name(subafun) &&+ |
+
| 1248 | +13x | +
+ is.function(afun) &&+ |
+
| 1249 | ++ |
+ ## this is gross. basically testing+ |
+
| 1250 | ++ |
+ ## if the symbol we have corresponds+ |
+
| 1251 | ++ |
+ ## in some meaningful way to the function+ |
+
| 1252 | ++ |
+ ## we will be calling.+ |
+
| 1253 | +13x | +
+ identical(+ |
+
| 1254 | +13x | +
+ mget(+ |
+
| 1255 | +13x | +
+ as.character(subafun),+ |
+
| 1256 | +13x | +
+ mode = "function",+ |
+
| 1257 | +13x | +
+ ifnotfound = list(NULL),+ |
+
| 1258 | +13x | +
+ inherits = TRUE+ |
+
| 1259 | +13x | +
+ )[[1]],+ |
+
| 1260 | +13x | +
+ afun+ |
+
| 1261 | ++ |
+ )+ |
+
| 1262 | ++ |
+ ) {
+ |
+
| 1263 | +13x | +
+ defrowlab <- as.character(subafun)+ |
+
| 1264 | ++ |
+ } else {
+ |
+
| 1265 | +! | +
+ defrowlab <- ""+ |
+
| 1266 | ++ |
+ }+ |
+
| 1267 | +13x | +
+ afun <- lapply(+ |
+
| 1268 | +13x | +
+ get_acolvar_vars(lyt),+ |
+
| 1269 | +13x | +
+ function(x) afun+ |
+
| 1270 | ++ |
+ )+ |
+
| 1271 | ++ |
+ } else {
+ |
+
| 1272 | +9x | +
+ defrowlab <- ""+ |
+
| 1273 | ++ |
+ }+ |
+
| 1274 | +22x | +
+ spl <- AnalyzeColVarSplit(+ |
+
| 1275 | +22x | +
+ afun = afun,+ |
+
| 1276 | +22x | +
+ defrowlab = defrowlab,+ |
+
| 1277 | +22x | +
+ split_format = format,+ |
+
| 1278 | +22x | +
+ split_na_str = na_str,+ |
+
| 1279 | +22x | +
+ split_name = get_acolvar_name(lyt),+ |
+
| 1280 | +22x | +
+ indent_mod = indent_mod,+ |
+
| 1281 | +22x | +
+ extra_args = extra_args,+ |
+
| 1282 | +22x | +
+ inclNAs = inclNAs+ |
+
| 1283 | ++ |
+ )+ |
+
| 1284 | +22x | +
+ pos <- next_rpos(lyt, nested, for_analyze = TRUE)+ |
+
| 1285 | +22x | +
+ split_rows(lyt, spl, pos)+ |
+
| 1286 | ++ |
+ }+ |
+
| 1287 | ++ | + + | +
| 1288 | ++ |
+ ## Add a total column at the next **top level** spot in+ |
+
| 1289 | ++ |
+ ## the column layout.+ |
+
| 1290 | ++ | + + | +
| 1291 | ++ |
+ #' Add overall column+ |
+
| 1292 | ++ |
+ #'+ |
+
| 1293 | ++ |
+ #' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits.+ |
+
| 1294 | ++ |
+ #' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits.+ |
+
| 1295 | ++ |
+ #'+ |
+
| 1296 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1297 | ++ |
+ #'+ |
+
| 1298 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 1299 | ++ |
+ #'+ |
+
| 1300 | ++ |
+ #' @seealso [add_overall_level()]+ |
+
| 1301 | ++ |
+ #'+ |
+
| 1302 | ++ |
+ #' @examples+ |
+
| 1303 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1304 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1305 | ++ |
+ #' add_overall_col("All Patients") %>%
+ |
+
| 1306 | ++ |
+ #' analyze("AGE")
+ |
+
| 1307 | ++ |
+ #' lyt+ |
+
| 1308 | ++ |
+ #'+ |
+
| 1309 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 1310 | ++ |
+ #' tbl+ |
+
| 1311 | ++ |
+ #'+ |
+
| 1312 | ++ |
+ #' @export+ |
+
| 1313 | ++ |
+ add_overall_col <- function(lyt, label) {
+ |
+
| 1314 | +111x | +
+ spl <- AllSplit(label)+ |
+
| 1315 | +111x | +
+ split_cols(+ |
+
| 1316 | +111x | +
+ lyt,+ |
+
| 1317 | +111x | +
+ spl,+ |
+
| 1318 | +111x | +
+ next_cpos(lyt, FALSE)+ |
+
| 1319 | ++ |
+ )+ |
+
| 1320 | ++ |
+ }+ |
+
| 1321 | ++ | + + | +
| 1322 | ++ |
+ ## add_row_summary ====+ |
+
| 1323 | ++ | + + | +
| 1324 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1325 | ++ |
+ #'+ |
+
| 1326 | ++ |
+ #' @export+ |
+
| 1327 | ++ |
+ #'+ |
+
| 1328 | ++ |
+ #' @rdname int_methods+ |
+
| 1329 | ++ |
+ setGeneric(+ |
+
| 1330 | ++ |
+ ".add_row_summary",+ |
+
| 1331 | ++ |
+ function(lyt,+ |
+
| 1332 | ++ |
+ label,+ |
+
| 1333 | ++ |
+ cfun,+ |
+
| 1334 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 1335 | ++ |
+ cformat = NULL,+ |
+
| 1336 | ++ |
+ cna_str = "-",+ |
+
| 1337 | ++ |
+ indent_mod = 0L,+ |
+
| 1338 | ++ |
+ cvar = "",+ |
+
| 1339 | ++ |
+ extra_args = list()) {
+ |
+
| 1340 | +447x | +
+ standardGeneric(".add_row_summary")
+ |
+
| 1341 | ++ |
+ }+ |
+
| 1342 | ++ |
+ )+ |
+
| 1343 | ++ | + + | +
| 1344 | ++ |
+ #' @rdname int_methods+ |
+
| 1345 | ++ |
+ setMethod(+ |
+
| 1346 | ++ |
+ ".add_row_summary", "PreDataTableLayouts",+ |
+
| 1347 | ++ |
+ function(lyt,+ |
+
| 1348 | ++ |
+ label,+ |
+
| 1349 | ++ |
+ cfun,+ |
+
| 1350 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 1351 | ++ |
+ cformat = NULL,+ |
+
| 1352 | ++ |
+ cna_str = "-",+ |
+
| 1353 | ++ |
+ indent_mod = 0L,+ |
+
| 1354 | ++ |
+ cvar = "",+ |
+
| 1355 | ++ |
+ extra_args = list()) {
+ |
+
| 1356 | +114x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 1357 | +114x | +
+ tmp <- .add_row_summary(rlayout(lyt), label, cfun,+ |
+
| 1358 | +114x | +
+ child_labels = child_labels,+ |
+
| 1359 | +114x | +
+ cformat = cformat,+ |
+
| 1360 | +114x | +
+ cna_str = cna_str,+ |
+
| 1361 | +114x | +
+ indent_mod = indent_mod,+ |
+
| 1362 | +114x | +
+ cvar = cvar,+ |
+
| 1363 | +114x | +
+ extra_args = extra_args+ |
+
| 1364 | ++ |
+ )+ |
+
| 1365 | +114x | +
+ rlayout(lyt) <- tmp+ |
+
| 1366 | +114x | +
+ lyt+ |
+
| 1367 | ++ |
+ }+ |
+
| 1368 | ++ |
+ )+ |
+
| 1369 | ++ | + + | +
| 1370 | ++ |
+ #' @rdname int_methods+ |
+
| 1371 | ++ |
+ setMethod(+ |
+
| 1372 | ++ |
+ ".add_row_summary", "PreDataRowLayout",+ |
+
| 1373 | ++ |
+ function(lyt,+ |
+
| 1374 | ++ |
+ label,+ |
+
| 1375 | ++ |
+ cfun,+ |
+
| 1376 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 1377 | ++ |
+ cformat = NULL,+ |
+
| 1378 | ++ |
+ cna_str = "-",+ |
+
| 1379 | ++ |
+ indent_mod = 0L,+ |
+
| 1380 | ++ |
+ cvar = "",+ |
+
| 1381 | ++ |
+ extra_args = list()) {
+ |
+
| 1382 | +114x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 1383 | +114x | +
+ if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
+ |
+
| 1384 | ++ |
+ ## XXX ignoring indent mod here+ |
+
| 1385 | +9x | +
+ rt <- root_spl(lyt)+ |
+
| 1386 | +9x | +
+ rt <- .add_row_summary(rt,+ |
+
| 1387 | +9x | +
+ label,+ |
+
| 1388 | +9x | +
+ cfun,+ |
+
| 1389 | +9x | +
+ child_labels = child_labels,+ |
+
| 1390 | +9x | +
+ cformat = cformat,+ |
+
| 1391 | +9x | +
+ cna_str = cna_str,+ |
+
| 1392 | +9x | +
+ cvar = cvar,+ |
+
| 1393 | +9x | +
+ extra_args = extra_args+ |
+
| 1394 | ++ |
+ )+ |
+
| 1395 | +9x | +
+ root_spl(lyt) <- rt+ |
+
| 1396 | ++ |
+ } else {
+ |
+
| 1397 | +105x | +
+ ind <- length(lyt)+ |
+
| 1398 | +105x | +
+ tmp <- .add_row_summary(lyt[[ind]], label, cfun,+ |
+
| 1399 | +105x | +
+ child_labels = child_labels,+ |
+
| 1400 | +105x | +
+ cformat = cformat,+ |
+
| 1401 | +105x | +
+ cna_str = cna_str,+ |
+
| 1402 | +105x | +
+ indent_mod = indent_mod,+ |
+
| 1403 | +105x | +
+ cvar = cvar,+ |
+
| 1404 | +105x | +
+ extra_args = extra_args+ |
+
| 1405 | ++ |
+ )+ |
+
| 1406 | +105x | +
+ lyt[[ind]] <- tmp+ |
+
| 1407 | ++ |
+ }+ |
+
| 1408 | +114x | +
+ lyt+ |
+
| 1409 | ++ |
+ }+ |
+
| 1410 | ++ |
+ )+ |
+
| 1411 | ++ | + + | +
| 1412 | ++ |
+ #' @rdname int_methods+ |
+
| 1413 | ++ |
+ setMethod(+ |
+
| 1414 | ++ |
+ ".add_row_summary", "SplitVector",+ |
+
| 1415 | ++ |
+ function(lyt,+ |
+
| 1416 | ++ |
+ label,+ |
+
| 1417 | ++ |
+ cfun,+ |
+
| 1418 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 1419 | ++ |
+ cformat = NULL,+ |
+
| 1420 | ++ |
+ cna_str = "-",+ |
+
| 1421 | ++ |
+ indent_mod = 0L,+ |
+
| 1422 | ++ |
+ cvar = "",+ |
+
| 1423 | ++ |
+ extra_args = list()) {
+ |
+
| 1424 | +105x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 1425 | +105x | +
+ ind <- length(lyt)+ |
+
| 1426 | +! | +
+ if (ind == 0) stop("no split to add content rows at")
+ |
+
| 1427 | +105x | +
+ spl <- lyt[[ind]]+ |
+
| 1428 | ++ |
+ # if(is(spl, "AnalyzeVarSplit"))+ |
+
| 1429 | ++ |
+ # stop("can't add content rows to analyze variable split")
+ |
+
| 1430 | +105x | +
+ tmp <- .add_row_summary(spl,+ |
+
| 1431 | +105x | +
+ label,+ |
+
| 1432 | +105x | +
+ cfun,+ |
+
| 1433 | +105x | +
+ child_labels = child_labels,+ |
+
| 1434 | +105x | +
+ cformat = cformat,+ |
+
| 1435 | +105x | +
+ cna_str = cna_str,+ |
+
| 1436 | +105x | +
+ indent_mod = indent_mod,+ |
+
| 1437 | +105x | +
+ cvar = cvar,+ |
+
| 1438 | +105x | +
+ extra_args = extra_args+ |
+
| 1439 | ++ |
+ )+ |
+
| 1440 | +105x | +
+ lyt[[ind]] <- tmp+ |
+
| 1441 | +105x | +
+ lyt+ |
+
| 1442 | ++ |
+ }+ |
+
| 1443 | ++ |
+ )+ |
+
| 1444 | ++ | + + | +
| 1445 | ++ |
+ #' @rdname int_methods+ |
+
| 1446 | ++ |
+ setMethod(+ |
+
| 1447 | ++ |
+ ".add_row_summary", "Split",+ |
+
| 1448 | ++ |
+ function(lyt,+ |
+
| 1449 | ++ |
+ label,+ |
+
| 1450 | ++ |
+ cfun,+ |
+
| 1451 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 1452 | ++ |
+ cformat = NULL,+ |
+
| 1453 | ++ |
+ cna_str = "-",+ |
+
| 1454 | ++ |
+ indent_mod = 0L,+ |
+
| 1455 | ++ |
+ cvar = "",+ |
+
| 1456 | ++ |
+ extra_args = list()) {
+ |
+
| 1457 | +114x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 1458 | ++ |
+ # lbl_kids = .labelkids_helper(child_labels)+ |
+
| 1459 | +114x | +
+ content_fun(lyt) <- cfun+ |
+
| 1460 | +114x | +
+ content_indent_mod(lyt) <- indent_mod+ |
+
| 1461 | +114x | +
+ content_var(lyt) <- cvar+ |
+
| 1462 | ++ |
+ ## obj_format(lyt) = cformat+ |
+
| 1463 | +114x | +
+ content_format(lyt) <- cformat+ |
+
| 1464 | +114x | +
+ if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
+ |
+
| 1465 | +! | +
+ label_kids(lyt) <- child_labels+ |
+
| 1466 | ++ |
+ }+ |
+
| 1467 | +114x | +
+ content_na_str <- cna_str+ |
+
| 1468 | +114x | +
+ content_extra_args(lyt) <- extra_args+ |
+
| 1469 | +114x | +
+ lyt+ |
+
| 1470 | ++ |
+ }+ |
+
| 1471 | ++ |
+ )+ |
+
| 1472 | ++ | + + | +
| 1473 | ++ |
+ .count_raw_constr <- function(var, format, label_fstr) {
+ |
+
| 1474 | +1x | +
+ function(df, labelstr = "") {
+ |
+
| 1475 | +3x | +
+ if (grepl("%s", label_fstr, fixed = TRUE)) {
+ |
+
| 1476 | +! | +
+ label <- sprintf(label_fstr, labelstr)+ |
+
| 1477 | ++ |
+ } else {
+ |
+
| 1478 | +3x | +
+ label <- label_fstr+ |
+
| 1479 | ++ |
+ }+ |
+
| 1480 | +3x | +
+ if (is(df, "data.frame")) {
+ |
+
| 1481 | +3x | +
+ if (!is.null(var) && nzchar(var)) {
+ |
+
| 1482 | +3x | +
+ cnt <- sum(!is.na(df[[var]]))+ |
+
| 1483 | ++ |
+ } else {
+ |
+
| 1484 | +! | +
+ cnt <- nrow(df)+ |
+
| 1485 | ++ |
+ }+ |
+
| 1486 | +1x | +
+ } else { # df is the data column vector
+ |
+
| 1487 | +! | +
+ cnt <- sum(!is.na(df))+ |
+
| 1488 | ++ |
+ }+ |
+
| 1489 | +3x | +
+ ret <- rcell(cnt,+ |
+
| 1490 | +3x | +
+ format = format,+ |
+
| 1491 | +3x | +
+ label = label+ |
+
| 1492 | ++ |
+ )+ |
+
| 1493 | +3x | +
+ ret+ |
+
| 1494 | ++ |
+ }+ |
+
| 1495 | ++ |
+ }+ |
+
| 1496 | ++ | + + | +
| 1497 | ++ |
+ .count_wpcts_constr <- function(var, format, label_fstr) {
+ |
+
| 1498 | +100x | +
+ function(df, labelstr = "", .N_col) {
+ |
+
| 1499 | +1507x | +
+ if (grepl("%s", label_fstr, fixed = TRUE)) {
+ |
+
| 1500 | +1483x | +
+ label <- sprintf(label_fstr, labelstr)+ |
+
| 1501 | ++ |
+ } else {
+ |
+
| 1502 | +24x | +
+ label <- label_fstr+ |
+
| 1503 | ++ |
+ }+ |
+
| 1504 | +1507x | +
+ if (is(df, "data.frame")) {
+ |
+
| 1505 | +1507x | +
+ if (!is.null(var) && nzchar(var)) {
+ |
+
| 1506 | +383x | +
+ cnt <- sum(!is.na(df[[var]]))+ |
+
| 1507 | ++ |
+ } else {
+ |
+
| 1508 | +1124x | +
+ cnt <- nrow(df)+ |
+
| 1509 | ++ |
+ }+ |
+
| 1510 | +100x | +
+ } else { # df is the data column vector
+ |
+
| 1511 | +! | +
+ cnt <- sum(!is.na(df))+ |
+
| 1512 | ++ |
+ }+ |
+
| 1513 | ++ |
+ ## the formatter does the *100 so we don't here.+ |
+
| 1514 | ++ |
+ ## TODO name elements of this so that ARD generation has access to them+ |
+
| 1515 | ++ |
+ ## ret <- rcell(c(n = cnt, pct = cnt / .N_col),+ |
+
| 1516 | +1507x | +
+ ret <- rcell(c(cnt, cnt / .N_col),+ |
+
| 1517 | +1507x | +
+ format = format,+ |
+
| 1518 | +1507x | +
+ label = label+ |
+
| 1519 | ++ |
+ )+ |
+
| 1520 | +1507x | +
+ ret+ |
+
| 1521 | ++ |
+ }+ |
+
| 1522 | ++ |
+ }+ |
+
| 1523 | ++ | + + | +
| 1524 | ++ |
+ .validate_cfuns <- function(fun) {
+ |
+
| 1525 | +120x | +
+ if (is.list(fun)) {
+ |
+
| 1526 | +2x | +
+ return(unlist(lapply(fun, .validate_cfuns)))+ |
+
| 1527 | ++ |
+ }+ |
+
| 1528 | ++ | + + | +
| 1529 | +118x | +
+ frmls <- formals(fun)+ |
+
| 1530 | +118x | +
+ ls_pos <- match("labelstr", names(frmls))
+ |
+
| 1531 | +118x | +
+ if (is.na(ls_pos)) {
+ |
+
| 1532 | +! | +
+ stop("content functions must explicitly accept a 'labelstr' argument")
+ |
+
| 1533 | ++ |
+ }+ |
+
| 1534 | ++ | + + | +
| 1535 | +118x | +
+ list(fun)+ |
+
| 1536 | ++ |
+ }+ |
+
| 1537 | ++ | + + | +
| 1538 | ++ |
+ #' Analysis function to count levels of a factor with percentage of the column total+ |
+
| 1539 | ++ |
+ #'+ |
+
| 1540 | ++ |
+ #' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery.+ |
+
| 1541 | ++ |
+ #' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery.+ |
+
| 1542 | ++ |
+ #'+ |
+
| 1543 | ++ |
+ #' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor.+ |
+
| 1544 | ++ |
+ #'+ |
+
| 1545 | ++ |
+ #' @examples+ |
+
| 1546 | ++ |
+ #' counts_wpcts(DM$SEX, 400)+ |
+
| 1547 | ++ |
+ #'+ |
+
| 1548 | ++ |
+ #' @export+ |
+
| 1549 | ++ |
+ counts_wpcts <- function(x, .N_col) {
+ |
+
| 1550 | +2x | +
+ if (!is.factor(x)) {
+ |
+
| 1551 | +1x | +
+ stop(+ |
+
| 1552 | +1x | +
+ "using the 'counts_wpcts' analysis function requires factor data ",+ |
+
| 1553 | +1x | +
+ "to guarantee equal numbers of rows across all collumns, got class ",+ |
+
| 1554 | +1x | +
+ class(x), "."+ |
+
| 1555 | ++ |
+ )+ |
+
| 1556 | ++ |
+ }+ |
+
| 1557 | +1x | +
+ ret <- table(x)+ |
+
| 1558 | +1x | +
+ in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)")))+ |
+
| 1559 | ++ |
+ }+ |
+
| 1560 | ++ | + + | +
| 1561 | ++ |
+ #' Add a content row of summary counts+ |
+
| 1562 | ++ |
+ #'+ |
+
| 1563 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1564 | ++ |
+ #'+ |
+
| 1565 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 1566 | ++ |
+ #'+ |
+
| 1567 | ++ |
+ #' @details+ |
+
| 1568 | ++ |
+ #' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values+ |
+
| 1569 | ++ |
+ #' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of+ |
+
| 1570 | ++ |
+ #' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only+ |
+
| 1571 | ++ |
+ #' raw counts are used.+ |
+
| 1572 | ++ |
+ #'+ |
+
| 1573 | ++ |
+ #' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset+ |
+
| 1574 | ++ |
+ #' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept+ |
+
| 1575 | ++ |
+ #' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently+ |
+
| 1576 | ++ |
+ #' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]).+ |
+
| 1577 | ++ |
+ #'+ |
+
| 1578 | ++ |
+ #' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params]+ |
+
| 1579 | ++ |
+ #' that can be used in `cfun`.+ |
+
| 1580 | ++ |
+ #'+ |
+
| 1581 | ++ |
+ #' @examples+ |
+
| 1582 | ++ |
+ #' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
+ |
+
| 1583 | ++ |
+ #'+ |
+
| 1584 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1585 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1586 | ++ |
+ #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
+ |
+
| 1587 | ++ |
+ #' summarize_row_groups(label_fstr = "%s (n)") %>%+ |
+
| 1588 | ++ |
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
+ |
+
| 1589 | ++ |
+ #' lyt+ |
+
| 1590 | ++ |
+ #'+ |
+
| 1591 | ++ |
+ #' tbl <- build_table(lyt, DM2)+ |
+
| 1592 | ++ |
+ #' tbl+ |
+
| 1593 | ++ |
+ #'+ |
+
| 1594 | ++ |
+ #' row_paths_summary(tbl) # summary count is a content table+ |
+
| 1595 | ++ |
+ #'+ |
+
| 1596 | ++ |
+ #' ## use a cfun and extra_args to customize summarization+ |
+
| 1597 | ++ |
+ #' ## behavior+ |
+
| 1598 | ++ |
+ #' sfun <- function(x, labelstr, trim) {
+ |
+
| 1599 | ++ |
+ #' in_rows(+ |
+
| 1600 | ++ |
+ #' c(mean(x, trim = trim), trim),+ |
+
| 1601 | ++ |
+ #' .formats = "xx.x (xx.x%)",+ |
+
| 1602 | ++ |
+ #' .labels = sprintf(+ |
+
| 1603 | ++ |
+ #' "%s (Trimmed mean and trim %%)",+ |
+
| 1604 | ++ |
+ #' labelstr+ |
+
| 1605 | ++ |
+ #' )+ |
+
| 1606 | ++ |
+ #' )+ |
+
| 1607 | ++ |
+ #' }+ |
+
| 1608 | ++ |
+ #'+ |
+
| 1609 | ++ |
+ #' lyt2 <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 1610 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1611 | ++ |
+ #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
+ |
+
| 1612 | ++ |
+ #' summarize_row_groups("AGE",
+ |
+
| 1613 | ++ |
+ #' cfun = sfun,+ |
+
| 1614 | ++ |
+ #' extra_args = list(trim = .2)+ |
+
| 1615 | ++ |
+ #' ) %>%+ |
+
| 1616 | ++ |
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ |
+
| 1617 | ++ |
+ #' append_topleft(c("Country", " Age"))
+ |
+
| 1618 | ++ |
+ #'+ |
+
| 1619 | ++ |
+ #' tbl2 <- build_table(lyt2, DM2)+ |
+
| 1620 | ++ |
+ #' tbl2+ |
+
| 1621 | ++ |
+ #'+ |
+
| 1622 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1623 | ++ |
+ #' @export+ |
+
| 1624 | ++ |
+ summarize_row_groups <- function(lyt,+ |
+
| 1625 | ++ |
+ var = "",+ |
+
| 1626 | ++ |
+ label_fstr = "%s",+ |
+
| 1627 | ++ |
+ format = "xx (xx.x%)",+ |
+
| 1628 | ++ |
+ na_str = "-",+ |
+
| 1629 | ++ |
+ cfun = NULL,+ |
+
| 1630 | ++ |
+ indent_mod = 0L,+ |
+
| 1631 | ++ |
+ extra_args = list()) {
+ |
+
| 1632 | +114x | +
+ if (is.null(cfun)) {
+ |
+
| 1633 | +101x | +
+ if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
+ |
+
| 1634 | +1x | +
+ cfun <- .count_raw_constr(var, format, label_fstr)+ |
+
| 1635 | ++ |
+ } else {
+ |
+
| 1636 | +100x | +
+ cfun <- .count_wpcts_constr(var, format, label_fstr)+ |
+
| 1637 | ++ |
+ }+ |
+
| 1638 | ++ |
+ }+ |
+
| 1639 | +114x | +
+ cfun <- .validate_cfuns(cfun)+ |
+
| 1640 | +114x | +
+ .add_row_summary(lyt,+ |
+
| 1641 | +114x | +
+ cfun = cfun,+ |
+
| 1642 | +114x | +
+ cformat = format,+ |
+
| 1643 | +114x | +
+ cna_str = na_str,+ |
+
| 1644 | +114x | +
+ indent_mod = indent_mod,+ |
+
| 1645 | +114x | +
+ cvar = var,+ |
+
| 1646 | +114x | +
+ extra_args = extra_args+ |
+
| 1647 | ++ |
+ )+ |
+
| 1648 | ++ |
+ }+ |
+
| 1649 | ++ | + + | +
| 1650 | ++ |
+ #' Add the column population counts to the header+ |
+
| 1651 | ++ |
+ #'+ |
+
| 1652 | ++ |
+ #' Add the data derived column counts.+ |
+
| 1653 | ++ |
+ #'+ |
+
| 1654 | ++ |
+ #' @details It is often the case that the the column counts derived from the+ |
+
| 1655 | ++ |
+ #' input data to [build_table()] is not representative of the population counts.+ |
+
| 1656 | ++ |
+ #' For example, if events are counted in the table and the header should+ |
+
| 1657 | ++ |
+ #' display the number of subjects and not the total number of events.+ |
+
| 1658 | ++ |
+ #'+ |
+
| 1659 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1660 | ++ |
+ #'+ |
+
| 1661 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 1662 | ++ |
+ #'+ |
+
| 1663 | ++ |
+ #' @examples+ |
+
| 1664 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1665 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1666 | ++ |
+ #' add_colcounts() %>%+ |
+
| 1667 | ++ |
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ |
+
| 1668 | ++ |
+ #' analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
+ |
+
| 1669 | ++ |
+ #' lyt+ |
+
| 1670 | ++ |
+ #'+ |
+
| 1671 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 1672 | ++ |
+ #' tbl+ |
+
| 1673 | ++ |
+ #'+ |
+
| 1674 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1675 | ++ |
+ #' @export+ |
+
| 1676 | ++ |
+ add_colcounts <- function(lyt, format = "(N=xx)") {
+ |
+
| 1677 | +5x | +
+ if (is.null(lyt)) {
+ |
+
| 1678 | +! | +
+ lyt <- PreDataTableLayouts()+ |
+
| 1679 | ++ |
+ }+ |
+
| 1680 | +5x | +
+ disp_ccounts(lyt) <- TRUE+ |
+
| 1681 | +5x | +
+ colcount_format(lyt) <- format+ |
+
| 1682 | +5x | +
+ lyt+ |
+
| 1683 | ++ |
+ }+ |
+
| 1684 | ++ | + + | +
| 1685 | ++ |
+ ## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting.+ |
+
| 1686 | ++ |
+ #' Add an already calculated table to the layout+ |
+
| 1687 | ++ |
+ #'+ |
+
| 1688 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1689 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1690 | ++ |
+ #'+ |
+
| 1691 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 1692 | ++ |
+ #'+ |
+
| 1693 | ++ |
+ #' @examples+ |
+
| 1694 | ++ |
+ #' lyt1 <- basic_table() %>%+ |
+
| 1695 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1696 | ++ |
+ #' analyze("AGE", afun = mean, format = "xx.xx")
+ |
+
| 1697 | ++ |
+ #'+ |
+
| 1698 | ++ |
+ #' tbl1 <- build_table(lyt1, DM)+ |
+
| 1699 | ++ |
+ #' tbl1+ |
+
| 1700 | ++ |
+ #'+ |
+
| 1701 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 1702 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1703 | ++ |
+ #' analyze("AGE", afun = sd, format = "xx.xx") %>%
+ |
+
| 1704 | ++ |
+ #' add_existing_table(tbl1)+ |
+
| 1705 | ++ |
+ #'+ |
+
| 1706 | ++ |
+ #' tbl2 <- build_table(lyt2, DM)+ |
+
| 1707 | ++ |
+ #' tbl2+ |
+
| 1708 | ++ |
+ #'+ |
+
| 1709 | ++ |
+ #' table_structure(tbl2)+ |
+
| 1710 | ++ |
+ #' row_paths_summary(tbl2)+ |
+
| 1711 | ++ |
+ #'+ |
+
| 1712 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1713 | ++ |
+ #' @export+ |
+
| 1714 | ++ |
+ add_existing_table <- function(lyt, tt, indent_mod = 0) {
+ |
+
| 1715 | +1x | +
+ indent_mod(tt) <- indent_mod+ |
+
| 1716 | +1x | +
+ lyt <- split_rows(+ |
+
| 1717 | +1x | +
+ lyt,+ |
+
| 1718 | +1x | +
+ tt,+ |
+
| 1719 | +1x | +
+ next_rpos(lyt, nested = FALSE)+ |
+
| 1720 | ++ |
+ )+ |
+
| 1721 | +1x | +
+ lyt+ |
+
| 1722 | ++ |
+ }+ |
+
| 1723 | ++ | + + | +
| 1724 | ++ |
+ ## takes_coln = function(f) {
+ |
+
| 1725 | ++ |
+ ## stopifnot(is(f, "function"))+ |
+
| 1726 | ++ |
+ ## forms = names(formals(f))+ |
+
| 1727 | ++ |
+ ## res = ".N_col" %in% forms+ |
+
| 1728 | ++ |
+ ## res+ |
+
| 1729 | ++ |
+ ## }+ |
+
| 1730 | ++ | + + | +
| 1731 | ++ |
+ ## takes_totn = function(f) {
+ |
+
| 1732 | ++ |
+ ## stopifnot(is(f, "function"))+ |
+
| 1733 | ++ |
+ ## forms = names(formals(f))+ |
+
| 1734 | ++ |
+ ## res = ".N_total" %in% forms+ |
+
| 1735 | ++ |
+ ## res+ |
+
| 1736 | ++ |
+ ## }+ |
+
| 1737 | ++ | + + | +
| 1738 | ++ |
+ ## use data to transform dynamic cuts to static cuts+ |
+
| 1739 | ++ |
+ #' @rdname int_methods+ |
+
| 1740 | +2739x | +
+ setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))
+ |
+
| 1741 | ++ | + + | +
| 1742 | ++ |
+ #' @rdname int_methods+ |
+
| 1743 | +1016x | +
+ setMethod("fix_dyncuts", "Split", function(spl, df) spl)
+ |
+
| 1744 | ++ | + + | +
| 1745 | ++ |
+ #' @rdname int_methods+ |
+
| 1746 | ++ |
+ setMethod(+ |
+
| 1747 | ++ |
+ "fix_dyncuts", "VarDynCutSplit",+ |
+
| 1748 | ++ |
+ function(spl, df) {
+ |
+
| 1749 | +5x | +
+ var <- spl_payload(spl)+ |
+
| 1750 | +5x | +
+ varvec <- df[[var]]+ |
+
| 1751 | ++ | + + | +
| 1752 | +5x | +
+ cfun <- spl_cutfun(spl)+ |
+
| 1753 | +5x | +
+ cuts <- cfun(varvec)+ |
+
| 1754 | +5x | +
+ cutlabels <- spl_cutlabelfun(spl)(cuts)+ |
+
| 1755 | +5x | +
+ if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
+ |
+
| 1756 | +1x | +
+ cutlabels <- names(cuts)[-1]+ |
+
| 1757 | ++ |
+ }+ |
+
| 1758 | ++ | + + | +
| 1759 | +5x | +
+ ret <- make_static_cut_split(+ |
+
| 1760 | +5x | +
+ var = var, split_label = obj_label(spl),+ |
+
| 1761 | +5x | +
+ cuts = cuts, cutlabels = cutlabels,+ |
+
| 1762 | +5x | +
+ cumulative = spl_is_cmlcuts(spl)+ |
+
| 1763 | ++ |
+ )+ |
+
| 1764 | ++ |
+ ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl),+ |
+
| 1765 | ++ |
+ ## cuts = cuts, cutlabels = cutlabels)+ |
+
| 1766 | ++ |
+ ## ## classes are tthe same structurally CumulativeCutSplit+ |
+
| 1767 | ++ |
+ ## ## is just a sentinal so it can hit different make_subset_expr+ |
+
| 1768 | ++ |
+ ## ## method+ |
+
| 1769 | ++ |
+ ## if(spl_is_cmlcuts(spl))+ |
+
| 1770 | ++ |
+ ## ret = as(ret, "CumulativeCutSplit")+ |
+
| 1771 | +5x | +
+ ret+ |
+
| 1772 | ++ |
+ }+ |
+
| 1773 | ++ |
+ )+ |
+
| 1774 | ++ | + + | +
| 1775 | ++ |
+ #' @rdname int_methods+ |
+
| 1776 | ++ |
+ setMethod(+ |
+
| 1777 | ++ |
+ "fix_dyncuts", "VTableTree",+ |
+
| 1778 | +1x | +
+ function(spl, df) spl+ |
+
| 1779 | ++ |
+ )+ |
+
| 1780 | ++ | + + | +
| 1781 | ++ |
+ .fd_helper <- function(spl, df) {
+ |
+
| 1782 | +1380x | +
+ lst <- lapply(spl, fix_dyncuts, df = df)+ |
+
| 1783 | +1380x | +
+ spl@.Data <- lst+ |
+
| 1784 | +1380x | +
+ spl+ |
+
| 1785 | ++ |
+ }+ |
+
| 1786 | ++ | + + | +
| 1787 | ++ |
+ #' @rdname int_methods+ |
+
| 1788 | ++ |
+ setMethod(+ |
+
| 1789 | ++ |
+ "fix_dyncuts", "PreDataRowLayout",+ |
+
| 1790 | ++ |
+ function(spl, df) {
+ |
+
| 1791 | ++ |
+ # rt = root_spl(spl)+ |
+
| 1792 | +337x | +
+ ret <- .fd_helper(spl, df)+ |
+
| 1793 | ++ |
+ # root_spl(ret) = rt+ |
+
| 1794 | +337x | +
+ ret+ |
+
| 1795 | ++ |
+ }+ |
+
| 1796 | ++ |
+ )+ |
+
| 1797 | ++ | + + | +
| 1798 | ++ |
+ #' @rdname int_methods+ |
+
| 1799 | ++ |
+ setMethod(+ |
+
| 1800 | ++ |
+ "fix_dyncuts", "PreDataColLayout",+ |
+
| 1801 | ++ |
+ function(spl, df) {
+ |
+
| 1802 | ++ |
+ # rt = root_spl(spl)+ |
+
| 1803 | +337x | +
+ ret <- .fd_helper(spl, df)+ |
+
| 1804 | ++ |
+ # root_spl(ret) = rt+ |
+
| 1805 | ++ |
+ # disp_ccounts(ret) = disp_ccounts(spl)+ |
+
| 1806 | ++ |
+ # colcount_format(ret) = colcount_format(spl)+ |
+
| 1807 | +337x | +
+ ret+ |
+
| 1808 | ++ |
+ }+ |
+
| 1809 | ++ |
+ )+ |
+
| 1810 | ++ | + + | +
| 1811 | ++ |
+ #' @rdname int_methods+ |
+
| 1812 | ++ |
+ setMethod(+ |
+
| 1813 | ++ |
+ "fix_dyncuts", "SplitVector",+ |
+
| 1814 | ++ |
+ function(spl, df) {
+ |
+
| 1815 | +706x | +
+ .fd_helper(spl, df)+ |
+
| 1816 | ++ |
+ }+ |
+
| 1817 | ++ |
+ )+ |
+
| 1818 | ++ | + + | +
| 1819 | ++ |
+ #' @rdname int_methods+ |
+
| 1820 | ++ |
+ setMethod(+ |
+
| 1821 | ++ |
+ "fix_dyncuts", "PreDataTableLayouts",+ |
+
| 1822 | ++ |
+ function(spl, df) {
+ |
+
| 1823 | +337x | +
+ rlayout(spl) <- fix_dyncuts(rlayout(spl), df)+ |
+
| 1824 | +337x | +
+ clayout(spl) <- fix_dyncuts(clayout(spl), df)+ |
+
| 1825 | +337x | +
+ spl+ |
+
| 1826 | ++ |
+ }+ |
+
| 1827 | ++ |
+ )+ |
+
| 1828 | ++ | + + | +
| 1829 | ++ |
+ ## Manual column construction in a simple (seeming to the user) way.+ |
+
| 1830 | ++ |
+ #' Manual column declaration+ |
+
| 1831 | ++ |
+ #'+ |
+
| 1832 | ++ |
+ #' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given,+ |
+
| 1833 | ++ |
+ #' the values of the second are nested within each value of the first, and so on.+ |
+
| 1834 | ++ |
+ #' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`.+ |
+
| 1835 | ++ |
+ #' @param ccount_format (`FormatSpec`)\cr the format to use when counts are displayed.+ |
+
| 1836 | ++ |
+ #'+ |
+
| 1837 | ++ |
+ #' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed+ |
+
| 1838 | ++ |
+ #' table.+ |
+
| 1839 | ++ |
+ #'+ |
+
| 1840 | ++ |
+ #' @examples+ |
+
| 1841 | ++ |
+ #' # simple one level column space+ |
+
| 1842 | ++ |
+ #' rows <- lapply(1:5, function(i) {
+ |
+
| 1843 | ++ |
+ #' DataRow(rep(i, times = 3))+ |
+
| 1844 | ++ |
+ #' })+ |
+
| 1845 | ++ |
+ #' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
+ |
+
| 1846 | ++ |
+ #' tbl+ |
+
| 1847 | ++ |
+ #'+ |
+
| 1848 | ++ |
+ #' # manually declared nesting+ |
+
| 1849 | ++ |
+ #' tbl2 <- TableTree(+ |
+
| 1850 | ++ |
+ #' kids = list(DataRow(as.list(1:4))),+ |
+
| 1851 | ++ |
+ #' cinfo = manual_cols(+ |
+
| 1852 | ++ |
+ #' Arm = c("Arm A", "Arm B"),
+ |
+
| 1853 | ++ |
+ #' Gender = c("M", "F")
+ |
+
| 1854 | ++ |
+ #' )+ |
+
| 1855 | ++ |
+ #' )+ |
+
| 1856 | ++ |
+ #' tbl2+ |
+
| 1857 | ++ |
+ #'+ |
+
| 1858 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1859 | ++ |
+ #' @export+ |
+
| 1860 | ++ |
+ manual_cols <- function(..., .lst = list(...), ccount_format = NULL) {
+ |
+
| 1861 | +40x | +
+ if (is.null(names(.lst))) {
+ |
+
| 1862 | +40x | +
+ names(.lst) <- paste("colsplit", seq_along(.lst))
+ |
+
| 1863 | ++ |
+ }+ |
+
| 1864 | ++ | + + | +
| 1865 | +40x | +
+ splvec <- SplitVector(lst = mapply(ManualSplit,+ |
+
| 1866 | +40x | +
+ levels = .lst,+ |
+
| 1867 | +40x | +
+ label = names(.lst)+ |
+
| 1868 | ++ |
+ ))+ |
+
| 1869 | +40x | +
+ ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos(), global_cc_format = ccount_format)+ |
+
| 1870 | ++ | + + | +
| 1871 | +40x | +
+ ret <- InstantiatedColumnInfo(treelyt = ctree)+ |
+
| 1872 | +40x | +
+ rm_all_colcounts(ret)+ |
+
| 1873 | ++ |
+ }+ |
+
| 1874 | ++ | + + | +
| 1875 | ++ | + + | +
| 1876 | ++ |
+ #' Set all column counts at all levels of nesting to NA+ |
+
| 1877 | ++ |
+ #'+ |
+
| 1878 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1879 | ++ |
+ #'+ |
+
| 1880 | ++ |
+ #' @return `obj` with all column counts reset to missing+ |
+
| 1881 | ++ |
+ #'+ |
+
| 1882 | ++ |
+ #' @export+ |
+
| 1883 | ++ |
+ #' @examples+ |
+
| 1884 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1885 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1886 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 1887 | ++ |
+ #' analyze("AGE")
+ |
+
| 1888 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 1889 | ++ |
+ #'+ |
+
| 1890 | ++ |
+ #' # before+ |
+
| 1891 | ++ |
+ #' col_counts(tbl)+ |
+
| 1892 | ++ |
+ #' tbl <- rm_all_colcounts(tbl)+ |
+
| 1893 | ++ |
+ #' col_counts(tbl)+ |
+
| 1894 | +215x | +
+ setGeneric("rm_all_colcounts", function(obj) standardGeneric("rm_all_colcounts"))
+ |
+
| 1895 | ++ | + + | +
| 1896 | ++ |
+ #' @rdname rm_all_colcounts+ |
+
| 1897 | ++ |
+ #' @export+ |
+
| 1898 | ++ |
+ setMethod(+ |
+
| 1899 | ++ |
+ "rm_all_colcounts", "VTableTree",+ |
+
| 1900 | ++ |
+ function(obj) {
+ |
+
| 1901 | +! | +
+ cinfo <- col_info(obj)+ |
+
| 1902 | +! | +
+ cinfo <- rm_all_colcounts(cinfo)+ |
+
| 1903 | +! | +
+ col_info(obj) <- cinfo+ |
+
| 1904 | +! | +
+ obj+ |
+
| 1905 | ++ |
+ }+ |
+
| 1906 | ++ |
+ )+ |
+
| 1907 | ++ | + + | +
| 1908 | ++ |
+ #' @rdname rm_all_colcounts+ |
+
| 1909 | ++ |
+ #' @export+ |
+
| 1910 | ++ |
+ setMethod(+ |
+
| 1911 | ++ |
+ "rm_all_colcounts", "InstantiatedColumnInfo",+ |
+
| 1912 | ++ |
+ function(obj) {
+ |
+
| 1913 | +40x | +
+ ctree <- coltree(obj)+ |
+
| 1914 | +40x | +
+ ctree <- rm_all_colcounts(ctree)+ |
+
| 1915 | +40x | +
+ coltree(obj) <- ctree+ |
+
| 1916 | +40x | +
+ obj+ |
+
| 1917 | ++ |
+ }+ |
+
| 1918 | ++ |
+ )+ |
+
| 1919 | ++ | + + | +
| 1920 | ++ |
+ #' @rdname rm_all_colcounts+ |
+
| 1921 | ++ |
+ #' @export+ |
+
| 1922 | ++ |
+ setMethod(+ |
+
| 1923 | ++ |
+ "rm_all_colcounts", "LayoutColTree",+ |
+
| 1924 | ++ |
+ function(obj) {
+ |
+
| 1925 | +51x | +
+ obj@column_count <- NA_integer_+ |
+
| 1926 | +51x | +
+ tree_children(obj) <- lapply(tree_children(obj), rm_all_colcounts)+ |
+
| 1927 | +51x | +
+ obj+ |
+
| 1928 | ++ |
+ }+ |
+
| 1929 | ++ |
+ )+ |
+
| 1930 | ++ | + + | +
| 1931 | ++ |
+ #' @rdname rm_all_colcounts+ |
+
| 1932 | ++ |
+ #' @export+ |
+
| 1933 | ++ |
+ setMethod(+ |
+
| 1934 | ++ |
+ "rm_all_colcounts", "LayoutColLeaf",+ |
+
| 1935 | ++ |
+ function(obj) {
+ |
+
| 1936 | +124x | +
+ obj@column_count <- NA_integer_+ |
+
| 1937 | +124x | +
+ obj+ |
+
| 1938 | ++ |
+ }+ |
+
| 1939 | ++ |
+ )+ |
+
| 1940 | ++ | + + | +
| 1941 | ++ |
+ #' Returns a function that coerces the return values of a function to a list+ |
+
| 1942 | ++ |
+ #'+ |
+
| 1943 | ++ |
+ #' @param f (`function`)\cr the function to wrap.+ |
+
| 1944 | ++ |
+ #'+ |
+
| 1945 | ++ |
+ #' @details+ |
+
| 1946 | ++ |
+ #' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an+ |
+
| 1947 | ++ |
+ #' otherwise identical wrapper function whose first argument is named `df`.+ |
+
| 1948 | ++ |
+ #'+ |
+
| 1949 | ++ |
+ #' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as+ |
+
| 1950 | ++ |
+ #' their first argument are passed the full subset data frame, while those which accept anything else notably+ |
+
| 1951 | ++ |
+ #' including `x` are passed only the relevant subset of the variable being analyzed.+ |
+
| 1952 | ++ |
+ #'+ |
+
| 1953 | ++ |
+ #' @return A function that returns a list of `CellValue` objects.+ |
+
| 1954 | ++ |
+ #'+ |
+
| 1955 | ++ |
+ #' @examples+ |
+
| 1956 | ++ |
+ #' summary(iris$Sepal.Length)+ |
+
| 1957 | ++ |
+ #'+ |
+
| 1958 | ++ |
+ #' f <- list_wrap_x(summary)+ |
+
| 1959 | ++ |
+ #' f(x = iris$Sepal.Length)+ |
+
| 1960 | ++ |
+ #'+ |
+
| 1961 | ++ |
+ #' f2 <- list_wrap_df(summary)+ |
+
| 1962 | ++ |
+ #' f2(df = iris$Sepal.Length)+ |
+
| 1963 | ++ |
+ #'+ |
+
| 1964 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1965 | ++ |
+ #' @rdname list_wrap+ |
+
| 1966 | ++ |
+ #' @export+ |
+
| 1967 | ++ |
+ list_wrap_x <- function(f) {
+ |
+
| 1968 | +16x | +
+ function(x, ...) {
+ |
+
| 1969 | +70x | +
+ vs <- as.list(f(x, ...))+ |
+
| 1970 | +70x | +
+ ret <- mapply(+ |
+
| 1971 | +70x | +
+ function(v, nm) {
+ |
+
| 1972 | +250x | +
+ rcell(v, label = nm)+ |
+
| 1973 | ++ |
+ },+ |
+
| 1974 | +70x | +
+ v = vs,+ |
+
| 1975 | +70x | +
+ nm = names(vs)+ |
+
| 1976 | ++ |
+ )+ |
+
| 1977 | +70x | +
+ ret+ |
+
| 1978 | ++ |
+ }+ |
+
| 1979 | ++ |
+ }+ |
+
| 1980 | ++ | + + | +
| 1981 | ++ |
+ #' @rdname list_wrap+ |
+
| 1982 | ++ |
+ #' @export+ |
+
| 1983 | ++ |
+ list_wrap_df <- function(f) {
+ |
+
| 1984 | +1x | +
+ function(df, ...) {
+ |
+
| 1985 | +1x | +
+ vs <- as.list(f(df, ...))+ |
+
| 1986 | +1x | +
+ ret <- mapply(+ |
+
| 1987 | +1x | +
+ function(v, nm) {
+ |
+
| 1988 | +6x | +
+ rcell(v, label = nm)+ |
+
| 1989 | ++ |
+ },+ |
+
| 1990 | +1x | +
+ v = vs,+ |
+
| 1991 | +1x | +
+ nm = names(vs)+ |
+
| 1992 | ++ |
+ )+ |
+
| 1993 | +1x | +
+ ret+ |
+
| 1994 | ++ |
+ }+ |
+
| 1995 | ++ |
+ }+ |
+
| 1996 | ++ | + + | +
| 1997 | ++ |
+ #' Layout with 1 column and zero rows+ |
+
| 1998 | ++ |
+ #'+ |
+
| 1999 | ++ |
+ #' Every layout must start with a basic table.+ |
+
| 2000 | ++ |
+ #'+ |
+
| 2001 | ++ |
+ #' @inheritParams constr_args+ |
+
| 2002 | ++ |
+ #' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of+ |
+
| 2003 | ++ |
+ #' applied to data. `NA`, the default, indicates that the `show_colcounts`+ |
+
| 2004 | ++ |
+ #' argument(s) passed to the relevant calls to `split_cols_by*`+ |
+
| 2005 | ++ |
+ #' functions. Non-missing values will override the behavior specified in+ |
+
| 2006 | ++ |
+ #' column splitting layout instructions which create the lowest level, or+ |
+
| 2007 | ++ |
+ #' leaf, columns.+ |
+
| 2008 | ++ |
+ #' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d+ |
+
| 2009 | ++ |
+ #' where one component is a percent. This will also apply to any displayed higher+ |
+
| 2010 | ++ |
+ #' level column counts where an explicit format was not specified. Defaults to `"(N=xx)"`. See Details below.+ |
+
| 2011 | ++ |
+ #' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split+ |
+
| 2012 | ++ |
+ #' or division of the table will be highlighted by a line made of that character. See [section_div] for more+ |
+
| 2013 | ++ |
+ #' information.+ |
+
| 2014 | ++ |
+ #'+ |
+
| 2015 | ++ |
+ #' @details+ |
+
| 2016 | ++ |
+ #' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`,+ |
+
| 2017 | ++ |
+ #' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always+ |
+
| 2018 | ++ |
+ #' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be,+ |
+
| 2019 | ++ |
+ #' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of+ |
+
| 2020 | ++ |
+ #' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list+ |
+
| 2021 | ++ |
+ #' of valid format labels to select from.+ |
+
| 2022 | ++ |
+ #'+ |
+
| 2023 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 2024 | ++ |
+ #'+ |
+
| 2025 | ++ |
+ #' @note+ |
+
| 2026 | ++ |
+ #' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably+ |
+
| 2027 | ++ |
+ #' strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as+ |
+
| 2028 | ++ |
+ #' their percentage, even though the individual arm columns represent strict subsets of the "all patients" column.+ |
+
| 2029 | ++ |
+ #'+ |
+
| 2030 | ++ |
+ #' - Note that subtitles ([formatters::subtitles()]) and footers ([formatters::main_footer()] and+ |
+
| 2031 | ++ |
+ #' [formatters::prov_footer()]) that span more than one line can be supplied as a character vector to maintain+ |
+
| 2032 | ++ |
+ #' indentation on multiple lines.+ |
+
| 2033 | ++ |
+ #'+ |
+
| 2034 | ++ |
+ #' @examples+ |
+
| 2035 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 2036 | ++ |
+ #' analyze("AGE", afun = mean)
+ |
+
| 2037 | ++ |
+ #'+ |
+
| 2038 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 2039 | ++ |
+ #' tbl+ |
+
| 2040 | ++ |
+ #'+ |
+
| 2041 | ++ |
+ #' lyt2 <- basic_table(+ |
+
| 2042 | ++ |
+ #' title = "Title of table",+ |
+
| 2043 | ++ |
+ #' subtitles = c("a number", "of subtitles"),
+ |
+
| 2044 | ++ |
+ #' main_footer = "test footer",+ |
+
| 2045 | ++ |
+ #' prov_footer = paste(+ |
+
| 2046 | ++ |
+ #' "test.R program, executed at",+ |
+
| 2047 | ++ |
+ #' Sys.time()+ |
+
| 2048 | ++ |
+ #' )+ |
+
| 2049 | ++ |
+ #' ) %>%+ |
+
| 2050 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 2051 | ++ |
+ #' analyze("AGE", mean)
+ |
+
| 2052 | ++ |
+ #'+ |
+
| 2053 | ++ |
+ #' tbl2 <- build_table(lyt2, DM)+ |
+
| 2054 | ++ |
+ #' tbl2+ |
+
| 2055 | ++ |
+ #'+ |
+
| 2056 | ++ |
+ #' lyt3 <- basic_table(+ |
+
| 2057 | ++ |
+ #' show_colcounts = TRUE,+ |
+
| 2058 | ++ |
+ #' colcount_format = "xx. (xx.%)"+ |
+
| 2059 | ++ |
+ #' ) %>%+ |
+
| 2060 | ++ |
+ #' split_cols_by("ARM")
+ |
+
| 2061 | ++ |
+ #'+ |
+
| 2062 | ++ |
+ #' @export+ |
+
| 2063 | ++ |
+ basic_table <- function(title = "",+ |
+
| 2064 | ++ |
+ subtitles = character(),+ |
+
| 2065 | ++ |
+ main_footer = character(),+ |
+
| 2066 | ++ |
+ prov_footer = character(),+ |
+
| 2067 | ++ |
+ show_colcounts = NA, # FALSE,+ |
+
| 2068 | ++ |
+ colcount_format = "(N=xx)",+ |
+
| 2069 | ++ |
+ header_section_div = NA_character_,+ |
+
| 2070 | ++ |
+ top_level_section_div = NA_character_,+ |
+
| 2071 | ++ |
+ inset = 0L) {
+ |
+
| 2072 | +321x | +
+ inset <- as.integer(inset)+ |
+
| 2073 | +321x | +
+ if (is.na(inset) || inset < 0L) {
+ |
+
| 2074 | +2x | +
+ stop("Got invalid table_inset value, must be an integer > 0")
+ |
+
| 2075 | ++ |
+ }+ |
+
| 2076 | +319x | +
+ .check_header_section_div(header_section_div)+ |
+
| 2077 | +319x | +
+ checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1)+ |
+
| 2078 | ++ | + + | +
| 2079 | +319x | +
+ ret <- PreDataTableLayouts(+ |
+
| 2080 | +319x | +
+ title = title,+ |
+
| 2081 | +319x | +
+ subtitles = subtitles,+ |
+
| 2082 | +319x | +
+ main_footer = main_footer,+ |
+
| 2083 | +319x | +
+ prov_footer = prov_footer,+ |
+
| 2084 | +319x | +
+ header_section_div = header_section_div,+ |
+
| 2085 | +319x | +
+ top_level_section_div = top_level_section_div,+ |
+
| 2086 | +319x | +
+ table_inset = as.integer(inset)+ |
+
| 2087 | ++ |
+ )+ |
+
| 2088 | ++ | + + | +
| 2089 | ++ |
+ ## unconditional now, NA case is handled in cinfo construction+ |
+
| 2090 | +319x | +
+ disp_ccounts(ret) <- show_colcounts+ |
+
| 2091 | +319x | +
+ colcount_format(ret) <- colcount_format+ |
+
| 2092 | ++ |
+ ## if (isTRUE(show_colcounts)) {
+ |
+
| 2093 | ++ |
+ ## ret <- add_colcounts(ret, format = colcount_format)+ |
+
| 2094 | ++ |
+ ## }+ |
+
| 2095 | +319x | +
+ ret+ |
+
| 2096 | ++ |
+ }+ |
+
| 2097 | ++ | + + | +
| 2098 | ++ |
+ #' Append a description to the 'top-left' materials for the layout+ |
+
| 2099 | ++ |
+ #'+ |
+
| 2100 | ++ |
+ #' This function *adds* `newlines` to the current set of "top-left materials".+ |
+
| 2101 | ++ |
+ #'+ |
+
| 2102 | ++ |
+ #' @details+ |
+
| 2103 | ++ |
+ #' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content+ |
+
| 2104 | ++ |
+ #' displayed to the left of the column labels when the resulting tables are printed).+ |
+
| 2105 | ++ |
+ #'+ |
+
| 2106 | ++ |
+ #' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to+ |
+
| 2107 | ++ |
+ #' them either when they are added or when they are displayed.+ |
+
| 2108 | ++ |
+ #'+ |
+
| 2109 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 2110 | ++ |
+ #' @param newlines (`character`)\cr the new line(s) to be added to the materials.+ |
+
| 2111 | ++ |
+ #'+ |
+
| 2112 | ++ |
+ #' @note+ |
+
| 2113 | ++ |
+ #' Currently, where in the construction of the layout this is called makes no difference, as it is independent of+ |
+
| 2114 | ++ |
+ #' the actual splitting keywords. This may change in the future.+ |
+
| 2115 | ++ |
+ #'+ |
+
| 2116 | ++ |
+ #' This function is experimental, its name and the details of its behavior are subject to change in future versions.+ |
+
| 2117 | ++ |
+ #'+ |
+
| 2118 | ++ |
+ #' @inherit split_cols_by return+ |
+
| 2119 | ++ |
+ #'+ |
+
| 2120 | ++ |
+ #' @seealso [top_left()]+ |
+
| 2121 | ++ |
+ #'+ |
+
| 2122 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 2123 | ++ |
+ #' library(dplyr)+ |
+
| 2124 | ++ |
+ #'+ |
+
| 2125 | ++ |
+ #' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX))+ |
+
| 2126 | ++ |
+ #'+ |
+
| 2127 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 2128 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 2129 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 2130 | ++ |
+ #' split_rows_by("RACE") %>%
+ |
+
| 2131 | ++ |
+ #' append_topleft("Ethnicity") %>%
+ |
+
| 2132 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 2133 | ++ |
+ #' append_topleft(" Age")
+ |
+
| 2134 | ++ |
+ #'+ |
+
| 2135 | ++ |
+ #' tbl <- build_table(lyt, DM2)+ |
+
| 2136 | ++ |
+ #' tbl+ |
+
| 2137 | ++ |
+ #'+ |
+
| 2138 | ++ |
+ #' @export+ |
+
| 2139 | ++ |
+ append_topleft <- function(lyt, newlines) {
+ |
+
| 2140 | +51x | +
+ stopifnot(+ |
+
| 2141 | +51x | +
+ is(lyt, "PreDataTableLayouts"),+ |
+
| 2142 | +51x | +
+ is(newlines, "character")+ |
+
| 2143 | ++ |
+ )+ |
+
| 2144 | +51x | +
+ lyt@top_left <- c(lyt@top_left, newlines)+ |
+
| 2145 | +51x | +
+ lyt+ |
+
| 2146 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Internal generics and methods+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no+ |
+
| 4 | ++ |
+ #' attention to this documentation.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param x (`ANY`)\cr the object.+ |
+
| 7 | ++ |
+ #' @param obj (`ANY`)\cr the object.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @name internal_methods+ |
+
| 10 | ++ |
+ #' @rdname int_methods+ |
+
| 11 | ++ |
+ #' @aliases int_methods+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @rdname dimensions+ |
+
| 17 | ++ |
+ #' @exportMethod nrow+ |
+
| 18 | ++ |
+ setMethod(+ |
+
| 19 | ++ |
+ "nrow", "VTableTree",+ |
+
| 20 | +2186x | +
+ function(x) length(collect_leaves(x, TRUE, TRUE))+ |
+
| 21 | ++ |
+ )+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ #' @rdname int_methods+ |
+
| 24 | ++ |
+ #' @exportMethod nrow+ |
+
| 25 | ++ |
+ setMethod(+ |
+
| 26 | ++ |
+ "nrow", "TableRow",+ |
+
| 27 | +959x | +
+ function(x) 1L+ |
+
| 28 | ++ |
+ )+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ #' Table dimensions+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @param x (`TableTree` or `ElementaryTable`)\cr a table object.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @examples+ |
+
| 35 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 36 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 37 | ++ |
+ #' analyze(c("SEX", "AGE"))
+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' dim(tbl)+ |
+
| 42 | ++ |
+ #' nrow(tbl)+ |
+
| 43 | ++ |
+ #' ncol(tbl)+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' NROW(tbl)+ |
+
| 46 | ++ |
+ #' NCOL(tbl)+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @rdname dimensions+ |
+
| 49 | ++ |
+ #' @exportMethod ncol+ |
+
| 50 | ++ |
+ setMethod(+ |
+
| 51 | ++ |
+ "ncol", "VTableNodeInfo",+ |
+
| 52 | ++ |
+ function(x) {
+ |
+
| 53 | +22105x | +
+ ncol(col_info(x))+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ |
+ )+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ #' @rdname int_methods+ |
+
| 58 | ++ |
+ #' @exportMethod ncol+ |
+
| 59 | ++ |
+ setMethod(+ |
+
| 60 | ++ |
+ "ncol", "TableRow",+ |
+
| 61 | ++ |
+ function(x) {
+ |
+
| 62 | +65920x | +
+ if (!no_colinfo(x)) {
+ |
+
| 63 | +64984x | +
+ ncol(col_info(x))+ |
+
| 64 | ++ |
+ } else {
+ |
+
| 65 | +936x | +
+ length(spanned_values(x))+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ |
+ )+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ #' @rdname int_methods+ |
+
| 71 | ++ |
+ #' @exportMethod ncol+ |
+
| 72 | ++ |
+ setMethod(+ |
+
| 73 | ++ |
+ "ncol", "LabelRow",+ |
+
| 74 | ++ |
+ function(x) {
+ |
+
| 75 | +20749x | +
+ ncol(col_info(x))+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ #' @rdname int_methods+ |
+
| 80 | ++ |
+ #' @exportMethod ncol+ |
+
| 81 | ++ |
+ setMethod(+ |
+
| 82 | ++ |
+ "ncol", "InstantiatedColumnInfo",+ |
+
| 83 | ++ |
+ function(x) {
+ |
+
| 84 | +109862x | +
+ length(col_exprs(x))+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ #' @rdname dimensions+ |
+
| 89 | ++ |
+ #' @exportMethod dim+ |
+
| 90 | ++ |
+ setMethod(+ |
+
| 91 | ++ |
+ "dim", "VTableNodeInfo",+ |
+
| 92 | +18172x | +
+ function(x) c(nrow(x), ncol(x))+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ #' Retrieve or set the direct children of a tree-style object+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure.+ |
+
| 98 | ++ |
+ #' @param value (`list`)\cr new list of children.+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @return A list of direct children of `x`.+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' @export+ |
+
| 103 | ++ |
+ #' @rdname tree_children+ |
+
| 104 | +234942x | +
+ setGeneric("tree_children", function(x) standardGeneric("tree_children"))
+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ #' @exportMethod tree_children+ |
+
| 107 | ++ |
+ #' @rdname int_methods+ |
+
| 108 | ++ |
+ setMethod(+ |
+
| 109 | ++ |
+ "tree_children", c(x = "VTree"),+ |
+
| 110 | +! | +
+ function(x) x@children+ |
+
| 111 | ++ |
+ )+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ #' @exportMethod tree_children+ |
+
| 114 | ++ |
+ #' @rdname int_methods+ |
+
| 115 | ++ |
+ setMethod(+ |
+
| 116 | ++ |
+ "tree_children", c(x = "VTableTree"),+ |
+
| 117 | +62094x | +
+ function(x) x@children+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ ## this includes VLeaf but also allows for general methods+ |
+
| 121 | ++ |
+ ## needed for table_inset being carried around by rows and+ |
+
| 122 | ++ |
+ ## such.+ |
+
| 123 | ++ |
+ #' @exportMethod tree_children+ |
+
| 124 | ++ |
+ #' @rdname int_methods+ |
+
| 125 | ++ |
+ setMethod(+ |
+
| 126 | ++ |
+ "tree_children", c(x = "ANY"), ## "VLeaf"),+ |
+
| 127 | +11924x | +
+ function(x) list()+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ #' @export+ |
+
| 131 | ++ |
+ #' @rdname tree_children+ |
+
| 132 | +56871x | +
+ setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))
+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @exportMethod tree_children<-+ |
+
| 135 | ++ |
+ #' @rdname int_methods+ |
+
| 136 | ++ |
+ setMethod(+ |
+
| 137 | ++ |
+ "tree_children<-", c(x = "VTree"),+ |
+
| 138 | ++ |
+ function(x, value) {
+ |
+
| 139 | +! | +
+ x@children <- value+ |
+
| 140 | +! | +
+ x+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ |
+ )+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ #' @exportMethod tree_children<-+ |
+
| 145 | ++ |
+ #' @rdname int_methods+ |
+
| 146 | ++ |
+ setMethod(+ |
+
| 147 | ++ |
+ "tree_children<-", c(x = "VTableTree"),+ |
+
| 148 | ++ |
+ function(x, value) {
+ |
+
| 149 | +51444x | +
+ x@children <- value+ |
+
| 150 | +51444x | +
+ x+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ |
+ )+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ #' Retrieve or set content table from a `TableTree`+ |
+
| 155 | ++ |
+ #'+ |
+
| 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 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not+ |
+
| 161 | ++ |
+ #' a formal table object).+ |
+
| 162 | ++ |
+ #'+ |
+
| 163 | ++ |
+ #' @export+ |
+
| 164 | ++ |
+ #' @rdname content_table+ |
+
| 165 | +87256x | +
+ setGeneric("content_table", function(obj) standardGeneric("content_table"))
+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ #' @exportMethod content_table+ |
+
| 168 | ++ |
+ #' @rdname int_methods+ |
+
| 169 | ++ |
+ setMethod(+ |
+
| 170 | ++ |
+ "content_table", "TableTree",+ |
+
| 171 | +56729x | +
+ function(obj) obj@content+ |
+
| 172 | ++ |
+ )+ |
+
| 173 | ++ | + + | +
| 174 | ++ |
+ #' @exportMethod content_table+ |
+
| 175 | ++ |
+ #' @rdname int_methods+ |
+
| 176 | ++ |
+ setMethod(+ |
+
| 177 | ++ |
+ "content_table", "ANY",+ |
+
| 178 | +10708x | +
+ function(obj) NULL+ |
+
| 179 | ++ |
+ )+ |
+
| 180 | ++ | + + | +
| 181 | ++ |
+ #' @param value (`ElementaryTable`)\cr the new content table for `obj`.+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #' @export+ |
+
| 184 | ++ |
+ #' @rdname content_table+ |
+
| 185 | +6315x | +
+ setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))
+ |
+
| 186 | ++ | + + | +
| 187 | ++ |
+ #' @exportMethod "content_table<-"+ |
+
| 188 | ++ |
+ #' @rdname int_methods+ |
+
| 189 | ++ |
+ setMethod(+ |
+
| 190 | ++ |
+ "content_table<-", c("TableTree", "ElementaryTable"),
+ |
+
| 191 | ++ |
+ function(obj, value) {
+ |
+
| 192 | +6315x | +
+ obj@content <- value+ |
+
| 193 | +6315x | +
+ obj+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | ++ | + + | +
| 197 | ++ |
+ #' @param for_analyze (`flag`) whether split is an analyze split.+ |
+
| 198 | ++ |
+ #' @rdname int_methods+ |
+
| 199 | +1109x | +
+ setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))
+ |
+
| 200 | ++ | + + | +
| 201 | ++ |
+ #' @rdname int_methods+ |
+
| 202 | ++ |
+ setMethod(+ |
+
| 203 | ++ |
+ "next_rpos", "PreDataTableLayouts",+ |
+
| 204 | ++ |
+ function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze)+ |
+
| 205 | ++ |
+ )+ |
+
| 206 | ++ | + + | +
| 207 | ++ |
+ .check_if_nest <- function(obj, nested, for_analyze) {
+ |
+
| 208 | +251x | +
+ if (!nested) {
+ |
+
| 209 | +16x | +
+ FALSE+ |
+
| 210 | ++ |
+ } else {
+ |
+
| 211 | ++ |
+ ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?)+ |
+
| 212 | +235x | +
+ for_analyze ||+ |
+
| 213 | ++ |
+ ## If its not an analyze split it can't go under an analyze split+ |
+
| 214 | +235x | +
+ !(is(last_rowsplit(obj), "VAnalyzeSplit") ||+ |
+
| 215 | +235x | +
+ is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint+ |
+
| 216 | ++ |
+ }+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ #' @rdname int_methods+ |
+
| 220 | ++ |
+ setMethod(+ |
+
| 221 | ++ |
+ "next_rpos", "PreDataRowLayout",+ |
+
| 222 | ++ |
+ function(obj, nested, for_analyze) {
+ |
+
| 223 | +554x | +
+ l <- length(obj)+ |
+
| 224 | +554x | +
+ if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
+ |
+
| 225 | +25x | +
+ l <- l + 1L+ |
+
| 226 | ++ |
+ }+ |
+
| 227 | +554x | +
+ l+ |
+
| 228 | ++ |
+ }+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ | + + | +
| 231 | ++ |
+ #' @rdname int_methods+ |
+
| 232 | +1x | +
+ setMethod("next_rpos", "ANY", function(obj, nested) 1L)
+ |
+
| 233 | ++ | + + | +
| 234 | ++ |
+ #' @rdname int_methods+ |
+
| 235 | +623x | +
+ setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))
+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ #' @rdname int_methods+ |
+
| 238 | ++ |
+ setMethod(+ |
+
| 239 | ++ |
+ "next_cpos", "PreDataTableLayouts",+ |
+
| 240 | ++ |
+ function(obj, nested) next_cpos(clayout(obj), nested)+ |
+
| 241 | ++ |
+ )+ |
+
| 242 | ++ | + + | +
| 243 | ++ |
+ #' @rdname int_methods+ |
+
| 244 | ++ |
+ setMethod(+ |
+
| 245 | ++ |
+ "next_cpos", "PreDataColLayout",+ |
+
| 246 | ++ |
+ function(obj, nested) {
+ |
+
| 247 | +311x | +
+ if (nested || length(obj[[length(obj)]]) == 0) {
+ |
+
| 248 | +303x | +
+ length(obj)+ |
+
| 249 | ++ |
+ } else {
+ |
+
| 250 | +8x | +
+ length(obj) + 1L+ |
+
| 251 | ++ |
+ }+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ |
+ )+ |
+
| 254 | ++ | + + | +
| 255 | ++ |
+ #' @rdname int_methods+ |
+
| 256 | ++ |
+ setMethod("next_cpos", "ANY", function(obj, nested) 1L)
+ |
+
| 257 | ++ | + + | +
| 258 | ++ |
+ #' @rdname int_methods+ |
+
| 259 | +2581x | +
+ setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))
+ |
+
| 260 | ++ | + + | +
| 261 | ++ |
+ #' @rdname int_methods+ |
+
| 262 | ++ |
+ setMethod(+ |
+
| 263 | ++ |
+ "last_rowsplit", "NULL",+ |
+
| 264 | +! | +
+ function(obj) NULL+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | ++ | + + | +
| 267 | ++ |
+ #' @rdname int_methods+ |
+
| 268 | ++ |
+ setMethod(+ |
+
| 269 | ++ |
+ "last_rowsplit", "SplitVector",+ |
+
| 270 | ++ |
+ function(obj) {
+ |
+
| 271 | +1011x | +
+ if (length(obj) == 0) {
+ |
+
| 272 | +222x | +
+ NULL+ |
+
| 273 | ++ |
+ } else {
+ |
+
| 274 | +789x | +
+ obj[[length(obj)]]+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ |
+ }+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ #' @rdname int_methods+ |
+
| 280 | ++ |
+ setMethod(+ |
+
| 281 | ++ |
+ "last_rowsplit", "PreDataRowLayout",+ |
+
| 282 | ++ |
+ function(obj) {
+ |
+
| 283 | +1011x | +
+ if (length(obj) == 0) {
+ |
+
| 284 | +! | +
+ NULL+ |
+
| 285 | ++ |
+ } else {
+ |
+
| 286 | +1011x | +
+ last_rowsplit(obj[[length(obj)]])+ |
+
| 287 | ++ |
+ }+ |
+
| 288 | ++ |
+ }+ |
+
| 289 | ++ |
+ )+ |
+
| 290 | ++ | + + | +
| 291 | ++ |
+ #' @rdname int_methods+ |
+
| 292 | ++ |
+ setMethod(+ |
+
| 293 | ++ |
+ "last_rowsplit", "PreDataTableLayouts",+ |
+
| 294 | +557x | +
+ function(obj) last_rowsplit(rlayout(obj))+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ # rlayout ----+ |
+
| 298 | ++ |
+ ## TODO maybe export these?+ |
+
| 299 | ++ | + + | +
| 300 | ++ |
+ #' @rdname int_methods+ |
+
| 301 | +3809x | +
+ setGeneric("rlayout", function(obj) standardGeneric("rlayout"))
+ |
+
| 302 | ++ | + + | +
| 303 | ++ |
+ #' @rdname int_methods+ |
+
| 304 | ++ |
+ setMethod(+ |
+
| 305 | ++ |
+ "rlayout", "PreDataTableLayouts",+ |
+
| 306 | +3809x | +
+ function(obj) obj@row_layout+ |
+
| 307 | ++ |
+ )+ |
+
| 308 | ++ | + + | +
| 309 | ++ |
+ #' @rdname int_methods+ |
+
| 310 | +! | +
+ setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())
+ |
+
| 311 | ++ | + + | +
| 312 | ++ |
+ #' @rdname int_methods+ |
+
| 313 | +1701x | +
+ setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))
+ |
+
| 314 | ++ | + + | +
| 315 | ++ |
+ #' @rdname int_methods+ |
+
| 316 | ++ |
+ setMethod(+ |
+
| 317 | ++ |
+ "rlayout<-", "PreDataTableLayouts",+ |
+
| 318 | ++ |
+ function(object, value) {
+ |
+
| 319 | +1701x | +
+ object@row_layout <- value+ |
+
| 320 | +1701x | +
+ object+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | ++ |
+ )+ |
+
| 323 | ++ | + + | +
| 324 | ++ |
+ #' @rdname int_methods+ |
+
| 325 | +62517x | +
+ setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))
+ |
+
| 326 | ++ | + + | +
| 327 | ++ |
+ ## setMethod("tree_pos", "VNodeInfo",
+ |
+
| 328 | ++ |
+ ## function(obj) obj@pos_in_tree)+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ #' @rdname int_methods+ |
+
| 331 | ++ |
+ setMethod(+ |
+
| 332 | ++ |
+ "tree_pos", "VLayoutNode",+ |
+
| 333 | +! | +
+ function(obj) obj@pos_in_tree+ |
+
| 334 | ++ |
+ )+ |
+
| 335 | ++ | + + | +
| 336 | ++ |
+ #' @rdname int_methods+ |
+
| 337 | +1367x | +
+ setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))
+ |
+
| 338 | ++ | + + | +
| 339 | ++ |
+ #' @rdname int_methods+ |
+
| 340 | ++ |
+ setMethod(+ |
+
| 341 | ++ |
+ "pos_subset", "TreePos",+ |
+
| 342 | +1367x | +
+ function(obj) obj@subset+ |
+
| 343 | ++ |
+ )+ |
+
| 344 | ++ | + + | +
| 345 | ++ |
+ #' @rdname int_methods+ |
+
| 346 | +101x | +
+ setGeneric("tree_pos<-", function(obj, value) standardGeneric("tree_pos<-"))
+ |
+
| 347 | ++ | + + | +
| 348 | ++ |
+ #' @rdname int_methods+ |
+
| 349 | ++ |
+ setMethod(+ |
+
| 350 | ++ |
+ "tree_pos<-", "VLayoutNode",+ |
+
| 351 | ++ |
+ function(obj, value) {
+ |
+
| 352 | +101x | +
+ obj@pos_in_tree <- value+ |
+
| 353 | +101x | +
+ obj+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | ++ |
+ )+ |
+
| 356 | ++ | + + | +
| 357 | ++ |
+ ## setMethod("pos_subset", "VNodeInfo",
+ |
+
| 358 | ++ |
+ ## function(obj) pos_subset(tree_pos(obj)))+ |
+
| 359 | ++ | + + | +
| 360 | ++ |
+ #' @rdname int_methods+ |
+
| 361 | ++ |
+ setMethod(+ |
+
| 362 | ++ |
+ "pos_subset", "VLayoutNode",+ |
+
| 363 | +! | +
+ function(obj) pos_subset(tree_pos(obj))+ |
+
| 364 | ++ |
+ )+ |
+
| 365 | ++ | + + | +
| 366 | ++ |
+ #' @rdname int_methods+ |
+
| 367 | +50691x | +
+ setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))
+ |
+
| 368 | ++ | + + | +
| 369 | ++ |
+ #' @rdname int_methods+ |
+
| 370 | ++ |
+ setMethod(+ |
+
| 371 | ++ |
+ "pos_splits", "TreePos",+ |
+
| 372 | +50691x | +
+ function(obj) obj@splits+ |
+
| 373 | ++ |
+ )+ |
+
| 374 | ++ | + + | +
| 375 | ++ |
+ ## setMethod("pos_splits", "VNodeInfo",
+ |
+
| 376 | ++ |
+ ## function(obj) pos_splits(tree_pos(obj)))+ |
+
| 377 | ++ | + + | +
| 378 | ++ |
+ #' @rdname int_methods+ |
+
| 379 | ++ |
+ setMethod(+ |
+
| 380 | ++ |
+ "pos_splits", "VLayoutNode",+ |
+
| 381 | +! | +
+ function(obj) pos_splits(tree_pos(obj))+ |
+
| 382 | ++ |
+ )+ |
+
| 383 | ++ | + + | +
| 384 | ++ |
+ #' @rdname int_methods+ |
+
| 385 | +101x | +
+ setGeneric("pos_splits<-", function(obj, value) standardGeneric("pos_splits<-"))
+ |
+
| 386 | ++ | + + | +
| 387 | ++ |
+ #' @rdname int_methods+ |
+
| 388 | ++ |
+ setMethod(+ |
+
| 389 | ++ |
+ "pos_splits<-", "TreePos",+ |
+
| 390 | ++ |
+ function(obj, value) {
+ |
+
| 391 | +101x | +
+ obj@splits <- value+ |
+
| 392 | +101x | +
+ obj+ |
+
| 393 | ++ |
+ }+ |
+
| 394 | ++ |
+ )+ |
+
| 395 | ++ | + + | +
| 396 | ++ |
+ #' @rdname int_methods+ |
+
| 397 | ++ |
+ setMethod(+ |
+
| 398 | ++ |
+ "pos_splits<-", "VLayoutNode",+ |
+
| 399 | ++ |
+ function(obj, value) {
+ |
+
| 400 | +! | +
+ pos <- tree_pos(obj)+ |
+
| 401 | +! | +
+ pos_splits(pos) <- value+ |
+
| 402 | +! | +
+ tree_pos(obj) <- pos+ |
+
| 403 | +! | +
+ obj+ |
+
| 404 | +! | +
+ obj+ |
+
| 405 | ++ |
+ }+ |
+
| 406 | ++ |
+ )+ |
+
| 407 | ++ | + + | +
| 408 | ++ | + + | +
| 409 | ++ | + + | +
| 410 | ++ | + + | +
| 411 | ++ |
+ #' @rdname int_methods+ |
+
| 412 | +57004x | +
+ setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))
+ |
+
| 413 | ++ | + + | +
| 414 | ++ |
+ #' @rdname int_methods+ |
+
| 415 | ++ |
+ setMethod(+ |
+
| 416 | ++ |
+ "pos_splvals", "TreePos",+ |
+
| 417 | +57004x | +
+ function(obj) obj@s_values+ |
+
| 418 | ++ |
+ )+ |
+
| 419 | ++ | + + | +
| 420 | ++ |
+ ## setMethod("pos_splvals", "VNodeInfo",
+ |
+
| 421 | ++ |
+ ## function(obj) pos_splvals(tree_pos(obj)))+ |
+
| 422 | ++ | + + | +
| 423 | ++ |
+ #' @rdname int_methods+ |
+
| 424 | ++ |
+ setMethod(+ |
+
| 425 | ++ |
+ "pos_splvals", "VLayoutNode",+ |
+
| 426 | +! | +
+ function(obj) pos_splvals(tree_pos(obj))+ |
+
| 427 | ++ |
+ )+ |
+
| 428 | ++ | + + | +
| 429 | ++ |
+ #' @rdname int_methods+ |
+
| 430 | +101x | +
+ setGeneric("pos_splvals<-", function(obj, value) standardGeneric("pos_splvals<-"))
+ |
+
| 431 | ++ | + + | +
| 432 | ++ |
+ #' @rdname int_methods+ |
+
| 433 | ++ |
+ setMethod(+ |
+
| 434 | ++ |
+ "pos_splvals<-", "TreePos",+ |
+
| 435 | ++ |
+ function(obj, value) {
+ |
+
| 436 | +101x | +
+ obj@s_values <- value+ |
+
| 437 | +101x | +
+ obj+ |
+
| 438 | ++ |
+ }+ |
+
| 439 | ++ |
+ )+ |
+
| 440 | ++ | + + | +
| 441 | ++ |
+ ## setMethod("pos_splvals", "VNodeInfo",
+ |
+
| 442 | ++ |
+ ## function(obj) pos_splvals(tree_pos(obj)))+ |
+
| 443 | ++ | + + | +
| 444 | ++ |
+ #' @rdname int_methods+ |
+
| 445 | ++ |
+ setMethod(+ |
+
| 446 | ++ |
+ "pos_splvals<-", "VLayoutNode",+ |
+
| 447 | ++ |
+ function(obj, value) {
+ |
+
| 448 | +! | +
+ pos <- tree_pos(obj)+ |
+
| 449 | +! | +
+ pos_splvals(pos) <- value+ |
+
| 450 | +! | +
+ tree_pos(obj) <- pos+ |
+
| 451 | +! | +
+ obj+ |
+
| 452 | ++ |
+ }+ |
+
| 453 | ++ |
+ )+ |
+
| 454 | ++ | + + | +
| 455 | ++ | + + | +
| 456 | ++ |
+ #' @rdname int_methods+ |
+
| 457 | +1367x | +
+ setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))
+ |
+
| 458 | ++ | + + | +
| 459 | ++ |
+ #' @rdname int_methods+ |
+
| 460 | ++ |
+ setMethod(+ |
+
| 461 | ++ |
+ "pos_splval_labels", "TreePos",+ |
+
| 462 | +1367x | +
+ function(obj) obj@sval_labels+ |
+
| 463 | ++ |
+ )+ |
+
| 464 | ++ |
+ ## no longer used+ |
+
| 465 | ++ | + + | +
| 466 | ++ |
+ ## setMethod("pos_splval_labels", "VNodeInfo",
+ |
+
| 467 | ++ |
+ ## function(obj) pos_splval_labels(tree_pos(obj)))+ |
+
| 468 | ++ |
+ ## #' @rdname int_methods+ |
+
| 469 | ++ |
+ ## setMethod("pos_splval_labels", "VLayoutNode",
+ |
+
| 470 | ++ |
+ ## function(obj) pos_splval_labels(tree_pos(obj)))+ |
+
| 471 | ++ | + + | +
| 472 | ++ |
+ #' @rdname int_methods+ |
+
| 473 | +14778x | +
+ setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))
+ |
+
| 474 | ++ | + + | +
| 475 | ++ |
+ #' @rdname int_methods+ |
+
| 476 | +14778x | +
+ setMethod("spl_payload", "Split", function(obj) obj@payload)
+ |
+
| 477 | ++ | + + | +
| 478 | ++ |
+ #' @rdname int_methods+ |
+
| 479 | +3x | +
+ setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))
+ |
+
| 480 | ++ | + + | +
| 481 | ++ |
+ #' @rdname int_methods+ |
+
| 482 | ++ |
+ setMethod("spl_payload<-", "Split", function(obj, value) {
+ |
+
| 483 | +3x | +
+ obj@payload <- value+ |
+
| 484 | +3x | +
+ obj+ |
+
| 485 | ++ |
+ })+ |
+
| 486 | ++ | + + | +
| 487 | ++ |
+ #' @rdname int_methods+ |
+
| 488 | +715x | +
+ setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))
+ |
+
| 489 | ++ | + + | +
| 490 | ++ |
+ #' @rdname int_methods+ |
+
| 491 | +712x | +
+ setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)
+ |
+
| 492 | ++ | + + | +
| 493 | ++ |
+ ## TODO revisit. do we want to do this? used in vars_in_layout, but only+ |
+
| 494 | ++ |
+ ## for convenience.+ |
+
| 495 | ++ |
+ #' @rdname int_methods+ |
+
| 496 | +3x | +
+ setMethod("spl_label_var", "Split", function(obj) NULL)
+ |
+
| 497 | ++ | + + | +
| 498 | ++ |
+ ### name related things+ |
+
| 499 | ++ |
+ # #' @inherit formatters::formatter_methods+ |
+
| 500 | ++ |
+ #' Methods for generics in the `formatters` package+ |
+
| 501 | ++ |
+ #'+ |
+
| 502 | ++ |
+ #' See the `formatters` documentation for descriptions of these generics.+ |
+
| 503 | ++ |
+ #'+ |
+
| 504 | ++ |
+ #' @inheritParams gen_args+ |
+
| 505 | ++ |
+ #'+ |
+
| 506 | ++ |
+ #' @return+ |
+
| 507 | ++ |
+ #' * Accessor functions return the current value of the component being accessed of `obj`+ |
+
| 508 | ++ |
+ #' * Setter functions return a modified copy of `obj` with the new value.+ |
+
| 509 | ++ |
+ #'+ |
+
| 510 | ++ |
+ #' @rdname formatters_methods+ |
+
| 511 | ++ |
+ #' @aliases formatters_methods+ |
+
| 512 | ++ |
+ #' @exportMethod obj_name+ |
+
| 513 | ++ |
+ setMethod(+ |
+
| 514 | ++ |
+ "obj_name", "VNodeInfo",+ |
+
| 515 | +45280x | +
+ function(obj) obj@name+ |
+
| 516 | ++ |
+ )+ |
+
| 517 | ++ | + + | +
| 518 | ++ |
+ #' @rdname formatters_methods+ |
+
| 519 | ++ |
+ #' @exportMethod obj_name+ |
+
| 520 | ++ |
+ setMethod(+ |
+
| 521 | ++ |
+ "obj_name", "Split",+ |
+
| 522 | +111090x | +
+ function(obj) obj@name+ |
+
| 523 | ++ |
+ )+ |
+
| 524 | ++ | + + | +
| 525 | ++ |
+ #' @rdname formatters_methods+ |
+
| 526 | ++ |
+ #' @exportMethod obj_name<-+ |
+
| 527 | ++ |
+ setMethod(+ |
+
| 528 | ++ |
+ "obj_name<-", "VNodeInfo",+ |
+
| 529 | ++ |
+ function(obj, value) {
+ |
+
| 530 | +21x | +
+ obj@name <- value+ |
+
| 531 | +21x | +
+ obj+ |
+
| 532 | ++ |
+ }+ |
+
| 533 | ++ |
+ )+ |
+
| 534 | ++ | + + | +
| 535 | ++ |
+ #' @rdname formatters_methods+ |
+
| 536 | ++ |
+ #' @exportMethod obj_name<-+ |
+
| 537 | ++ |
+ setMethod(+ |
+
| 538 | ++ |
+ "obj_name<-", "Split",+ |
+
| 539 | ++ |
+ function(obj, value) {
+ |
+
| 540 | +3x | +
+ obj@name <- value+ |
+
| 541 | +3x | +
+ obj+ |
+
| 542 | ++ |
+ }+ |
+
| 543 | ++ |
+ )+ |
+
| 544 | ++ | + + | +
| 545 | ++ |
+ ### Label related things+ |
+
| 546 | ++ |
+ #' @rdname formatters_methods+ |
+
| 547 | ++ |
+ #' @exportMethod obj_label+ |
+
| 548 | +2085x | +
+ setMethod("obj_label", "Split", function(obj) obj@split_label)
+ |
+
| 549 | ++ | + + | +
| 550 | ++ |
+ #' @rdname formatters_methods+ |
+
| 551 | ++ |
+ #' @exportMethod obj_label+ |
+
| 552 | +39342x | +
+ setMethod("obj_label", "TableRow", function(obj) obj@label)
+ |
+
| 553 | ++ | + + | +
| 554 | ++ |
+ ## 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 | ++ |
+ #' @rdname formatters_methods+ |
+
| 558 | ++ |
+ #' @exportMethod obj_label+ |
+
| 559 | ++ |
+ setMethod(+ |
+
| 560 | ++ |
+ "obj_label", "VTableTree",+ |
+
| 561 | +262x | +
+ function(obj) obj_label(tt_labelrow(obj))+ |
+
| 562 | ++ |
+ )+ |
+
| 563 | ++ | + + | +
| 564 | ++ |
+ #' @rdname formatters_methods+ |
+
| 565 | ++ |
+ #' @exportMethod obj_label+ |
+
| 566 | +! | +
+ setMethod("obj_label", "ValueWrapper", function(obj) obj@label)
+ |
+
| 567 | ++ | + + | +
| 568 | ++ |
+ #' @rdname formatters_methods+ |
+
| 569 | ++ |
+ #' @exportMethod obj_label<-+ |
+
| 570 | ++ |
+ setMethod(+ |
+
| 571 | ++ |
+ "obj_label<-", "Split",+ |
+
| 572 | ++ |
+ function(obj, value) {
+ |
+
| 573 | +1x | +
+ obj@split_label <- value+ |
+
| 574 | +1x | +
+ obj+ |
+
| 575 | ++ |
+ }+ |
+
| 576 | ++ |
+ )+ |
+
| 577 | ++ | + + | +
| 578 | ++ |
+ #' @rdname formatters_methods+ |
+
| 579 | ++ |
+ #' @exportMethod obj_label<-+ |
+
| 580 | ++ |
+ setMethod(+ |
+
| 581 | ++ |
+ "obj_label<-", "TableRow",+ |
+
| 582 | ++ |
+ function(obj, value) {
+ |
+
| 583 | +32x | +
+ obj@label <- value+ |
+
| 584 | +32x | +
+ obj+ |
+
| 585 | ++ |
+ }+ |
+
| 586 | ++ |
+ )+ |
+
| 587 | ++ | + + | +
| 588 | ++ |
+ #' @rdname formatters_methods+ |
+
| 589 | ++ |
+ #' @exportMethod obj_label<-+ |
+
| 590 | ++ |
+ setMethod(+ |
+
| 591 | ++ |
+ "obj_label<-", "ValueWrapper",+ |
+
| 592 | ++ |
+ function(obj, value) {
+ |
+
| 593 | +! | +
+ obj@label <- value+ |
+
| 594 | +! | +
+ obj+ |
+
| 595 | ++ |
+ }+ |
+
| 596 | ++ |
+ )+ |
+
| 597 | ++ | + + | +
| 598 | ++ |
+ #' @rdname formatters_methods+ |
+
| 599 | ++ |
+ #' @exportMethod obj_label<-+ |
+
| 600 | ++ |
+ setMethod(+ |
+
| 601 | ++ |
+ "obj_label<-", "VTableTree",+ |
+
| 602 | ++ |
+ function(obj, value) {
+ |
+
| 603 | +11x | +
+ lr <- tt_labelrow(obj)+ |
+
| 604 | +11x | +
+ obj_label(lr) <- value+ |
+
| 605 | +11x | +
+ if (!is.na(value) && nzchar(value)) {
+ |
+
| 606 | +10x | +
+ labelrow_visible(lr) <- TRUE+ |
+
| 607 | +1x | +
+ } else if (is.na(value)) {
+ |
+
| 608 | +1x | +
+ labelrow_visible(lr) <- FALSE+ |
+
| 609 | ++ |
+ }+ |
+
| 610 | +11x | +
+ tt_labelrow(obj) <- lr+ |
+
| 611 | +11x | +
+ obj+ |
+
| 612 | ++ |
+ }+ |
+
| 613 | ++ |
+ )+ |
+
| 614 | ++ | + + | +
| 615 | ++ |
+ ### Label rows.+ |
+
| 616 | ++ |
+ #' @rdname int_methods+ |
+
| 617 | +128412x | +
+ setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))
+ |
+
| 618 | ++ | + + | +
| 619 | ++ |
+ #' @rdname int_methods+ |
+
| 620 | ++ |
+ setMethod(+ |
+
| 621 | ++ |
+ "tt_labelrow", "VTableTree",+ |
+
| 622 | +45865x | +
+ function(obj) obj@labelrow+ |
+
| 623 | ++ |
+ )+ |
+
| 624 | ++ | + + | +
| 625 | ++ |
+ #' @rdname int_methods+ |
+
| 626 | +4048x | +
+ setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))
+ |
+
| 627 | ++ | + + | +
| 628 | ++ |
+ #' @rdname int_methods+ |
+
| 629 | ++ |
+ setMethod(+ |
+
| 630 | ++ |
+ "tt_labelrow<-", c("VTableTree", "LabelRow"),
+ |
+
| 631 | ++ |
+ function(obj, value) {
+ |
+
| 632 | +4048x | +
+ if (no_colinfo(value)) {
+ |
+
| 633 | +1x | +
+ col_info(value) <- col_info(obj)+ |
+
| 634 | ++ |
+ }+ |
+
| 635 | +4048x | +
+ obj@labelrow <- value+ |
+
| 636 | +4048x | +
+ obj+ |
+
| 637 | ++ |
+ }+ |
+
| 638 | ++ |
+ )+ |
+
| 639 | ++ | + + | +
| 640 | ++ |
+ #' @rdname int_methods+ |
+
| 641 | +194361x | +
+ setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))
+ |
+
| 642 | ++ | + + | +
| 643 | ++ |
+ #' @rdname int_methods+ |
+
| 644 | ++ |
+ setMethod(+ |
+
| 645 | ++ |
+ "labelrow_visible", "VTableTree",+ |
+
| 646 | ++ |
+ function(obj) {
+ |
+
| 647 | +28032x | +
+ labelrow_visible(tt_labelrow(obj))+ |
+
| 648 | ++ |
+ }+ |
+
| 649 | ++ |
+ )+ |
+
| 650 | ++ | + + | +
| 651 | ++ |
+ #' @rdname int_methods+ |
+
| 652 | ++ |
+ setMethod(+ |
+
| 653 | ++ |
+ "labelrow_visible", "LabelRow",+ |
+
| 654 | +105840x | +
+ function(obj) obj@visible+ |
+
| 655 | ++ |
+ )+ |
+
| 656 | ++ | + + | +
| 657 | ++ |
+ #' @rdname int_methods+ |
+
| 658 | ++ |
+ setMethod(+ |
+
| 659 | ++ |
+ "labelrow_visible", "VAnalyzeSplit",+ |
+
| 660 | +1375x | +
+ function(obj) .labelkids_helper(obj@var_label_position)+ |
+
| 661 | ++ |
+ )+ |
+
| 662 | ++ | + + | +
| 663 | ++ |
+ #' @rdname int_methods+ |
+
| 664 | +2865x | +
+ setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))
+ |
+
| 665 | ++ | + + | +
| 666 | ++ |
+ #' @rdname int_methods+ |
+
| 667 | ++ |
+ setMethod(+ |
+
| 668 | ++ |
+ "labelrow_visible<-", "VTableTree",+ |
+
| 669 | ++ |
+ function(obj, value) {
+ |
+
| 670 | +1294x | +
+ lr <- tt_labelrow(obj)+ |
+
| 671 | +1294x | +
+ labelrow_visible(lr) <- value+ |
+
| 672 | +1294x | +
+ tt_labelrow(obj) <- lr+ |
+
| 673 | +1294x | +
+ obj+ |
+
| 674 | ++ |
+ }+ |
+
| 675 | ++ |
+ )+ |
+
| 676 | ++ | + + | +
| 677 | ++ |
+ #' @rdname int_methods+ |
+
| 678 | ++ |
+ setMethod(+ |
+
| 679 | ++ |
+ "labelrow_visible<-", "LabelRow",+ |
+
| 680 | ++ |
+ function(obj, value) {
+ |
+
| 681 | +1305x | +
+ obj@visible <- value+ |
+
| 682 | +1305x | +
+ obj+ |
+
| 683 | ++ |
+ }+ |
+
| 684 | ++ |
+ )+ |
+
| 685 | ++ | + + | +
| 686 | ++ |
+ #' @rdname int_methods+ |
+
| 687 | ++ |
+ setMethod(+ |
+
| 688 | ++ |
+ "labelrow_visible<-", "VAnalyzeSplit",+ |
+
| 689 | ++ |
+ function(obj, value) {
+ |
+
| 690 | +266x | +
+ obj@var_label_position <- value+ |
+
| 691 | +266x | +
+ obj+ |
+
| 692 | ++ |
+ }+ |
+
| 693 | ++ |
+ )+ |
+
| 694 | ++ | + + | +
| 695 | ++ |
+ ## 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 | +1519x | +
+ setGeneric("label_kids", function(spl) standardGeneric("label_kids"))
+ |
+
| 699 | ++ | + + | +
| 700 | ++ |
+ #' @rdname int_methods+ |
+
| 701 | +1519x | +
+ setMethod("label_kids", "Split", function(spl) spl@label_children)
+ |
+
| 702 | ++ | + + | +
| 703 | ++ |
+ #' @rdname int_methods+ |
+
| 704 | +3x | +
+ setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))
+ |
+
| 705 | ++ | + + | +
| 706 | ++ |
+ #' @rdname int_methods+ |
+
| 707 | ++ |
+ setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
+ |
+
| 708 | +1x | +
+ label_kids(spl) <- .labelkids_helper(value)+ |
+
| 709 | +1x | +
+ spl+ |
+
| 710 | ++ |
+ })+ |
+
| 711 | ++ | + + | +
| 712 | ++ |
+ #' @rdname int_methods+ |
+
| 713 | ++ |
+ setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
+ |
+
| 714 | +2x | +
+ spl@label_children <- value+ |
+
| 715 | +2x | +
+ spl+ |
+
| 716 | ++ |
+ })+ |
+
| 717 | ++ | + + | +
| 718 | ++ |
+ #' @rdname int_methods+ |
+
| 719 | +399x | +
+ setGeneric("vis_label", function(spl) standardGeneric("vis_label"))
+ |
+
| 720 | ++ | + + | +
| 721 | ++ |
+ #' @rdname int_methods+ |
+
| 722 | ++ |
+ setMethod("vis_label", "Split", function(spl) {
+ |
+
| 723 | +399x | +
+ .labelkids_helper(label_position(spl))+ |
+
| 724 | ++ |
+ })+ |
+
| 725 | ++ | + + | +
| 726 | ++ |
+ ## #' @rdname int_methods+ |
+
| 727 | ++ |
+ ## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
+ |
+
| 728 | ++ |
+ ## #' @rdname int_methods+ |
+
| 729 | ++ |
+ ## setMethod("vis_label<-", "Split", function(spl, value) {
+ |
+
| 730 | ++ |
+ ## stop("defunct")
+ |
+
| 731 | ++ |
+ ## if(is.na(value))+ |
+
| 732 | ++ |
+ ## stop("split label visibility must be TRUE or FALSE, got NA")
+ |
+
| 733 | ++ |
+ ## # spl@split_label_visible <- value+ |
+
| 734 | ++ |
+ ## spl+ |
+
| 735 | ++ |
+ ## })+ |
+
| 736 | ++ | + + | +
| 737 | ++ |
+ #' @rdname int_methods+ |
+
| 738 | +1027x | +
+ setGeneric("label_position", function(spl) standardGeneric("label_position"))
+ |
+
| 739 | ++ | + + | +
| 740 | ++ |
+ #' @rdname int_methods+ |
+
| 741 | +703x | +
+ setMethod("label_position", "Split", function(spl) spl@split_label_position)
+ |
+
| 742 | ++ | + + | +
| 743 | ++ |
+ #' @rdname int_methods+ |
+
| 744 | +324x | +
+ setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)
+ |
+
| 745 | ++ | + + | +
| 746 | ++ |
+ #' @rdname int_methods+ |
+
| 747 | +48x | +
+ setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))
+ |
+
| 748 | ++ | + + | +
| 749 | ++ |
+ #' @rdname int_methods+ |
+
| 750 | ++ |
+ setMethod("label_position<-", "Split", function(spl, value) {
+ |
+
| 751 | +48x | +
+ value <- match.arg(value, valid_lbl_pos)+ |
+
| 752 | +48x | +
+ spl@split_label_position <- value+ |
+
| 753 | +48x | +
+ spl+ |
+
| 754 | ++ |
+ })+ |
+
| 755 | ++ | + + | +
| 756 | ++ |
+ ### Function accessors (summary, tabulation and split) ----+ |
+
| 757 | ++ | + + | +
| 758 | ++ |
+ #' @rdname int_methods+ |
+
| 759 | +3279x | +
+ setGeneric("content_fun", function(obj) standardGeneric("content_fun"))
+ |
+
| 760 | ++ | + + | +
| 761 | ++ |
+ #' @rdname int_methods+ |
+
| 762 | +3228x | +
+ setMethod("content_fun", "Split", function(obj) obj@content_fun)
+ |
+
| 763 | ++ | + + | +
| 764 | ++ |
+ #' @rdname int_methods+ |
+
| 765 | +114x | +
+ setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))
+ |
+
| 766 | ++ | + + | +
| 767 | ++ |
+ #' @rdname int_methods+ |
+
| 768 | ++ |
+ setMethod("content_fun<-", "Split", function(object, value) {
+ |
+
| 769 | +114x | +
+ object@content_fun <- value+ |
+
| 770 | +114x | +
+ object+ |
+
| 771 | ++ |
+ })+ |
+
| 772 | ++ | + + | +
| 773 | ++ |
+ #' @rdname int_methods+ |
+
| 774 | +1695x | +
+ setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))
+ |
+
| 775 | ++ | + + | +
| 776 | ++ |
+ #' @rdname int_methods+ |
+
| 777 | +1600x | +
+ setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)
+ |
+
| 778 | ++ | + + | +
| 779 | ++ |
+ #' @rdname int_methods+ |
+
| 780 | +95x | +
+ setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)
+ |
+
| 781 | ++ | + + | +
| 782 | ++ |
+ ## not used and probably not needed+ |
+
| 783 | ++ |
+ ## #' @rdname int_methods+ |
+
| 784 | ++ |
+ ## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))
+ |
+
| 785 | ++ | + + | +
| 786 | ++ |
+ ## #' @rdname int_methods+ |
+
| 787 | ++ |
+ ## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
+ |
+
| 788 | ++ |
+ ## object@analysis_fun <- value+ |
+
| 789 | ++ |
+ ## object+ |
+
| 790 | ++ |
+ ## })+ |
+
| 791 | ++ |
+ ## #' @rdname int_methods+ |
+
| 792 | ++ |
+ ## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
+ |
+
| 793 | ++ |
+ ## if(is(value, "function"))+ |
+
| 794 | ++ |
+ ## value <- list(value)+ |
+
| 795 | ++ |
+ ## object@analysis_fun <- value+ |
+
| 796 | ++ |
+ ## object+ |
+
| 797 | ++ |
+ ## })+ |
+
| 798 | ++ | + + | +
| 799 | ++ |
+ #' @rdname int_methods+ |
+
| 800 | +1091x | +
+ setGeneric("split_fun", function(obj) standardGeneric("split_fun"))
+ |
+
| 801 | ++ | + + | +
| 802 | ++ |
+ #' @rdname int_methods+ |
+
| 803 | +909x | +
+ setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)
+ |
+
| 804 | ++ | + + | +
| 805 | ++ |
+ ## 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("split_fun", "Split", function(obj) NULL)
+ |
+
| 810 | ++ | + + | +
| 811 | ++ |
+ #' @rdname int_methods+ |
+
| 812 | +13x | +
+ setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))
+ |
+
| 813 | ++ | + + | +
| 814 | ++ |
+ #' @rdname int_methods+ |
+
| 815 | ++ |
+ setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
+ |
+
| 816 | +13x | +
+ obj@split_fun <- value+ |
+
| 817 | +13x | +
+ obj+ |
+
| 818 | ++ |
+ })+ |
+
| 819 | ++ | + + | +
| 820 | ++ |
+ # nocov start+ |
+
| 821 | ++ |
+ ## Only that type of split currently has the slot+ |
+
| 822 | ++ |
+ ## this should probably change? for now define+ |
+
| 823 | ++ |
+ ## an accessor that just returns NULL+ |
+
| 824 | ++ |
+ #' @rdname int_methods+ |
+
| 825 | ++ |
+ setMethod(+ |
+
| 826 | ++ |
+ "split_fun<-", "Split",+ |
+
| 827 | ++ |
+ function(obj, value) {
+ |
+
| 828 | ++ |
+ stop(+ |
+
| 829 | ++ |
+ "Attempted to set a custom split function on a non-customizable split.",+ |
+
| 830 | ++ |
+ "This should not happen, please contact the maintainers."+ |
+
| 831 | ++ |
+ )+ |
+
| 832 | ++ |
+ }+ |
+
| 833 | ++ |
+ )+ |
+
| 834 | ++ |
+ # nocov end+ |
+
| 835 | ++ | + + | +
| 836 | ++ |
+ ## Content specification related accessors ----+ |
+
| 837 | ++ | + + | +
| 838 | ++ |
+ #' @rdname int_methods+ |
+
| 839 | +469x | +
+ setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))
+ |
+
| 840 | ++ | + + | +
| 841 | ++ |
+ #' @rdname int_methods+ |
+
| 842 | +469x | +
+ setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)
+ |
+
| 843 | ++ | + + | +
| 844 | ++ |
+ #' @rdname int_methods+ |
+
| 845 | +114x | +
+ setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))
+ |
+
| 846 | ++ | + + | +
| 847 | ++ |
+ #' @rdname int_methods+ |
+
| 848 | ++ |
+ setMethod("content_extra_args<-", "Split", function(object, value) {
+ |
+
| 849 | +114x | +
+ object@content_extra_args <- value+ |
+
| 850 | +114x | +
+ object+ |
+
| 851 | ++ |
+ })+ |
+
| 852 | ++ | + + | +
| 853 | ++ |
+ #' @rdname int_methods+ |
+
| 854 | +1841x | +
+ setGeneric("content_var", function(obj) standardGeneric("content_var"))
+ |
+
| 855 | ++ | + + | +
| 856 | ++ |
+ #' @rdname int_methods+ |
+
| 857 | +1841x | +
+ setMethod("content_var", "Split", function(obj) obj@content_var)
+ |
+
| 858 | ++ | + + | +
| 859 | ++ |
+ #' @rdname int_methods+ |
+
| 860 | +114x | +
+ setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))
+ |
+
| 861 | ++ | + + | +
| 862 | ++ |
+ #' @rdname int_methods+ |
+
| 863 | ++ |
+ setMethod("content_var<-", "Split", function(object, value) {
+ |
+
| 864 | +114x | +
+ object@content_var <- value+ |
+
| 865 | +114x | +
+ object+ |
+
| 866 | ++ |
+ })+ |
+
| 867 | ++ | + + | +
| 868 | ++ |
+ ### Miscellaneous accessors ----+ |
+
| 869 | ++ | + + | +
| 870 | ++ |
+ #' @rdname int_methods+ |
+
| 871 | +1102x | +
+ setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))
+ |
+
| 872 | ++ | + + | +
| 873 | ++ |
+ #' @rdname int_methods+ |
+
| 874 | ++ |
+ setMethod(+ |
+
| 875 | ++ |
+ "avar_inclNAs", "VAnalyzeSplit",+ |
+
| 876 | +1102x | +
+ function(obj) obj@include_NAs+ |
+
| 877 | ++ |
+ )+ |
+
| 878 | ++ | + + | +
| 879 | ++ |
+ #' @rdname int_methods+ |
+
| 880 | +! | +
+ setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))
+ |
+
| 881 | ++ | + + | +
| 882 | ++ |
+ #' @rdname int_methods+ |
+
| 883 | ++ |
+ setMethod(+ |
+
| 884 | ++ |
+ "avar_inclNAs<-", "VAnalyzeSplit",+ |
+
| 885 | ++ |
+ function(obj, value) {
+ |
+
| 886 | +! | +
+ obj@include_NAs <- value+ |
+
| 887 | ++ |
+ }+ |
+
| 888 | ++ |
+ )+ |
+
| 889 | ++ | + + | +
| 890 | ++ |
+ #' @rdname int_methods+ |
+
| 891 | +821x | +
+ setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))
+ |
+
| 892 | ++ | + + | +
| 893 | ++ |
+ #' @rdname int_methods+ |
+
| 894 | +821x | +
+ setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)
+ |
+
| 895 | ++ | + + | +
| 896 | ++ |
+ #' @rdname int_methods+ |
+
| 897 | +2785x | +
+ setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))
+ |
+
| 898 | ++ | + + | +
| 899 | ++ |
+ #' @rdname int_methods+ |
+
| 900 | +2485x | +
+ setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)
+ |
+
| 901 | ++ | + + | +
| 902 | ++ |
+ #' @rdname int_methods+ |
+
| 903 | ++ |
+ setGeneric(+ |
+
| 904 | ++ |
+ "spl_child_order<-",+ |
+
| 905 | +630x | +
+ function(obj, value) standardGeneric("spl_child_order<-")
+ |
+
| 906 | ++ |
+ )+ |
+
| 907 | ++ | + + | +
| 908 | ++ |
+ #' @rdname int_methods+ |
+
| 909 | ++ |
+ setMethod(+ |
+
| 910 | ++ |
+ "spl_child_order<-", "VarLevelSplit",+ |
+
| 911 | ++ |
+ function(obj, value) {
+ |
+
| 912 | +630x | +
+ obj@value_order <- value+ |
+
| 913 | +630x | +
+ obj+ |
+
| 914 | ++ |
+ }+ |
+
| 915 | ++ |
+ )+ |
+
| 916 | ++ | + + | +
| 917 | ++ |
+ #' @rdname int_methods+ |
+
| 918 | ++ |
+ setMethod(+ |
+
| 919 | ++ |
+ "spl_child_order",+ |
+
| 920 | ++ |
+ "ManualSplit",+ |
+
| 921 | +51x | +
+ function(obj) obj@levels+ |
+
| 922 | ++ |
+ )+ |
+
| 923 | ++ | + + | +
| 924 | ++ |
+ #' @rdname int_methods+ |
+
| 925 | ++ |
+ setMethod(+ |
+
| 926 | ++ |
+ "spl_child_order",+ |
+
| 927 | ++ |
+ "MultiVarSplit",+ |
+
| 928 | +96x | +
+ function(obj) spl_varnames(obj)+ |
+
| 929 | ++ |
+ )+ |
+
| 930 | ++ | + + | +
| 931 | ++ |
+ #' @rdname int_methods+ |
+
| 932 | ++ |
+ setMethod(+ |
+
| 933 | ++ |
+ "spl_child_order",+ |
+
| 934 | ++ |
+ "AllSplit",+ |
+
| 935 | +109x | +
+ function(obj) character()+ |
+
| 936 | ++ |
+ )+ |
+
| 937 | ++ | + + | +
| 938 | ++ |
+ #' @rdname int_methods+ |
+
| 939 | ++ |
+ setMethod(+ |
+
| 940 | ++ |
+ "spl_child_order",+ |
+
| 941 | ++ |
+ "VarStaticCutSplit",+ |
+
| 942 | +44x | +
+ function(obj) spl_cutlabels(obj)+ |
+
| 943 | ++ |
+ )+ |
+
| 944 | ++ | + + | +
| 945 | ++ |
+ #' @rdname int_methods+ |
+
| 946 | +989x | +
+ setGeneric("root_spl", function(obj) standardGeneric("root_spl"))
+ |
+
| 947 | ++ | + + | +
| 948 | ++ |
+ #' @rdname int_methods+ |
+
| 949 | ++ |
+ setMethod(+ |
+
| 950 | ++ |
+ "root_spl", "PreDataAxisLayout",+ |
+
| 951 | +989x | +
+ function(obj) obj@root_split+ |
+
| 952 | ++ |
+ )+ |
+
| 953 | ++ | + + | +
| 954 | ++ |
+ #' @rdname int_methods+ |
+
| 955 | +9x | +
+ setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))
+ |
+
| 956 | ++ | + + | +
| 957 | ++ |
+ #' @rdname int_methods+ |
+
| 958 | ++ |
+ setMethod(+ |
+
| 959 | ++ |
+ "root_spl<-", "PreDataAxisLayout",+ |
+
| 960 | ++ |
+ function(obj, value) {
+ |
+
| 961 | +9x | +
+ obj@root_split <- value+ |
+
| 962 | +9x | +
+ obj+ |
+
| 963 | ++ |
+ }+ |
+
| 964 | ++ |
+ )+ |
+
| 965 | ++ | + + | +
| 966 | ++ |
+ #' Row attribute accessors+ |
+
| 967 | ++ |
+ #'+ |
+
| 968 | ++ |
+ #' @inheritParams gen_args+ |
+
| 969 | ++ |
+ #'+ |
+
| 970 | ++ |
+ #' @return Various return values depending on the accessor called.+ |
+
| 971 | ++ |
+ #'+ |
+
| 972 | ++ |
+ #' @export+ |
+
| 973 | ++ |
+ #' @rdname row_accessors+ |
+
| 974 | +72x | +
+ setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))
+ |
+
| 975 | ++ | + + | +
| 976 | ++ |
+ #' @rdname row_accessors+ |
+
| 977 | ++ |
+ #' @exportMethod obj_avar+ |
+
| 978 | +55x | +
+ setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)
+ |
+
| 979 | ++ | + + | +
| 980 | ++ |
+ #' @rdname row_accessors+ |
+
| 981 | ++ |
+ #' @exportMethod obj_avar+ |
+
| 982 | +17x | +
+ setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)
+ |
+
| 983 | ++ | + + | +
| 984 | ++ |
+ #' @export+ |
+
| 985 | ++ |
+ #' @rdname row_accessors+ |
+
| 986 | +67428x | +
+ setGeneric("row_cells", function(obj) standardGeneric("row_cells"))
+ |
+
| 987 | ++ | + + | +
| 988 | ++ |
+ #' @rdname row_accessors+ |
+
| 989 | ++ |
+ #' @exportMethod row_cells+ |
+
| 990 | +7393x | +
+ setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)
+ |
+
| 991 | ++ | + + | +
| 992 | ++ |
+ #' @rdname row_accessors+ |
+
| 993 | +4034x | +
+ setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))
+ |
+
| 994 | ++ | + + | +
| 995 | ++ |
+ #' @rdname row_accessors+ |
+
| 996 | ++ |
+ #' @exportMethod row_cells+ |
+
| 997 | ++ |
+ setMethod("row_cells<-", "TableRow", function(obj, value) {
+ |
+
| 998 | +4034x | +
+ obj@leaf_value <- value+ |
+
| 999 | +4034x | +
+ obj+ |
+
| 1000 | ++ |
+ })+ |
+
| 1001 | ++ | + + | +
| 1002 | ++ |
+ #' @export+ |
+
| 1003 | ++ |
+ #' @rdname row_accessors+ |
+
| 1004 | +2314x | +
+ setGeneric("row_values", function(obj) standardGeneric("row_values"))
+ |
+
| 1005 | ++ | + + | +
| 1006 | ++ |
+ #' @rdname row_accessors+ |
+
| 1007 | ++ |
+ #' @exportMethod row_values+ |
+
| 1008 | +522x | +
+ setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))
+ |
+
| 1009 | ++ | + + | +
| 1010 | ++ | + + | +
| 1011 | ++ |
+ #' @rdname row_accessors+ |
+
| 1012 | ++ |
+ #' @exportMethod row_values<-+ |
+
| 1013 | +1218x | +
+ setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))
+ |
+
| 1014 | ++ | + + | +
| 1015 | ++ |
+ #' @rdname row_accessors+ |
+
| 1016 | ++ |
+ #' @exportMethod row_values<-+ |
+
| 1017 | ++ |
+ setMethod(+ |
+
| 1018 | ++ |
+ "row_values<-", "TableRow",+ |
+
| 1019 | ++ |
+ function(obj, value) {
+ |
+
| 1020 | +1218x | +
+ obj@leaf_value <- lapply(value, rcell)+ |
+
| 1021 | +1218x | +
+ obj+ |
+
| 1022 | ++ |
+ }+ |
+
| 1023 | ++ |
+ )+ |
+
| 1024 | ++ | + + | +
| 1025 | ++ |
+ #' @rdname row_accessors+ |
+
| 1026 | ++ |
+ #' @exportMethod row_values<-+ |
+
| 1027 | ++ |
+ setMethod(+ |
+
| 1028 | ++ |
+ "row_values<-", "LabelRow",+ |
+
| 1029 | ++ |
+ function(obj, value) {
+ |
+
| 1030 | +! | +
+ stop("LabelRows cannot have row values.")
+ |
+
| 1031 | ++ |
+ }+ |
+
| 1032 | ++ |
+ )+ |
+
| 1033 | ++ | + + | +
| 1034 | ++ |
+ #' @rdname int_methods+ |
+
| 1035 | +937x | +
+ setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))
+ |
+
| 1036 | ++ | + + | +
| 1037 | ++ |
+ #' @rdname int_methods+ |
+
| 1038 | ++ |
+ setMethod(+ |
+
| 1039 | ++ |
+ "spanned_values", "TableRow",+ |
+
| 1040 | ++ |
+ function(obj) {
+ |
+
| 1041 | +937x | +
+ rawvalues(spanned_cells(obj))+ |
+
| 1042 | ++ |
+ }+ |
+
| 1043 | ++ |
+ )+ |
+
| 1044 | ++ | + + | +
| 1045 | ++ |
+ #' @rdname int_methods+ |
+
| 1046 | ++ |
+ setMethod(+ |
+
| 1047 | ++ |
+ "spanned_values", "LabelRow",+ |
+
| 1048 | ++ |
+ function(obj) {
+ |
+
| 1049 | +! | +
+ rep(list(NULL), ncol(obj))+ |
+
| 1050 | ++ |
+ }+ |
+
| 1051 | ++ |
+ )+ |
+
| 1052 | ++ | + + | +
| 1053 | ++ |
+ #' @rdname int_methods+ |
+
| 1054 | +937x | +
+ setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))
+ |
+
| 1055 | ++ | + + | +
| 1056 | ++ |
+ #' @rdname int_methods+ |
+
| 1057 | ++ |
+ setMethod(+ |
+
| 1058 | ++ |
+ "spanned_cells", "TableRow",+ |
+
| 1059 | ++ |
+ function(obj) {
+ |
+
| 1060 | +937x | +
+ sp <- row_cspans(obj)+ |
+
| 1061 | +937x | +
+ rvals <- row_cells(obj)+ |
+
| 1062 | +937x | +
+ unlist(+ |
+
| 1063 | +937x | +
+ mapply(function(v, s) rep(list(v), times = s),+ |
+
| 1064 | +937x | +
+ v = rvals, s = sp+ |
+
| 1065 | ++ |
+ ),+ |
+
| 1066 | +937x | +
+ recursive = FALSE+ |
+
| 1067 | ++ |
+ )+ |
+
| 1068 | ++ |
+ }+ |
+
| 1069 | ++ |
+ )+ |
+
| 1070 | ++ | + + | +
| 1071 | ++ |
+ #' @rdname int_methods+ |
+
| 1072 | ++ |
+ setMethod(+ |
+
| 1073 | ++ |
+ "spanned_cells", "LabelRow",+ |
+
| 1074 | ++ |
+ function(obj) {
+ |
+
| 1075 | +! | +
+ rep(list(NULL), ncol(obj))+ |
+
| 1076 | ++ |
+ }+ |
+
| 1077 | ++ |
+ )+ |
+
| 1078 | ++ | + + | +
| 1079 | ++ |
+ #' @rdname int_methods+ |
+
| 1080 | +3x | +
+ setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))
+ |
+
| 1081 | ++ | + + | +
| 1082 | ++ |
+ #' @rdname int_methods+ |
+
| 1083 | ++ |
+ setMethod(+ |
+
| 1084 | ++ |
+ "spanned_values<-", "TableRow",+ |
+
| 1085 | ++ |
+ function(obj, value) {
+ |
+
| 1086 | +2x | +
+ sp <- row_cspans(obj)+ |
+
| 1087 | ++ |
+ ## this is 3 times too clever!!!+ |
+
| 1088 | +2x | +
+ valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1))))+ |
+
| 1089 | ++ | + + | +
| 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 (",
+ |
+
| 1099 | +1x | +
+ paste(sp, collapse = " "), ")"+ |
+
| 1100 | ++ |
+ )+ |
+
| 1101 | ++ |
+ }+ |
+
| 1102 | ++ |
+ }+ |
+
| 1103 | ++ |
+ )+ |
+
| 1104 | +1x | +
+ rvals <- value[valindices]+ |
+
| 1105 | ++ | + + | +
| 1106 | ++ |
+ ## rvals = lapply(split(value, splvec),+ |
+
| 1107 | ++ |
+ ## function(v) {
+ |
+
| 1108 | ++ |
+ ## if(length(v) == 1)+ |
+
| 1109 | ++ |
+ ## return(v)+ |
+
| 1110 | ++ |
+ ## stopifnot(length(unique(v)) == 1L)+ |
+
| 1111 | ++ |
+ ## rcell(unique(v), colspan<- length(v))+ |
+
| 1112 | ++ |
+ ## })+ |
+
| 1113 | ++ |
+ ## if(any(splvec > 1))+ |
+
| 1114 | ++ |
+ ## rvals <- lapply(rvals, function(x) x[[1]])+ |
+
| 1115 | +1x | +
+ row_values(obj) <- rvals+ |
+
| 1116 | +1x | +
+ obj+ |
+
| 1117 | ++ |
+ }+ |
+
| 1118 | ++ |
+ )+ |
+
| 1119 | ++ | + + | +
| 1120 | ++ |
+ #' @rdname int_methods+ |
+
| 1121 | ++ |
+ setMethod(+ |
+
| 1122 | ++ |
+ "spanned_values<-", "LabelRow",+ |
+
| 1123 | ++ |
+ function(obj, value) {
+ |
+
| 1124 | +1x | +
+ if (!is.null(value)) {
+ |
+
| 1125 | +1x | +
+ stop("Label rows can't have non-null cell values, got", value)
+ |
+
| 1126 | ++ |
+ }+ |
+
| 1127 | +! | +
+ obj+ |
+
| 1128 | ++ |
+ }+ |
+
| 1129 | ++ |
+ )+ |
+
| 1130 | ++ | + + | +
| 1131 | ++ |
+ ### Format manipulation+ |
+
| 1132 | ++ |
+ ### obj_format<- is not recursive+ |
+
| 1133 | ++ |
+ ## TODO export these?+ |
+
| 1134 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1135 | ++ |
+ #' @export+ |
+
| 1136 | +6348x | +
+ setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)
+ |
+
| 1137 | ++ | + + | +
| 1138 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1139 | ++ |
+ #' @export+ |
+
| 1140 | +105854x | +
+ setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))
+ |
+
| 1141 | ++ | + + | +
| 1142 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1143 | ++ |
+ #' @export+ |
+
| 1144 | +2243x | +
+ setMethod("obj_format", "Split", function(obj) obj@split_format)
+ |
+
| 1145 | ++ | + + | +
| 1146 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1147 | ++ |
+ #' @export+ |
+
| 1148 | ++ |
+ setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
+ |
+
| 1149 | +1647x | +
+ obj@format <- value+ |
+
| 1150 | +1647x | +
+ obj+ |
+
| 1151 | ++ |
+ })+ |
+
| 1152 | ++ | + + | +
| 1153 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1154 | ++ |
+ #' @export+ |
+
| 1155 | ++ |
+ setMethod("obj_format<-", "Split", function(obj, value) {
+ |
+
| 1156 | +1x | +
+ obj@split_format <- value+ |
+
| 1157 | +1x | +
+ obj+ |
+
| 1158 | ++ |
+ })+ |
+
| 1159 | ++ | + + | +
| 1160 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1161 | ++ |
+ #' @export+ |
+
| 1162 | ++ |
+ setMethod("obj_format<-", "CellValue", function(obj, value) {
+ |
+
| 1163 | +1173x | +
+ attr(obj, "format") <- value+ |
+
| 1164 | +1173x | +
+ obj+ |
+
| 1165 | ++ |
+ })+ |
+
| 1166 | ++ | + + | +
| 1167 | ++ |
+ #' @rdname int_methods+ |
+
| 1168 | ++ |
+ #' @export+ |
+
| 1169 | ++ |
+ setMethod("obj_na_str<-", "CellValue", function(obj, value) {
+ |
+
| 1170 | +4098x | +
+ attr(obj, "format_na_str") <- value+ |
+
| 1171 | +4098x | +
+ obj+ |
+
| 1172 | ++ |
+ })+ |
+
| 1173 | ++ | + + | +
| 1174 | ++ |
+ #' @rdname int_methods+ |
+
| 1175 | ++ |
+ #' @export+ |
+
| 1176 | ++ |
+ setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
+ |
+
| 1177 | +26x | +
+ obj@na_str <- value+ |
+
| 1178 | +26x | +
+ obj+ |
+
| 1179 | ++ |
+ })+ |
+
| 1180 | ++ | + + | +
| 1181 | ++ |
+ #' @rdname int_methods+ |
+
| 1182 | ++ |
+ #' @export+ |
+
| 1183 | ++ |
+ setMethod("obj_na_str<-", "Split", function(obj, value) {
+ |
+
| 1184 | +! | +
+ obj@split_na_str <- value+ |
+
| 1185 | +! | +
+ obj+ |
+
| 1186 | ++ |
+ })+ |
+
| 1187 | ++ | + + | +
| 1188 | ++ |
+ #' @rdname int_methods+ |
+
| 1189 | ++ |
+ #' @export+ |
+
| 1190 | +27738x | +
+ setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)
+ |
+
| 1191 | ++ | + + | +
| 1192 | ++ |
+ #' @rdname formatters_methods+ |
+
| 1193 | ++ |
+ #' @export+ |
+
| 1194 | +1142x | +
+ setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)
+ |
+
| 1195 | ++ | + + | +
| 1196 | ++ |
+ .no_na_str <- function(x) {
+ |
+
| 1197 | +14931x | +
+ if (!is.character(x)) {
+ |
+
| 1198 | +6049x | +
+ x <- obj_na_str(x)+ |
+
| 1199 | ++ |
+ }+ |
+
| 1200 | +14931x | +
+ length(x) == 0 || all(is.na(x))+ |
+
| 1201 | ++ |
+ }+ |
+
| 1202 | ++ | + + | +
| 1203 | ++ |
+ #' @rdname int_methods+ |
+
| 1204 | ++ |
+ setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
+ |
+
| 1205 | +8875x | +
+ standardGeneric("set_format_recursive")
+ |
+
| 1206 | ++ |
+ })+ |
+
| 1207 | ++ | + + | +
| 1208 | ++ |
+ #' @param override (`flag`)\cr whether to override attribute.+ |
+
| 1209 | ++ |
+ #'+ |
+
| 1210 | ++ |
+ #' @rdname int_methods+ |
+
| 1211 | ++ |
+ setMethod(+ |
+
| 1212 | ++ |
+ "set_format_recursive", "TableRow",+ |
+
| 1213 | ++ |
+ function(obj, format, na_str, override = FALSE) {
+ |
+
| 1214 | +1048x | +
+ if (is.null(format) && .no_na_str(na_str)) {
+ |
+
| 1215 | +524x | +
+ return(obj)+ |
+
| 1216 | ++ |
+ }+ |
+
| 1217 | ++ | + + | +
| 1218 | +524x | +
+ if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
+ |
+
| 1219 | +524x | +
+ obj_format(obj) <- format+ |
+
| 1220 | ++ |
+ }+ |
+
| 1221 | +524x | +
+ if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
+ |
+
| 1222 | +! | +
+ obj_na_str(obj) <- na_str+ |
+
| 1223 | ++ |
+ }+ |
+
| 1224 | +524x | +
+ lcells <- row_cells(obj)+ |
+
| 1225 | +524x | +
+ lvals <- lapply(lcells, function(x) {
+ |
+
| 1226 | +1879x | +
+ if (!is.null(x) && (override || is.null(obj_format(x)))) {
+ |
+
| 1227 | +53x | +
+ obj_format(x) <- obj_format(obj)+ |
+
| 1228 | ++ |
+ }+ |
+
| 1229 | +1879x | +
+ if (!is.null(x) && (override || .no_na_str(x))) {
+ |
+
| 1230 | +1879x | +
+ obj_na_str(x) <- obj_na_str(obj)+ |
+
| 1231 | ++ |
+ }+ |
+
| 1232 | +1879x | +
+ x+ |
+
| 1233 | ++ |
+ })+ |
+
| 1234 | +524x | +
+ row_values(obj) <- lvals+ |
+
| 1235 | +524x | +
+ obj+ |
+
| 1236 | ++ |
+ }+ |
+
| 1237 | ++ |
+ )+ |
+
| 1238 | ++ | + + | +
| 1239 | ++ |
+ #' @rdname int_methods+ |
+
| 1240 | ++ |
+ setMethod(+ |
+
| 1241 | ++ |
+ "set_format_recursive", "LabelRow",+ |
+
| 1242 | +11x | +
+ function(obj, format, override = FALSE) obj+ |
+
| 1243 | ++ |
+ )+ |
+
| 1244 | ++ | + + | +
| 1245 | ++ |
+ setMethod(+ |
+
| 1246 | ++ |
+ "set_format_recursive", "VTableTree",+ |
+
| 1247 | ++ |
+ 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)+ |
+
| 1251 | ++ |
+ }+ |
+
| 1252 | ++ | + + | +
| 1253 | +7x | +
+ if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
+ |
+
| 1254 | +7x | +
+ obj_format(obj) <- format+ |
+
| 1255 | ++ |
+ }+ |
+
| 1256 | +7x | +
+ if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
+ |
+
| 1257 | +! | +
+ obj_na_str(obj) <- na_str+ |
+
| 1258 | ++ |
+ }+ |
+
| 1259 | ++ | + + | +
| 1260 | +7x | +
+ kids <- tree_children(obj)+ |
+
| 1261 | +7x | +
+ kids <- lapply(kids, function(x, format2, na_str2, oride) {
+ |
+
| 1262 | +33x | +
+ set_format_recursive(x,+ |
+
| 1263 | +33x | +
+ format = format2, na_str = na_str2, override = oride+ |
+
| 1264 | ++ |
+ )+ |
+
| 1265 | ++ |
+ },+ |
+
| 1266 | +7x | +
+ format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override+ |
+
| 1267 | ++ |
+ )+ |
+
| 1268 | +7x | +
+ tree_children(obj) <- kids+ |
+
| 1269 | +7x | +
+ obj+ |
+
| 1270 | ++ |
+ }+ |
+
| 1271 | ++ |
+ )+ |
+
| 1272 | ++ | + + | +
| 1273 | ++ |
+ #' @rdname int_methods+ |
+
| 1274 | +1833x | +
+ setGeneric("content_format", function(obj) standardGeneric("content_format"))
+ |
+
| 1275 | ++ | + + | +
| 1276 | ++ |
+ #' @rdname int_methods+ |
+
| 1277 | +1833x | +
+ setMethod("content_format", "Split", function(obj) obj@content_format)
+ |
+
| 1278 | ++ | + + | +
| 1279 | ++ |
+ #' @rdname int_methods+ |
+
| 1280 | +114x | +
+ setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))
+ |
+
| 1281 | ++ | + + | +
| 1282 | ++ |
+ #' @rdname int_methods+ |
+
| 1283 | ++ |
+ setMethod("content_format<-", "Split", function(obj, value) {
+ |
+
| 1284 | +114x | +
+ obj@content_format <- value+ |
+
| 1285 | +114x | +
+ obj+ |
+
| 1286 | ++ |
+ })+ |
+
| 1287 | ++ | + + | +
| 1288 | ++ |
+ #' @rdname int_methods+ |
+
| 1289 | +1833x | +
+ setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))
+ |
+
| 1290 | ++ | + + | +
| 1291 | ++ |
+ #' @rdname int_methods+ |
+
| 1292 | +1833x | +
+ setMethod("content_na_str", "Split", function(obj) obj@content_na_str)
+ |
+
| 1293 | ++ | + + | +
| 1294 | ++ |
+ #' @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 | +! | +
+ obj@content_na_str <- value+ |
+
| 1300 | +! | +
+ obj+ |
+
| 1301 | ++ |
+ })+ |
+
| 1302 | ++ | + + | +
| 1303 | ++ |
+ #' Value formats+ |
+
| 1304 | ++ |
+ #'+ |
+
| 1305 | ++ |
+ #' Returns a matrix of formats for the cells in a table.+ |
+
| 1306 | ++ |
+ #'+ |
+
| 1307 | ++ |
+ #' @param obj (`VTableTree` or `TableRow`)\cr a table or row object.+ |
+
| 1308 | ++ |
+ #' @param default (`string`, `function`, or `list`)\cr default format.+ |
+
| 1309 | ++ |
+ #'+ |
+
| 1310 | ++ |
+ #' @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 | ++ |
+ #' @examples+ |
+
| 1316 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1317 | ++ |
+ #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
+ |
+
| 1318 | ++ |
+ #' analyze("AGE")
+ |
+
| 1319 | ++ |
+ #'+ |
+
| 1320 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 1321 | ++ |
+ #' value_formats(tbl)+ |
+
| 1322 | ++ |
+ #'+ |
+
| 1323 | ++ |
+ #' @export+ |
+
| 1324 | +1123x | +
+ setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))
+ |
+
| 1325 | ++ | + + | +
| 1326 | ++ |
+ #' @rdname value_formats+ |
+
| 1327 | ++ |
+ setMethod(+ |
+
| 1328 | ++ |
+ "value_formats", "ANY",+ |
+
| 1329 | ++ |
+ function(obj, default) {
+ |
+
| 1330 | +762x | +
+ obj_format(obj) %||% default+ |
+
| 1331 | ++ |
+ }+ |
+
| 1332 | ++ |
+ )+ |
+
| 1333 | ++ | + + | +
| 1334 | ++ |
+ #' @rdname value_formats+ |
+
| 1335 | ++ |
+ setMethod(+ |
+
| 1336 | ++ |
+ "value_formats", "TableRow",+ |
+
| 1337 | ++ |
+ function(obj, default) {
+ |
+
| 1338 | +245x | +
+ 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 | ++ |
+ }+ |
+
| 1344 | ++ |
+ )+ |
+
| 1345 | ++ | + + | +
| 1346 | ++ |
+ #' @rdname value_formats+ |
+
| 1347 | ++ |
+ setMethod(+ |
+
| 1348 | ++ |
+ "value_formats", "LabelRow",+ |
+
| 1349 | ++ |
+ function(obj, default) {
+ |
+
| 1350 | +102x | +
+ rep(list(NULL), ncol(obj))+ |
+
| 1351 | ++ |
+ }+ |
+
| 1352 | ++ |
+ )+ |
+
| 1353 | ++ | + + | +
| 1354 | ++ |
+ #' @rdname value_formats+ |
+
| 1355 | ++ |
+ setMethod(+ |
+
| 1356 | ++ |
+ "value_formats", "VTableTree",+ |
+
| 1357 | ++ |
+ function(obj, default) {
+ |
+
| 1358 | +14x | +
+ if (!is.null(obj_format(obj))) {
+ |
+
| 1359 | +! | +
+ default <- obj_format(obj)+ |
+
| 1360 | ++ |
+ }+ |
+
| 1361 | +14x | +
+ rws <- collect_leaves(obj, TRUE, TRUE)+ |
+
| 1362 | +14x | +
+ 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 | ++ |
+ }+ |
+
| 1367 | ++ |
+ )+ |
+
| 1368 | ++ | + + | +
| 1369 | ++ |
+ ### Collect all leaves of a current tree+ |
+
| 1370 | ++ |
+ ### This is a workhorse function in various+ |
+
| 1371 | ++ |
+ ### places+ |
+
| 1372 | ++ |
+ ### NB this is written generally enought o+ |
+
| 1373 | ++ |
+ ### be used on all tree-based structures in the+ |
+
| 1374 | ++ |
+ ### framework.+ |
+
| 1375 | ++ | + + | +
| 1376 | ++ |
+ #' Collect leaves of a `TableTree`+ |
+
| 1377 | ++ |
+ #'+ |
+
| 1378 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1379 | ++ |
+ #' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`.+ |
+
| 1380 | ++ |
+ #' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`.+ |
+
| 1381 | ++ |
+ #'+ |
+
| 1382 | ++ |
+ #' @return A list of `TableRow` objects for all rows in the table.+ |
+
| 1383 | ++ |
+ #'+ |
+
| 1384 | ++ |
+ #' @export+ |
+
| 1385 | ++ |
+ setGeneric("collect_leaves",
+ |
+
| 1386 | ++ |
+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ |
+
| 1387 | +106724x | +
+ standardGeneric("collect_leaves")
+ |
+
| 1388 | ++ |
+ },+ |
+
| 1389 | ++ |
+ signature = "tt"+ |
+
| 1390 | ++ |
+ )+ |
+
| 1391 | ++ | + + | +
| 1392 | ++ |
+ #' @inheritParams collect_leaves+ |
+
| 1393 | ++ |
+ #'+ |
+
| 1394 | ++ |
+ #' @rdname int_methods+ |
+
| 1395 | ++ |
+ #' @exportMethod collect_leaves+ |
+
| 1396 | ++ |
+ setMethod(+ |
+
| 1397 | ++ |
+ "collect_leaves", "TableTree",+ |
+
| 1398 | ++ |
+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ |
+
| 1399 | +23430x | +
+ ret <- c(+ |
+
| 1400 | +23430x | +
+ if (add.labrows && labelrow_visible(tt)) {
+ |
+
| 1401 | +9654x | +
+ tt_labelrow(tt)+ |
+
| 1402 | ++ |
+ },+ |
+
| 1403 | +23430x | +
+ if (incl.cont) {
+ |
+
| 1404 | +23430x | +
+ tree_children(content_table(tt))+ |
+
| 1405 | ++ |
+ },+ |
+
| 1406 | +23430x | +
+ lapply(tree_children(tt),+ |
+
| 1407 | +23430x | +
+ collect_leaves,+ |
+
| 1408 | +23430x | +
+ incl.cont = incl.cont, add.labrows = add.labrows+ |
+
| 1409 | ++ |
+ )+ |
+
| 1410 | ++ |
+ )+ |
+
| 1411 | +23430x | +
+ unlist(ret, recursive = TRUE)+ |
+
| 1412 | ++ |
+ }+ |
+
| 1413 | ++ |
+ )+ |
+
| 1414 | ++ | + + | +
| 1415 | ++ |
+ #' @rdname int_methods+ |
+
| 1416 | ++ |
+ #' @exportMethod collect_leaves+ |
+
| 1417 | ++ |
+ setMethod(+ |
+
| 1418 | ++ |
+ "collect_leaves", "ElementaryTable",+ |
+
| 1419 | ++ |
+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ |
+
| 1420 | +54042x | +
+ ret <- tree_children(tt)+ |
+
| 1421 | +54042x | +
+ if (add.labrows && labelrow_visible(tt)) {
+ |
+
| 1422 | +10488x | +
+ ret <- c(tt_labelrow(tt), ret)+ |
+
| 1423 | ++ |
+ }+ |
+
| 1424 | +54042x | +
+ ret+ |
+
| 1425 | ++ |
+ }+ |
+
| 1426 | ++ |
+ )+ |
+
| 1427 | ++ | + + | +
| 1428 | ++ |
+ #' @rdname int_methods+ |
+
| 1429 | ++ |
+ #' @exportMethod collect_leaves+ |
+
| 1430 | ++ |
+ setMethod(+ |
+
| 1431 | ++ |
+ "collect_leaves", "VTree",+ |
+
| 1432 | ++ |
+ function(tt, incl.cont, add.labrows) {
+ |
+
| 1433 | +! | +
+ ret <- lapply(+ |
+
| 1434 | +! | +
+ tree_children(tt),+ |
+
| 1435 | +! | +
+ collect_leaves+ |
+
| 1436 | ++ |
+ )+ |
+
| 1437 | +! | +
+ unlist(ret, recursive = TRUE)+ |
+
| 1438 | ++ |
+ }+ |
+
| 1439 | ++ |
+ )+ |
+
| 1440 | ++ | + + | +
| 1441 | ++ |
+ #' @rdname int_methods+ |
+
| 1442 | ++ |
+ #' @exportMethod collect_leaves+ |
+
| 1443 | ++ |
+ setMethod(+ |
+
| 1444 | ++ |
+ "collect_leaves", "VLeaf",+ |
+
| 1445 | ++ |
+ function(tt, incl.cont, add.labrows) {
+ |
+
| 1446 | +686x | +
+ list(tt)+ |
+
| 1447 | ++ |
+ }+ |
+
| 1448 | ++ |
+ )+ |
+
| 1449 | ++ | + + | +
| 1450 | ++ |
+ #' @rdname int_methods+ |
+
| 1451 | ++ |
+ #' @exportMethod collect_leaves+ |
+
| 1452 | ++ |
+ setMethod(+ |
+
| 1453 | ++ |
+ "collect_leaves", "NULL",+ |
+
| 1454 | ++ |
+ function(tt, incl.cont, add.labrows) {
+ |
+
| 1455 | +! | +
+ list()+ |
+
| 1456 | ++ |
+ }+ |
+
| 1457 | ++ |
+ )+ |
+
| 1458 | ++ | + + | +
| 1459 | ++ |
+ #' @rdname int_methods+ |
+
| 1460 | ++ |
+ #' @exportMethod collect_leaves+ |
+
| 1461 | ++ |
+ setMethod(+ |
+
| 1462 | ++ |
+ "collect_leaves", "ANY",+ |
+
| 1463 | ++ |
+ function(tt, incl.cont, add.labrows) {
+ |
+
| 1464 | +! | +
+ stop("class ", class(tt), " does not inherit from VTree or VLeaf")
+ |
+
| 1465 | ++ |
+ }+ |
+
| 1466 | ++ |
+ )+ |
+
| 1467 | ++ | + + | +
| 1468 | ++ |
+ n_leaves <- function(tt, ...) {
+ |
+
| 1469 | +202x | +
+ length(collect_leaves(tt, ...))+ |
+
| 1470 | ++ |
+ }+ |
+
| 1471 | ++ | + + | +
| 1472 | ++ |
+ ### Spanning information ----+ |
+
| 1473 | ++ | + + | +
| 1474 | ++ |
+ #' @rdname int_methods+ |
+
| 1475 | +53069x | +
+ setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))
+ |
+
| 1476 | ++ | + + | +
| 1477 | ++ |
+ #' @rdname int_methods+ |
+
| 1478 | +4516x | +
+ setMethod("row_cspans", "TableRow", function(obj) obj@colspans)
+ |
+
| 1479 | ++ | + + | +
| 1480 | ++ |
+ #' @rdname int_methods+ |
+
| 1481 | ++ |
+ setMethod(+ |
+
| 1482 | ++ |
+ "row_cspans", "LabelRow",+ |
+
| 1483 | +1489x | +
+ function(obj) rep(1L, ncol(obj))+ |
+
| 1484 | ++ |
+ )+ |
+
| 1485 | ++ | + + | +
| 1486 | ++ |
+ #' @rdname int_methods+ |
+
| 1487 | +3974x | +
+ setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))
+ |
+
| 1488 | ++ | + + | +
| 1489 | ++ |
+ #' @rdname int_methods+ |
+
| 1490 | ++ |
+ setMethod("row_cspans<-", "TableRow", function(obj, value) {
+ |
+
| 1491 | +3974x | +
+ obj@colspans <- value+ |
+
| 1492 | +3974x | +
+ obj+ |
+
| 1493 | ++ |
+ })+ |
+
| 1494 | ++ | + + | +
| 1495 | ++ |
+ #' @rdname int_methods+ |
+
| 1496 | ++ |
+ setMethod("row_cspans<-", "LabelRow", function(obj, value) {
+ |
+
| 1497 | ++ |
+ stop("attempted to set colspans for LabelRow") # nocov
+ |
+
| 1498 | ++ |
+ })+ |
+
| 1499 | ++ | + + | +
| 1500 | ++ |
+ ## XXX TODO colapse with above?+ |
+
| 1501 | ++ |
+ #' @rdname int_methods+ |
+
| 1502 | +46444x | +
+ setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))
+ |
+
| 1503 | ++ | + + | +
| 1504 | ++ |
+ #' @rdname int_methods+ |
+
| 1505 | ++ |
+ setMethod(+ |
+
| 1506 | ++ |
+ "cell_cspan", "CellValue",+ |
+
| 1507 | +46444x | +
+ function(obj) attr(obj, "colspan", exact = TRUE)+ |
+
| 1508 | ++ |
+ ) ## obj@colspan)+ |
+
| 1509 | ++ | + + | +
| 1510 | ++ |
+ #' @rdname int_methods+ |
+
| 1511 | ++ |
+ setGeneric(+ |
+
| 1512 | ++ |
+ "cell_cspan<-",+ |
+
| 1513 | +6892x | +
+ function(obj, value) standardGeneric("cell_cspan<-")
+ |
+
| 1514 | ++ |
+ )+ |
+
| 1515 | ++ | + + | +
| 1516 | ++ |
+ #' @rdname int_methods+ |
+
| 1517 | ++ |
+ setMethod("cell_cspan<-", "CellValue", function(obj, value) {
+ |
+
| 1518 | ++ |
+ ## obj@colspan <- value+ |
+
| 1519 | +6892x | +
+ attr(obj, "colspan") <- value+ |
+
| 1520 | +6892x | +
+ obj+ |
+
| 1521 | ++ |
+ })+ |
+
| 1522 | ++ | + + | +
| 1523 | ++ |
+ #' @rdname int_methods+ |
+
| 1524 | +26620x | +
+ setGeneric("cell_align", function(obj) standardGeneric("cell_align"))
+ |
+
| 1525 | ++ | + + | +
| 1526 | ++ |
+ #' @rdname int_methods+ |
+
| 1527 | ++ |
+ setMethod(+ |
+
| 1528 | ++ |
+ "cell_align", "CellValue",+ |
+
| 1529 | +26620x | +
+ function(obj) attr(obj, "align", exact = TRUE) %||% "center"+ |
+
| 1530 | ++ |
+ ) ## obj@colspan)+ |
+
| 1531 | ++ | + + | +
| 1532 | ++ |
+ #' @rdname int_methods+ |
+
| 1533 | ++ |
+ setGeneric(+ |
+
| 1534 | ++ |
+ "cell_align<-",+ |
+
| 1535 | +56x | +
+ function(obj, value) standardGeneric("cell_align<-")
+ |
+
| 1536 | ++ |
+ )+ |
+
| 1537 | ++ | + + | +
| 1538 | ++ |
+ #' @rdname int_methods+ |
+
| 1539 | ++ |
+ setMethod("cell_align<-", "CellValue", function(obj, value) {
+ |
+
| 1540 | ++ |
+ ## obj@colspan <- value+ |
+
| 1541 | +56x | +
+ if (is.null(value)) {
+ |
+
| 1542 | +! | +
+ value <- "center"+ |
+
| 1543 | ++ |
+ } else {
+ |
+
| 1544 | +56x | +
+ value <- tolower(value)+ |
+
| 1545 | ++ |
+ }+ |
+
| 1546 | +56x | +
+ check_aligns(value)+ |
+
| 1547 | +56x | +
+ attr(obj, "align") <- value+ |
+
| 1548 | +56x | +
+ obj+ |
+
| 1549 | ++ |
+ })+ |
+
| 1550 | ++ | + + | +
| 1551 | ++ |
+ ### Level (indent) in tree structure ----+ |
+
| 1552 | ++ | + + | +
| 1553 | ++ |
+ #' @rdname int_methods+ |
+
| 1554 | +209x | +
+ setGeneric("tt_level", function(obj) standardGeneric("tt_level"))
+ |
+
| 1555 | ++ | + + | +
| 1556 | ++ |
+ ## this will hit everything via inheritence+ |
+
| 1557 | ++ |
+ #' @rdname int_methods+ |
+
| 1558 | +209x | +
+ setMethod("tt_level", "VNodeInfo", function(obj) obj@level)
+ |
+
| 1559 | ++ | + + | +
| 1560 | ++ |
+ #' @rdname int_methods+ |
+
| 1561 | +2x | +
+ setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))
+ |
+
| 1562 | ++ | + + | +
| 1563 | ++ |
+ ## this will hit everyhing via inheritence+ |
+
| 1564 | ++ |
+ #' @rdname int_methods+ |
+
| 1565 | ++ |
+ setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
+ |
+
| 1566 | +1x | +
+ obj@level <- as.integer(value)+ |
+
| 1567 | +1x | +
+ obj+ |
+
| 1568 | ++ |
+ })+ |
+
| 1569 | ++ | + + | +
| 1570 | ++ |
+ #' @rdname int_methods+ |
+
| 1571 | ++ |
+ setMethod(+ |
+
| 1572 | ++ |
+ "tt_level<-", "VTableTree",+ |
+
| 1573 | ++ |
+ function(obj, value) {
+ |
+
| 1574 | +1x | +
+ obj@level <- as.integer(value)+ |
+
| 1575 | +1x | +
+ tree_children(obj) <- lapply(tree_children(obj),+ |
+
| 1576 | +1x | +
+ `tt_level<-`,+ |
+
| 1577 | +1x | +
+ value = as.integer(value) + 1L+ |
+
| 1578 | ++ |
+ )+ |
+
| 1579 | +1x | +
+ obj+ |
+
| 1580 | ++ |
+ }+ |
+
| 1581 | ++ |
+ )+ |
+
| 1582 | ++ | + + | +
| 1583 | ++ |
+ #' @rdname int_methods+ |
+
| 1584 | ++ |
+ #' @export+ |
+
| 1585 | +52936x | +
+ setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))
+ |
+
| 1586 | ++ | + + | +
| 1587 | ++ |
+ #' @rdname int_methods+ |
+
| 1588 | ++ |
+ setMethod(+ |
+
| 1589 | ++ |
+ "indent_mod", "Split",+ |
+
| 1590 | +2876x | +
+ function(obj) obj@indent_modifier+ |
+
| 1591 | ++ |
+ )+ |
+
| 1592 | ++ | + + | +
| 1593 | ++ |
+ #' @rdname int_methods+ |
+
| 1594 | ++ |
+ setMethod(+ |
+
| 1595 | ++ |
+ "indent_mod", "VTableNodeInfo",+ |
+
| 1596 | +24167x | +
+ function(obj) obj@indent_modifier+ |
+
| 1597 | ++ |
+ )+ |
+
| 1598 | ++ | + + | +
| 1599 | ++ |
+ #' @rdname int_methods+ |
+
| 1600 | ++ |
+ setMethod(+ |
+
| 1601 | ++ |
+ "indent_mod", "ANY",+ |
+
| 1602 | +22595x | +
+ function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L+ |
+
| 1603 | ++ |
+ )+ |
+
| 1604 | ++ | + + | +
| 1605 | ++ |
+ #' @rdname int_methods+ |
+
| 1606 | ++ |
+ setMethod(+ |
+
| 1607 | ++ |
+ "indent_mod", "RowsVerticalSection",+ |
+
| 1608 | ++ |
+ ## function(obj) setNames(obj@indent_mods,names(obj)))+ |
+
| 1609 | ++ |
+ function(obj) {
+ |
+
| 1610 | +1592x | +
+ val <- attr(obj, "indent_mods", exact = TRUE) %||%+ |
+
| 1611 | +1592x | +
+ vapply(obj, indent_mod, 1L) ## rep(0L, length(obj))+ |
+
| 1612 | +1592x | +
+ setNames(val, names(obj))+ |
+
| 1613 | ++ |
+ }+ |
+
| 1614 | ++ |
+ )+ |
+
| 1615 | ++ | + + | +
| 1616 | ++ |
+ #' @examples+ |
+
| 1617 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1618 | ++ |
+ #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
+ |
+
| 1619 | ++ |
+ #' analyze("AGE")
+ |
+
| 1620 | ++ |
+ #'+ |
+
| 1621 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 1622 | ++ |
+ #' indent_mod(tbl)+ |
+
| 1623 | ++ |
+ #' indent_mod(tbl) <- 1L+ |
+
| 1624 | ++ |
+ #' tbl+ |
+
| 1625 | ++ |
+ #'+ |
+
| 1626 | ++ |
+ #' @rdname int_methods+ |
+
| 1627 | ++ |
+ #' @export+ |
+
| 1628 | +1422x | +
+ setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))
+ |
+
| 1629 | ++ | + + | +
| 1630 | ++ |
+ #' @rdname int_methods+ |
+
| 1631 | ++ |
+ setMethod(+ |
+
| 1632 | ++ |
+ "indent_mod<-", "Split",+ |
+
| 1633 | ++ |
+ function(obj, value) {
+ |
+
| 1634 | +1x | +
+ obj@indent_modifier <- as.integer(value)+ |
+
| 1635 | +1x | +
+ obj+ |
+
| 1636 | ++ |
+ }+ |
+
| 1637 | ++ |
+ )+ |
+
| 1638 | ++ | + + | +
| 1639 | ++ |
+ #' @rdname int_methods+ |
+
| 1640 | ++ |
+ setMethod(+ |
+
| 1641 | ++ |
+ "indent_mod<-", "VTableNodeInfo",+ |
+
| 1642 | ++ |
+ function(obj, value) {
+ |
+
| 1643 | +1418x | +
+ obj@indent_modifier <- as.integer(value)+ |
+
| 1644 | +1418x | +
+ obj+ |
+
| 1645 | ++ |
+ }+ |
+
| 1646 | ++ |
+ )+ |
+
| 1647 | ++ | + + | +
| 1648 | ++ |
+ #' @rdname int_methods+ |
+
| 1649 | ++ |
+ setMethod(+ |
+
| 1650 | ++ |
+ "indent_mod<-", "CellValue",+ |
+
| 1651 | ++ |
+ function(obj, value) {
+ |
+
| 1652 | +2x | +
+ attr(obj, "indent_mod") <- as.integer(value)+ |
+
| 1653 | +2x | +
+ obj+ |
+
| 1654 | ++ |
+ }+ |
+
| 1655 | ++ |
+ )+ |
+
| 1656 | ++ | + + | +
| 1657 | ++ |
+ #' @rdname int_methods+ |
+
| 1658 | ++ |
+ setMethod(+ |
+
| 1659 | ++ |
+ "indent_mod<-", "RowsVerticalSection",+ |
+
| 1660 | ++ |
+ function(obj, value) {
+ |
+
| 1661 | +1x | +
+ if (length(value) != 1 && length(value) != length(obj)) {
+ |
+
| 1662 | +! | +
+ stop(+ |
+
| 1663 | +! | +
+ "When setting indent mods on a RowsVerticalSection the value ",+ |
+
| 1664 | +! | +
+ "must have length 1 or the number of rows"+ |
+
| 1665 | ++ |
+ )+ |
+
| 1666 | ++ |
+ }+ |
+
| 1667 | +1x | +
+ attr(obj, "indent_mods") <- as.integer(value)+ |
+
| 1668 | +1x | +
+ obj+ |
+
| 1669 | ++ | + + | +
| 1670 | ++ |
+ ## obj@indent_mods <- value+ |
+
| 1671 | ++ |
+ ## obj+ |
+
| 1672 | ++ |
+ }+ |
+
| 1673 | ++ |
+ )+ |
+
| 1674 | ++ | + + | +
| 1675 | ++ |
+ #' @rdname int_methods+ |
+
| 1676 | ++ |
+ setGeneric(+ |
+
| 1677 | ++ |
+ "content_indent_mod",+ |
+
| 1678 | +1191x | +
+ function(obj) standardGeneric("content_indent_mod")
+ |
+
| 1679 | ++ |
+ )+ |
+
| 1680 | ++ | + + | +
| 1681 | ++ |
+ #' @rdname int_methods+ |
+
| 1682 | ++ |
+ setMethod(+ |
+
| 1683 | ++ |
+ "content_indent_mod", "Split",+ |
+
| 1684 | +1191x | +
+ function(obj) obj@content_indent_modifier+ |
+
| 1685 | ++ |
+ )+ |
+
| 1686 | ++ | + + | +
| 1687 | ++ |
+ #' @rdname int_methods+ |
+
| 1688 | ++ |
+ setMethod(+ |
+
| 1689 | ++ |
+ "content_indent_mod", "VTableNodeInfo",+ |
+
| 1690 | +! | +
+ function(obj) obj@content_indent_modifier+ |
+
| 1691 | ++ |
+ )+ |
+
| 1692 | ++ | + + | +
| 1693 | ++ |
+ #' @rdname int_methods+ |
+
| 1694 | ++ |
+ setGeneric(+ |
+
| 1695 | ++ |
+ "content_indent_mod<-",+ |
+
| 1696 | +114x | +
+ function(obj, value) standardGeneric("content_indent_mod<-")
+ |
+
| 1697 | ++ |
+ )+ |
+
| 1698 | ++ | + + | +
| 1699 | ++ |
+ #' @rdname int_methods+ |
+
| 1700 | ++ |
+ setMethod(+ |
+
| 1701 | ++ |
+ "content_indent_mod<-", "Split",+ |
+
| 1702 | ++ |
+ function(obj, value) {
+ |
+
| 1703 | +114x | +
+ obj@content_indent_modifier <- as.integer(value)+ |
+
| 1704 | +114x | +
+ obj+ |
+
| 1705 | ++ |
+ }+ |
+
| 1706 | ++ |
+ )+ |
+
| 1707 | ++ | + + | +
| 1708 | ++ |
+ #' @rdname int_methods+ |
+
| 1709 | ++ |
+ setMethod(+ |
+
| 1710 | ++ |
+ "content_indent_mod<-", "VTableNodeInfo",+ |
+
| 1711 | ++ |
+ function(obj, value) {
+ |
+
| 1712 | +! | +
+ obj@content_indent_modifier <- as.integer(value)+ |
+
| 1713 | +! | +
+ obj+ |
+
| 1714 | ++ |
+ }+ |
+
| 1715 | ++ |
+ )+ |
+
| 1716 | ++ | + + | +
| 1717 | ++ |
+ ## TODO export these?+ |
+
| 1718 | ++ |
+ #' @rdname int_methods+ |
+
| 1719 | ++ |
+ #' @export+ |
+
| 1720 | +164771x | +
+ setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))
+ |
+
| 1721 | ++ | + + | +
| 1722 | ++ |
+ #' @rdname int_methods+ |
+
| 1723 | +! | +
+ setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)
+ |
+
| 1724 | ++ | + + | +
| 1725 | ++ |
+ #' @rdname int_methods+ |
+
| 1726 | +66x | +
+ setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)
+ |
+
| 1727 | ++ | + + | +
| 1728 | ++ |
+ #' @rdname int_methods+ |
+
| 1729 | +3479x | +
+ setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))
+ |
+
| 1730 | ++ | + + | +
| 1731 | ++ |
+ #' @rdname int_methods+ |
+
| 1732 | +4458x | +
+ setMethod("rawvalues", "ANY", function(obj) obj)
+ |
+
| 1733 | ++ | + + | +
| 1734 | ++ |
+ #' @rdname int_methods+ |
+
| 1735 | +82974x | +
+ setMethod("rawvalues", "CellValue", function(obj) obj[[1]])
+ |
+
| 1736 | ++ | + + | +
| 1737 | ++ |
+ #' @rdname int_methods+ |
+
| 1738 | ++ |
+ setMethod(+ |
+
| 1739 | ++ |
+ "rawvalues", "TreePos",+ |
+
| 1740 | +228x | +
+ function(obj) rawvalues(pos_splvals(obj))+ |
+
| 1741 | ++ |
+ )+ |
+
| 1742 | ++ | + + | +
| 1743 | ++ |
+ #' @rdname int_methods+ |
+
| 1744 | ++ |
+ setMethod(+ |
+
| 1745 | ++ |
+ "rawvalues", "RowsVerticalSection",+ |
+
| 1746 | +2x | +
+ function(obj) unlist(obj, recursive = FALSE)+ |
+
| 1747 | ++ |
+ )+ |
+
| 1748 | ++ | + + | +
| 1749 | ++ |
+ #' @rdname int_methods+ |
+
| 1750 | ++ |
+ #' @export+ |
+
| 1751 | +82591x | +
+ setGeneric("value_names", function(obj) standardGeneric("value_names"))
+ |
+
| 1752 | ++ | + + | +
| 1753 | ++ |
+ #' @rdname int_methods+ |
+
| 1754 | ++ |
+ setMethod(+ |
+
| 1755 | ++ |
+ "value_names", "ANY",+ |
+
| 1756 | +38x | +
+ function(obj) as.character(rawvalues(obj))+ |
+
| 1757 | ++ |
+ )+ |
+
| 1758 | ++ | + + | +
| 1759 | ++ |
+ #' @rdname int_methods+ |
+
| 1760 | ++ |
+ setMethod(+ |
+
| 1761 | ++ |
+ "value_names", "TreePos",+ |
+
| 1762 | +1363x | +
+ function(obj) value_names(pos_splvals(obj))+ |
+
| 1763 | ++ |
+ )+ |
+
| 1764 | ++ | + + | +
| 1765 | ++ |
+ #' @rdname int_methods+ |
+
| 1766 | ++ |
+ setMethod(+ |
+
| 1767 | ++ |
+ "value_names", "list",+ |
+
| 1768 | +6628x | +
+ function(obj) lapply(obj, value_names)+ |
+
| 1769 | ++ |
+ )+ |
+
| 1770 | ++ | + + | +
| 1771 | ++ |
+ #' @rdname int_methods+ |
+
| 1772 | ++ |
+ setMethod(+ |
+
| 1773 | ++ |
+ "value_names", "ValueWrapper",+ |
+
| 1774 | +! | +
+ function(obj) rawvalues(obj)+ |
+
| 1775 | ++ |
+ )+ |
+
| 1776 | ++ | + + | +
| 1777 | ++ |
+ #' @rdname int_methods+ |
+
| 1778 | ++ |
+ setMethod(+ |
+
| 1779 | ++ |
+ "value_names", "LevelComboSplitValue",+ |
+
| 1780 | +1601x | +
+ function(obj) obj@value+ |
+
| 1781 | ++ |
+ ) ## obj@comboname)+ |
+
| 1782 | ++ | + + | +
| 1783 | ++ |
+ #' @rdname int_methods+ |
+
| 1784 | ++ |
+ setMethod(+ |
+
| 1785 | ++ |
+ "value_names", "RowsVerticalSection",+ |
+
| 1786 | +3160x | +
+ function(obj) attr(obj, "row_names", exact = TRUE)+ |
+
| 1787 | ++ |
+ ) ## obj@row_names)+ |
+
| 1788 | ++ | + + | +
| 1789 | ++ |
+ ## not sure if I need these anywhere+ |
+
| 1790 | ++ |
+ ## XXX+ |
+
| 1791 | ++ |
+ #' @rdname int_methods+ |
+
| 1792 | +5423x | +
+ setGeneric("value_labels", function(obj) standardGeneric("value_labels"))
+ |
+
| 1793 | ++ | + + | +
| 1794 | ++ |
+ #' @rdname int_methods+ |
+
| 1795 | +! | +
+ setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))
+ |
+
| 1796 | ++ | + + | +
| 1797 | ++ |
+ #' @rdname int_methods+ |
+
| 1798 | ++ |
+ setMethod(+ |
+
| 1799 | ++ |
+ "value_labels", "TreePos",+ |
+
| 1800 | +! | +
+ function(obj) sapply(pos_splvals(obj), obj_label)+ |
+
| 1801 | ++ |
+ )+ |
+
| 1802 | ++ | + + | +
| 1803 | ++ |
+ #' @rdname int_methods+ |
+
| 1804 | ++ |
+ setMethod("value_labels", "list", function(obj) {
+ |
+
| 1805 | +3782x | +
+ ret <- lapply(obj, obj_label)+ |
+
| 1806 | ++ |
+ if (!is.null(names(obj))) {
+ |
+
| 1807 | +528x | +
+ inds <- vapply(ret, function(x) length(x) == 0, NA)+ |
+
| 1808 | +528x | +
+ ret[inds] <- names(obj)[inds]+ |
+
| 1809 | ++ |
+ }+ |
+
| 1810 | +3782x | +
+ ret+ |
+
| 1811 | ++ |
+ })+ |
+
| 1812 | ++ | + + | +
| 1813 | ++ |
+ #' @rdname int_methods+ |
+
| 1814 | ++ |
+ setMethod(+ |
+
| 1815 | ++ |
+ "value_labels",+ |
+
| 1816 | ++ |
+ "RowsVerticalSection",+ |
+
| 1817 | +1593x | +
+ function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj))+ |
+
| 1818 | ++ |
+ )+ |
+
| 1819 | ++ | + + | +
| 1820 | ++ |
+ #' @rdname int_methods+ |
+
| 1821 | +! | +
+ setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))
+ |
+
| 1822 | ++ | + + | +
| 1823 | ++ |
+ #' @rdname int_methods+ |
+
| 1824 | ++ |
+ setMethod(+ |
+
| 1825 | ++ |
+ "value_labels", "LevelComboSplitValue",+ |
+
| 1826 | +! | +
+ function(obj) obj_label(obj)+ |
+
| 1827 | ++ |
+ )+ |
+
| 1828 | ++ | + + | +
| 1829 | ++ |
+ #' @rdname int_methods+ |
+
| 1830 | +48x | +
+ setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)
+ |
+
| 1831 | ++ | + + | +
| 1832 | ++ |
+ #' @rdname int_methods+ |
+
| 1833 | +5491x | +
+ setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
+ |
+
| 1834 | ++ |
+ #' @rdname int_methods+ |
+
| 1835 | +110x | +
+ setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
+ |
+
| 1836 | ++ |
+ #' @rdname int_methods+ |
+
| 1837 | +! | +
+ setMethod("value_expr", "ANY", function(obj) NULL)
+ |
+
| 1838 | ++ |
+ ## no setters for now, we'll see about that.+ |
+
| 1839 | ++ | + + | +
| 1840 | ++ |
+ #' @rdname int_methods+ |
+
| 1841 | +6x | +
+ setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))
+ |
+
| 1842 | ++ | + + | +
| 1843 | ++ |
+ #' @rdname int_methods+ |
+
| 1844 | +6x | +
+ setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)
+ |
+
| 1845 | ++ | + + | +
| 1846 | ++ |
+ #' @rdname int_methods+ |
+
| 1847 | ++ |
+ setGeneric(+ |
+
| 1848 | ++ |
+ "spl_varlabels<-",+ |
+
| 1849 | +2x | +
+ function(object, value) standardGeneric("spl_varlabels<-")
+ |
+
| 1850 | ++ |
+ )+ |
+
| 1851 | ++ | + + | +
| 1852 | ++ |
+ #' @rdname int_methods+ |
+
| 1853 | ++ |
+ setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
+ |
+
| 1854 | +2x | +
+ object@var_labels <- value+ |
+
| 1855 | +2x | +
+ object+ |
+
| 1856 | ++ |
+ })+ |
+
| 1857 | ++ | + + | +
| 1858 | ++ |
+ ## These two are similar enough we could probably combine+ |
+
| 1859 | ++ |
+ ## them but conceptually they are pretty different+ |
+
| 1860 | ++ |
+ ## split_exargs is a list of extra arguments that apply+ |
+
| 1861 | ++ |
+ ## to *all the chidlren*,+ |
+
| 1862 | ++ |
+ ## while splv_extra is for *child-specific* extra arguments,+ |
+
| 1863 | ++ |
+ ## associated with specific values of the split+ |
+
| 1864 | ++ |
+ #' @rdname int_methods+ |
+
| 1865 | +3612x | +
+ setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))
+ |
+
| 1866 | ++ | + + | +
| 1867 | ++ |
+ #' @rdname int_methods+ |
+
| 1868 | ++ |
+ setMethod(+ |
+
| 1869 | ++ |
+ "splv_extra", "SplitValue",+ |
+
| 1870 | +3612x | +
+ function(obj) obj@extra+ |
+
| 1871 | ++ |
+ )+ |
+
| 1872 | ++ | + + | +
| 1873 | ++ |
+ #' @rdname int_methods+ |
+
| 1874 | ++ |
+ setGeneric(+ |
+
| 1875 | ++ |
+ "splv_extra<-",+ |
+
| 1876 | +2007x | +
+ function(obj, value) standardGeneric("splv_extra<-")
+ |
+
| 1877 | ++ |
+ )+ |
+
| 1878 | ++ |
+ #' @rdname int_methods+ |
+
| 1879 | ++ |
+ setMethod(+ |
+
| 1880 | ++ |
+ "splv_extra<-", "SplitValue",+ |
+
| 1881 | ++ |
+ function(obj, value) {
+ |
+
| 1882 | +2007x | +
+ obj@extra <- value+ |
+
| 1883 | +2007x | +
+ obj+ |
+
| 1884 | ++ |
+ }+ |
+
| 1885 | ++ |
+ )+ |
+
| 1886 | ++ | + + | +
| 1887 | ++ |
+ #' @rdname int_methods+ |
+
| 1888 | +2158x | +
+ setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))
+ |
+
| 1889 | ++ | + + | +
| 1890 | ++ |
+ #' @rdname int_methods+ |
+
| 1891 | ++ |
+ setMethod(+ |
+
| 1892 | ++ |
+ "split_exargs", "Split",+ |
+
| 1893 | +2107x | +
+ function(obj) obj@extra_args+ |
+
| 1894 | ++ |
+ )+ |
+
| 1895 | ++ | + + | +
| 1896 | ++ |
+ #' @rdname int_methods+ |
+
| 1897 | ++ |
+ setGeneric(+ |
+
| 1898 | ++ |
+ "split_exargs<-",+ |
+
| 1899 | +1x | +
+ function(obj, value) standardGeneric("split_exargs<-")
+ |
+
| 1900 | ++ |
+ )+ |
+
| 1901 | ++ | + + | +
| 1902 | ++ |
+ #' @rdname int_methods+ |
+
| 1903 | ++ |
+ setMethod(+ |
+
| 1904 | ++ |
+ "split_exargs<-", "Split",+ |
+
| 1905 | ++ |
+ function(obj, value) {
+ |
+
| 1906 | +1x | +
+ obj@extra_args <- value+ |
+
| 1907 | +1x | +
+ obj+ |
+
| 1908 | ++ |
+ }+ |
+
| 1909 | ++ |
+ )+ |
+
| 1910 | ++ | + + | +
| 1911 | +! | +
+ is_labrow <- function(obj) is(obj, "LabelRow")+ |
+
| 1912 | ++ | + + | +
| 1913 | ++ |
+ spl_ref_group <- function(obj) {
+ |
+
| 1914 | +17x | +
+ stopifnot(is(obj, "VarLevWBaselineSplit"))+ |
+
| 1915 | +17x | +
+ obj@ref_group_value+ |
+
| 1916 | ++ |
+ }+ |
+
| 1917 | ++ | + + | +
| 1918 | ++ |
+ ### column info+ |
+
| 1919 | ++ | + + | +
| 1920 | ++ |
+ #' Column information/structure accessors+ |
+
| 1921 | ++ |
+ #'+ |
+
| 1922 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1923 | ++ |
+ #' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being+ |
+
| 1924 | ++ |
+ #' generated from a pre-data layout object.+ |
+
| 1925 | ++ |
+ #' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only.+ |
+
| 1926 | ++ |
+ #' Path (in column structure).+ |
+
| 1927 | ++ |
+ #' @param rtpos (`TreePos`)\cr root position.+ |
+
| 1928 | ++ |
+ #'+ |
+
| 1929 | ++ |
+ #' @return A `LayoutColTree` object.+ |
+
| 1930 | ++ |
+ #'+ |
+
| 1931 | ++ |
+ #' @rdname col_accessors+ |
+
| 1932 | ++ |
+ #' @export+ |
+
| 1933 | +3960x | +
+ setGeneric("clayout", function(obj) standardGeneric("clayout"))
+ |
+
| 1934 | ++ | + + | +
| 1935 | ++ |
+ #' @rdname col_accessors+ |
+
| 1936 | ++ |
+ #' @exportMethod clayout+ |
+
| 1937 | ++ |
+ setMethod(+ |
+
| 1938 | ++ |
+ "clayout", "VTableNodeInfo",+ |
+
| 1939 | +7x | +
+ function(obj) coltree(col_info(obj))+ |
+
| 1940 | ++ |
+ )+ |
+
| 1941 | ++ | + + | +
| 1942 | ++ |
+ #' @rdname col_accessors+ |
+
| 1943 | ++ |
+ #' @exportMethod clayout+ |
+
| 1944 | ++ |
+ setMethod(+ |
+
| 1945 | ++ |
+ "clayout", "PreDataTableLayouts",+ |
+
| 1946 | +3953x | +
+ function(obj) obj@col_layout+ |
+
| 1947 | ++ |
+ )+ |
+
| 1948 | ++ | + + | +
| 1949 | ++ |
+ ## useful convenience for the cascading methods in colby_constructors+ |
+
| 1950 | ++ |
+ #' @rdname col_accessors+ |
+
| 1951 | ++ |
+ #' @exportMethod clayout+ |
+
| 1952 | +! | +
+ setMethod("clayout", "ANY", function(obj) PreDataColLayout())
+ |
+
| 1953 | ++ | + + | +
| 1954 | ++ |
+ #' @rdname col_accessors+ |
+
| 1955 | ++ |
+ #' @export+ |
+
| 1956 | +1426x | +
+ setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))
+ |
+
| 1957 | ++ | + + | +
| 1958 | ++ |
+ #' @rdname col_accessors+ |
+
| 1959 | ++ |
+ #' @exportMethod clayout<-+ |
+
| 1960 | ++ |
+ setMethod(+ |
+
| 1961 | ++ |
+ "clayout<-", "PreDataTableLayouts",+ |
+
| 1962 | ++ |
+ function(object, value) {
+ |
+
| 1963 | +1426x | +
+ object@col_layout <- value+ |
+
| 1964 | +1426x | +
+ object+ |
+
| 1965 | ++ |
+ }+ |
+
| 1966 | ++ |
+ )+ |
+
| 1967 | ++ | + + | +
| 1968 | ++ |
+ #' @rdname col_accessors+ |
+
| 1969 | ++ |
+ #' @export+ |
+
| 1970 | +260117x | +
+ setGeneric("col_info", function(obj) standardGeneric("col_info"))
+ |
+
| 1971 | ++ | + + | +
| 1972 | ++ |
+ #' @rdname col_accessors+ |
+
| 1973 | ++ |
+ #' @exportMethod col_info+ |
+
| 1974 | ++ |
+ setMethod(+ |
+
| 1975 | ++ |
+ "col_info", "VTableNodeInfo",+ |
+
| 1976 | +229378x | +
+ function(obj) obj@col_info+ |
+
| 1977 | ++ |
+ )+ |
+
| 1978 | ++ | + + | +
| 1979 | ++ |
+ ### XXX I've made this recursive. Do we ALWAYS want it to be?+ |
+
| 1980 | ++ |
+ ###+ |
+
| 1981 | ++ |
+ ### I think we do.+ |
+
| 1982 | ++ |
+ #' @rdname col_accessors+ |
+
| 1983 | ++ |
+ #' @export+ |
+
| 1984 | +70058x | +
+ setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))
+ |
+
| 1985 | ++ | + + | +
| 1986 | ++ |
+ #' @return Returns various information about columns, depending on the accessor used.+ |
+
| 1987 | ++ |
+ #'+ |
+
| 1988 | ++ |
+ #' @exportMethod col_info<-+ |
+
| 1989 | ++ |
+ #' @rdname col_accessors+ |
+
| 1990 | ++ |
+ setMethod(+ |
+
| 1991 | ++ |
+ "col_info<-", "TableRow",+ |
+
| 1992 | ++ |
+ function(obj, value) {
+ |
+
| 1993 | +42044x | +
+ obj@col_info <- value+ |
+
| 1994 | +42044x | +
+ obj+ |
+
| 1995 | ++ |
+ }+ |
+
| 1996 | ++ |
+ )+ |
+
| 1997 | ++ | + + | +
| 1998 | ++ |
+ .set_cinfo_kids <- function(obj) {
+ |
+
| 1999 | +21746x | +
+ kids <- lapply(+ |
+
| 2000 | +21746x | +
+ tree_children(obj),+ |
+
| 2001 | +21746x | +
+ function(x) {
+ |
+
| 2002 | +51566x | +
+ col_info(x) <- col_info(obj)+ |
+
| 2003 | +51566x | +
+ x+ |
+
| 2004 | ++ |
+ }+ |
+
| 2005 | ++ |
+ )+ |
+
| 2006 | +21746x | +
+ tree_children(obj) <- kids+ |
+
| 2007 | +21746x | +
+ obj+ |
+
| 2008 | ++ |
+ }+ |
+
| 2009 | ++ | + + | +
| 2010 | ++ |
+ #' @rdname col_accessors+ |
+
| 2011 | ++ |
+ #' @exportMethod col_info<-+ |
+
| 2012 | ++ |
+ setMethod(+ |
+
| 2013 | ++ |
+ "col_info<-", "ElementaryTable",+ |
+
| 2014 | ++ |
+ function(obj, value) {
+ |
+
| 2015 | +14110x | +
+ obj@col_info <- value+ |
+
| 2016 | +14110x | +
+ .set_cinfo_kids(obj)+ |
+
| 2017 | ++ |
+ }+ |
+
| 2018 | ++ |
+ )+ |
+
| 2019 | ++ | + + | +
| 2020 | ++ |
+ #' @rdname col_accessors+ |
+
| 2021 | ++ |
+ #' @exportMethod col_info<-+ |
+
| 2022 | ++ |
+ setMethod(+ |
+
| 2023 | ++ |
+ "col_info<-", "TableTree",+ |
+
| 2024 | ++ |
+ function(obj, value) {
+ |
+
| 2025 | +7636x | +
+ obj@col_info <- value+ |
+
| 2026 | +7636x | +
+ if (nrow(content_table(obj))) {
+ |
+
| 2027 | +1992x | +
+ ct <- content_table(obj)+ |
+
| 2028 | +1992x | +
+ col_info(ct) <- value+ |
+
| 2029 | +1992x | +
+ content_table(obj) <- ct+ |
+
| 2030 | ++ |
+ }+ |
+
| 2031 | +7636x | +
+ .set_cinfo_kids(obj)+ |
+
| 2032 | ++ |
+ }+ |
+
| 2033 | ++ |
+ )+ |
+
| 2034 | ++ | + + | +
| 2035 | ++ |
+ #' @rdname col_accessors+ |
+
| 2036 | ++ |
+ #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for column+ |
+
| 2037 | ++ |
+ #' counts throughout this column tree (i.e. if not overridden by a more specific format+ |
+
| 2038 | ++ |
+ #' specification).+ |
+
| 2039 | ++ |
+ #' @export+ |
+
| 2040 | ++ |
+ setGeneric(+ |
+
| 2041 | ++ |
+ "coltree",+ |
+
| 2042 | +11850x | +
+ function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format = "(N=xx)") standardGeneric("coltree")
+ |
+
| 2043 | ++ |
+ )+ |
+
| 2044 | ++ | + + | +
| 2045 | ++ |
+ #' @rdname col_accessors+ |
+
| 2046 | ++ |
+ #' @exportMethod coltree+ |
+
| 2047 | ++ |
+ setMethod(+ |
+
| 2048 | ++ |
+ "coltree", "InstantiatedColumnInfo",+ |
+
| 2049 | ++ |
+ function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format) {
+ |
+
| 2050 | +7806x | +
+ if (!is.null(df)) {
+ |
+
| 2051 | +! | +
+ warning("Ignoring df argument and retrieving already-computed LayoutColTree")
+ |
+
| 2052 | ++ |
+ }+ |
+
| 2053 | +7806x | +
+ obj@tree_layout+ |
+
| 2054 | ++ |
+ }+ |
+
| 2055 | ++ |
+ )+ |
+
| 2056 | ++ | + + | +
| 2057 | ++ |
+ #' @rdname col_accessors+ |
+
| 2058 | ++ |
+ #' @export coltree+ |
+
| 2059 | ++ |
+ setMethod(+ |
+
| 2060 | ++ |
+ "coltree", "PreDataTableLayouts",+ |
+
| 2061 | ++ |
+ function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
+ |
+
| 2062 | +1x | +
+ coltree(clayout(obj), df, rtpos, alt_counts_df = alt_counts_df, ccount_format = ccount_format)+ |
+
| 2063 | ++ |
+ }+ |
+
| 2064 | ++ |
+ )+ |
+
| 2065 | ++ | + + | +
| 2066 | ++ |
+ #' @rdname col_accessors+ |
+
| 2067 | ++ |
+ #' @export coltree+ |
+
| 2068 | ++ |
+ setMethod(+ |
+
| 2069 | ++ |
+ "coltree", "PreDataColLayout",+ |
+
| 2070 | ++ |
+ function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
+ |
+
| 2071 | +327x | +
+ obj <- set_def_child_ord(obj, df)+ |
+
| 2072 | +327x | +
+ kids <- lapply(+ |
+
| 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 | +
+ alt_counts_df = alt_counts_df,+ |
+
| 2080 | +335x | +
+ global_cc_format = ccount_format+ |
+
| 2081 | ++ |
+ )+ |
+
| 2082 | ++ |
+ }+ |
+
| 2083 | ++ |
+ )+ |
+
| 2084 | +320x | +
+ if (length(kids) == 1) {
+ |
+
| 2085 | +313x | +
+ res <- kids[[1]]+ |
+
| 2086 | ++ |
+ } else {
+ |
+
| 2087 | +7x | +
+ res <- LayoutColTree(+ |
+
| 2088 | +7x | +
+ lev = 0L,+ |
+
| 2089 | +7x | +
+ kids = kids,+ |
+
| 2090 | +7x | +
+ tpos = rtpos,+ |
+
| 2091 | +7x | +
+ spl = RootSplit(),+ |
+
| 2092 | +7x | +
+ colcount = NROW(alt_counts_df),+ |
+
| 2093 | +7x | +
+ colcount_format = ccount_format+ |
+
| 2094 | ++ |
+ )+ |
+
| 2095 | ++ |
+ }+ |
+
| 2096 | +320x | +
+ disp_ccounts(res) <- disp_ccounts(obj)+ |
+
| 2097 | +320x | +
+ res+ |
+
| 2098 | ++ |
+ }+ |
+
| 2099 | ++ |
+ )+ |
+
| 2100 | ++ | + + | +
| 2101 | ++ |
+ #' @rdname col_accessors+ |
+
| 2102 | ++ |
+ #' @export coltree+ |
+
| 2103 | ++ |
+ setMethod(+ |
+
| 2104 | ++ |
+ "coltree", "LayoutColTree",+ |
+
| 2105 | ++ |
+ function(obj, df, rtpos, alt_counts_df, ccount_format) obj+ |
+
| 2106 | ++ |
+ )+ |
+
| 2107 | ++ | + + | +
| 2108 | ++ |
+ #' @rdname col_accessors+ |
+
| 2109 | ++ |
+ #' @export coltree+ |
+
| 2110 | ++ |
+ setMethod(+ |
+
| 2111 | ++ |
+ "coltree", "VTableTree",+ |
+
| 2112 | ++ |
+ function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))+ |
+
| 2113 | ++ |
+ )+ |
+
| 2114 | ++ | + + | +
| 2115 | ++ |
+ #' @rdname col_accessors+ |
+
| 2116 | ++ |
+ #' @export coltree+ |
+
| 2117 | ++ |
+ setMethod(+ |
+
| 2118 | ++ |
+ "coltree", "TableRow",+ |
+
| 2119 | ++ |
+ function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))+ |
+
| 2120 | ++ |
+ )+ |
+
| 2121 | ++ | + + | +
| 2122 | +916x | +
+ setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
+ |
+
| 2123 | ++ |
+ setMethod(+ |
+
| 2124 | ++ |
+ "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
+ |
+
| 2125 | ++ |
+ function(obj, value) {
+ |
+
| 2126 | +494x | +
+ obj@tree_layout <- value+ |
+
| 2127 | +494x | +
+ obj+ |
+
| 2128 | ++ |
+ }+ |
+
| 2129 | ++ |
+ )+ |
+
| 2130 | ++ | + + | +
| 2131 | ++ |
+ setMethod(+ |
+
| 2132 | ++ |
+ "coltree<-", c("VTableTree", "LayoutColTree"),
+ |
+
| 2133 | ++ |
+ function(obj, value) {
+ |
+
| 2134 | +422x | +
+ cinfo <- col_info(obj)+ |
+
| 2135 | +422x | +
+ coltree(cinfo) <- value+ |
+
| 2136 | +422x | +
+ col_info(obj) <- cinfo+ |
+
| 2137 | +422x | +
+ obj+ |
+
| 2138 | ++ |
+ }+ |
+
| 2139 | ++ |
+ )+ |
+
| 2140 | ++ | + + | +
| 2141 | ++ |
+ #' @rdname col_accessors+ |
+
| 2142 | ++ |
+ #' @export+ |
+
| 2143 | +115974x | +
+ setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))
+ |
+
| 2144 | ++ | + + | +
| 2145 | ++ |
+ #' @rdname col_accessors+ |
+
| 2146 | ++ |
+ #' @export col_exprs+ |
+
| 2147 | ++ |
+ setMethod(+ |
+
| 2148 | ++ |
+ "col_exprs", "PreDataTableLayouts",+ |
+
| 2149 | +1x | +
+ function(obj, df = NULL) col_exprs(clayout(obj), df)+ |
+
| 2150 | ++ |
+ )+ |
+
| 2151 | ++ | + + | +
| 2152 | ++ |
+ #' @rdname col_accessors+ |
+
| 2153 | ++ |
+ #' @export col_exprs+ |
+
| 2154 | ++ |
+ setMethod(+ |
+
| 2155 | ++ |
+ "col_exprs", "PreDataColLayout",+ |
+
| 2156 | ++ |
+ function(obj, df = NULL) {
+ |
+
| 2157 | +1x | +
+ if (is.null(df)) {
+ |
+
| 2158 | +! | +
+ stop("can't determine col_exprs without data")
+ |
+
| 2159 | ++ |
+ }+ |
+
| 2160 | +1x | +
+ ct <- coltree(obj, df = df)+ |
+
| 2161 | +1x | +
+ make_col_subsets(ct, df = df)+ |
+
| 2162 | ++ |
+ }+ |
+
| 2163 | ++ |
+ )+ |
+
| 2164 | ++ | + + | +
| 2165 | ++ |
+ #' @rdname col_accessors+ |
+
| 2166 | ++ |
+ #' @export col_exprs+ |
+
| 2167 | ++ |
+ setMethod(+ |
+
| 2168 | ++ |
+ "col_exprs", "InstantiatedColumnInfo",+ |
+
| 2169 | ++ |
+ function(obj, df = NULL) {
+ |
+
| 2170 | +115972x | +
+ if (!is.null(df)) {
+ |
+
| 2171 | +! | +
+ warning("Ignoring df method when extracted precomputed column subsetting expressions.")
+ |
+
| 2172 | ++ |
+ }+ |
+
| 2173 | +115972x | +
+ obj@subset_exprs+ |
+
| 2174 | ++ |
+ }+ |
+
| 2175 | ++ |
+ )+ |
+
| 2176 | ++ | + + | +
| 2177 | ++ |
+ #' @rdname int_methods+ |
+
| 2178 | +2534x | +
+ setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))
+ |
+
| 2179 | ++ | + + | +
| 2180 | ++ |
+ #' @rdname int_methods+ |
+
| 2181 | ++ |
+ setMethod(+ |
+
| 2182 | ++ |
+ "col_extra_args", "InstantiatedColumnInfo",+ |
+
| 2183 | ++ |
+ function(obj, df) {
+ |
+
| 2184 | +2214x | +
+ if (!is.null(df)) {
+ |
+
| 2185 | +! | +
+ warning("Ignorning df when retrieving already-computed column extra arguments.")
+ |
+
| 2186 | ++ |
+ }+ |
+
| 2187 | +2214x | +
+ obj@cextra_args+ |
+
| 2188 | ++ |
+ }+ |
+
| 2189 | ++ |
+ )+ |
+
| 2190 | ++ | + + | +
| 2191 | ++ |
+ #' @rdname int_methods+ |
+
| 2192 | ++ |
+ setMethod(+ |
+
| 2193 | ++ |
+ "col_extra_args", "PreDataTableLayouts",+ |
+
| 2194 | ++ |
+ function(obj, df) col_extra_args(clayout(obj), df)+ |
+
| 2195 | ++ |
+ )+ |
+
| 2196 | ++ | + + | +
| 2197 | ++ |
+ #' @rdname int_methods+ |
+
| 2198 | ++ |
+ setMethod(+ |
+
| 2199 | ++ |
+ "col_extra_args", "PreDataColLayout",+ |
+
| 2200 | ++ |
+ function(obj, df) {
+ |
+
| 2201 | +! | +
+ col_extra_args(coltree(obj, df), NULL)+ |
+
| 2202 | ++ |
+ }+ |
+
| 2203 | ++ |
+ )+ |
+
| 2204 | ++ | + + | +
| 2205 | ++ |
+ #' @rdname int_methods+ |
+
| 2206 | ++ |
+ setMethod(+ |
+
| 2207 | ++ |
+ "col_extra_args", "LayoutColTree",+ |
+
| 2208 | ++ |
+ function(obj, df) {
+ |
+
| 2209 | +320x | +
+ if (!is.null(df)) {
+ |
+
| 2210 | +! | +
+ warning("Ignoring df argument and returning already calculated extra arguments")
+ |
+
| 2211 | ++ |
+ }+ |
+
| 2212 | +320x | +
+ get_col_extras(obj)+ |
+
| 2213 | ++ |
+ }+ |
+
| 2214 | ++ |
+ )+ |
+
| 2215 | ++ | + + | +
| 2216 | ++ |
+ #' @rdname int_methods+ |
+
| 2217 | ++ |
+ setMethod(+ |
+
| 2218 | ++ |
+ "col_extra_args", "LayoutColLeaf",+ |
+
| 2219 | ++ |
+ function(obj, df) {
+ |
+
| 2220 | +! | +
+ if (!is.null(df)) {
+ |
+
| 2221 | +! | +
+ warning("Ignoring df argument and returning already calculated extra arguments")
+ |
+
| 2222 | ++ |
+ }+ |
+
| 2223 | ++ | + + | +
| 2224 | +! | +
+ get_pos_extra(pos = tree_pos(obj))+ |
+
| 2225 | ++ |
+ }+ |
+
| 2226 | ++ |
+ )+ |
+
| 2227 | ++ | + + | +
| 2228 | ++ |
+ #' @seealso [facet_colcount()]+ |
+
| 2229 | ++ |
+ #' @export+ |
+
| 2230 | ++ |
+ #' @rdname col_accessors+ |
+
| 2231 | +1993x | +
+ setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))
+ |
+
| 2232 | ++ | + + | +
| 2233 | ++ |
+ #' @export+ |
+
| 2234 | ++ |
+ #' @rdname col_accessors+ |
+
| 2235 | ++ |
+ setMethod(+ |
+
| 2236 | ++ |
+ "col_counts", "InstantiatedColumnInfo",+ |
+
| 2237 | ++ |
+ function(obj, path = NULL) {
+ |
+
| 2238 | +1978x | +
+ if (is.null(path)) {
+ |
+
| 2239 | +1977x | +
+ lfs <- collect_leaves(coltree(obj))+ |
+
| 2240 | +1977x | +
+ ret <- vapply(lfs, facet_colcount, 1L, path = NULL)+ |
+
| 2241 | ++ |
+ } else {
+ |
+
| 2242 | +1x | +
+ ret <- facet_colcount(obj, path)+ |
+
| 2243 | ++ |
+ }+ |
+
| 2244 | ++ |
+ ## required for strict backwards compatibility,+ |
+
| 2245 | ++ |
+ ## even though its undesirable behavior.+ |
+
| 2246 | +1978x | +
+ unname(ret)+ |
+
| 2247 | ++ |
+ }+ |
+
| 2248 | ++ |
+ )+ |
+
| 2249 | ++ | + + | +
| 2250 | ++ |
+ #' @export+ |
+
| 2251 | ++ |
+ #' @rdname col_accessors+ |
+
| 2252 | ++ |
+ setMethod(+ |
+
| 2253 | ++ |
+ "col_counts", "VTableNodeInfo",+ |
+
| 2254 | +15x | +
+ function(obj, path = NULL) col_counts(col_info(obj), path = path)+ |
+
| 2255 | ++ |
+ )+ |
+
| 2256 | ++ | + + | +
| 2257 | ++ |
+ #' @export+ |
+
| 2258 | ++ |
+ #' @rdname col_accessors+ |
+
| 2259 | +14x | +
+ setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))
+ |
+
| 2260 | ++ | + + | +
| 2261 | ++ |
+ #' @export+ |
+
| 2262 | ++ |
+ #' @rdname col_accessors+ |
+
| 2263 | ++ |
+ setMethod(+ |
+
| 2264 | ++ |
+ "col_counts<-", "InstantiatedColumnInfo",+ |
+
| 2265 | ++ |
+ function(obj, path = NULL, value) {
+ |
+
| 2266 | ++ |
+ ## obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value+ |
+
| 2267 | ++ |
+ ## obj+ |
+
| 2268 | +9x | +
+ if (!is.null(path)) {
+ |
+
| 2269 | +1x | +
+ all_paths <- list(path)+ |
+
| 2270 | ++ |
+ } else {
+ |
+
| 2271 | +8x | +
+ all_paths <- make_col_df(obj, visible_only = TRUE)$path+ |
+
| 2272 | ++ |
+ }+ |
+
| 2273 | +9x | +
+ if (length(value) != length(all_paths)) {
+ |
+
| 2274 | +! | +
+ stop(+ |
+
| 2275 | +! | +
+ "Got ", length(value), " values for ",+ |
+
| 2276 | +! | +
+ length(all_paths), " column paths",+ |
+
| 2277 | +! | +
+ if (is.null(path)) " (from path = NULL)",+ |
+
| 2278 | ++ |
+ "."+ |
+
| 2279 | ++ |
+ )+ |
+
| 2280 | ++ |
+ }+ |
+
| 2281 | +9x | +
+ ctree <- coltree(obj)+ |
+
| 2282 | +9x | +
+ for (i in seq_along(all_paths)) {
+ |
+
| 2283 | +73x | +
+ facet_colcount(ctree, all_paths[[i]]) <- value[i]+ |
+
| 2284 | ++ |
+ }+ |
+
| 2285 | +9x | +
+ coltree(obj) <- ctree+ |
+
| 2286 | +9x | +
+ obj+ |
+
| 2287 | ++ |
+ }+ |
+
| 2288 | ++ |
+ )+ |
+
| 2289 | ++ | + + | +
| 2290 | ++ |
+ #' @export+ |
+
| 2291 | ++ |
+ #' @rdname col_accessors+ |
+
| 2292 | ++ |
+ setMethod(+ |
+
| 2293 | ++ |
+ "col_counts<-", "VTableNodeInfo",+ |
+
| 2294 | ++ |
+ function(obj, path = NULL, value) {
+ |
+
| 2295 | +5x | +
+ cinfo <- col_info(obj)+ |
+
| 2296 | +5x | +
+ col_counts(cinfo, path = path) <- value+ |
+
| 2297 | +5x | +
+ col_info(obj) <- cinfo+ |
+
| 2298 | +5x | +
+ obj+ |
+
| 2299 | ++ |
+ }+ |
+
| 2300 | ++ |
+ )+ |
+
| 2301 | ++ | + + | +
| 2302 | ++ |
+ #' @export+ |
+
| 2303 | ++ |
+ #' @rdname col_accessors+ |
+
| 2304 | +1573x | +
+ setGeneric("col_total", function(obj) standardGeneric("col_total"))
+ |
+
| 2305 | ++ | + + | +
| 2306 | ++ |
+ #' @export+ |
+
| 2307 | ++ |
+ #' @rdname col_accessors+ |
+
| 2308 | ++ |
+ setMethod(+ |
+
| 2309 | ++ |
+ "col_total", "InstantiatedColumnInfo",+ |
+
| 2310 | +1572x | +
+ function(obj) obj@total_count+ |
+
| 2311 | ++ |
+ )+ |
+
| 2312 | ++ | + + | +
| 2313 | ++ |
+ #' @export+ |
+
| 2314 | ++ |
+ #' @rdname col_accessors+ |
+
| 2315 | ++ |
+ setMethod(+ |
+
| 2316 | ++ |
+ "col_total", "VTableNodeInfo",+ |
+
| 2317 | +1x | +
+ function(obj) col_total(col_info(obj))+ |
+
| 2318 | ++ |
+ )+ |
+
| 2319 | ++ | + + | +
| 2320 | ++ |
+ #' @export+ |
+
| 2321 | ++ |
+ #' @rdname col_accessors+ |
+
| 2322 | +2x | +
+ setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))
+ |
+
| 2323 | ++ | + + | +
| 2324 | ++ |
+ #' @export+ |
+
| 2325 | ++ |
+ #' @rdname col_accessors+ |
+
| 2326 | ++ |
+ setMethod(+ |
+
| 2327 | ++ |
+ "col_total<-", "InstantiatedColumnInfo",+ |
+
| 2328 | ++ |
+ function(obj, value) {
+ |
+
| 2329 | ++ |
+ ## all methods funnel to this one so ensure integer-ness here.+ |
+
| 2330 | +1x | +
+ obj@total_count <- as.integer(value)+ |
+
| 2331 | +1x | +
+ obj+ |
+
| 2332 | ++ |
+ }+ |
+
| 2333 | ++ |
+ )+ |
+
| 2334 | ++ | + + | +
| 2335 | ++ |
+ #' @export+ |
+
| 2336 | ++ |
+ #' @rdname col_accessors+ |
+
| 2337 | ++ |
+ setMethod(+ |
+
| 2338 | ++ |
+ "col_total<-", "VTableNodeInfo",+ |
+
| 2339 | ++ |
+ function(obj, value) {
+ |
+
| 2340 | +1x | +
+ cinfo <- col_info(obj)+ |
+
| 2341 | +1x | +
+ col_total(cinfo) <- value+ |
+
| 2342 | +1x | +
+ col_info(obj) <- cinfo+ |
+
| 2343 | +1x | +
+ obj+ |
+
| 2344 | ++ |
+ }+ |
+
| 2345 | ++ |
+ )+ |
+
| 2346 | ++ | + + | +
| 2347 | ++ |
+ #' @rdname int_methods+ |
+
| 2348 | +18584x | +
+ setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))
+ |
+
| 2349 | ++ | + + | +
| 2350 | ++ |
+ #' @rdname int_methods+ |
+
| 2351 | ++ |
+ setMethod(+ |
+
| 2352 | ++ |
+ "disp_ccounts", "VTableTree",+ |
+
| 2353 | +305x | +
+ function(obj) disp_ccounts(col_info(obj))+ |
+
| 2354 | ++ |
+ )+ |
+
| 2355 | ++ | + + | +
| 2356 | ++ |
+ #' @rdname int_methods+ |
+
| 2357 | ++ |
+ setMethod(+ |
+
| 2358 | ++ |
+ "disp_ccounts", "InstantiatedColumnInfo",+ |
+
| 2359 | +602x | +
+ function(obj) obj@display_columncounts+ |
+
| 2360 | ++ |
+ )+ |
+
| 2361 | ++ | + + | +
| 2362 | ++ |
+ #' @rdname int_methods+ |
+
| 2363 | ++ |
+ setMethod(+ |
+
| 2364 | ++ |
+ "disp_ccounts", "PreDataTableLayouts",+ |
+
| 2365 | +958x | +
+ function(obj) disp_ccounts(clayout(obj))+ |
+
| 2366 | ++ |
+ )+ |
+
| 2367 | ++ | + + | +
| 2368 | ++ |
+ #' @rdname int_methods+ |
+
| 2369 | ++ |
+ setMethod(+ |
+
| 2370 | ++ |
+ "disp_ccounts", "PreDataColLayout",+ |
+
| 2371 | +1278x | +
+ function(obj) obj@display_columncounts+ |
+
| 2372 | ++ |
+ )+ |
+
| 2373 | ++ | + + | +
| 2374 | ++ |
+ #' @rdname int_methods+ |
+
| 2375 | ++ |
+ setMethod(+ |
+
| 2376 | ++ |
+ "disp_ccounts", "LayoutColTree",+ |
+
| 2377 | +715x | +
+ function(obj) obj@display_columncounts+ |
+
| 2378 | ++ |
+ )+ |
+
| 2379 | ++ | + + | +
| 2380 | ++ |
+ #' @rdname int_methods+ |
+
| 2381 | ++ |
+ setMethod(+ |
+
| 2382 | ++ |
+ "disp_ccounts", "LayoutColLeaf",+ |
+
| 2383 | +13365x | +
+ function(obj) obj@display_columncounts+ |
+
| 2384 | ++ |
+ )+ |
+
| 2385 | ++ | + + | +
| 2386 | ++ |
+ #' @rdname int_methods+ |
+
| 2387 | ++ |
+ setMethod(+ |
+
| 2388 | ++ |
+ "disp_ccounts", "Split",+ |
+
| 2389 | +1226x | +
+ function(obj) obj@child_show_colcounts+ |
+
| 2390 | ++ |
+ )+ |
+
| 2391 | ++ | + + | +
| 2392 | ++ |
+ #' @rdname int_methods+ |
+
| 2393 | +2223x | +
+ setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))
+ |
+
| 2394 | ++ | + + | +
| 2395 | ++ |
+ #' @rdname int_methods+ |
+
| 2396 | ++ |
+ setMethod(+ |
+
| 2397 | ++ |
+ "disp_ccounts<-", "VTableTree",+ |
+
| 2398 | ++ |
+ function(obj, value) {
+ |
+
| 2399 | +1x | +
+ cinfo <- col_info(obj)+ |
+
| 2400 | +1x | +
+ disp_ccounts(cinfo) <- value+ |
+
| 2401 | +1x | +
+ col_info(obj) <- cinfo+ |
+
| 2402 | +1x | +
+ obj+ |
+
| 2403 | ++ |
+ }+ |
+
| 2404 | ++ |
+ )+ |
+
| 2405 | ++ | + + | +
| 2406 | ++ |
+ #' @rdname int_methods+ |
+
| 2407 | ++ |
+ setMethod(+ |
+
| 2408 | ++ |
+ "disp_ccounts<-", "InstantiatedColumnInfo",+ |
+
| 2409 | ++ |
+ function(obj, value) {
+ |
+
| 2410 | +2x | +
+ obj@display_columncounts <- value+ |
+
| 2411 | +2x | +
+ obj+ |
+
| 2412 | ++ |
+ }+ |
+
| 2413 | ++ |
+ )+ |
+
| 2414 | ++ | + + | +
| 2415 | ++ |
+ #' @rdname int_methods+ |
+
| 2416 | ++ |
+ setMethod(+ |
+
| 2417 | ++ |
+ "disp_ccounts<-", "PreDataColLayout",+ |
+
| 2418 | ++ |
+ function(obj, value) {
+ |
+
| 2419 | +324x | +
+ obj@display_columncounts <- value+ |
+
| 2420 | +324x | +
+ obj+ |
+
| 2421 | ++ |
+ }+ |
+
| 2422 | ++ |
+ )+ |
+
| 2423 | ++ | + + | +
| 2424 | ++ |
+ #' @rdname int_methods+ |
+
| 2425 | ++ |
+ setMethod(+ |
+
| 2426 | ++ |
+ "disp_ccounts<-", "LayoutColTree",+ |
+
| 2427 | ++ |
+ function(obj, value) {
+ |
+
| 2428 | +321x | +
+ obj@display_columncounts <- value+ |
+
| 2429 | +321x | +
+ obj+ |
+
| 2430 | ++ |
+ }+ |
+
| 2431 | ++ |
+ )+ |
+
| 2432 | ++ | + + | +
| 2433 | ++ |
+ #' @rdname int_methods+ |
+
| 2434 | ++ |
+ setMethod(+ |
+
| 2435 | ++ |
+ "disp_ccounts<-", "LayoutColLeaf",+ |
+
| 2436 | ++ |
+ function(obj, value) {
+ |
+
| 2437 | +1251x | +
+ obj@display_columncounts <- value+ |
+
| 2438 | +1251x | +
+ obj+ |
+
| 2439 | ++ |
+ }+ |
+
| 2440 | ++ |
+ )+ |
+
| 2441 | ++ | + + | +
| 2442 | ++ |
+ #' @rdname int_methods+ |
+
| 2443 | ++ |
+ setMethod(+ |
+
| 2444 | ++ |
+ "disp_ccounts<-", "PreDataTableLayouts",+ |
+
| 2445 | ++ |
+ function(obj, value) {
+ |
+
| 2446 | +324x | +
+ clyt <- clayout(obj)+ |
+
| 2447 | +324x | +
+ disp_ccounts(clyt) <- value+ |
+
| 2448 | +324x | +
+ clayout(obj) <- clyt+ |
+
| 2449 | +324x | +
+ obj+ |
+
| 2450 | ++ |
+ }+ |
+
| 2451 | ++ |
+ )+ |
+
| 2452 | ++ | + + | +
| 2453 | ++ | + + | +
| 2454 | ++ |
+ ## this is a horrible hack but when we have non-nested siblings at the top level+ |
+
| 2455 | ++ |
+ ## the beginning of the "path <-> position" relationship breaks down.+ |
+
| 2456 | ++ |
+ ## we probably *should* have e.g., c("root", "top_level_splname_1",
+ |
+
| 2457 | ++ |
+ ## "top_level_splname_1, "top_level_splname_1_value", ...)+ |
+
| 2458 | ++ |
+ ## but its pretty clear why no one will be happy with that, I think+ |
+
| 2459 | ++ |
+ ## so we punt on the problem for now with an explicit workaround+ |
+
| 2460 | ++ |
+ ##+ |
+
| 2461 | ++ |
+ ## those first non-nested siblings currently have (incorrect)+ |
+
| 2462 | ++ |
+ ## empty tree_pos elements so we just look at the obj_name+ |
+
| 2463 | ++ | + + | +
| 2464 | ++ |
+ pos_singleton_path <- function(obj) {
+ |
+
| 2465 | +5885x | +
+ pos <- tree_pos(obj)+ |
+
| 2466 | +5885x | +
+ splvals <- pos_splvals(pos)+ |
+
| 2467 | +5885x | +
+ length(splvals) == 0 ||+ |
+
| 2468 | +5885x | +
+ (length(splvals) == 1 && is.na(unlist(value_names(splvals))))+ |
+
| 2469 | ++ |
+ }+ |
+
| 2470 | ++ | + + | +
| 2471 | ++ |
+ ## close to a duplicate of tt_at_path, but... not quite :(+ |
+
| 2472 | ++ |
+ #' @rdname int_methods+ |
+
| 2473 | ++ |
+ coltree_at_path <- function(obj, path, ...) {
+ |
+
| 2474 | +2964x | +
+ if (length(path) == 0) {
+ |
+
| 2475 | +642x | +
+ return(obj)+ |
+
| 2476 | ++ |
+ }+ |
+
| 2477 | +2322x | +
+ stopifnot(+ |
+
| 2478 | +2322x | +
+ is(path, "character"),+ |
+
| 2479 | +2322x | +
+ length(path) > 0+ |
+
| 2480 | ++ |
+ )+ |
+
| 2481 | +2322x | +
+ if (any(grepl("@content", path, fixed = TRUE))) {
+ |
+
| 2482 | +! | +
+ stop("@content token is not valid for column paths.")
+ |
+
| 2483 | ++ |
+ }+ |
+
| 2484 | ++ | + + | +
| 2485 | +2322x | +
+ cur <- obj+ |
+
| 2486 | +2322x | +
+ curpath <- pos_to_path(tree_pos(obj)) # path+ |
+
| 2487 | +2322x | +
+ num_consume_path <- 2+ |
+
| 2488 | +2322x | +
+ while (!identical(curpath, path) && !is(cur, "LayoutColLeaf")) { # length(curpath) > 0) {
+ |
+
| 2489 | +4059x | +
+ kids <- tree_children(cur)+ |
+
| 2490 | +4059x | +
+ kidmatch <- find_kid_path_match(kids, path)+ |
+
| 2491 | +4059x | +
+ if (length(kidmatch) == 0) {
+ |
+
| 2492 | +! | +
+ stop(+ |
+
| 2493 | +! | +
+ "unable to match full path: ", paste(path, sep = "->"),+ |
+
| 2494 | +! | +
+ "\n path of last match: ", paste(curpath, sep = "->")+ |
+
| 2495 | ++ |
+ )+ |
+
| 2496 | ++ |
+ }+ |
+
| 2497 | +4059x | +
+ cur <- kids[[kidmatch]]+ |
+
| 2498 | +4059x | +
+ curpath <- pos_to_path(tree_pos(cur))+ |
+
| 2499 | ++ |
+ }+ |
+
| 2500 | +2322x | +
+ cur+ |
+
| 2501 | ++ |
+ }+ |
+
| 2502 | ++ | + + | +
| 2503 | ++ |
+ find_kid_path_match <- function(kids, path) {
+ |
+
| 2504 | +8114x | +
+ if (length(kids) == 0) {
+ |
+
| 2505 | +! | +
+ return(integer())+ |
+
| 2506 | ++ |
+ }+ |
+
| 2507 | +8114x | +
+ kidpaths <- lapply(kids, function(k) pos_to_path(tree_pos(k)))+ |
+
| 2508 | ++ | + + | +
| 2509 | +8114x | +
+ matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)+ |
+
| 2510 | +8114x | +
+ firstkidpos <- tree_pos(kids[[1]])+ |
+
| 2511 | +8114x | +
+ 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 | +8114x | +
+ which(matches)+ |
+
| 2516 | ++ |
+ }+ |
+
| 2517 | ++ | + + | +
| 2518 | ++ | + + | +
| 2519 | ++ |
+ ## almost a duplicate of recursive_replace, but I spent a bunch+ |
+
| 2520 | ++ |
+ ## of time ramming my head against the different way pathing happens+ |
+
| 2521 | ++ |
+ ## in column space (unfortunately) before giving up building+ |
+
| 2522 | ++ |
+ ## coltree_at_path around recursive_replace, so here we are.+ |
+
| 2523 | ++ | + + | +
| 2524 | ++ |
+ ct_recursive_replace <- function(ctree, path, value, pos = 1) {
+ |
+
| 2525 | +6375x | +
+ pos <- tree_pos(ctree)+ |
+
| 2526 | +6375x | +
+ curpth <- pos_to_path(pos)+ |
+
| 2527 | +6375x | +
+ if (identical(path, curpth)) {
+ |
+
| 2528 | +2320x | +
+ return(value)+ |
+
| 2529 | +4055x | +
+ } else if (is(ctree, "LayoutColLeaf")) {
+ |
+
| 2530 | +! | +
+ stop(+ |
+
| 2531 | +! | +
+ "unable to match full path: ", paste(path, sep = "->"),+ |
+
| 2532 | +! | +
+ "\n path at leaf: ", paste(curpth, sep = "->")+ |
+
| 2533 | ++ |
+ )+ |
+
| 2534 | ++ |
+ }+ |
+
| 2535 | +4055x | +
+ kids <- tree_children(ctree)+ |
+
| 2536 | +4055x | +
+ kids_singl <- pos_singleton_path(kids[[1]])+ |
+
| 2537 | +4055x | +
+ kidind <- find_kid_path_match(kids, path)+ |
+
| 2538 | ++ | + + | +
| 2539 | +4055x | +
+ if (length(kidind) == 0) {
+ |
+
| 2540 | +! | +
+ stop("Path appears invalid for this tree at step ", path[1])
+ |
+
| 2541 | +4055x | +
+ } else if (length(kidind) > 1) {
+ |
+
| 2542 | +! | +
+ stop(+ |
+
| 2543 | +! | +
+ "singleton step (root, cbind_root, etc) in path appears to have matched multiple children. ",+ |
+
| 2544 | +! | +
+ "This shouldn't happen, please contact the maintainers."+ |
+
| 2545 | ++ |
+ )+ |
+
| 2546 | ++ |
+ }+ |
+
| 2547 | ++ | + + | +
| 2548 | +4055x | +
+ kids[[kidind]] <- ct_recursive_replace(+ |
+
| 2549 | +4055x | +
+ kids[[kidind]],+ |
+
| 2550 | +4055x | +
+ path, value+ |
+
| 2551 | ++ |
+ )+ |
+
| 2552 | +4055x | +
+ tree_children(ctree) <- kids+ |
+
| 2553 | +4055x | +
+ ctree+ |
+
| 2554 | ++ |
+ }+ |
+
| 2555 | ++ | + + | +
| 2556 | ++ |
+ `coltree_at_path<-` <- function(obj, path, value) {
+ |
+
| 2557 | +2320x | +
+ obj <- ct_recursive_replace(obj, path, value)+ |
+
| 2558 | +2320x | +
+ obj+ |
+
| 2559 | ++ |
+ }+ |
+
| 2560 | ++ | + + | +
| 2561 | ++ |
+ #' Set visibility of column counts for a group of sibling facets+ |
+
| 2562 | ++ |
+ #'+ |
+
| 2563 | ++ |
+ #' @inheritParams gen_args+ |
+
| 2564 | ++ |
+ #' @param path (`character`)\cr the path *to the parent of the+ |
+
| 2565 | ++ |
+ #' desired siblings*. The last element in the path should+ |
+
| 2566 | ++ |
+ #' be a split name.+ |
+
| 2567 | ++ |
+ #' @return obj, modified with the desired column count.+ |
+
| 2568 | ++ |
+ #' display behavior+ |
+
| 2569 | ++ |
+ #'+ |
+
| 2570 | ++ |
+ #' @seealso [colcount_visible()]+ |
+
| 2571 | ++ |
+ #'+ |
+
| 2572 | ++ |
+ #' @export+ |
+
| 2573 | ++ |
+ `facet_colcounts_visible<-` <- function(obj, path, value) {
+ |
+
| 2574 | +1x | +
+ coldf <- make_col_df(obj, visible_only = FALSE)+ |
+
| 2575 | +1x | +
+ allpaths <- coldf$path+ |
+
| 2576 | +1x | +
+ lenpath <- length(path)+ |
+
| 2577 | +1x | +
+ match_paths <- vapply(allpaths, function(path_i) {
+ |
+
| 2578 | +10x | +
+ (length(path_i) == lenpath + 1) &&+ |
+
| 2579 | +10x | +
+ (all(head(path_i, -1) == path))+ |
+
| 2580 | +1x | +
+ }, TRUE)+ |
+
| 2581 | +1x | +
+ for (curpath in allpaths[match_paths]) {
+ |
+
| 2582 | +2x | +
+ colcount_visible(obj, curpath) <- value+ |
+
| 2583 | ++ |
+ }+ |
+
| 2584 | +1x | +
+ obj+ |
+
| 2585 | ++ |
+ }+ |
+
| 2586 | ++ | + + | +
| 2587 | ++ |
+ #' Get or set column count for a facet in column space+ |
+
| 2588 | ++ |
+ #'+ |
+
| 2589 | ++ |
+ #' @inheritParams gen_args+ |
+
| 2590 | ++ |
+ #' @param path character. This path must end on a+ |
+
| 2591 | ++ |
+ #' split value, e.g., the level of a categorical variable+ |
+
| 2592 | ++ |
+ #' that was split on in column space, but it need not+ |
+
| 2593 | ++ |
+ #' be the path to an individual column.+ |
+
| 2594 | ++ |
+ #'+ |
+
| 2595 | ++ |
+ #' @return for `facet_colcount` the current count associated+ |
+
| 2596 | ++ |
+ #' with that facet in column space, for `facet_colcount<-`,+ |
+
| 2597 | ++ |
+ #' `obj` modified with the new column count for the specified+ |
+
| 2598 | ++ |
+ #' facet.+ |
+
| 2599 | ++ |
+ #'+ |
+
| 2600 | ++ |
+ #' @note Updating a lower-level (more specific)+ |
+
| 2601 | ++ |
+ #' column count manually **will not** update the+ |
+
| 2602 | ++ |
+ #' counts for its parent facets. This cannot be made+ |
+
| 2603 | ++ |
+ #' automatic because the rtables framework does not+ |
+
| 2604 | ++ |
+ #' require sibling facets to be mutually exclusive+ |
+
| 2605 | ++ |
+ #' (e.g., total "arm", faceting into cumulative+ |
+
| 2606 | ++ |
+ #' quantiles, etc) and thus the count of a parent facet+ |
+
| 2607 | ++ |
+ #' will not always be simply the sum of the counts for+ |
+
| 2608 | ++ |
+ #' all of its children.+ |
+
| 2609 | ++ |
+ #'+ |
+
| 2610 | ++ |
+ #' @seealso [col_counts()]+ |
+
| 2611 | ++ |
+ #'+ |
+
| 2612 | ++ |
+ #' @examples+ |
+
| 2613 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 2614 | ++ |
+ #' split_cols_by("ARM", show_colcounts = TRUE) %>%
+ |
+
| 2615 | ++ |
+ #' split_cols_by("SEX",
+ |
+
| 2616 | ++ |
+ #' split_fun = keep_split_levels(c("F", "M")),
+ |
+
| 2617 | ++ |
+ #' show_colcounts = TRUE+ |
+
| 2618 | ++ |
+ #' ) %>%+ |
+
| 2619 | ++ |
+ #' split_cols_by("STRATA1", show_colcounts = TRUE) %>%
+ |
+
| 2620 | ++ |
+ #' analyze("AGE")
+ |
+
| 2621 | ++ |
+ #'+ |
+
| 2622 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 2623 | ++ |
+ #'+ |
+
| 2624 | ++ |
+ #' facet_colcount(tbl, c("ARM", "A: Drug X"))
+ |
+
| 2625 | ++ |
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F"))
+ |
+
| 2626 | ++ |
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A"))
+ |
+
| 2627 | ++ |
+ #'+ |
+
| 2628 | ++ |
+ #' ## modify specific count after table creation+ |
+
| 2629 | ++ |
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A")) <- 25
+ |
+
| 2630 | ++ |
+ #'+ |
+
| 2631 | ++ |
+ #' ## show black space for certain counts by assign NA+ |
+
| 2632 | ++ |
+ #'+ |
+
| 2633 | ++ |
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "C")) <- NA
+ |
+
| 2634 | ++ |
+ #'+ |
+
| 2635 | ++ |
+ #' @export+ |
+
| 2636 | ++ |
+ setGeneric(+ |
+
| 2637 | ++ |
+ "facet_colcount",+ |
+
| 2638 | +20274x | +
+ function(obj, path) standardGeneric("facet_colcount")
+ |
+
| 2639 | ++ |
+ )+ |
+
| 2640 | ++ | + + | +
| 2641 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2642 | ++ |
+ #' @export+ |
+
| 2643 | ++ |
+ setMethod(+ |
+
| 2644 | ++ |
+ "facet_colcount", "LayoutColTree",+ |
+
| 2645 | ++ |
+ function(obj, path = NULL) {
+ |
+
| 2646 | ++ |
+ ## if(length(path) == 0L)+ |
+
| 2647 | ++ |
+ ## stop("face_colcount requires a non-null path") #nocov
+ |
+
| 2648 | +643x | +
+ subtree <- coltree_at_path(obj, path)+ |
+
| 2649 | +643x | +
+ subtree@column_count+ |
+
| 2650 | ++ |
+ }+ |
+
| 2651 | ++ |
+ )+ |
+
| 2652 | ++ | + + | +
| 2653 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2654 | ++ |
+ #' @export+ |
+
| 2655 | ++ |
+ setMethod(+ |
+
| 2656 | ++ |
+ "facet_colcount", "LayoutColLeaf",+ |
+
| 2657 | ++ |
+ function(obj, path = NULL) {
+ |
+
| 2658 | ++ |
+ ## not sure if we should check for null here as above+ |
+
| 2659 | +19630x | +
+ obj@column_count+ |
+
| 2660 | ++ |
+ }+ |
+
| 2661 | ++ |
+ )+ |
+
| 2662 | ++ | + + | +
| 2663 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2664 | ++ |
+ #' @export+ |
+
| 2665 | ++ |
+ setMethod(+ |
+
| 2666 | ++ |
+ "facet_colcount", "VTableTree",+ |
+
| 2667 | +! | +
+ function(obj, path) facet_colcount(coltree(obj), path = path)+ |
+
| 2668 | ++ |
+ )+ |
+
| 2669 | ++ | + + | +
| 2670 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2671 | ++ |
+ #' @export+ |
+
| 2672 | ++ |
+ setMethod(+ |
+
| 2673 | ++ |
+ "facet_colcount", "InstantiatedColumnInfo",+ |
+
| 2674 | +1x | +
+ function(obj, path) facet_colcount(coltree(obj), path = path)+ |
+
| 2675 | ++ |
+ )+ |
+
| 2676 | ++ | + + | +
| 2677 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2678 | ++ |
+ #' @export+ |
+
| 2679 | ++ |
+ setGeneric(+ |
+
| 2680 | ++ |
+ "facet_colcount<-",+ |
+
| 2681 | +1070x | +
+ function(obj, path, value) standardGeneric("facet_colcount<-")
+ |
+
| 2682 | ++ |
+ )+ |
+
| 2683 | ++ | + + | +
| 2684 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2685 | ++ |
+ #' @export+ |
+
| 2686 | ++ |
+ setMethod(+ |
+
| 2687 | ++ |
+ "facet_colcount<-", "LayoutColTree",+ |
+
| 2688 | ++ |
+ function(obj, path, value) {
+ |
+
| 2689 | +1068x | +
+ ct <- coltree_at_path(obj, path)+ |
+
| 2690 | +1068x | +
+ ct@column_count <- as.integer(value)+ |
+
| 2691 | +1068x | +
+ coltree_at_path(obj, path) <- ct+ |
+
| 2692 | +1068x | +
+ obj+ |
+
| 2693 | ++ |
+ }+ |
+
| 2694 | ++ |
+ )+ |
+
| 2695 | ++ | + + | +
| 2696 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2697 | ++ |
+ #' @export+ |
+
| 2698 | ++ |
+ setMethod(+ |
+
| 2699 | ++ |
+ "facet_colcount<-", "LayoutColLeaf",+ |
+
| 2700 | ++ |
+ function(obj, path, value) {
+ |
+
| 2701 | +! | +
+ obj@column_count <- as.integer(value)+ |
+
| 2702 | +! | +
+ obj+ |
+
| 2703 | ++ |
+ }+ |
+
| 2704 | ++ |
+ )+ |
+
| 2705 | ++ | + + | +
| 2706 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2707 | ++ |
+ #' @export+ |
+
| 2708 | ++ |
+ setMethod(+ |
+
| 2709 | ++ |
+ "facet_colcount<-", "VTableTree",+ |
+
| 2710 | ++ |
+ function(obj, path, value) {
+ |
+
| 2711 | +1x | +
+ cinfo <- col_info(obj)+ |
+
| 2712 | +1x | +
+ facet_colcount(cinfo, path) <- value+ |
+
| 2713 | +1x | +
+ col_info(obj) <- cinfo+ |
+
| 2714 | +1x | +
+ obj+ |
+
| 2715 | ++ |
+ }+ |
+
| 2716 | ++ |
+ )+ |
+
| 2717 | ++ | + + | +
| 2718 | ++ |
+ #' @rdname facet_colcount+ |
+
| 2719 | ++ |
+ #' @export+ |
+
| 2720 | ++ |
+ setMethod(+ |
+
| 2721 | ++ |
+ "facet_colcount<-", "InstantiatedColumnInfo",+ |
+
| 2722 | ++ |
+ function(obj, path, value) {
+ |
+
| 2723 | +1x | +
+ ct <- coltree(obj)+ |
+
| 2724 | +1x | +
+ facet_colcount(ct, path) <- value+ |
+
| 2725 | +1x | +
+ coltree(obj) <- ct+ |
+
| 2726 | +1x | +
+ obj+ |
+
| 2727 | ++ |
+ }+ |
+
| 2728 | ++ |
+ )+ |
+
| 2729 | ++ | + + | +
| 2730 | ++ |
+ #' Value and Visibility of specific column counts by path+ |
+
| 2731 | ++ |
+ #'+ |
+
| 2732 | ++ |
+ #' @inheritParams gen_args+ |
+
| 2733 | ++ |
+ #'+ |
+
| 2734 | ++ |
+ #' @return for `colcount_visible` a logical scalar+ |
+
| 2735 | ++ |
+ #' indicating whether the specified position in+ |
+
| 2736 | ++ |
+ #' the column hierarchy is set to display its column count;+ |
+
| 2737 | ++ |
+ #' for `colcount_visible<-`, `obj` updated with+ |
+
| 2738 | ++ |
+ #' the specified count displaying behavior set.+ |
+
| 2739 | ++ |
+ #'+ |
+
| 2740 | ++ |
+ #' @note Users generally should not call `colcount_visible`+ |
+
| 2741 | ++ |
+ #' directly, as setting sibling facets to have differing+ |
+
| 2742 | ++ |
+ #' column count visibility will result in an error when+ |
+
| 2743 | ++ |
+ #' printing or paginating the table.+ |
+
| 2744 | ++ |
+ #'+ |
+
| 2745 | ++ |
+ #' @export+ |
+
| 2746 | +2x | +
+ setGeneric("colcount_visible", function(obj, path) standardGeneric("colcount_visible"))
+ |
+
| 2747 | ++ | + + | +
| 2748 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2749 | ++ |
+ #' @export+ |
+
| 2750 | ++ |
+ setMethod(+ |
+
| 2751 | ++ |
+ "colcount_visible", "VTableTree",+ |
+
| 2752 | +1x | +
+ function(obj, path) colcount_visible(coltree(obj), path)+ |
+
| 2753 | ++ |
+ )+ |
+
| 2754 | ++ | + + | +
| 2755 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2756 | ++ |
+ #' @export+ |
+
| 2757 | ++ |
+ setMethod(+ |
+
| 2758 | ++ |
+ "colcount_visible", "InstantiatedColumnInfo",+ |
+
| 2759 | +! | +
+ function(obj, path) colcount_visible(coltree(obj), path)+ |
+
| 2760 | ++ |
+ )+ |
+
| 2761 | ++ | + + | +
| 2762 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2763 | ++ |
+ #' @export+ |
+
| 2764 | ++ |
+ setMethod(+ |
+
| 2765 | ++ |
+ "colcount_visible", "LayoutColTree",+ |
+
| 2766 | ++ |
+ function(obj, path) {
+ |
+
| 2767 | +1x | +
+ subtree <- coltree_at_path(obj, path)+ |
+
| 2768 | +1x | +
+ disp_ccounts(subtree)+ |
+
| 2769 | ++ |
+ }+ |
+
| 2770 | ++ |
+ )+ |
+
| 2771 | ++ | + + | +
| 2772 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2773 | ++ |
+ #' @export+ |
+
| 2774 | +1276x | +
+ setGeneric("colcount_visible<-", function(obj, path, value) standardGeneric("colcount_visible<-"))
+ |
+
| 2775 | ++ | + + | +
| 2776 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2777 | ++ |
+ #' @export+ |
+
| 2778 | ++ |
+ setMethod(+ |
+
| 2779 | ++ |
+ "colcount_visible<-", "VTableTree",+ |
+
| 2780 | ++ |
+ function(obj, path, value) {
+ |
+
| 2781 | +3x | +
+ ctree <- coltree(obj)+ |
+
| 2782 | +3x | +
+ colcount_visible(ctree, path) <- value+ |
+
| 2783 | +3x | +
+ coltree(obj) <- ctree+ |
+
| 2784 | +3x | +
+ obj+ |
+
| 2785 | ++ |
+ }+ |
+
| 2786 | ++ |
+ )+ |
+
| 2787 | ++ | + + | +
| 2788 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2789 | ++ |
+ #' @export+ |
+
| 2790 | ++ |
+ setMethod(+ |
+
| 2791 | ++ |
+ "colcount_visible<-", "InstantiatedColumnInfo",+ |
+
| 2792 | ++ |
+ function(obj, path, value) {
+ |
+
| 2793 | +21x | +
+ ctree <- coltree(obj)+ |
+
| 2794 | +21x | +
+ colcount_visible(ctree, path) <- value+ |
+
| 2795 | +21x | +
+ coltree(obj) <- ctree+ |
+
| 2796 | +21x | +
+ obj+ |
+
| 2797 | ++ |
+ }+ |
+
| 2798 | ++ |
+ )+ |
+
| 2799 | ++ | + + | +
| 2800 | ++ | + + | +
| 2801 | ++ |
+ #' @rdname colcount_visible+ |
+
| 2802 | ++ |
+ #' @export+ |
+
| 2803 | ++ |
+ setMethod(+ |
+
| 2804 | ++ |
+ "colcount_visible<-", "LayoutColTree",+ |
+
| 2805 | ++ |
+ function(obj, path, value) {
+ |
+
| 2806 | +1252x | +
+ subtree <- coltree_at_path(obj, path)+ |
+
| 2807 | +1252x | +
+ disp_ccounts(subtree) <- value+ |
+
| 2808 | +1252x | +
+ coltree_at_path(obj, path) <- subtree+ |
+
| 2809 | +1252x | +
+ obj+ |
+
| 2810 | ++ |
+ }+ |
+
| 2811 | ++ |
+ )+ |
+
| 2812 | ++ | + + | +
| 2813 | ++ |
+ #' @rdname int_methods+ |
+
| 2814 | ++ |
+ #' @export+ |
+
| 2815 | +15649x | +
+ setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))
+ |
+
| 2816 | ++ | + + | +
| 2817 | ++ |
+ #' @rdname int_methods+ |
+
| 2818 | ++ |
+ #' @export+ |
+
| 2819 | ++ |
+ setMethod(+ |
+
| 2820 | ++ |
+ "colcount_format", "InstantiatedColumnInfo",+ |
+
| 2821 | +630x | +
+ function(obj) obj@columncount_format+ |
+
| 2822 | ++ |
+ )+ |
+
| 2823 | ++ | + + | +
| 2824 | ++ |
+ #' @rdname int_methods+ |
+
| 2825 | ++ |
+ #' @export+ |
+
| 2826 | ++ |
+ setMethod(+ |
+
| 2827 | ++ |
+ "colcount_format", "VTableNodeInfo",+ |
+
| 2828 | +337x | +
+ function(obj) colcount_format(col_info(obj))+ |
+
| 2829 | ++ |
+ )+ |
+
| 2830 | ++ | + + | +
| 2831 | ++ |
+ #' @rdname int_methods+ |
+
| 2832 | ++ |
+ #' @export+ |
+
| 2833 | ++ |
+ setMethod(+ |
+
| 2834 | ++ |
+ "colcount_format", "PreDataColLayout",+ |
+
| 2835 | +325x | +
+ function(obj) obj@columncount_format+ |
+
| 2836 | ++ |
+ )+ |
+
| 2837 | ++ | + + | +
| 2838 | ++ |
+ #' @rdname int_methods+ |
+
| 2839 | ++ |
+ #' @export+ |
+
| 2840 | ++ |
+ setMethod(+ |
+
| 2841 | ++ |
+ "colcount_format", "PreDataTableLayouts",+ |
+
| 2842 | +325x | +
+ function(obj) colcount_format(clayout(obj))+ |
+
| 2843 | ++ |
+ )+ |
+
| 2844 | ++ | + + | +
| 2845 | ++ |
+ #' @rdname int_methods+ |
+
| 2846 | ++ |
+ #' @export+ |
+
| 2847 | ++ |
+ setMethod(+ |
+
| 2848 | ++ |
+ "colcount_format", "Split",+ |
+
| 2849 | +1226x | +
+ function(obj) obj@child_colcount_format+ |
+
| 2850 | ++ |
+ )+ |
+
| 2851 | ++ | + + | +
| 2852 | ++ |
+ #' @rdname int_methods+ |
+
| 2853 | ++ |
+ #' @export+ |
+
| 2854 | ++ |
+ setMethod(+ |
+
| 2855 | ++ |
+ "colcount_format", "LayoutColTree",+ |
+
| 2856 | +642x | +
+ function(obj) obj@columncount_format+ |
+
| 2857 | ++ |
+ )+ |
+
| 2858 | ++ | + + | +
| 2859 | ++ |
+ #' @rdname int_methods+ |
+
| 2860 | ++ |
+ #' @export+ |
+
| 2861 | ++ |
+ setMethod(+ |
+
| 2862 | ++ |
+ "colcount_format", "LayoutColLeaf",+ |
+
| 2863 | +12029x | +
+ function(obj) obj@columncount_format+ |
+
| 2864 | ++ |
+ )+ |
+
| 2865 | ++ | + + | +
| 2866 | ++ | + + | +
| 2867 | ++ | + + | +
| 2868 | ++ |
+ #' @rdname int_methods+ |
+
| 2869 | ++ |
+ #' @export+ |
+
| 2870 | ++ |
+ setGeneric(+ |
+
| 2871 | ++ |
+ "colcount_format<-",+ |
+
| 2872 | +650x | +
+ function(obj, value) standardGeneric("colcount_format<-")
+ |
+
| 2873 | ++ |
+ )+ |
+
| 2874 | ++ | + + | +
| 2875 | ++ |
+ #' @export+ |
+
| 2876 | ++ |
+ #' @rdname int_methods+ |
+
| 2877 | ++ |
+ setMethod(+ |
+
| 2878 | ++ |
+ "colcount_format<-", "InstantiatedColumnInfo",+ |
+
| 2879 | ++ |
+ function(obj, value) {
+ |
+
| 2880 | +1x | +
+ obj@columncount_format <- value+ |
+
| 2881 | +1x | +
+ obj+ |
+
| 2882 | ++ |
+ }+ |
+
| 2883 | ++ |
+ )+ |
+
| 2884 | ++ | + + | +
| 2885 | ++ |
+ #' @rdname int_methods+ |
+
| 2886 | ++ |
+ #' @export+ |
+
| 2887 | ++ |
+ setMethod(+ |
+
| 2888 | ++ |
+ "colcount_format<-", "VTableNodeInfo",+ |
+
| 2889 | ++ |
+ function(obj, value) {
+ |
+
| 2890 | +1x | +
+ cinfo <- col_info(obj)+ |
+
| 2891 | +1x | +
+ colcount_format(cinfo) <- value+ |
+
| 2892 | +1x | +
+ col_info(obj) <- cinfo+ |
+
| 2893 | +1x | +
+ obj+ |
+
| 2894 | ++ |
+ }+ |
+
| 2895 | ++ |
+ )+ |
+
| 2896 | ++ | + + | +
| 2897 | ++ |
+ #' @rdname int_methods+ |
+
| 2898 | ++ |
+ #' @export+ |
+
| 2899 | ++ |
+ setMethod(+ |
+
| 2900 | ++ |
+ "colcount_format<-", "PreDataColLayout",+ |
+
| 2901 | ++ |
+ function(obj, value) {
+ |
+
| 2902 | +324x | +
+ obj@columncount_format <- value+ |
+
| 2903 | +324x | +
+ obj+ |
+
| 2904 | ++ |
+ }+ |
+
| 2905 | ++ |
+ )+ |
+
| 2906 | ++ | + + | +
| 2907 | ++ |
+ #' @rdname int_methods+ |
+
| 2908 | ++ |
+ #' @export+ |
+
| 2909 | ++ |
+ setMethod(+ |
+
| 2910 | ++ |
+ "colcount_format<-", "PreDataTableLayouts",+ |
+
| 2911 | ++ |
+ function(obj, value) {
+ |
+
| 2912 | +324x | +
+ clyt <- clayout(obj)+ |
+
| 2913 | +324x | +
+ colcount_format(clyt) <- value+ |
+
| 2914 | +324x | +
+ clayout(obj) <- clyt+ |
+
| 2915 | +324x | +
+ obj+ |
+
| 2916 | ++ |
+ }+ |
+
| 2917 | ++ |
+ )+ |
+
| 2918 | ++ | + + | +
| 2919 | ++ |
+ ## It'd probably be better if this had the full set of methods as above+ |
+
| 2920 | ++ |
+ ## but its not currently modelled in the class and probably isn't needed+ |
+
| 2921 | ++ |
+ ## super much+ |
+
| 2922 | ++ |
+ #' @rdname int_methods+ |
+
| 2923 | ++ |
+ #' @export+ |
+
| 2924 | +608x | +
+ setGeneric("colcount_na_str", function(obj) standardGeneric("colcount_na_str"))
+ |
+
| 2925 | ++ | + + | +
| 2926 | ++ |
+ #' @rdname int_methods+ |
+
| 2927 | ++ |
+ #' @export+ |
+
| 2928 | ++ |
+ setMethod(+ |
+
| 2929 | ++ |
+ "colcount_na_str", "InstantiatedColumnInfo",+ |
+
| 2930 | +307x | +
+ function(obj) obj@columncount_na_str+ |
+
| 2931 | ++ |
+ )+ |
+
| 2932 | ++ | + + | +
| 2933 | ++ |
+ #' @rdname int_methods+ |
+
| 2934 | ++ |
+ #' @export+ |
+
| 2935 | ++ |
+ setMethod(+ |
+
| 2936 | ++ |
+ "colcount_na_str", "VTableNodeInfo",+ |
+
| 2937 | +301x | +
+ function(obj) colcount_na_str(col_info(obj))+ |
+
| 2938 | ++ |
+ )+ |
+
| 2939 | ++ | + + | +
| 2940 | ++ |
+ #' @rdname int_methods+ |
+
| 2941 | ++ |
+ #' @export+ |
+
| 2942 | ++ |
+ setGeneric(+ |
+
| 2943 | ++ |
+ "colcount_na_str<-",+ |
+
| 2944 | +4x | +
+ function(obj, value) standardGeneric("colcount_na_str<-")
+ |
+
| 2945 | ++ |
+ )+ |
+
| 2946 | ++ | + + | +
| 2947 | ++ |
+ #' @export+ |
+
| 2948 | ++ |
+ #' @rdname int_methods+ |
+
| 2949 | ++ |
+ setMethod(+ |
+
| 2950 | ++ |
+ "colcount_na_str<-", "InstantiatedColumnInfo",+ |
+
| 2951 | ++ |
+ function(obj, value) {
+ |
+
| 2952 | +2x | +
+ obj@columncount_na_str <- value+ |
+
| 2953 | +2x | +
+ obj+ |
+
| 2954 | ++ |
+ }+ |
+
| 2955 | ++ |
+ )+ |
+
| 2956 | ++ | + + | +
| 2957 | ++ |
+ #' @rdname int_methods+ |
+
| 2958 | ++ |
+ #' @export+ |
+
| 2959 | ++ |
+ setMethod(+ |
+
| 2960 | ++ |
+ "colcount_na_str<-", "VTableNodeInfo",+ |
+
| 2961 | ++ |
+ 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+ |
+
| 2966 | ++ |
+ }+ |
+
| 2967 | ++ |
+ )+ |
+
| 2968 | ++ | + + | +
| 2969 | ++ |
+ #' Exported for use in `tern`+ |
+
| 2970 | ++ |
+ #'+ |
+
| 2971 | ++ |
+ #' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information?+ |
+
| 2972 | ++ |
+ #'+ |
+
| 2973 | ++ |
+ #' @inheritParams gen_args+ |
+
| 2974 | ++ |
+ #'+ |
+
| 2975 | ++ |
+ #' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise.+ |
+
| 2976 | ++ |
+ #'+ |
+
| 2977 | ++ |
+ #' @rdname no_info+ |
+
| 2978 | ++ |
+ #' @export+ |
+
| 2979 | +172415x | +
+ setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))
+ |
+
| 2980 | ++ | + + | +
| 2981 | ++ |
+ #' @exportMethod no_colinfo+ |
+
| 2982 | ++ |
+ #' @rdname no_info+ |
+
| 2983 | ++ |
+ setMethod(+ |
+
| 2984 | ++ |
+ "no_colinfo", "VTableNodeInfo",+ |
+
| 2985 | +73293x | +
+ function(obj) no_colinfo(col_info(obj))+ |
+
| 2986 | ++ |
+ )+ |
+
| 2987 | ++ | + + | +
| 2988 | ++ |
+ #' @exportMethod no_colinfo+ |
+
| 2989 | ++ |
+ #' @rdname no_info+ |
+
| 2990 | ++ |
+ setMethod(+ |
+
| 2991 | ++ |
+ "no_colinfo", "InstantiatedColumnInfo",+ |
+
| 2992 | +89155x | +
+ function(obj) length(obj@subset_exprs) == 0+ |
+
| 2993 | ++ |
+ ) ## identical(obj, EmptyColInfo))+ |
+
| 2994 | ++ | + + | +
| 2995 | ++ |
+ #' Names of a `TableTree`+ |
+
| 2996 | ++ |
+ #'+ |
+
| 2997 | ++ |
+ #' @param x (`TableTree`)\cr the object.+ |
+
| 2998 | ++ |
+ #'+ |
+
| 2999 | ++ |
+ #' @details+ |
+
| 3000 | ++ |
+ #' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level+ |
+
| 3001 | ++ |
+ #' split values repped out across the columns that they span.+ |
+
| 3002 | ++ |
+ #'+ |
+
| 3003 | ++ |
+ #' @return The column names of `x`, as defined in the details above.+ |
+
| 3004 | ++ |
+ #'+ |
+
| 3005 | ++ |
+ #' @exportMethod names+ |
+
| 3006 | ++ |
+ #' @rdname names+ |
+
| 3007 | ++ |
+ setMethod(+ |
+
| 3008 | ++ |
+ "names", "VTableNodeInfo",+ |
+
| 3009 | +109x | +
+ function(x) names(col_info(x))+ |
+
| 3010 | ++ |
+ )+ |
+
| 3011 | ++ | + + | +
| 3012 | ++ |
+ #' @rdname names+ |
+
| 3013 | ++ |
+ #' @exportMethod names+ |
+
| 3014 | ++ |
+ setMethod(+ |
+
| 3015 | ++ |
+ "names", "InstantiatedColumnInfo",+ |
+
| 3016 | +127x | +
+ function(x) names(coltree(x))+ |
+
| 3017 | ++ |
+ )+ |
+
| 3018 | ++ | + + | +
| 3019 | ++ |
+ #' @rdname names+ |
+
| 3020 | ++ |
+ #' @exportMethod names+ |
+
| 3021 | ++ |
+ setMethod(+ |
+
| 3022 | ++ |
+ "names", "LayoutColTree",+ |
+
| 3023 | ++ |
+ function(x) {
+ |
+
| 3024 | +163x | +
+ unname(unlist(lapply(+ |
+
| 3025 | +163x | +
+ tree_children(x),+ |
+
| 3026 | +163x | +
+ function(obj) {
+ |
+
| 3027 | +202x | +
+ nm <- obj_name(obj)+ |
+
| 3028 | +202x | +
+ rep(nm, n_leaves(obj))+ |
+
| 3029 | ++ |
+ }+ |
+
| 3030 | ++ |
+ )))+ |
+
| 3031 | ++ |
+ }+ |
+
| 3032 | ++ |
+ )+ |
+
| 3033 | ++ | + + | +
| 3034 | ++ |
+ #' @rdname names+ |
+
| 3035 | ++ |
+ #' @exportMethod row.names+ |
+
| 3036 | ++ |
+ setMethod(+ |
+
| 3037 | ++ |
+ "row.names", "VTableTree",+ |
+
| 3038 | ++ |
+ function(x) {
+ |
+
| 3039 | +104x | +
+ unname(sapply(collect_leaves(x, add.labrows = TRUE),+ |
+
| 3040 | +104x | +
+ obj_label,+ |
+
| 3041 | +104x | +
+ USE.NAMES = FALSE+ |
+
| 3042 | +104x | +
+ )) ## XXXX this should probably be obj_name???+ |
+
| 3043 | ++ |
+ }+ |
+
| 3044 | ++ |
+ )+ |
+
| 3045 | ++ | + + | +
| 3046 | ++ |
+ #' Convert to a vector+ |
+
| 3047 | ++ |
+ #'+ |
+
| 3048 | ++ |
+ #' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in+ |
+
| 3049 | ++ |
+ #' realistic scenarios.+ |
+
| 3050 | ++ |
+ #'+ |
+
| 3051 | ++ |
+ #' @param x (`ANY`)\cr the object to be converted to a vector.+ |
+
| 3052 | ++ |
+ #' @param mode (`string`)\cr passed on to [as.vector()].+ |
+
| 3053 | ++ |
+ #'+ |
+
| 3054 | ++ |
+ #' @return A vector of the chosen mode (or an error is raised if more than one row was present).+ |
+
| 3055 | ++ |
+ #'+ |
+
| 3056 | ++ |
+ #' @note This only works for a table with a single row or a row object.+ |
+
| 3057 | ++ |
+ #'+ |
+
| 3058 | ++ |
+ #' @name asvec+ |
+
| 3059 | ++ |
+ #' @aliases as.vector,VTableTree-method+ |
+
| 3060 | ++ |
+ #' @exportMethod as.vector+ |
+
| 3061 | ++ |
+ setMethod("as.vector", "VTableTree", function(x, mode) {
+ |
+
| 3062 | +12x | +
+ stopifnot(nrow(x) == 1L)+ |
+
| 3063 | +12x | +
+ if (nrow(content_table(x)) == 1L) {
+ |
+
| 3064 | +! | +
+ tab <- content_table(x)+ |
+
| 3065 | ++ |
+ } else {
+ |
+
| 3066 | +12x | +
+ tab <- x+ |
+
| 3067 | ++ |
+ }+ |
+
| 3068 | +12x | +
+ as.vector(tree_children(tab)[[1]], mode = mode)+ |
+
| 3069 | ++ |
+ })+ |
+
| 3070 | ++ | + + | +
| 3071 | ++ |
+ #' @inheritParams asvec+ |
+
| 3072 | ++ |
+ #'+ |
+
| 3073 | ++ |
+ #' @rdname int_methods+ |
+
| 3074 | ++ |
+ #' @exportMethod as.vector+ |
+
| 3075 | ++ |
+ setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))
+ |
+
| 3076 | ++ | + + | +
| 3077 | ++ |
+ #' @rdname int_methods+ |
+
| 3078 | ++ |
+ #' @exportMethod as.vector+ |
+
| 3079 | ++ |
+ setMethod("as.vector", "ElementaryTable", function(x, mode) {
+ |
+
| 3080 | +2x | +
+ stopifnot(nrow(x) == 1L)+ |
+
| 3081 | +2x | +
+ as.vector(tree_children(x)[[1]], mode = mode)+ |
+
| 3082 | ++ |
+ })+ |
+
| 3083 | ++ | + + | +
| 3084 | ++ |
+ ## cuts ----+ |
+
| 3085 | ++ | + + | +
| 3086 | ++ |
+ #' @rdname int_methods+ |
+
| 3087 | +220x | +
+ setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))
+ |
+
| 3088 | ++ | + + | +
| 3089 | ++ |
+ #' @rdname int_methods+ |
+
| 3090 | ++ |
+ setMethod(+ |
+
| 3091 | ++ |
+ "spl_cuts", "VarStaticCutSplit",+ |
+
| 3092 | +220x | +
+ function(obj) obj@cuts+ |
+
| 3093 | ++ |
+ )+ |
+
| 3094 | ++ | + + | +
| 3095 | ++ |
+ #' @rdname int_methods+ |
+
| 3096 | +264x | +
+ setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))
+ |
+
| 3097 | ++ | + + | +
| 3098 | ++ |
+ #' @rdname int_methods+ |
+
| 3099 | ++ |
+ setMethod(+ |
+
| 3100 | ++ |
+ "spl_cutlabels", "VarStaticCutSplit",+ |
+
| 3101 | +264x | +
+ function(obj) obj@cut_labels+ |
+
| 3102 | ++ |
+ )+ |
+
| 3103 | ++ | + + | +
| 3104 | ++ |
+ #' @rdname int_methods+ |
+
| 3105 | +5x | +
+ setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))
+ |
+
| 3106 | ++ | + + | +
| 3107 | ++ |
+ #' @rdname int_methods+ |
+
| 3108 | ++ |
+ setMethod(+ |
+
| 3109 | ++ |
+ "spl_cutfun", "VarDynCutSplit",+ |
+
| 3110 | +5x | +
+ function(obj) obj@cut_fun+ |
+
| 3111 | ++ |
+ )+ |
+
| 3112 | ++ | + + | +
| 3113 | ++ |
+ #' @rdname int_methods+ |
+
| 3114 | +5x | +
+ setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))
+ |
+
| 3115 | ++ | + + | +
| 3116 | ++ |
+ #' @rdname int_methods+ |
+
| 3117 | ++ |
+ setMethod(+ |
+
| 3118 | ++ |
+ "spl_cutlabelfun", "VarDynCutSplit",+ |
+
| 3119 | +5x | +
+ function(obj) obj@cut_label_fun+ |
+
| 3120 | ++ |
+ )+ |
+
| 3121 | ++ | + + | +
| 3122 | ++ |
+ #' @rdname int_methods+ |
+
| 3123 | +5x | +
+ setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))
+ |
+
| 3124 | ++ | + + | +
| 3125 | ++ |
+ #' @rdname int_methods+ |
+
| 3126 | ++ |
+ setMethod(+ |
+
| 3127 | ++ |
+ "spl_is_cmlcuts", "VarDynCutSplit",+ |
+
| 3128 | +5x | +
+ function(obj) obj@cumulative_cuts+ |
+
| 3129 | ++ |
+ )+ |
+
| 3130 | ++ | + + | +
| 3131 | ++ |
+ #' @rdname int_methods+ |
+
| 3132 | ++ |
+ setGeneric(+ |
+
| 3133 | ++ |
+ "spl_varnames",+ |
+
| 3134 | +198x | +
+ function(obj) standardGeneric("spl_varnames")
+ |
+
| 3135 | ++ |
+ )+ |
+
| 3136 | ++ | + + | +
| 3137 | ++ |
+ #' @rdname int_methods+ |
+
| 3138 | ++ |
+ setMethod(+ |
+
| 3139 | ++ |
+ "spl_varnames", "MultiVarSplit",+ |
+
| 3140 | +198x | +
+ function(obj) obj@var_names+ |
+
| 3141 | ++ |
+ )+ |
+
| 3142 | ++ | + + | +
| 3143 | ++ |
+ #' @rdname int_methods+ |
+
| 3144 | ++ |
+ setGeneric(+ |
+
| 3145 | ++ |
+ "spl_varnames<-",+ |
+
| 3146 | +2x | +
+ function(object, value) standardGeneric("spl_varnames<-")
+ |
+
| 3147 | ++ |
+ )+ |
+
| 3148 | ++ | + + | +
| 3149 | ++ |
+ #' @rdname int_methods+ |
+
| 3150 | ++ |
+ setMethod(+ |
+
| 3151 | ++ |
+ "spl_varnames<-", "MultiVarSplit",+ |
+
| 3152 | ++ |
+ function(object, value) {
+ |
+
| 3153 | +2x | +
+ oldvnms <- spl_varnames(object)+ |
+
| 3154 | +2x | +
+ oldvlbls <- spl_varlabels(object)+ |
+
| 3155 | +2x | +
+ object@var_names <- value+ |
+
| 3156 | +2x | +
+ if (identical(oldvnms, oldvlbls)) {
+ |
+
| 3157 | +1x | +
+ spl_varlabels(object) <- value+ |
+
| 3158 | ++ |
+ }+ |
+
| 3159 | +2x | +
+ object+ |
+
| 3160 | ++ |
+ }+ |
+
| 3161 | ++ |
+ )+ |
+
| 3162 | ++ | + + | +
| 3163 | ++ |
+ #' Top left material+ |
+
| 3164 | ++ |
+ #'+ |
+
| 3165 | ++ |
+ #' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the+ |
+
| 3166 | ++ |
+ #' area of the table between the column header display and the label of the first row. These functions access+ |
+
| 3167 | ++ |
+ #' and modify that material.+ |
+
| 3168 | ++ |
+ #'+ |
+
| 3169 | ++ |
+ #' @inheritParams gen_args+ |
+
| 3170 | ++ |
+ #'+ |
+
| 3171 | ++ |
+ #' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the+ |
+
| 3172 | ++ |
+ #' case of the setter).+ |
+
| 3173 | ++ |
+ #'+ |
+
| 3174 | ++ |
+ #' @export+ |
+
| 3175 | ++ |
+ #' @rdname top_left+ |
+
| 3176 | +6884x | +
+ setGeneric("top_left", function(obj) standardGeneric("top_left"))
+ |
+
| 3177 | ++ | + + | +
| 3178 | ++ |
+ #' @export+ |
+
| 3179 | ++ |
+ #' @rdname top_left+ |
+
| 3180 | +2992x | +
+ setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))
+ |
+
| 3181 | ++ | + + | +
| 3182 | ++ |
+ #' @export+ |
+
| 3183 | ++ |
+ #' @rdname top_left+ |
+
| 3184 | +3566x | +
+ setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)
+ |
+
| 3185 | ++ | + + | +
| 3186 | ++ |
+ #' @export+ |
+
| 3187 | ++ |
+ #' @rdname top_left+ |
+
| 3188 | +326x | +
+ setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)
+ |
+
| 3189 | ++ | + + | +
| 3190 | ++ |
+ #' @export+ |
+
| 3191 | ++ |
+ #' @rdname top_left+ |
+
| 3192 | +5909x | +
+ setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))
+ |
+
| 3193 | ++ | + + | +
| 3194 | ++ |
+ #' @export+ |
+
| 3195 | ++ |
+ #' @rdname top_left+ |
+
| 3196 | ++ |
+ 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+ |
+
| 3201 | ++ |
+ })+ |
+
| 3202 | ++ | + + | +
| 3203 | ++ |
+ #' @export+ |
+
| 3204 | ++ |
+ #' @rdname top_left+ |
+
| 3205 | ++ |
+ setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
+ |
+
| 3206 | +2954x | +
+ obj@top_left <- value+ |
+
| 3207 | +2954x | +
+ obj+ |
+
| 3208 | ++ |
+ })+ |
+
| 3209 | ++ | + + | +
| 3210 | ++ |
+ #' @export+ |
+
| 3211 | ++ |
+ #' @rdname top_left+ |
+
| 3212 | ++ |
+ setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
+ |
+
| 3213 | +1x | +
+ obj@top_left <- value+ |
+
| 3214 | +1x | +
+ obj+ |
+
| 3215 | ++ |
+ })+ |
+
| 3216 | ++ | + + | +
| 3217 | ++ |
+ vil_collapse <- function(x) {
+ |
+
| 3218 | +14x | +
+ x <- unlist(x)+ |
+
| 3219 | +14x | +
+ x <- x[!is.na(x)]+ |
+
| 3220 | +14x | +
+ x <- unique(x)+ |
+
| 3221 | +14x | +
+ x[nzchar(x)]+ |
+
| 3222 | ++ |
+ }+ |
+
| 3223 | ++ | + + | +
| 3224 | ++ |
+ #' List variables required by a pre-data table layout+ |
+
| 3225 | ++ |
+ #'+ |
+
| 3226 | ++ |
+ #' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof).+ |
+
| 3227 | ++ |
+ #'+ |
+
| 3228 | ++ |
+ #' @details+ |
+
| 3229 | ++ |
+ #' This will walk the layout declaration and return a vector of the names of the unique variables that are used+ |
+
| 3230 | ++ |
+ #' in any of the following ways:+ |
+
| 3231 | ++ |
+ #'+ |
+
| 3232 | ++ |
+ #' * Variable being split on (directly or via cuts)+ |
+
| 3233 | ++ |
+ #' * Element of a Multi-variable column split+ |
+
| 3234 | ++ |
+ #' * Content variable+ |
+
| 3235 | ++ |
+ #' * Value-label variable+ |
+
| 3236 | ++ |
+ #'+ |
+
| 3237 | ++ |
+ #' @return A character vector containing the unique variables explicitly used in the layout (see the notes below).+ |
+
| 3238 | ++ |
+ #'+ |
+
| 3239 | ++ |
+ #' @note+ |
+
| 3240 | ++ |
+ #' * This function will not detect dependencies implicit in analysis or summary functions which accept `x`+ |
+
| 3241 | ++ |
+ #' or `df` and then rely on the existence of particular variables not being split on/analyzed.+ |
+
| 3242 | ++ |
+ #' * The order these variable names appear within the return vector is undefined and should not be relied upon.+ |
+
| 3243 | ++ |
+ #'+ |
+
| 3244 | ++ |
+ #' @examples+ |
+
| 3245 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 3246 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 3247 | ++ |
+ #' split_cols_by("SEX") %>%
+ |
+
| 3248 | ++ |
+ #' summarize_row_groups(label_fstr = "Overall (N)") %>%+ |
+
| 3249 | ++ |
+ #' split_rows_by("RACE",
+ |
+
| 3250 | ++ |
+ #' split_label = "Ethnicity", labels_var = "ethn_lab",+ |
+
| 3251 | ++ |
+ #' split_fun = drop_split_levels+ |
+
| 3252 | ++ |
+ #' ) %>%+ |
+
| 3253 | ++ |
+ #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
+ |
+
| 3254 | ++ |
+ #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
+ |
+
| 3255 | ++ |
+ #'+ |
+
| 3256 | ++ |
+ #' vars_in_layout(lyt)+ |
+
| 3257 | ++ |
+ #'+ |
+
| 3258 | ++ |
+ #' @export+ |
+
| 3259 | ++ |
+ #' @rdname vil+ |
+
| 3260 | +15x | +
+ setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))
+ |
+
| 3261 | ++ | + + | +
| 3262 | ++ |
+ #' @rdname vil+ |
+
| 3263 | ++ |
+ setMethod(+ |
+
| 3264 | ++ |
+ "vars_in_layout", "PreDataTableLayouts",+ |
+
| 3265 | ++ |
+ function(lyt) {
+ |
+
| 3266 | +1x | +
+ vil_collapse(c(+ |
+
| 3267 | +1x | +
+ vars_in_layout(clayout(lyt)),+ |
+
| 3268 | +1x | +
+ vars_in_layout(rlayout(lyt))+ |
+
| 3269 | ++ |
+ ))+ |
+
| 3270 | ++ |
+ }+ |
+
| 3271 | ++ |
+ )+ |
+
| 3272 | ++ | + + | +
| 3273 | ++ |
+ #' @rdname vil+ |
+
| 3274 | ++ |
+ setMethod(+ |
+
| 3275 | ++ |
+ "vars_in_layout", "PreDataAxisLayout",+ |
+
| 3276 | ++ |
+ function(lyt) {
+ |
+
| 3277 | +2x | +
+ vil_collapse(lapply(lyt, vars_in_layout))+ |
+
| 3278 | ++ |
+ }+ |
+
| 3279 | ++ |
+ )+ |
+
| 3280 | ++ | + + | +
| 3281 | ++ |
+ #' @rdname vil+ |
+
| 3282 | ++ |
+ setMethod(+ |
+
| 3283 | ++ |
+ "vars_in_layout", "SplitVector",+ |
+
| 3284 | ++ |
+ function(lyt) {
+ |
+
| 3285 | +3x | +
+ vil_collapse(lapply(lyt, vars_in_layout))+ |
+
| 3286 | ++ |
+ }+ |
+
| 3287 | ++ |
+ )+ |
+
| 3288 | ++ | + + | +
| 3289 | ++ |
+ #' @rdname vil+ |
+
| 3290 | ++ |
+ setMethod(+ |
+
| 3291 | ++ |
+ "vars_in_layout", "Split",+ |
+
| 3292 | ++ |
+ function(lyt) {
+ |
+
| 3293 | +7x | +
+ vil_collapse(c(+ |
+
| 3294 | +7x | +
+ spl_payload(lyt),+ |
+
| 3295 | ++ |
+ ## for an AllSplit/RootSplit+ |
+
| 3296 | ++ |
+ ## doesn't have to be same as payload+ |
+
| 3297 | +7x | +
+ content_var(lyt),+ |
+
| 3298 | +7x | +
+ spl_label_var(lyt)+ |
+
| 3299 | ++ |
+ ))+ |
+
| 3300 | ++ |
+ }+ |
+
| 3301 | ++ |
+ )+ |
+
| 3302 | ++ | + + | +
| 3303 | ++ |
+ #' @rdname vil+ |
+
| 3304 | ++ |
+ setMethod(+ |
+
| 3305 | ++ |
+ "vars_in_layout", "CompoundSplit",+ |
+
| 3306 | +1x | +
+ function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout))+ |
+
| 3307 | ++ |
+ )+ |
+
| 3308 | ++ | + + | +
| 3309 | ++ |
+ #' @rdname vil+ |
+
| 3310 | ++ |
+ setMethod(+ |
+
| 3311 | ++ |
+ "vars_in_layout", "ManualSplit",+ |
+
| 3312 | +1x | +
+ function(lyt) character()+ |
+
| 3313 | ++ |
+ )+ |
+
| 3314 | ++ | + + | +
| 3315 | ++ |
+ ## Titles and footers ----+ |
+
| 3316 | ++ | + + | +
| 3317 | ++ |
+ # ##' Titles and Footers+ |
+
| 3318 | ++ |
+ # ##'+ |
+
| 3319 | ++ |
+ # ##' Get or set the titles and footers on an object+ |
+
| 3320 | ++ |
+ # ##'+ |
+
| 3321 | ++ |
+ # ##' @inheritParams gen_args+ |
+
| 3322 | ++ |
+ # ##'+ |
+
| 3323 | ++ |
+ # ##' @rdname title_footer+ |
+
| 3324 | ++ |
+ # ##' @export+ |
+
| 3325 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3326 | ++ |
+ #' @export+ |
+
| 3327 | ++ |
+ setMethod(+ |
+
| 3328 | ++ |
+ "main_title", "VTitleFooter",+ |
+
| 3329 | +3559x | +
+ function(obj) obj@main_title+ |
+
| 3330 | ++ |
+ )+ |
+
| 3331 | ++ | + + | +
| 3332 | ++ |
+ ##' @rdname formatters_methods+ |
+
| 3333 | ++ |
+ ##' @export+ |
+
| 3334 | ++ |
+ setMethod(+ |
+
| 3335 | ++ |
+ "main_title<-", "VTitleFooter",+ |
+
| 3336 | ++ |
+ function(obj, value) {
+ |
+
| 3337 | +3166x | +
+ stopifnot(length(value) == 1)+ |
+
| 3338 | +3166x | +
+ obj@main_title <- value+ |
+
| 3339 | +3166x | +
+ obj+ |
+
| 3340 | ++ |
+ }+ |
+
| 3341 | ++ |
+ )+ |
+
| 3342 | ++ | + + | +
| 3343 | ++ |
+ # Getters for TableRow is here for convenience for binding (no need of setters)+ |
+
| 3344 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3345 | ++ |
+ #' @export+ |
+
| 3346 | ++ |
+ setMethod(+ |
+
| 3347 | ++ |
+ "main_title", "TableRow",+ |
+
| 3348 | +6x | +
+ function(obj) ""+ |
+
| 3349 | ++ |
+ )+ |
+
| 3350 | ++ | + + | +
| 3351 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3352 | ++ |
+ #' @export+ |
+
| 3353 | ++ |
+ setMethod(+ |
+
| 3354 | ++ |
+ "subtitles", "VTitleFooter",+ |
+
| 3355 | +3549x | +
+ function(obj) obj@subtitles+ |
+
| 3356 | ++ |
+ )+ |
+
| 3357 | ++ | + + | +
| 3358 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3359 | ++ |
+ #' @export+ |
+
| 3360 | ++ |
+ setMethod(+ |
+
| 3361 | ++ |
+ "subtitles<-", "VTitleFooter",+ |
+
| 3362 | ++ |
+ function(obj, value) {
+ |
+
| 3363 | +3161x | +
+ obj@subtitles <- value+ |
+
| 3364 | +3161x | +
+ obj+ |
+
| 3365 | ++ |
+ }+ |
+
| 3366 | ++ |
+ )+ |
+
| 3367 | ++ | + + | +
| 3368 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3369 | ++ |
+ #' @export+ |
+
| 3370 | ++ |
+ setMethod(+ |
+
| 3371 | ++ |
+ "subtitles", "TableRow", # Only getter: see main_title for TableRow+ |
+
| 3372 | +6x | +
+ function(obj) character()+ |
+
| 3373 | ++ |
+ )+ |
+
| 3374 | ++ | + + | +
| 3375 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3376 | ++ |
+ #' @export+ |
+
| 3377 | ++ |
+ setMethod(+ |
+
| 3378 | ++ |
+ "main_footer", "VTitleFooter",+ |
+
| 3379 | +3567x | +
+ function(obj) obj@main_footer+ |
+
| 3380 | ++ |
+ )+ |
+
| 3381 | ++ | + + | +
| 3382 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3383 | ++ |
+ #' @export+ |
+
| 3384 | ++ |
+ setMethod(+ |
+
| 3385 | ++ |
+ "main_footer<-", "VTitleFooter",+ |
+
| 3386 | ++ |
+ function(obj, value) {
+ |
+
| 3387 | +3166x | +
+ obj@main_footer <- value+ |
+
| 3388 | +3166x | +
+ obj+ |
+
| 3389 | ++ |
+ }+ |
+
| 3390 | ++ |
+ )+ |
+
| 3391 | ++ | + + | +
| 3392 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3393 | ++ |
+ #' @export+ |
+
| 3394 | ++ |
+ setMethod(+ |
+
| 3395 | ++ |
+ "main_footer", "TableRow", # Only getter: see main_title for TableRow+ |
+
| 3396 | +6x | +
+ function(obj) character()+ |
+
| 3397 | ++ |
+ )+ |
+
| 3398 | ++ | + + | +
| 3399 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3400 | ++ |
+ #' @export+ |
+
| 3401 | ++ |
+ setMethod(+ |
+
| 3402 | ++ |
+ "prov_footer", "VTitleFooter",+ |
+
| 3403 | +3548x | +
+ function(obj) obj@provenance_footer+ |
+
| 3404 | ++ |
+ )+ |
+
| 3405 | ++ | + + | +
| 3406 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3407 | ++ |
+ #' @export+ |
+
| 3408 | ++ |
+ setMethod(+ |
+
| 3409 | ++ |
+ "prov_footer<-", "VTitleFooter",+ |
+
| 3410 | ++ |
+ function(obj, value) {
+ |
+
| 3411 | +3160x | +
+ obj@provenance_footer <- value+ |
+
| 3412 | +3160x | +
+ obj+ |
+
| 3413 | ++ |
+ }+ |
+
| 3414 | ++ |
+ )+ |
+
| 3415 | ++ | + + | +
| 3416 | ++ |
+ #' @rdname formatters_methods+ |
+
| 3417 | ++ |
+ #' @export+ |
+
| 3418 | ++ |
+ setMethod(+ |
+
| 3419 | ++ |
+ "prov_footer", "TableRow", # Only getter: see main_title for TableRow+ |
+
| 3420 | +6x | +
+ function(obj) character()+ |
+
| 3421 | ++ |
+ )+ |
+
| 3422 | ++ | + + | +
| 3423 | ++ |
+ make_ref_value <- function(value) {
+ |
+
| 3424 | +3231x | +
+ if (is(value, "RefFootnote")) {
+ |
+
| 3425 | +! | +
+ value <- list(value)+ |
+
| 3426 | +3231x | +
+ } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
+ |
+
| 3427 | +10x | +
+ value <- lapply(value, RefFootnote)+ |
+
| 3428 | ++ |
+ }+ |
+
| 3429 | +3231x | +
+ value+ |
+
| 3430 | ++ |
+ }+ |
+
| 3431 | ++ | + + | +
| 3432 | ++ |
+ #' Referential footnote accessors+ |
+
| 3433 | ++ |
+ #'+ |
+
| 3434 | ++ |
+ #' Access and set the referential footnotes aspects of a built table.+ |
+
| 3435 | ++ |
+ #'+ |
+
| 3436 | ++ |
+ #' @inheritParams gen_args+ |
+
| 3437 | ++ |
+ #'+ |
+
| 3438 | ++ |
+ #' @export+ |
+
| 3439 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3440 | +50212x | +
+ setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))
+ |
+
| 3441 | ++ | + + | +
| 3442 | ++ |
+ #' @export+ |
+
| 3443 | ++ |
+ #' @rdname int_methods+ |
+
| 3444 | ++ |
+ setMethod(+ |
+
| 3445 | ++ |
+ "row_footnotes", "TableRow",+ |
+
| 3446 | +48225x | +
+ function(obj) obj@row_footnotes+ |
+
| 3447 | ++ |
+ )+ |
+
| 3448 | ++ | + + | +
| 3449 | ++ |
+ #' @export+ |
+
| 3450 | ++ |
+ #' @rdname int_methods+ |
+
| 3451 | ++ |
+ setMethod(+ |
+
| 3452 | ++ |
+ "row_footnotes", "RowsVerticalSection",+ |
+
| 3453 | +1567x | +
+ function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list()+ |
+
| 3454 | ++ |
+ )+ |
+
| 3455 | ++ | + + | +
| 3456 | ++ |
+ #' @export+ |
+
| 3457 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3458 | +65x | +
+ setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))
+ |
+
| 3459 | ++ | + + | +
| 3460 | ++ |
+ #' @export+ |
+
| 3461 | ++ |
+ #' @rdname int_methods+ |
+
| 3462 | ++ |
+ setMethod(+ |
+
| 3463 | ++ |
+ "row_footnotes<-", "TableRow",+ |
+
| 3464 | ++ |
+ function(obj, value) {
+ |
+
| 3465 | +65x | +
+ obj@row_footnotes <- make_ref_value(value)+ |
+
| 3466 | +65x | +
+ obj+ |
+
| 3467 | ++ |
+ }+ |
+
| 3468 | ++ |
+ )+ |
+
| 3469 | ++ | + + | +
| 3470 | ++ |
+ #' @export+ |
+
| 3471 | ++ |
+ #' @rdname int_methods+ |
+
| 3472 | ++ |
+ setMethod(+ |
+
| 3473 | ++ |
+ "row_footnotes", "VTableTree",+ |
+
| 3474 | ++ |
+ function(obj) {
+ |
+
| 3475 | +420x | +
+ rws <- collect_leaves(obj, TRUE, TRUE)+ |
+
| 3476 | +420x | +
+ cells <- lapply(rws, row_footnotes)+ |
+
| 3477 | +420x | +
+ cells+ |
+
| 3478 | ++ |
+ }+ |
+
| 3479 | ++ |
+ )+ |
+
| 3480 | ++ | + + | +
| 3481 | ++ |
+ #' @export+ |
+
| 3482 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3483 | +197732x | +
+ setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))
+ |
+
| 3484 | ++ | + + | +
| 3485 | ++ |
+ #' @export+ |
+
| 3486 | ++ |
+ #' @rdname int_methods+ |
+
| 3487 | ++ |
+ setMethod(+ |
+
| 3488 | ++ |
+ "cell_footnotes", "CellValue",+ |
+
| 3489 | +158301x | +
+ function(obj) attr(obj, "footnotes", exact = TRUE) %||% list()+ |
+
| 3490 | ++ |
+ )+ |
+
| 3491 | ++ | + + | +
| 3492 | ++ |
+ #' @export+ |
+
| 3493 | ++ |
+ #' @rdname int_methods+ |
+
| 3494 | ++ |
+ setMethod(+ |
+
| 3495 | ++ |
+ "cell_footnotes", "TableRow",+ |
+
| 3496 | ++ |
+ function(obj) {
+ |
+
| 3497 | +34817x | +
+ ret <- lapply(row_cells(obj), cell_footnotes)+ |
+
| 3498 | +34817x | +
+ if (length(ret) != ncol(obj)) {
+ |
+
| 3499 | +143x | +
+ ret <- rep(ret, row_cspans(obj))+ |
+
| 3500 | ++ |
+ }+ |
+
| 3501 | +34817x | +
+ ret+ |
+
| 3502 | ++ |
+ }+ |
+
| 3503 | ++ |
+ )+ |
+
| 3504 | ++ | + + | +
| 3505 | ++ |
+ #' @export+ |
+
| 3506 | ++ |
+ #' @rdname int_methods+ |
+
| 3507 | ++ |
+ setMethod(+ |
+
| 3508 | ++ |
+ "cell_footnotes", "LabelRow",+ |
+
| 3509 | ++ |
+ function(obj) {
+ |
+
| 3510 | +4194x | +
+ rep(list(list()), ncol(obj))+ |
+
| 3511 | ++ |
+ }+ |
+
| 3512 | ++ |
+ )+ |
+
| 3513 | ++ | + + | +
| 3514 | ++ |
+ #' @export+ |
+
| 3515 | ++ |
+ #' @rdname int_methods+ |
+
| 3516 | ++ |
+ setMethod(+ |
+
| 3517 | ++ |
+ "cell_footnotes", "VTableTree",+ |
+
| 3518 | ++ |
+ function(obj) {
+ |
+
| 3519 | +420x | +
+ rws <- collect_leaves(obj, TRUE, TRUE)+ |
+
| 3520 | +420x | +
+ cells <- lapply(rws, cell_footnotes)+ |
+
| 3521 | +420x | +
+ do.call(rbind, cells)+ |
+
| 3522 | ++ |
+ }+ |
+
| 3523 | ++ |
+ )+ |
+
| 3524 | ++ | + + | +
| 3525 | ++ |
+ #' @export+ |
+
| 3526 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3527 | +617x | +
+ setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))
+ |
+
| 3528 | ++ | + + | +
| 3529 | ++ |
+ #' @export+ |
+
| 3530 | ++ |
+ #' @rdname int_methods+ |
+
| 3531 | ++ |
+ setMethod(+ |
+
| 3532 | ++ |
+ "cell_footnotes<-", "CellValue",+ |
+
| 3533 | ++ |
+ function(obj, value) {
+ |
+
| 3534 | +557x | +
+ attr(obj, "footnotes") <- make_ref_value(value)+ |
+
| 3535 | +557x | +
+ obj+ |
+
| 3536 | ++ |
+ }+ |
+
| 3537 | ++ |
+ )+ |
+
| 3538 | ++ | + + | +
| 3539 | ++ |
+ .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.")
+ |
+
| 3542 | ++ |
+ }+ |
+
| 3543 | ++ | + + | +
| 3544 | +60x | +
+ row_cells(obj) <- mapply(+ |
+
| 3545 | +60x | +
+ function(cell, fns) {
+ |
+
| 3546 | +191x | +
+ if (is.list(fns)) {
+ |
+
| 3547 | +185x | +
+ cell_footnotes(cell) <- lapply(fns, RefFootnote)+ |
+
| 3548 | ++ |
+ } else {
+ |
+
| 3549 | +6x | +
+ cell_footnotes(cell) <- list(RefFootnote(fns))+ |
+
| 3550 | ++ |
+ }+ |
+
| 3551 | +191x | +
+ cell+ |
+
| 3552 | ++ |
+ },+ |
+
| 3553 | +60x | +
+ cell = row_cells(obj),+ |
+
| 3554 | +60x | +
+ fns = value, SIMPLIFY = FALSE+ |
+
| 3555 | ++ |
+ )+ |
+
| 3556 | +60x | +
+ obj+ |
+
| 3557 | ++ |
+ }+ |
+
| 3558 | ++ | + + | +
| 3559 | ++ |
+ #' @export+ |
+
| 3560 | ++ |
+ #' @rdname int_methods+ |
+
| 3561 | ++ |
+ setMethod("cell_footnotes<-", "DataRow",
+ |
+
| 3562 | ++ |
+ definition = .cfn_set_helper+ |
+
| 3563 | ++ |
+ )+ |
+
| 3564 | ++ | + + | +
| 3565 | ++ |
+ #' @export+ |
+
| 3566 | ++ |
+ #' @rdname int_methods+ |
+
| 3567 | ++ |
+ setMethod("cell_footnotes<-", "ContentRow",
+ |
+
| 3568 | ++ |
+ definition = .cfn_set_helper+ |
+
| 3569 | ++ |
+ )+ |
+
| 3570 | ++ | + + | +
| 3571 | ++ |
+ # Deprecated methods ----+ |
+
| 3572 | ++ | + + | +
| 3573 | ++ |
+ #' @export+ |
+
| 3574 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3575 | +! | +
+ setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))
+ |
+
| 3576 | ++ | + + | +
| 3577 | ++ |
+ #' @export+ |
+
| 3578 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3579 | ++ |
+ setMethod("col_fnotes_here", "ANY", function(obj) {
+ |
+
| 3580 | +! | +
+ lifecycle::deprecate_warn(+ |
+
| 3581 | +! | +
+ when = "0.6.6",+ |
+
| 3582 | +! | +
+ what = "col_fnotes_here()",+ |
+
| 3583 | +! | +
+ with = "col_footnotes()"+ |
+
| 3584 | ++ |
+ )+ |
+
| 3585 | +! | +
+ col_footnotes(obj)+ |
+
| 3586 | ++ |
+ })+ |
+
| 3587 | ++ | + + | +
| 3588 | ++ |
+ #' @export+ |
+
| 3589 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3590 | +! | +
+ setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
+ |
+
| 3591 | ++ | + + | +
| 3592 | ++ |
+ #' @export+ |
+
| 3593 | ++ |
+ #' @rdname int_methods+ |
+
| 3594 | ++ |
+ setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
+ |
+
| 3595 | +! | +
+ lifecycle::deprecate_warn(+ |
+
| 3596 | +! | +
+ when = "0.6.6",+ |
+
| 3597 | +! | +
+ what = I("col_fnotes_here()<-"),
+ |
+
| 3598 | +! | +
+ with = I("col_footnotes()<-")
+ |
+
| 3599 | ++ |
+ )+ |
+
| 3600 | +! | +
+ col_footnotes(obj) <- value+ |
+
| 3601 | ++ |
+ })+ |
+
| 3602 | ++ | + + | +
| 3603 | ++ |
+ #' @export+ |
+
| 3604 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3605 | +16303x | +
+ setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))
+ |
+
| 3606 | ++ | + + | +
| 3607 | ++ |
+ #' @export+ |
+
| 3608 | ++ |
+ #' @rdname int_methods+ |
+
| 3609 | +1405x | +
+ setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)
+ |
+
| 3610 | ++ | + + | +
| 3611 | ++ |
+ #' @export+ |
+
| 3612 | ++ |
+ #' @rdname int_methods+ |
+
| 3613 | +14479x | +
+ setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)
+ |
+
| 3614 | ++ | + + | +
| 3615 | ++ |
+ #' @export+ |
+
| 3616 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3617 | +1999x | +
+ setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))
+ |
+
| 3618 | ++ | + + | +
| 3619 | ++ |
+ #' @export+ |
+
| 3620 | ++ |
+ #' @rdname int_methods+ |
+
| 3621 | ++ |
+ setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
+ |
+
| 3622 | +747x | +
+ obj@col_footnotes <- make_ref_value(value)+ |
+
| 3623 | +747x | +
+ obj+ |
+
| 3624 | ++ |
+ })+ |
+
| 3625 | ++ | + + | +
| 3626 | ++ |
+ #' @export+ |
+
| 3627 | ++ |
+ #' @rdname int_methods+ |
+
| 3628 | ++ |
+ setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
+ |
+
| 3629 | +1252x | +
+ obj@col_footnotes <- make_ref_value(value)+ |
+
| 3630 | +1252x | +
+ obj+ |
+
| 3631 | ++ |
+ })+ |
+
| 3632 | ++ | + + | +
| 3633 | ++ |
+ #' @export+ |
+
| 3634 | ++ |
+ #' @rdname int_methods+ |
+
| 3635 | ++ |
+ setMethod(+ |
+
| 3636 | ++ |
+ "col_footnotes", "VTableTree",+ |
+
| 3637 | ++ |
+ function(obj) {
+ |
+
| 3638 | +419x | +
+ ctree <- coltree(obj)+ |
+
| 3639 | +419x | +
+ 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 | ++ |
+ }+ |
+
| 3644 | +419x | +
+ all_col_fnotes <- lapply(cols, col_footnotes)+ |
+
| 3645 | +419x | +
+ if (is.null(unlist(all_col_fnotes))) {
+ |
+
| 3646 | +414x | +
+ return(NULL)+ |
+
| 3647 | ++ |
+ }+ |
+
| 3648 | ++ | + + | +
| 3649 | +5x | +
+ return(all_col_fnotes)+ |
+
| 3650 | ++ |
+ }+ |
+
| 3651 | ++ |
+ )+ |
+
| 3652 | ++ | + + | +
| 3653 | ++ |
+ #' @export+ |
+
| 3654 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3655 | +584x | +
+ setGeneric("ref_index", function(obj) standardGeneric("ref_index"))
+ |
+
| 3656 | ++ | + + | +
| 3657 | ++ |
+ #' @export+ |
+
| 3658 | ++ |
+ #' @rdname int_methods+ |
+
| 3659 | ++ |
+ setMethod(+ |
+
| 3660 | ++ |
+ "ref_index", "RefFootnote",+ |
+
| 3661 | +584x | +
+ function(obj) obj@index+ |
+
| 3662 | ++ |
+ )+ |
+
| 3663 | ++ | + + | +
| 3664 | ++ |
+ #' @export+ |
+
| 3665 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3666 | +71x | +
+ setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))
+ |
+
| 3667 | ++ | + + | +
| 3668 | ++ |
+ #' @export+ |
+
| 3669 | ++ |
+ #' @rdname int_methods+ |
+
| 3670 | ++ |
+ setMethod(+ |
+
| 3671 | ++ |
+ "ref_index<-", "RefFootnote",+ |
+
| 3672 | ++ |
+ function(obj, value) {
+ |
+
| 3673 | +71x | +
+ obj@index <- value+ |
+
| 3674 | +71x | +
+ obj+ |
+
| 3675 | ++ |
+ }+ |
+
| 3676 | ++ |
+ )+ |
+
| 3677 | ++ | + + | +
| 3678 | ++ |
+ #' @export+ |
+
| 3679 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3680 | +513x | +
+ setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))
+ |
+
| 3681 | ++ | + + | +
| 3682 | ++ |
+ #' @export+ |
+
| 3683 | ++ |
+ #' @rdname int_methods+ |
+
| 3684 | ++ |
+ setMethod(+ |
+
| 3685 | ++ |
+ "ref_symbol", "RefFootnote",+ |
+
| 3686 | +513x | +
+ function(obj) obj@symbol+ |
+
| 3687 | ++ |
+ )+ |
+
| 3688 | ++ | + + | +
| 3689 | ++ |
+ #' @export+ |
+
| 3690 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3691 | +! | +
+ setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))
+ |
+
| 3692 | ++ | + + | +
| 3693 | ++ |
+ #' @export+ |
+
| 3694 | ++ |
+ #' @rdname int_methods+ |
+
| 3695 | ++ |
+ setMethod(+ |
+
| 3696 | ++ |
+ "ref_symbol<-", "RefFootnote",+ |
+
| 3697 | ++ |
+ function(obj, value) {
+ |
+
| 3698 | +! | +
+ obj@symbol <- value+ |
+
| 3699 | +! | +
+ obj+ |
+
| 3700 | ++ |
+ }+ |
+
| 3701 | ++ |
+ )+ |
+
| 3702 | ++ | + + | +
| 3703 | ++ |
+ #' @export+ |
+
| 3704 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3705 | +509x | +
+ setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))
+ |
+
| 3706 | ++ | + + | +
| 3707 | ++ |
+ #' @export+ |
+
| 3708 | ++ |
+ #' @rdname int_methods+ |
+
| 3709 | ++ |
+ setMethod(+ |
+
| 3710 | ++ |
+ "ref_msg", "RefFootnote",+ |
+
| 3711 | +509x | +
+ function(obj) obj@value+ |
+
| 3712 | ++ |
+ )+ |
+
| 3713 | ++ | + + | +
| 3714 | +20x | +
+ setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))
+ |
+
| 3715 | ++ | + + | +
| 3716 | ++ |
+ setMethod(+ |
+
| 3717 | ++ |
+ ".fnote_set_inner<-", c("TableRow", "NULL"),
+ |
+
| 3718 | ++ |
+ function(ttrp, colpath, value) {
+ |
+
| 3719 | +7x | +
+ row_footnotes(ttrp) <- value+ |
+
| 3720 | +7x | +
+ ttrp+ |
+
| 3721 | ++ |
+ }+ |
+
| 3722 | ++ |
+ )+ |
+
| 3723 | ++ | + + | +
| 3724 | ++ |
+ setMethod(+ |
+
| 3725 | ++ |
+ ".fnote_set_inner<-", c("TableRow", "character"),
+ |
+
| 3726 | ++ |
+ function(ttrp, colpath, value) {
+ |
+
| 3727 | +6x | +
+ ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE)+ |
+
| 3728 | +6x | +
+ cfns <- cell_footnotes(ttrp)+ |
+
| 3729 | +6x | +
+ cfns[[ind]] <- value+ |
+
| 3730 | +6x | +
+ cell_footnotes(ttrp) <- cfns+ |
+
| 3731 | +6x | +
+ ttrp+ |
+
| 3732 | ++ |
+ }+ |
+
| 3733 | ++ |
+ )+ |
+
| 3734 | ++ | + + | +
| 3735 | ++ |
+ setMethod(+ |
+
| 3736 | ++ |
+ ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
+ |
+
| 3737 | ++ |
+ function(ttrp, colpath, value) {
+ |
+
| 3738 | +1x | +
+ ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value)+ |
+
| 3739 | +1x | +
+ coltree(ttrp) <- ctree+ |
+
| 3740 | +1x | +
+ ttrp+ |
+
| 3741 | ++ |
+ }+ |
+
| 3742 | ++ |
+ )+ |
+
| 3743 | ++ | + + | +
| 3744 | ++ |
+ setMethod(+ |
+
| 3745 | ++ |
+ ".fnote_set_inner<-", c("VTableTree", "ANY"),
+ |
+
| 3746 | ++ |
+ function(ttrp, colpath, value) {
+ |
+
| 3747 | +6x | +
+ if (labelrow_visible(ttrp) && !is.null(value)) {
+ |
+
| 3748 | +2x | +
+ lblrw <- tt_labelrow(ttrp)+ |
+
| 3749 | +2x | +
+ row_footnotes(lblrw) <- value+ |
+
| 3750 | +2x | +
+ tt_labelrow(ttrp) <- lblrw+ |
+
| 3751 | +4x | +
+ } else if (NROW(content_table(ttrp)) == 1L) {
+ |
+
| 3752 | +4x | +
+ ctbl <- content_table(ttrp)+ |
+
| 3753 | +4x | +
+ pth <- make_row_df(ctbl)$path[[1]]+ |
+
| 3754 | +4x | +
+ fnotes_at_path(ctbl, pth, colpath) <- value+ |
+
| 3755 | +4x | +
+ content_table(ttrp) <- ctbl+ |
+
| 3756 | ++ |
+ } else {
+ |
+
| 3757 | ++ |
+ stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
+ |
+
| 3758 | ++ |
+ }+ |
+
| 3759 | +6x | +
+ ttrp+ |
+
| 3760 | ++ |
+ }+ |
+
| 3761 | ++ |
+ )+ |
+
| 3762 | ++ | + + | +
| 3763 | ++ |
+ #' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should+ |
+
| 3764 | ++ |
+ #' go on the column rather than cell.+ |
+
| 3765 | ++ |
+ #' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go+ |
+
| 3766 | ++ |
+ #' on the row rather than cell.+ |
+
| 3767 | ++ |
+ #' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately+ |
+
| 3768 | ++ |
+ #' recalculated. Defaults to `TRUE`.+ |
+
| 3769 | ++ |
+ #'+ |
+
| 3770 | ++ |
+ #' @examples+ |
+
| 3771 | ++ |
+ #' # How to add referencial footnotes after having created a table+ |
+
| 3772 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 3773 | ++ |
+ #' split_rows_by("SEX", page_by = TRUE) %>%
+ |
+
| 3774 | ++ |
+ #' analyze("AGE")
+ |
+
| 3775 | ++ |
+ #'+ |
+
| 3776 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 3777 | ++ |
+ #' tbl <- trim_rows(tbl)+ |
+
| 3778 | ++ |
+ #' # Check the row and col structure to add precise references+ |
+
| 3779 | ++ |
+ #' # row_paths(tbl)+ |
+
| 3780 | ++ |
+ #' # col_paths(t)+ |
+
| 3781 | ++ |
+ #' # row_paths_summary(tbl)+ |
+
| 3782 | ++ |
+ #' # col_paths_summary(tbl)+ |
+
| 3783 | ++ |
+ #'+ |
+
| 3784 | ++ |
+ #' # Add the citation numbers on the table and relative references in the footnotes+ |
+
| 3785 | ++ |
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
+ |
+
| 3786 | ++ |
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
+ |
+
| 3787 | ++ |
+ #' # tbl+ |
+
| 3788 | ++ |
+ #'+ |
+
| 3789 | ++ |
+ #' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()]+ |
+
| 3790 | ++ |
+ #'+ |
+
| 3791 | ++ |
+ #' @export+ |
+
| 3792 | ++ |
+ #' @rdname ref_fnotes+ |
+
| 3793 | ++ |
+ setGeneric("fnotes_at_path<-", function(obj,
+ |
+
| 3794 | ++ |
+ rowpath = NULL,+ |
+
| 3795 | ++ |
+ colpath = NULL,+ |
+
| 3796 | ++ |
+ reset_idx = TRUE,+ |
+
| 3797 | ++ |
+ value) {
+ |
+
| 3798 | +20x | +
+ standardGeneric("fnotes_at_path<-")
+ |
+
| 3799 | ++ |
+ })+ |
+
| 3800 | ++ | + + | +
| 3801 | ++ |
+ ## non-null rowpath, null or non-null colpath+ |
+
| 3802 | ++ |
+ #' @inheritParams fnotes_at_path<-+ |
+
| 3803 | ++ |
+ #'+ |
+
| 3804 | ++ |
+ #' @export+ |
+
| 3805 | ++ |
+ #' @rdname int_methods+ |
+
| 3806 | ++ |
+ setMethod(+ |
+
| 3807 | ++ |
+ "fnotes_at_path<-", c("VTableTree", "character"),
+ |
+
| 3808 | ++ |
+ function(obj,+ |
+
| 3809 | ++ |
+ rowpath = NULL,+ |
+
| 3810 | ++ |
+ colpath = NULL,+ |
+
| 3811 | ++ |
+ reset_idx = TRUE,+ |
+
| 3812 | ++ |
+ 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)+ |
+
| 3818 | ++ |
+ }+ |
+
| 3819 | +19x | +
+ obj+ |
+
| 3820 | ++ |
+ }+ |
+
| 3821 | ++ |
+ )+ |
+
| 3822 | ++ | + + | +
| 3823 | ++ |
+ #' @export+ |
+
| 3824 | ++ |
+ #' @rdname int_methods+ |
+
| 3825 | ++ |
+ setMethod(+ |
+
| 3826 | ++ |
+ "fnotes_at_path<-", c("VTableTree", "NULL"),
+ |
+
| 3827 | ++ |
+ function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
+ |
+
| 3828 | +1x | +
+ cinfo <- col_info(obj)+ |
+
| 3829 | +1x | +
+ .fnote_set_inner(cinfo, colpath) <- value+ |
+
| 3830 | +1x | +
+ col_info(obj) <- cinfo+ |
+
| 3831 | +1x | +
+ if (reset_idx) {
+ |
+
| 3832 | +1x | +
+ obj <- update_ref_indexing(obj)+ |
+
| 3833 | ++ |
+ }+ |
+
| 3834 | +1x | +
+ obj+ |
+
| 3835 | ++ |
+ }+ |
+
| 3836 | ++ |
+ )+ |
+
| 3837 | ++ | + + | +
| 3838 | +2887x | +
+ setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))
+ |
+
| 3839 | ++ | + + | +
| 3840 | +349x | +
+ setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))
+ |
+
| 3841 | ++ | + + | +
| 3842 | +1573x | +
+ setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))
+ |
+
| 3843 | ++ | + + | +
| 3844 | +914x | +
+ setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)
+ |
+
| 3845 | ++ | + + | +
| 3846 | +2380x | +
+ setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))
+ |
+
| 3847 | ++ | + + | +
| 3848 | +357x | +
+ setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)
+ |
+
| 3849 | ++ | + + | +
| 3850 | +1972x | +
+ setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)
+ |
+
| 3851 | ++ | + + | +
| 3852 | +! | +
+ setMethod("ptitle_prefix", "ANY", function(obj) NULL)
+ |
+
| 3853 | ++ | + + | +
| 3854 | +343x | +
+ setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)
+ |
+
| 3855 | ++ | + + | +
| 3856 | ++ |
+ setMethod("page_titles<-", "VTableTree", function(obj, value) {
+ |
+
| 3857 | +19x | +
+ obj@page_titles <- value+ |
+
| 3858 | +19x | +
+ obj+ |
+
| 3859 | ++ |
+ })+ |
+
| 3860 | ++ | + + | +
| 3861 | ++ |
+ ## Horizontal separator --------------------------------------------------------+ |
+
| 3862 | ++ | + + | +
| 3863 | ++ |
+ #' Access or recursively set header-body separator for tables+ |
+
| 3864 | ++ |
+ #'+ |
+
| 3865 | ++ |
+ #' @inheritParams gen_args+ |
+
| 3866 | ++ |
+ #' @param value (`string`)\cr string to use as new header/body separator.+ |
+
| 3867 | ++ |
+ #'+ |
+
| 3868 | ++ |
+ #' @return+ |
+
| 3869 | ++ |
+ #' * `horizontal_sep` returns the string acting as the header separator.+ |
+
| 3870 | ++ |
+ #' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its+ |
+
| 3871 | ++ |
+ #' subtables.+ |
+
| 3872 | ++ |
+ #'+ |
+
| 3873 | ++ |
+ #' @export+ |
+
| 3874 | +344x | +
+ setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))
+ |
+
| 3875 | ++ | + + | +
| 3876 | ++ |
+ #' @rdname horizontal_sep+ |
+
| 3877 | ++ |
+ #' @export+ |
+
| 3878 | ++ |
+ setMethod(+ |
+
| 3879 | ++ |
+ "horizontal_sep", "VTableTree",+ |
+
| 3880 | +344x | +
+ function(obj) obj@horizontal_sep+ |
+
| 3881 | ++ |
+ )+ |
+
| 3882 | ++ | + + | +
| 3883 | ++ |
+ #' @rdname horizontal_sep+ |
+
| 3884 | ++ |
+ #' @export+ |
+
| 3885 | +23453x | +
+ setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))
+ |
+
| 3886 | ++ | + + | +
| 3887 | ++ |
+ #' @rdname horizontal_sep+ |
+
| 3888 | ++ |
+ #' @export+ |
+
| 3889 | ++ |
+ setMethod(+ |
+
| 3890 | ++ |
+ "horizontal_sep<-", "VTableTree",+ |
+
| 3891 | ++ |
+ function(obj, value) {
+ |
+
| 3892 | +13124x | +
+ cont <- content_table(obj)+ |
+
| 3893 | +13124x | +
+ if (NROW(cont) > 0) {
+ |
+
| 3894 | +1890x | +
+ horizontal_sep(cont) <- value+ |
+
| 3895 | +1890x | +
+ content_table(obj) <- cont+ |
+
| 3896 | ++ |
+ }+ |
+
| 3897 | ++ | + + | +
| 3898 | +13124x | +
+ kids <- lapply(tree_children(obj),+ |
+
| 3899 | +13124x | +
+ `horizontal_sep<-`,+ |
+
| 3900 | +13124x | +
+ value = value+ |
+
| 3901 | ++ |
+ )+ |
+
| 3902 | ++ | + + | +
| 3903 | +13124x | +
+ tree_children(obj) <- kids+ |
+
| 3904 | +13124x | +
+ obj@horizontal_sep <- value+ |
+
| 3905 | +13124x | +
+ obj+ |
+
| 3906 | ++ |
+ }+ |
+
| 3907 | ++ |
+ )+ |
+
| 3908 | ++ | + + | +
| 3909 | ++ |
+ #' @rdname horizontal_sep+ |
+
| 3910 | ++ |
+ #' @export+ |
+
| 3911 | ++ |
+ setMethod(+ |
+
| 3912 | ++ |
+ "horizontal_sep<-", "TableRow",+ |
+
| 3913 | +10329x | +
+ function(obj, value) obj+ |
+
| 3914 | ++ |
+ )+ |
+
| 3915 | ++ | + + | +
| 3916 | ++ |
+ ## Section dividers ------------------------------------------------------------+ |
+
| 3917 | ++ | + + | +
| 3918 | ++ |
+ # Used for splits+ |
+
| 3919 | +1599x | +
+ setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))
+ |
+
| 3920 | ++ | + + | +
| 3921 | ++ |
+ setMethod(+ |
+
| 3922 | ++ |
+ "spl_section_div", "Split",+ |
+
| 3923 | +1599x | +
+ function(obj) obj@child_section_div+ |
+
| 3924 | ++ |
+ )+ |
+
| 3925 | ++ | + + | +
| 3926 | +! | +
+ setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))
+ |
+
| 3927 | ++ | + + | +
| 3928 | ++ |
+ setMethod(+ |
+
| 3929 | ++ |
+ "spl_section_div<-", "Split",+ |
+
| 3930 | ++ |
+ function(obj, value) {
+ |
+
| 3931 | +! | +
+ obj@child_section_div <- value+ |
+
| 3932 | +! | +
+ obj+ |
+
| 3933 | ++ |
+ }+ |
+
| 3934 | ++ |
+ )+ |
+
| 3935 | ++ | + + | +
| 3936 | ++ |
+ # Used for table object parts+ |
+
| 3937 | +24411x | +
+ setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
+ |
+
| 3938 | +9406x | +
+ setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
+ |
+
| 3939 | +4573x | +
+ setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
+ |
+
| 3940 | +10432x | +
+ setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)
+ |
+
| 3941 | ++ | + + | +
| 3942 | +1459x | +
+ setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
+ |
+
| 3943 | ++ |
+ setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
+ |
+
| 3944 | +1360x | +
+ obj@trailing_section_div <- value+ |
+
| 3945 | +1360x | +
+ obj+ |
+
| 3946 | ++ |
+ })+ |
+
| 3947 | ++ |
+ setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
+ |
+
| 3948 | +40x | +
+ obj@trailing_section_div <- value+ |
+
| 3949 | +40x | +
+ obj+ |
+
| 3950 | ++ |
+ })+ |
+
| 3951 | ++ |
+ setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
+ |
+
| 3952 | +59x | +
+ obj@trailing_section_div <- value+ |
+
| 3953 | +59x | +
+ obj+ |
+
| 3954 | ++ |
+ })+ |
+
| 3955 | ++ | + + | +
| 3956 | ++ |
+ #' Section dividers accessor and setter+ |
+
| 3957 | ++ |
+ #'+ |
+
| 3958 | ++ |
+ #' `section_div` can be used to set or get the section divider for a table object+ |
+
| 3959 | ++ |
+ #' produced by [build_table()]. When assigned in post-processing (`section_div<-`)+ |
+
| 3960 | ++ |
+ #' the table can have a section divider after every row, each assigned independently.+ |
+
| 3961 | ++ |
+ #' If assigning during layout creation, only [split_rows_by()] (and its related row-wise+ |
+
| 3962 | ++ |
+ #' splits) and [analyze()] have a `section_div` parameter that will produce separators+ |
+
| 3963 | ++ |
+ #' between split sections and data subgroups, respectively.+ |
+
| 3964 | ++ |
+ #'+ |
+
| 3965 | ++ |
+ #' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree`+ |
+
| 3966 | ++ |
+ #' or `TableRow`/`LabelRow`.+ |
+
| 3967 | ++ |
+ #' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows+ |
+
| 3968 | ++ |
+ #' you to set the section divider only for sections that are splits or analyses if the number of+ |
+
| 3969 | ++ |
+ #' values is less than the number of rows in the table. If `TRUE`, the section divider will+ |
+
| 3970 | ++ |
+ #' be set for all rows of the table.+ |
+
| 3971 | ++ |
+ #' @param value (`character`)\cr vector of single characters to use as section dividers. Each character+ |
+
| 3972 | ++ |
+ #' is repeated such that all section dividers span the width of the table. Each character that is+ |
+
| 3973 | ++ |
+ #' not `NA_character_` will produce a trailing separator for each row of the table. `value` length+ |
+
| 3974 | ++ |
+ #' should reflect the number of rows, or be between 1 and the number of splits/levels.+ |
+
| 3975 | ++ |
+ #' See the Details section below for more information.+ |
+
| 3976 | ++ |
+ #'+ |
+
| 3977 | ++ |
+ #' @return The section divider string. Each line that does not have a trailing separator+ |
+
| 3978 | ++ |
+ #' will have `NA_character_` as section divider.+ |
+
| 3979 | ++ |
+ #'+ |
+
| 3980 | ++ |
+ #' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global+ |
+
| 3981 | ++ |
+ #' section dividers.+ |
+
| 3982 | ++ |
+ #'+ |
+
| 3983 | ++ |
+ #' @details+ |
+
| 3984 | ++ |
+ #' Assigned value to section divider must be a character vector. If any value is `NA_character_`+ |
+
| 3985 | ++ |
+ #' the section divider will be absent for that row or section. When you want to only affect sections+ |
+
| 3986 | ++ |
+ #' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows.+ |
+
| 3987 | ++ |
+ #' Ideally, the length of the vector should be less than the number of splits with, eventually, the+ |
+
| 3988 | ++ |
+ #' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted,+ |
+
| 3989 | ++ |
+ #' only the first split will be affected.+ |
+
| 3990 | ++ |
+ #' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table+ |
+
| 3991 | ++ |
+ #' construction, the section divider will be set for all the splits and eventually analyses, but+ |
+
| 3992 | ++ |
+ #' not for the header or each row of the table. This can be set with `header_section_div` in+ |
+
| 3993 | ++ |
+ #' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section+ |
+
| 3994 | ++ |
+ #' divider will be set for all the rows of the table.+ |
+
| 3995 | ++ |
+ #'+ |
+
| 3996 | ++ |
+ #' @examples+ |
+
| 3997 | ++ |
+ #' # Data+ |
+
| 3998 | ++ |
+ #' df <- data.frame(+ |
+
| 3999 | ++ |
+ #' cat = c(+ |
+
| 4000 | ++ |
+ #' "really long thing its so ", "long"+ |
+
| 4001 | ++ |
+ #' ),+ |
+
| 4002 | ++ |
+ #' value = c(6, 3, 10, 1)+ |
+
| 4003 | ++ |
+ #' )+ |
+
| 4004 | ++ |
+ #' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
+ |
+
| 4005 | ++ |
+ #'+ |
+
| 4006 | ++ |
+ #' tbl <- basic_table() %>%+ |
+
| 4007 | ++ |
+ #' split_rows_by("cat", section_div = "~") %>%
+ |
+
| 4008 | ++ |
+ #' analyze("value", afun = fast_afun, section_div = " ") %>%
+ |
+
| 4009 | ++ |
+ #' build_table(df)+ |
+
| 4010 | ++ |
+ #'+ |
+
| 4011 | ++ |
+ #' # Getter+ |
+
| 4012 | ++ |
+ #' section_div(tbl)+ |
+
| 4013 | ++ |
+ #'+ |
+
| 4014 | ++ |
+ #' # Setter+ |
+
| 4015 | ++ |
+ #' section_div(tbl) <- letters[seq_len(nrow(tbl))]+ |
+
| 4016 | ++ |
+ #' tbl+ |
+
| 4017 | ++ |
+ #'+ |
+
| 4018 | ++ |
+ #' # last letter can appear if there is another table+ |
+
| 4019 | ++ |
+ #' rbind(tbl, tbl)+ |
+
| 4020 | ++ |
+ #'+ |
+
| 4021 | ++ |
+ #' # header_section_div+ |
+
| 4022 | ++ |
+ #' header_section_div(tbl) <- "+"+ |
+
| 4023 | ++ |
+ #' tbl+ |
+
| 4024 | ++ |
+ #'+ |
+
| 4025 | ++ |
+ #' @docType methods+ |
+
| 4026 | ++ |
+ #' @rdname section_div+ |
+
| 4027 | ++ |
+ #' @export+ |
+
| 4028 | +362x | +
+ setGeneric("section_div", function(obj) standardGeneric("section_div"))
+ |
+
| 4029 | ++ | + + | +
| 4030 | ++ |
+ #' @rdname section_div+ |
+
| 4031 | ++ |
+ #' @aliases section_div,VTableTree-method+ |
+
| 4032 | ++ |
+ setMethod("section_div", "VTableTree", function(obj) {
+ |
+
| 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 | +
+ if (labelrow_visible(obj) || is_content_table) {
+ |
+
| 4036 | +67x | +
+ section_div <- trailing_section_div(obj)+ |
+
| 4037 | +67x | +
+ labelrow_div <- trailing_section_div(tt_labelrow(obj))+ |
+
| 4038 | +67x | +
+ rest_of_tree <- section_div(tree_children(obj))+ |
+
| 4039 | ++ |
+ # Case it is the section itself and not the labels to have a trailing sep+ |
+
| 4040 | +67x | +
+ if (!is.na(section_div)) {
+ |
+
| 4041 | +45x | +
+ rest_of_tree[length(rest_of_tree)] <- section_div+ |
+
| 4042 | ++ |
+ }+ |
+
| 4043 | +67x | +
+ unname(c(labelrow_div, rest_of_tree))+ |
+
| 4044 | ++ |
+ } else {
+ |
+
| 4045 | +83x | +
+ unname(section_div(tree_children(obj)))+ |
+
| 4046 | ++ |
+ }+ |
+
| 4047 | ++ |
+ })+ |
+
| 4048 | ++ | + + | +
| 4049 | ++ |
+ #' @rdname section_div+ |
+
| 4050 | ++ |
+ #' @aliases section_div,list-method+ |
+
| 4051 | ++ |
+ setMethod("section_div", "list", function(obj) {
+ |
+
| 4052 | +150x | +
+ unlist(lapply(obj, section_div))+ |
+
| 4053 | ++ |
+ })+ |
+
| 4054 | ++ | + + | +
| 4055 | ++ |
+ #' @rdname section_div+ |
+
| 4056 | ++ |
+ #' @aliases section_div,TableRow-method+ |
+
| 4057 | ++ |
+ setMethod("section_div", "TableRow", function(obj) {
+ |
+
| 4058 | +62x | +
+ trailing_section_div(obj)+ |
+
| 4059 | ++ |
+ })+ |
+
| 4060 | ++ | + + | +
| 4061 | ++ |
+ # section_div setter from table object+ |
+
| 4062 | ++ |
+ #' @rdname section_div+ |
+
| 4063 | ++ |
+ #' @export+ |
+
| 4064 | ++ |
+ setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
+ |
+
| 4065 | +217x | +
+ standardGeneric("section_div<-")
+ |
+
| 4066 | ++ |
+ })+ |
+
| 4067 | ++ | + + | +
| 4068 | ++ |
+ #' @rdname section_div+ |
+
| 4069 | ++ |
+ #' @aliases section_div<-,VTableTree-method+ |
+
| 4070 | ++ |
+ setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
+ |
+
| 4071 | +90x | +
+ char_v <- as.character(value)+ |
+
| 4072 | +90x | +
+ tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1)))+ |
+
| 4073 | +90x | +
+ max_tree_depth <- max(tree_depths)+ |
+
| 4074 | +90x | +
+ stopifnot(is.logical(only_sep_sections))+ |
+
| 4075 | +90x | +
+ .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj))+ |
+
| 4076 | ++ | + + | +
| 4077 | ++ |
+ # Automatic establishment of intent+ |
+
| 4078 | +90x | +
+ if (length(char_v) < nrow(obj)) {
+ |
+
| 4079 | +3x | +
+ only_sep_sections <- TRUE+ |
+
| 4080 | ++ |
+ }+ |
+
| 4081 | ++ | + + | +
| 4082 | ++ |
+ # Case where only separators or splits need to change externally+ |
+
| 4083 | +90x | +
+ if (only_sep_sections && length(char_v) < nrow(obj)) {
+ |
+
| 4084 | ++ |
+ # Case where char_v is longer than the max depth+ |
+
| 4085 | +3x | +
+ char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))]+ |
+
| 4086 | ++ |
+ # Filling up with NAs the rest of the tree depth section div chr vector+ |
+
| 4087 | +3x | +
+ missing_char_v_len <- max_tree_depth - length(char_v)+ |
+
| 4088 | +3x | +
+ char_v <- c(char_v, rep(NA_character_, missing_char_v_len))+ |
+
| 4089 | ++ |
+ }+ |
+
| 4090 | ++ | + + | +
| 4091 | ++ |
+ # Retrieving if it is a contentRow (no need for labelrow to be visible in this case)+ |
+
| 4092 | +90x | +
+ content_row_tbl <- content_table(obj)+ |
+
| 4093 | +90x | +
+ is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0+ |
+
| 4094 | ++ | + + | +
| 4095 | ++ |
+ # Main table structure change+ |
+
| 4096 | +90x | +
+ if (labelrow_visible(obj) || is_content_table) {
+ |
+
| 4097 | +40x | +
+ if (only_sep_sections) {
+ |
+
| 4098 | ++ |
+ # Only tables are modified+ |
+
| 4099 | +34x | +
+ trailing_section_div(tt_labelrow(obj)) <- NA_character_+ |
+
| 4100 | +34x | +
+ trailing_section_div(obj) <- char_v[1]+ |
+
| 4101 | +34x | +
+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]+ |
+
| 4102 | ++ |
+ } else {
+ |
+
| 4103 | ++ |
+ # All leaves are modified+ |
+
| 4104 | +6x | +
+ trailing_section_div(tt_labelrow(obj)) <- char_v[1]+ |
+
| 4105 | +6x | +
+ trailing_section_div(obj) <- NA_character_+ |
+
| 4106 | +6x | +
+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]+ |
+
| 4107 | ++ |
+ }+ |
+
| 4108 | ++ |
+ } else {
+ |
+
| 4109 | +50x | +
+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v+ |
+
| 4110 | ++ |
+ }+ |
+
| 4111 | +90x | +
+ obj+ |
+
| 4112 | ++ |
+ })+ |
+
| 4113 | ++ | + + | +
| 4114 | ++ |
+ #' @rdname section_div+ |
+
| 4115 | ++ |
+ #' @aliases section_div<-,list-method+ |
+
| 4116 | ++ |
+ setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
+ |
+
| 4117 | +90x | +
+ char_v <- as.character(value)+ |
+
| 4118 | +90x | +
+ for (i in seq_along(obj)) {
+ |
+
| 4119 | +121x | +
+ stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow"))+ |
+
| 4120 | +121x | +
+ list_element_size <- nrow(obj[[i]])+ |
+
| 4121 | +121x | +
+ if (only_sep_sections) {
+ |
+
| 4122 | +97x | +
+ char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))]+ |
+
| 4123 | +97x | +
+ char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i)))+ |
+
| 4124 | ++ |
+ } else {
+ |
+
| 4125 | +24x | +
+ init <- (i - 1) * list_element_size + 1+ |
+
| 4126 | +24x | +
+ chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1)+ |
+
| 4127 | +24x | +
+ char_v_i <- char_v[chunk_of_char_v_to_take]+ |
+
| 4128 | ++ |
+ }+ |
+
| 4129 | +121x | +
+ section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i+ |
+
| 4130 | ++ |
+ }+ |
+
| 4131 | +90x | +
+ obj+ |
+
| 4132 | ++ |
+ })+ |
+
| 4133 | ++ | + + | +
| 4134 | ++ |
+ #' @rdname section_div+ |
+
| 4135 | ++ |
+ #' @aliases section_div<-,TableRow-method+ |
+
| 4136 | ++ |
+ setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
+ |
+
| 4137 | +37x | +
+ trailing_section_div(obj) <- value+ |
+
| 4138 | +37x | +
+ obj+ |
+
| 4139 | ++ |
+ })+ |
+
| 4140 | ++ | + + | +
| 4141 | ++ |
+ #' @rdname section_div+ |
+
| 4142 | ++ |
+ #' @aliases section_div<-,LabelRow-method+ |
+
| 4143 | ++ |
+ setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
+ |
+
| 4144 | +! | +
+ trailing_section_div(obj) <- value+ |
+
| 4145 | +! | +
+ obj+ |
+
| 4146 | ++ |
+ })+ |
+
| 4147 | ++ | + + | +
| 4148 | ++ |
+ # Helper check function+ |
+
| 4149 | ++ |
+ .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.")
+ |
+
| 4153 | ++ |
+ }+ |
+
| 4154 | +90x | +
+ 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, ")."
+ |
+
| 4158 | ++ |
+ )+ |
+
| 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")
+ |
+
| 4163 | ++ |
+ }+ |
+
| 4164 | ++ |
+ }+ |
+
| 4165 | ++ | + + | +
| 4166 | ++ |
+ #' @rdname section_div+ |
+
| 4167 | ++ |
+ #' @export+ |
+
| 4168 | +595x | +
+ setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))
+ |
+
| 4169 | ++ | + + | +
| 4170 | ++ |
+ #' @rdname section_div+ |
+
| 4171 | ++ |
+ #' @aliases header_section_div,PreDataTableLayouts-method+ |
+
| 4172 | ++ |
+ setMethod(+ |
+
| 4173 | ++ |
+ "header_section_div", "PreDataTableLayouts",+ |
+
| 4174 | +296x | +
+ function(obj) obj@header_section_div+ |
+
| 4175 | ++ |
+ )+ |
+
| 4176 | ++ | + + | +
| 4177 | ++ |
+ #' @rdname section_div+ |
+
| 4178 | ++ |
+ #' @aliases header_section_div,PreDataTableLayouts-method+ |
+
| 4179 | ++ |
+ setMethod(+ |
+
| 4180 | ++ |
+ "header_section_div", "VTableTree",+ |
+
| 4181 | +299x | +
+ function(obj) obj@header_section_div+ |
+
| 4182 | ++ |
+ )+ |
+
| 4183 | ++ | + + | +
| 4184 | ++ |
+ #' @rdname section_div+ |
+
| 4185 | ++ |
+ #' @export+ |
+
| 4186 | +253x | +
+ setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))
+ |
+
| 4187 | ++ | + + | +
| 4188 | ++ |
+ #' @rdname section_div+ |
+
| 4189 | ++ |
+ #' @aliases header_section_div<-,PreDataTableLayouts-method+ |
+
| 4190 | ++ |
+ setMethod(+ |
+
| 4191 | ++ |
+ "header_section_div<-", "PreDataTableLayouts",+ |
+
| 4192 | ++ |
+ function(obj, value) {
+ |
+
| 4193 | +1x | +
+ .check_header_section_div(value)+ |
+
| 4194 | +1x | +
+ obj@header_section_div <- value+ |
+
| 4195 | +1x | +
+ obj+ |
+
| 4196 | ++ |
+ }+ |
+
| 4197 | ++ |
+ )+ |
+
| 4198 | ++ | + + | +
| 4199 | ++ |
+ #' @rdname section_div+ |
+
| 4200 | ++ |
+ #' @aliases header_section_div<-,PreDataTableLayouts-method+ |
+
| 4201 | ++ |
+ setMethod(+ |
+
| 4202 | ++ |
+ "header_section_div<-", "VTableTree",+ |
+
| 4203 | ++ |
+ function(obj, value) {
+ |
+
| 4204 | +252x | +
+ .check_header_section_div(value)+ |
+
| 4205 | +252x | +
+ obj@header_section_div <- value+ |
+
| 4206 | +252x | +
+ obj+ |
+
| 4207 | ++ |
+ }+ |
+
| 4208 | ++ |
+ )+ |
+
| 4209 | ++ | + + | +
| 4210 | ++ |
+ .check_header_section_div <- function(chr) {
+ |
+
| 4211 | +572x | +
+ if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
+ |
+
| 4212 | +! | +
+ stop("header_section_div must be a single character or NA_character_ if not used")
+ |
+
| 4213 | ++ |
+ }+ |
+
| 4214 | +572x | +
+ invisible(TRUE)+ |
+
| 4215 | ++ |
+ }+ |
+
| 4216 | ++ | + + | +
| 4217 | ++ |
+ #' @rdname section_div+ |
+
| 4218 | ++ |
+ #' @export+ |
+
| 4219 | +300x | +
+ setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))
+ |
+
| 4220 | ++ | + + | +
| 4221 | ++ |
+ #' @rdname section_div+ |
+
| 4222 | ++ |
+ #' @aliases top_level_section_div,PreDataTableLayouts-method+ |
+
| 4223 | ++ |
+ setMethod(+ |
+
| 4224 | ++ |
+ "top_level_section_div", "PreDataTableLayouts",+ |
+
| 4225 | +300x | +
+ function(obj) obj@top_level_section_div+ |
+
| 4226 | ++ |
+ )+ |
+
| 4227 | ++ | + + | +
| 4228 | ++ |
+ #' @rdname section_div+ |
+
| 4229 | ++ |
+ #' @export+ |
+
| 4230 | +1x | +
+ setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))
+ |
+
| 4231 | ++ | + + | +
| 4232 | ++ |
+ #' @rdname section_div+ |
+
| 4233 | ++ |
+ #' @aliases top_level_section_div<-,PreDataTableLayouts-method+ |
+
| 4234 | ++ |
+ setMethod(+ |
+
| 4235 | ++ |
+ "top_level_section_div<-", "PreDataTableLayouts",+ |
+
| 4236 | ++ |
+ 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+ |
+
| 4240 | ++ |
+ }+ |
+
| 4241 | ++ |
+ )+ |
+
| 4242 | ++ | + + | +
| 4243 | ++ |
+ ## table_inset ----------------------------------------------------------+ |
+
| 4244 | ++ | + + | +
| 4245 | ++ |
+ #' @rdname formatters_methods+ |
+
| 4246 | ++ |
+ #' @export+ |
+
| 4247 | ++ |
+ setMethod(+ |
+
| 4248 | ++ |
+ "table_inset", "VTableNodeInfo", ## VTableTree",+ |
+
| 4249 | +304x | +
+ function(obj) obj@table_inset+ |
+
| 4250 | ++ |
+ )+ |
+
| 4251 | ++ | + + | +
| 4252 | ++ |
+ #' @rdname formatters_methods+ |
+
| 4253 | ++ |
+ #' @export+ |
+
| 4254 | ++ |
+ setMethod(+ |
+
| 4255 | ++ |
+ "table_inset", "PreDataTableLayouts",+ |
+
| 4256 | +295x | +
+ function(obj) obj@table_inset+ |
+
| 4257 | ++ |
+ )+ |
+
| 4258 | ++ | + + | +
| 4259 | ++ |
+ ## #' @rdname formatters_methods+ |
+
| 4260 | ++ |
+ ## #' @export+ |
+
| 4261 | ++ |
+ ## setMethod("table_inset", "InstantiatedColumnInfo",
+ |
+
| 4262 | ++ |
+ ## function(obj) obj@table_inset)+ |
+
| 4263 | ++ | + + | +
| 4264 | ++ |
+ #' @rdname formatters_methods+ |
+
| 4265 | ++ |
+ #' @export+ |
+
| 4266 | ++ |
+ setMethod(+ |
+
| 4267 | ++ |
+ "table_inset<-", "VTableNodeInfo", ## "VTableTree",+ |
+
| 4268 | ++ |
+ function(obj, value) {
+ |
+
| 4269 | +15720x | +
+ if (!is.integer(value)) {
+ |
+
| 4270 | +5x | +
+ value <- as.integer(value)+ |
+
| 4271 | ++ |
+ }+ |
+
| 4272 | +15720x | +
+ if (is.na(value) || value < 0) {
+ |
+
| 4273 | +! | +
+ stop("Got invalid table_inset value, must be an integer > 0")
+ |
+
| 4274 | ++ |
+ }+ |
+
| 4275 | +15720x | +
+ cont <- content_table(obj)+ |
+
| 4276 | +15720x | +
+ if (NROW(cont) > 0) {
+ |
+
| 4277 | +1435x | +
+ table_inset(cont) <- value+ |
+
| 4278 | +1435x | +
+ content_table(obj) <- cont+ |
+
| 4279 | ++ |
+ }+ |
+
| 4280 | ++ | + + | +
| 4281 | +15720x | +
+ if (length(tree_children(obj)) > 0) {
+ |
+
| 4282 | +4732x | +
+ kids <- lapply(tree_children(obj),+ |
+
| 4283 | +4732x | +
+ `table_inset<-`,+ |
+
| 4284 | +4732x | +
+ value = value+ |
+
| 4285 | ++ |
+ )+ |
+
| 4286 | +4732x | +
+ tree_children(obj) <- kids+ |
+
| 4287 | ++ |
+ }+ |
+
| 4288 | +15720x | +
+ obj@table_inset <- value+ |
+
| 4289 | +15720x | +
+ obj+ |
+
| 4290 | ++ |
+ }+ |
+
| 4291 | ++ |
+ )+ |
+
| 4292 | ++ | + + | +
| 4293 | ++ |
+ #' @rdname formatters_methods+ |
+
| 4294 | ++ |
+ #' @export+ |
+
| 4295 | ++ |
+ setMethod(+ |
+
| 4296 | ++ |
+ "table_inset<-", "PreDataTableLayouts",+ |
+
| 4297 | ++ |
+ function(obj, value) {
+ |
+
| 4298 | +! | +
+ if (!is.integer(value)) {
+ |
+
| 4299 | +! | +
+ value <- as.integer(value)+ |
+
| 4300 | ++ |
+ }+ |
+
| 4301 | +! | +
+ if (is.na(value) || value < 0) {
+ |
+
| 4302 | +! | +
+ stop("Got invalid table_inset value, must be an integer > 0")
+ |
+
| 4303 | ++ |
+ }+ |
+
| 4304 | ++ | + + | +
| 4305 | +! | +
+ obj@table_inset <- value+ |
+
| 4306 | +! | +
+ obj+ |
+
| 4307 | ++ |
+ }+ |
+
| 4308 | ++ |
+ )+ |
+
| 4309 | ++ | + + | +
| 4310 | ++ |
+ #' @rdname formatters_methods+ |
+
| 4311 | ++ |
+ #' @export+ |
+
| 4312 | ++ |
+ setMethod(+ |
+
| 4313 | ++ |
+ "table_inset<-", "InstantiatedColumnInfo",+ |
+
| 4314 | ++ |
+ function(obj, value) {
+ |
+
| 4315 | +! | +
+ if (!is.integer(value)) {
+ |
+
| 4316 | +! | +
+ value <- as.integer(value)+ |
+
| 4317 | ++ |
+ }+ |
+
| 4318 | +! | +
+ if (is.na(value) || value < 0) {
+ |
+
| 4319 | +! | +
+ stop("Got invalid table_inset value, must be an integer > 0")
+ |
+
| 4320 | ++ |
+ }+ |
+
| 4321 | +! | +
+ obj@table_inset <- value+ |
+
| 4322 | +! | +
+ obj+ |
+
| 4323 | ++ |
+ }+ |
+
| 4324 | ++ |
+ )+ |
+
| 1 | ++ |
+ ## Split types -----------------------------------------------------------------+ |
+
| 2 | ++ |
+ ## variable: split on distinct values of a variable+ |
+
| 3 | ++ |
+ ## all: include all observations (root 'split')+ |
+
| 4 | ++ |
+ ## rawcut: cut on static values of a variable+ |
+
| 5 | ++ |
+ ## quantilecut: cut on quantiles of observed values for a variable+ |
+
| 6 | ++ |
+ ## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group??+ |
+
| 7 | ++ |
+ ## multicolumn: each child analyzes a different column+ |
+
| 8 | ++ |
+ ## arbitrary: children are not related to each other in any systematic fashion.+ |
+
| 9 | ++ | + + | +
| 10 | ++ |
+ ## null is ok here.+ |
+
| 11 | ++ |
+ check_ok_label <- function(lbl, multi_ok = FALSE) {
+ |
+
| 12 | +47843x | +
+ if (length(lbl) == 0) {
+ |
+
| 13 | +10879x | +
+ return(TRUE)+ |
+
| 14 | ++ |
+ }+ |
+
| 15 | ++ | + + | +
| 16 | +36964x | +
+ if (length(lbl) > 1) {
+ |
+
| 17 | +1754x | +
+ if (multi_ok) {
+ |
+
| 18 | +1754x | +
+ return(all(vapply(lbl, check_ok_label, TRUE)))+ |
+
| 19 | ++ |
+ }+ |
+
| 20 | +! | +
+ stop("got a label of length > 1")
+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | +35210x | +
+ if (grepl("([{}])", lbl)) {
+ |
+
| 24 | +1x | +
+ stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
+ |
+
| 25 | ++ |
+ }+ |
+
| 26 | +35209x | +
+ invisible(TRUE)+ |
+
| 27 | ++ |
+ }+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
+ |
+
| 30 | ++ |
+ .labelkids_helper <- function(charval) {
+ |
+
| 31 | +2387x | +
+ ret <- switch(charval,+ |
+
| 32 | +2387x | +
+ "default" = NA,+ |
+
| 33 | +2387x | +
+ "visible" = TRUE,+ |
+
| 34 | +2387x | +
+ "hidden" = FALSE,+ |
+
| 35 | +2387x | +
+ "topleft" = FALSE,+ |
+
| 36 | +2387x | +
+ stop(+ |
+
| 37 | +2387x | +
+ "unrecognized charval in .labelkids_helper. ",+ |
+
| 38 | +2387x | +
+ "this shouldn't ever happen"+ |
+
| 39 | ++ |
+ )+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | +2387x | +
+ ret+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ setOldClass("expression")
+ |
+
| 45 | ++ |
+ setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric"))
+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ setClassUnion("integerOrNULL", c("NULL", "integer"))
+ |
+
| 48 | ++ |
+ setClassUnion("characterOrNULL", c("NULL", "character"))
+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ ## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame?+ |
+
| 51 | ++ |
+ setClass("TreePos", representation(
+ |
+
| 52 | ++ |
+ splits = "list",+ |
+
| 53 | ++ |
+ s_values = "list",+ |
+
| 54 | ++ |
+ sval_labels = "character",+ |
+
| 55 | ++ |
+ subset = "SubsetDef"+ |
+
| 56 | ++ |
+ ),+ |
+
| 57 | ++ |
+ validity = function(object) {
+ |
+
| 58 | ++ |
+ nspl <- length(object@splits)+ |
+
| 59 | ++ |
+ length(object@s_values) == nspl && length(object@sval_labels) == nspl+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ setClassUnion("functionOrNULL", c("NULL", "function"))
+ |
+
| 64 | ++ |
+ setClassUnion("listOrNULL", c("NULL", "list"))
+ |
+
| 65 | ++ |
+ ## TODO (?) make "list" more specific, e.g FormatList, or FunctionList?+ |
+
| 66 | ++ |
+ setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
+ |
+
| 67 | ++ |
+ setClassUnion("ExprOrNULL", c("NULL", "expression"))
+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ setClass("ValueWrapper", representation(
+ |
+
| 70 | ++ |
+ value = "ANY",+ |
+
| 71 | ++ |
+ label = "characterOrNULL",+ |
+
| 72 | ++ |
+ subset_expression = "ExprOrNULL"+ |
+
| 73 | ++ |
+ ),+ |
+
| 74 | ++ |
+ contains = "VIRTUAL"+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | ++ |
+ ## heavier-weight than I'd like but I think we need+ |
+
| 77 | ++ |
+ ## this to carry around thee subsets for+ |
+
| 78 | ++ |
+ ## comparison-based splits+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ setClass("SplitValue",
+ |
+
| 81 | ++ |
+ contains = "ValueWrapper",+ |
+
| 82 | ++ |
+ representation(extra = "list")+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
+ |
+
| 86 | +4784x | +
+ if (is(val, "SplitValue")) {
+ |
+
| 87 | +2007x | +
+ if (length(splv_extra(val)) > 0) {
+ |
+
| 88 | +29x | +
+ extr <- c(splv_extra(val), extr)+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | +2007x | +
+ splv_extra(val) <- extr+ |
+
| 91 | +2007x | +
+ return(val)+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | +2777x | +
+ if (!is(extr, "list")) {
+ |
+
| 94 | +! | +
+ extr <- list(extr)+ |
+
| 95 | ++ |
+ }+ |
+
| 96 | +2777x | +
+ if (!is(label, "character")) {
+ |
+
| 97 | +! | +
+ label <- as.character(label)+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ | + + | +
| 100 | +2777x | +
+ if (!is.null(sub_expr) && !is.expression(sub_expr)) {
+ |
+
| 101 | +105x | +
+ sub_expr <- as.expression(sub_expr)+ |
+
| 102 | ++ |
+ } ## sometimes they will be "call" objects, etc+ |
+
| 103 | +2777x | +
+ check_ok_label(label)+ |
+
| 104 | +2777x | +
+ new("SplitValue",
+ |
+
| 105 | +2777x | +
+ value = val,+ |
+
| 106 | +2777x | +
+ extra = extr,+ |
+
| 107 | +2777x | +
+ label = label,+ |
+
| 108 | +2777x | +
+ subset_expression = sub_expr+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ setClass("LevelComboSplitValue",
+ |
+
| 113 | ++ |
+ contains = "SplitValue",+ |
+
| 114 | ++ |
+ representation(combolevels = "character")+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ ## wrapped in user-facing `add_combo_facet`+ |
+
| 118 | ++ |
+ LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
+ |
+
| 119 | +28x | +
+ 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+ |
+
| 126 | ++ |
+ )+ |
+
| 127 | ++ |
+ }+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ setClass("Split",
+ |
+
| 130 | ++ |
+ contains = "VIRTUAL",+ |
+
| 131 | ++ |
+ representation(+ |
+
| 132 | ++ |
+ payload = "ANY",+ |
+
| 133 | ++ |
+ name = "character",+ |
+
| 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+ |
+
| 139 | ++ |
+ ## get the content rows for the CHILDREN of this+ |
+
| 140 | ++ |
+ ## split!!!+ |
+
| 141 | ++ |
+ content_fun = "listOrNULL", ## functionOrNULL",+ |
+
| 142 | ++ |
+ content_format = "FormatSpec",+ |
+
| 143 | ++ |
+ content_na_str = "character",+ |
+
| 144 | ++ |
+ content_var = "character",+ |
+
| 145 | ++ |
+ label_children = "logical",+ |
+
| 146 | ++ |
+ extra_args = "list",+ |
+
| 147 | ++ |
+ indent_modifier = "integer",+ |
+
| 148 | ++ |
+ content_indent_modifier = "integer",+ |
+
| 149 | ++ |
+ content_extra_args = "list",+ |
+
| 150 | ++ |
+ page_title_prefix = "character",+ |
+
| 151 | ++ |
+ child_section_div = "character",+ |
+
| 152 | ++ |
+ child_show_colcounts = "logical",+ |
+
| 153 | ++ |
+ child_colcount_format = "FormatSpec"+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | ++ | + + | +
| 157 | ++ |
+ setClass("CustomizableSplit",
+ |
+
| 158 | ++ |
+ contains = "Split",+ |
+
| 159 | ++ |
+ representation(split_fun = "functionOrNULL")+ |
+
| 160 | ++ |
+ )+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ #' @author Gabriel Becker+ |
+
| 163 | ++ |
+ #' @exportClass VarLevelSplit+ |
+
| 164 | ++ |
+ #' @rdname VarLevelSplit+ |
+
| 165 | ++ |
+ setClass("VarLevelSplit",
+ |
+
| 166 | ++ |
+ contains = "CustomizableSplit",+ |
+
| 167 | ++ |
+ representation(+ |
+
| 168 | ++ |
+ value_label_var = "character",+ |
+
| 169 | ++ |
+ value_order = "ANY"+ |
+
| 170 | ++ |
+ )+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | ++ |
+ #' Split on levels within a variable+ |
+
| 173 | ++ |
+ #'+ |
+
| 174 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 175 | ++ |
+ #' @inheritParams constr_args+ |
+
| 176 | ++ |
+ #'+ |
+
| 177 | ++ |
+ #' @return a `VarLevelSplit` object.+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @export+ |
+
| 180 | ++ |
+ VarLevelSplit <- function(var,+ |
+
| 181 | ++ |
+ split_label,+ |
+
| 182 | ++ |
+ labels_var = NULL,+ |
+
| 183 | ++ |
+ cfun = NULL,+ |
+
| 184 | ++ |
+ cformat = NULL,+ |
+
| 185 | ++ |
+ cna_str = NA_character_,+ |
+
| 186 | ++ |
+ split_fun = NULL,+ |
+
| 187 | ++ |
+ split_format = NULL,+ |
+
| 188 | ++ |
+ split_na_str = NA_character_,+ |
+
| 189 | ++ |
+ valorder = NULL,+ |
+
| 190 | ++ |
+ split_name = var,+ |
+
| 191 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 192 | ++ |
+ extra_args = list(),+ |
+
| 193 | ++ |
+ indent_mod = 0L,+ |
+
| 194 | ++ |
+ label_pos = c("topleft", "hidden", "visible"),
+ |
+
| 195 | ++ |
+ cindent_mod = 0L,+ |
+
| 196 | ++ |
+ cvar = "",+ |
+
| 197 | ++ |
+ cextra_args = list(),+ |
+
| 198 | ++ |
+ page_prefix = NA_character_,+ |
+
| 199 | ++ |
+ section_div = NA_character_,+ |
+
| 200 | ++ |
+ show_colcounts = FALSE,+ |
+
| 201 | ++ |
+ colcount_format = NULL) {
+ |
+
| 202 | +518x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 203 | +518x | +
+ if (is.null(labels_var)) {
+ |
+
| 204 | +1x | +
+ labels_var <- var+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | +518x | +
+ check_ok_label(split_label)+ |
+
| 207 | +518x | +
+ new("VarLevelSplit",
+ |
+
| 208 | +518x | +
+ payload = var,+ |
+
| 209 | +518x | +
+ split_label = split_label,+ |
+
| 210 | +518x | +
+ name = split_name,+ |
+
| 211 | +518x | +
+ value_label_var = labels_var,+ |
+
| 212 | +518x | +
+ content_fun = cfun,+ |
+
| 213 | +518x | +
+ content_format = cformat,+ |
+
| 214 | +518x | +
+ content_na_str = cna_str,+ |
+
| 215 | +518x | +
+ split_fun = split_fun,+ |
+
| 216 | +518x | +
+ split_format = split_format,+ |
+
| 217 | +518x | +
+ split_na_str = split_na_str,+ |
+
| 218 | +518x | +
+ value_order = NULL,+ |
+
| 219 | +518x | +
+ label_children = .labelkids_helper(child_labels),+ |
+
| 220 | +518x | +
+ extra_args = extra_args,+ |
+
| 221 | +518x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 222 | +518x | +
+ content_indent_modifier = as.integer(cindent_mod),+ |
+
| 223 | +518x | +
+ content_var = cvar,+ |
+
| 224 | +518x | +
+ split_label_position = label_pos,+ |
+
| 225 | +518x | +
+ content_extra_args = cextra_args,+ |
+
| 226 | +518x | +
+ page_title_prefix = page_prefix,+ |
+
| 227 | +518x | +
+ child_section_div = section_div,+ |
+
| 228 | +518x | +
+ child_show_colcounts = show_colcounts,+ |
+
| 229 | +518x | +
+ child_colcount_format = colcount_format+ |
+
| 230 | ++ |
+ )+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | ++ | + + | +
| 233 | ++ |
+ setClass("AllSplit", contains = "Split")
+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ AllSplit <- function(split_label = "",+ |
+
| 236 | ++ |
+ cfun = NULL,+ |
+
| 237 | ++ |
+ cformat = NULL,+ |
+
| 238 | ++ |
+ cna_str = NA_character_,+ |
+
| 239 | ++ |
+ split_format = NULL,+ |
+
| 240 | ++ |
+ split_na_str = NA_character_,+ |
+
| 241 | ++ |
+ split_name = NULL,+ |
+
| 242 | ++ |
+ extra_args = list(),+ |
+
| 243 | ++ |
+ indent_mod = 0L,+ |
+
| 244 | ++ |
+ cindent_mod = 0L,+ |
+
| 245 | ++ |
+ cvar = "",+ |
+
| 246 | ++ |
+ cextra_args = list(),+ |
+
| 247 | ++ |
+ show_colcounts = FALSE,+ |
+
| 248 | ++ |
+ colcount_format = NULL,+ |
+
| 249 | ++ |
+ ...) {
+ |
+
| 250 | +213x | +
+ if (is.null(split_name)) {
+ |
+
| 251 | +112x | +
+ if (nzchar(split_label)) {
+ |
+
| 252 | +7x | +
+ split_name <- split_label+ |
+
| 253 | ++ |
+ } else {
+ |
+
| 254 | +105x | +
+ split_name <- "all obs"+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ |
+ }+ |
+
| 257 | +213x | +
+ check_ok_label(split_label)+ |
+
| 258 | +213x | +
+ new("AllSplit",
+ |
+
| 259 | +213x | +
+ split_label = split_label,+ |
+
| 260 | +213x | +
+ content_fun = cfun,+ |
+
| 261 | +213x | +
+ content_format = cformat,+ |
+
| 262 | +213x | +
+ content_na_str = cna_str,+ |
+
| 263 | +213x | +
+ split_format = split_format,+ |
+
| 264 | +213x | +
+ split_na_str = split_na_str,+ |
+
| 265 | +213x | +
+ name = split_name,+ |
+
| 266 | +213x | +
+ label_children = FALSE,+ |
+
| 267 | +213x | +
+ extra_args = extra_args,+ |
+
| 268 | +213x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 269 | +213x | +
+ content_indent_modifier = as.integer(cindent_mod),+ |
+
| 270 | +213x | +
+ content_var = cvar,+ |
+
| 271 | +213x | +
+ split_label_position = "hidden",+ |
+
| 272 | +213x | +
+ content_extra_args = cextra_args,+ |
+
| 273 | +213x | +
+ page_title_prefix = NA_character_,+ |
+
| 274 | +213x | +
+ child_section_div = NA_character_,+ |
+
| 275 | +213x | +
+ child_show_colcounts = show_colcounts,+ |
+
| 276 | +213x | +
+ child_colcount_format = colcount_format+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | ++ | + + | +
| 280 | ++ |
+ setClass("RootSplit", contains = "AllSplit")
+ |
+
| 281 | ++ | + + | +
| 282 | ++ |
+ RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "",+ |
+
| 283 | ++ |
+ split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
+ |
+
| 284 | +652x | +
+ check_ok_label(split_label)+ |
+
| 285 | +652x | +
+ new("RootSplit",
+ |
+
| 286 | +652x | +
+ split_label = split_label,+ |
+
| 287 | +652x | +
+ content_fun = cfun,+ |
+
| 288 | +652x | +
+ content_format = cformat,+ |
+
| 289 | +652x | +
+ content_na_str = cna_str,+ |
+
| 290 | +652x | +
+ split_format = split_format,+ |
+
| 291 | +652x | +
+ split_na_str = split_na_str,+ |
+
| 292 | +652x | +
+ name = "root",+ |
+
| 293 | +652x | +
+ label_children = FALSE,+ |
+
| 294 | +652x | +
+ indent_modifier = 0L,+ |
+
| 295 | +652x | +
+ content_indent_modifier = 0L,+ |
+
| 296 | +652x | +
+ content_var = cvar,+ |
+
| 297 | +652x | +
+ split_label_position = "hidden",+ |
+
| 298 | +652x | +
+ content_extra_args = cextra_args,+ |
+
| 299 | +652x | +
+ child_section_div = NA_character_,+ |
+
| 300 | +652x | +
+ child_show_colcounts = FALSE,+ |
+
| 301 | +652x | +
+ child_colcount_format = "(N=xx)"+ |
+
| 302 | ++ |
+ )+ |
+
| 303 | ++ |
+ }+ |
+
| 304 | ++ | + + | +
| 305 | ++ |
+ setClass("ManualSplit",
+ |
+
| 306 | ++ |
+ contains = "AllSplit",+ |
+
| 307 | ++ |
+ representation(levels = "character")+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ #' Manually defined split+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 313 | ++ |
+ #' @inheritParams constr_args+ |
+
| 314 | ++ |
+ #' @inheritParams gen_args+ |
+
| 315 | ++ |
+ #' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split).+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' @return A `ManualSplit` object.+ |
+
| 318 | ++ |
+ #'+ |
+
| 319 | ++ |
+ #' @author Gabriel Becker+ |
+
| 320 | ++ |
+ #' @export+ |
+
| 321 | ++ |
+ ManualSplit <- function(levels, label, name = "manual",+ |
+
| 322 | ++ |
+ extra_args = list(),+ |
+
| 323 | ++ |
+ indent_mod = 0L,+ |
+
| 324 | ++ |
+ cindent_mod = 0L,+ |
+
| 325 | ++ |
+ cvar = "",+ |
+
| 326 | ++ |
+ cextra_args = list(),+ |
+
| 327 | ++ |
+ label_pos = "visible",+ |
+
| 328 | ++ |
+ page_prefix = NA_character_,+ |
+
| 329 | ++ |
+ section_div = NA_character_) {
+ |
+
| 330 | +47x | +
+ label_pos <- match.arg(label_pos, label_pos_values)+ |
+
| 331 | +47x | +
+ check_ok_label(label, multi_ok = TRUE)+ |
+
| 332 | +47x | +
+ new("ManualSplit",
+ |
+
| 333 | +47x | +
+ split_label = label,+ |
+
| 334 | +47x | +
+ levels = levels,+ |
+
| 335 | +47x | +
+ name = name,+ |
+
| 336 | +47x | +
+ label_children = FALSE,+ |
+
| 337 | +47x | +
+ extra_args = extra_args,+ |
+
| 338 | +47x | +
+ indent_modifier = 0L,+ |
+
| 339 | +47x | +
+ content_indent_modifier = as.integer(cindent_mod),+ |
+
| 340 | +47x | +
+ content_var = cvar,+ |
+
| 341 | +47x | +
+ split_format = NULL,+ |
+
| 342 | +47x | +
+ split_na_str = NA_character_,+ |
+
| 343 | +47x | +
+ split_label_position = label_pos,+ |
+
| 344 | +47x | +
+ page_title_prefix = page_prefix,+ |
+
| 345 | +47x | +
+ child_section_div = section_div,+ |
+
| 346 | +47x | +
+ child_show_colcounts = FALSE,+ |
+
| 347 | +47x | +
+ child_colcount_format = "(N=xx)"+ |
+
| 348 | ++ |
+ )+ |
+
| 349 | ++ |
+ }+ |
+
| 350 | ++ | + + | +
| 351 | ++ |
+ ## splits across which variables are being analynzed+ |
+
| 352 | ++ |
+ setClass("MultiVarSplit",
+ |
+
| 353 | ++ |
+ contains = "CustomizableSplit", ## "Split",+ |
+
| 354 | ++ |
+ representation(+ |
+
| 355 | ++ |
+ var_labels = "character",+ |
+
| 356 | ++ |
+ var_names = "character"+ |
+
| 357 | ++ |
+ ),+ |
+
| 358 | ++ |
+ validity = function(object) {
+ |
+
| 359 | ++ |
+ length(object@payload) >= 1 &&+ |
+
| 360 | ++ |
+ all(!is.na(object@payload)) &&+ |
+
| 361 | ++ |
+ (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels))+ |
+
| 362 | ++ |
+ }+ |
+
| 363 | ++ |
+ )+ |
+
| 364 | ++ | + + | +
| 365 | ++ |
+ .make_suffix_vec <- function(n) {
+ |
+
| 366 | +3x | +
+ c(+ |
+
| 367 | ++ |
+ "",+ |
+
| 368 | +3x | +
+ sprintf(+ |
+
| 369 | +3x | +
+ "._[[%d]]_.",+ |
+
| 370 | +3x | +
+ seq_len(n - 1) + 1L+ |
+
| 371 | ++ |
+ )+ |
+
| 372 | ++ |
+ )+ |
+
| 373 | ++ |
+ }+ |
+
| 374 | ++ | + + | +
| 375 | ++ |
+ .make_multivar_names <- function(vars) {
+ |
+
| 376 | +29x | +
+ dups <- duplicated(vars)+ |
+
| 377 | +29x | +
+ if (!any(dups)) {
+ |
+
| 378 | +26x | +
+ return(vars)+ |
+
| 379 | ++ |
+ }+ |
+
| 380 | +3x | +
+ dupvars <- unique(vars[dups])+ |
+
| 381 | +3x | +
+ ret <- vars+ |
+
| 382 | +3x | +
+ for (v in dupvars) {
+ |
+
| 383 | +3x | +
+ pos <- which(ret == v)+ |
+
| 384 | +3x | +
+ ret[pos] <- paste0(+ |
+
| 385 | +3x | +
+ ret[pos],+ |
+
| 386 | +3x | +
+ .make_suffix_vec(length(pos))+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | ++ |
+ }+ |
+
| 389 | +3x | +
+ ret+ |
+
| 390 | ++ |
+ }+ |
+
| 391 | ++ | + + | +
| 392 | ++ |
+ #' Split between two or more different variables+ |
+
| 393 | ++ |
+ #'+ |
+
| 394 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 395 | ++ |
+ #' @inheritParams constr_args+ |
+
| 396 | ++ |
+ #'+ |
+
| 397 | ++ |
+ #' @return A `MultiVarSplit` object.+ |
+
| 398 | ++ |
+ #'+ |
+
| 399 | ++ |
+ #' @author Gabriel Becker+ |
+
| 400 | ++ |
+ #' @export+ |
+
| 401 | ++ |
+ MultiVarSplit <- function(vars,+ |
+
| 402 | ++ |
+ split_label = "",+ |
+
| 403 | ++ |
+ varlabels = NULL,+ |
+
| 404 | ++ |
+ varnames = NULL,+ |
+
| 405 | ++ |
+ cfun = NULL,+ |
+
| 406 | ++ |
+ cformat = NULL,+ |
+
| 407 | ++ |
+ cna_str = NA_character_,+ |
+
| 408 | ++ |
+ split_format = NULL,+ |
+
| 409 | ++ |
+ split_na_str = NA_character_,+ |
+
| 410 | ++ |
+ split_name = "multivars",+ |
+
| 411 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 412 | ++ |
+ extra_args = list(),+ |
+
| 413 | ++ |
+ indent_mod = 0L,+ |
+
| 414 | ++ |
+ cindent_mod = 0L,+ |
+
| 415 | ++ |
+ cvar = "",+ |
+
| 416 | ++ |
+ cextra_args = list(),+ |
+
| 417 | ++ |
+ label_pos = "visible",+ |
+
| 418 | ++ |
+ split_fun = NULL,+ |
+
| 419 | ++ |
+ page_prefix = NA_character_,+ |
+
| 420 | ++ |
+ section_div = NA_character_,+ |
+
| 421 | ++ |
+ show_colcounts = FALSE,+ |
+
| 422 | ++ |
+ colcount_format = NULL) {
+ |
+
| 423 | +29x | +
+ check_ok_label(split_label)+ |
+
| 424 | ++ |
+ ## no topleft allowed+ |
+
| 425 | +29x | +
+ label_pos <- match.arg(label_pos, label_pos_values[-3])+ |
+
| 426 | +29x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 427 | +29x | +
+ if (length(vars) == 1 && grepl(":", vars)) {
+ |
+
| 428 | +! | +
+ vars <- strsplit(vars, ":")[[1]]+ |
+
| 429 | ++ |
+ }+ |
+
| 430 | +29x | +
+ if (length(varlabels) == 0) { ## covers NULL and character()
+ |
+
| 431 | +1x | +
+ varlabels <- vars+ |
+
| 432 | ++ |
+ }+ |
+
| 433 | +29x | +
+ vnames <- varnames %||% .make_multivar_names(vars)+ |
+
| 434 | +29x | +
+ stopifnot(length(vnames) == length(vars))+ |
+
| 435 | +29x | +
+ new("MultiVarSplit",
+ |
+
| 436 | +29x | +
+ payload = vars,+ |
+
| 437 | +29x | +
+ split_label = split_label,+ |
+
| 438 | +29x | +
+ var_labels = varlabels,+ |
+
| 439 | +29x | +
+ var_names = vnames,+ |
+
| 440 | +29x | +
+ content_fun = cfun,+ |
+
| 441 | +29x | +
+ content_format = cformat,+ |
+
| 442 | +29x | +
+ content_na_str = cna_str,+ |
+
| 443 | +29x | +
+ split_format = split_format,+ |
+
| 444 | +29x | +
+ split_na_str = split_na_str,+ |
+
| 445 | +29x | +
+ label_children = .labelkids_helper(child_labels),+ |
+
| 446 | +29x | +
+ name = split_name,+ |
+
| 447 | +29x | +
+ extra_args = extra_args,+ |
+
| 448 | +29x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 449 | +29x | +
+ content_indent_modifier = as.integer(cindent_mod),+ |
+
| 450 | +29x | +
+ content_var = cvar,+ |
+
| 451 | +29x | +
+ split_label_position = label_pos,+ |
+
| 452 | +29x | +
+ content_extra_args = cextra_args,+ |
+
| 453 | +29x | +
+ split_fun = split_fun,+ |
+
| 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+ |
+
| 458 | ++ |
+ )+ |
+
| 459 | ++ |
+ }+ |
+
| 460 | ++ | + + | +
| 461 | ++ |
+ #' Splits for cutting by values of a numeric variable+ |
+
| 462 | ++ |
+ #'+ |
+
| 463 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 464 | ++ |
+ #' @inheritParams constr_args+ |
+
| 465 | ++ |
+ #'+ |
+
| 466 | ++ |
+ #' @exportClass VarStaticCutSplit+ |
+
| 467 | ++ |
+ #' @rdname cutsplits+ |
+
| 468 | ++ |
+ setClass("VarStaticCutSplit",
+ |
+
| 469 | ++ |
+ contains = "Split",+ |
+
| 470 | ++ |
+ representation(+ |
+
| 471 | ++ |
+ cuts = "numeric",+ |
+
| 472 | ++ |
+ cut_labels = "character"+ |
+
| 473 | ++ |
+ )+ |
+
| 474 | ++ |
+ )+ |
+
| 475 | ++ | + + | +
| 476 | ++ |
+ .is_cut_lab_lst <- function(cuts) {
+ |
+
| 477 | +12x | +
+ is.list(cuts) && is.numeric(cuts[[1]]) &&+ |
+
| 478 | +12x | +
+ is.character(cuts[[2]]) &&+ |
+
| 479 | +12x | +
+ length(cuts[[1]]) == length(cuts[[2]])+ |
+
| 480 | ++ |
+ }+ |
+
| 481 | ++ | + + | +
| 482 | ++ |
+ #' Create static cut or static cumulative cut split+ |
+
| 483 | ++ |
+ #'+ |
+
| 484 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 485 | ++ |
+ #' @inheritParams constr_args+ |
+
| 486 | ++ |
+ #'+ |
+
| 487 | ++ |
+ #' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit`+ |
+
| 488 | ++ |
+ #' object for [VarDynCutSplit()].+ |
+
| 489 | ++ |
+ #'+ |
+
| 490 | ++ |
+ #' @rdname cutsplits+ |
+
| 491 | ++ |
+ make_static_cut_split <- function(var,+ |
+
| 492 | ++ |
+ split_label,+ |
+
| 493 | ++ |
+ cuts,+ |
+
| 494 | ++ |
+ cutlabels = NULL,+ |
+
| 495 | ++ |
+ cfun = NULL,+ |
+
| 496 | ++ |
+ cformat = NULL,+ |
+
| 497 | ++ |
+ cna_str = NA_character_,+ |
+
| 498 | ++ |
+ split_format = NULL,+ |
+
| 499 | ++ |
+ split_na_str = NA_character_,+ |
+
| 500 | ++ |
+ split_name = var,+ |
+
| 501 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 502 | ++ |
+ extra_args = list(),+ |
+
| 503 | ++ |
+ indent_mod = 0L,+ |
+
| 504 | ++ |
+ cindent_mod = 0L,+ |
+
| 505 | ++ |
+ cvar = "",+ |
+
| 506 | ++ |
+ cextra_args = list(),+ |
+
| 507 | ++ |
+ label_pos = "visible",+ |
+
| 508 | ++ |
+ cumulative = FALSE,+ |
+
| 509 | ++ |
+ page_prefix = NA_character_,+ |
+
| 510 | ++ |
+ section_div = NA_character_,+ |
+
| 511 | ++ |
+ show_colcounts = FALSE,+ |
+
| 512 | ++ |
+ colcount_format = NULL) {
+ |
+
| 513 | +12x | +
+ cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit"+ |
+
| 514 | +12x | +
+ check_ok_label(split_label)+ |
+
| 515 | ++ | + + | +
| 516 | +12x | +
+ label_pos <- match.arg(label_pos, label_pos_values)+ |
+
| 517 | +12x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 518 | +12x | +
+ if (.is_cut_lab_lst(cuts)) {
+ |
+
| 519 | +! | +
+ cutlabels <- cuts[[2]]+ |
+
| 520 | +! | +
+ cuts <- cuts[[1]]+ |
+
| 521 | ++ |
+ }+ |
+
| 522 | +12x | +
+ if (is.unsorted(cuts, strictly = TRUE)) {
+ |
+
| 523 | +! | +
+ stop("invalid cuts vector. not sorted unique values.")
+ |
+
| 524 | ++ |
+ }+ |
+
| 525 | ++ | + + | +
| 526 | +12x | +
+ if (is.null(cutlabels) && !is.null(names(cuts))) {
+ |
+
| 527 | +1x | +
+ cutlabels <- names(cuts)[-1]+ |
+
| 528 | ++ |
+ } ## XXX is this always right?+ |
+
| 529 | ++ | + + | +
| 530 | +12x | +
+ new(cls,+ |
+
| 531 | +12x | +
+ payload = var,+ |
+
| 532 | +12x | +
+ split_label = split_label,+ |
+
| 533 | +12x | +
+ cuts = cuts,+ |
+
| 534 | +12x | +
+ cut_labels = cutlabels,+ |
+
| 535 | +12x | +
+ content_fun = cfun,+ |
+
| 536 | +12x | +
+ content_format = cformat,+ |
+
| 537 | +12x | +
+ content_na_str = cna_str,+ |
+
| 538 | +12x | +
+ split_format = split_format,+ |
+
| 539 | +12x | +
+ split_na_str = split_na_str,+ |
+
| 540 | +12x | +
+ name = split_name,+ |
+
| 541 | +12x | +
+ label_children = .labelkids_helper(child_labels),+ |
+
| 542 | +12x | +
+ extra_args = extra_args,+ |
+
| 543 | +12x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 544 | +12x | +
+ content_indent_modifier = as.integer(cindent_mod),+ |
+
| 545 | +12x | +
+ content_var = cvar,+ |
+
| 546 | +12x | +
+ split_label_position = label_pos,+ |
+
| 547 | +12x | +
+ content_extra_args = cextra_args,+ |
+
| 548 | +12x | +
+ page_title_prefix = page_prefix,+ |
+
| 549 | +12x | +
+ child_section_div = section_div,+ |
+
| 550 | +12x | +
+ child_show_colcounts = show_colcounts,+ |
+
| 551 | +12x | +
+ child_colcount_format = colcount_format+ |
+
| 552 | ++ |
+ )+ |
+
| 553 | ++ |
+ }+ |
+
| 554 | ++ | + + | +
| 555 | ++ |
+ #' @exportClass CumulativeCutSplit+ |
+
| 556 | ++ |
+ #' @rdname cutsplits+ |
+
| 557 | ++ |
+ setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")
+ |
+
| 558 | ++ | + + | +
| 559 | ++ |
+ ## make_static_cut_split with cumulative=TRUE is the constructor+ |
+
| 560 | ++ |
+ ## for CumulativeCutSplit+ |
+
| 561 | ++ | + + | +
| 562 | ++ |
+ ## do we want this to be a CustomizableSplit instead of+ |
+
| 563 | ++ |
+ ## taking cut_fun?+ |
+
| 564 | ++ |
+ ## cut_funct must take avector and no other arguments+ |
+
| 565 | ++ |
+ ## and return a named vector of cut points+ |
+
| 566 | ++ |
+ #' @exportClass VarDynCutSplit+ |
+
| 567 | ++ |
+ #' @rdname cutsplits+ |
+
| 568 | ++ |
+ setClass("VarDynCutSplit",
+ |
+
| 569 | ++ |
+ contains = "Split",+ |
+
| 570 | ++ |
+ representation(+ |
+
| 571 | ++ |
+ cut_fun = "function",+ |
+
| 572 | ++ |
+ cut_label_fun = "function",+ |
+
| 573 | ++ |
+ cumulative_cuts = "logical"+ |
+
| 574 | ++ |
+ )+ |
+
| 575 | ++ |
+ )+ |
+
| 576 | ++ | + + | +
| 577 | ++ |
+ #' @export+ |
+
| 578 | ++ |
+ #' @rdname cutsplits+ |
+
| 579 | ++ |
+ VarDynCutSplit <- function(var,+ |
+
| 580 | ++ |
+ split_label,+ |
+
| 581 | ++ |
+ cutfun,+ |
+
| 582 | ++ |
+ cutlabelfun = function(x) NULL,+ |
+
| 583 | ++ |
+ cfun = NULL,+ |
+
| 584 | ++ |
+ cformat = NULL,+ |
+
| 585 | ++ |
+ cna_str = NA_character_,+ |
+
| 586 | ++ |
+ split_format = NULL,+ |
+
| 587 | ++ |
+ split_na_str = NA_character_,+ |
+
| 588 | ++ |
+ split_name = var,+ |
+
| 589 | ++ |
+ child_labels = c("default", "visible", "hidden"),
+ |
+
| 590 | ++ |
+ extra_args = list(),+ |
+
| 591 | ++ |
+ cumulative = FALSE,+ |
+
| 592 | ++ |
+ indent_mod = 0L,+ |
+
| 593 | ++ |
+ cindent_mod = 0L,+ |
+
| 594 | ++ |
+ cvar = "",+ |
+
| 595 | ++ |
+ cextra_args = list(),+ |
+
| 596 | ++ |
+ label_pos = "visible",+ |
+
| 597 | ++ |
+ page_prefix = NA_character_,+ |
+
| 598 | ++ |
+ section_div = NA_character_,+ |
+
| 599 | ++ |
+ show_colcounts = FALSE,+ |
+
| 600 | ++ |
+ colcount_format = NULL) {
+ |
+
| 601 | +6x | +
+ check_ok_label(split_label)+ |
+
| 602 | +6x | +
+ label_pos <- match.arg(label_pos, label_pos_values)+ |
+
| 603 | +6x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 604 | +6x | +
+ new("VarDynCutSplit",
+ |
+
| 605 | +6x | +
+ payload = var,+ |
+
| 606 | +6x | +
+ split_label = split_label,+ |
+
| 607 | +6x | +
+ cut_fun = cutfun,+ |
+
| 608 | +6x | +
+ cumulative_cuts = cumulative,+ |
+
| 609 | +6x | +
+ cut_label_fun = cutlabelfun,+ |
+
| 610 | +6x | +
+ content_fun = cfun,+ |
+
| 611 | +6x | +
+ content_format = cformat,+ |
+
| 612 | +6x | +
+ content_na_str = cna_str,+ |
+
| 613 | +6x | +
+ split_format = split_format,+ |
+
| 614 | +6x | +
+ split_na_str = split_na_str,+ |
+
| 615 | +6x | +
+ name = split_name,+ |
+
| 616 | +6x | +
+ label_children = .labelkids_helper(child_labels),+ |
+
| 617 | +6x | +
+ extra_args = extra_args,+ |
+
| 618 | +6x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 619 | +6x | +
+ content_indent_modifier = as.integer(cindent_mod),+ |
+
| 620 | +6x | +
+ content_var = cvar,+ |
+
| 621 | +6x | +
+ split_label_position = label_pos,+ |
+
| 622 | +6x | +
+ content_extra_args = cextra_args,+ |
+
| 623 | +6x | +
+ page_title_prefix = page_prefix,+ |
+
| 624 | +6x | +
+ child_section_div = section_div,+ |
+
| 625 | +6x | +
+ child_show_colcounts = show_colcounts,+ |
+
| 626 | +6x | +
+ child_colcount_format = colcount_format+ |
+
| 627 | ++ |
+ )+ |
+
| 628 | ++ |
+ }+ |
+
| 629 | ++ | + + | +
| 630 | ++ |
+ ## NB analyze splits can't have content-related things+ |
+
| 631 | ++ |
+ setClass("VAnalyzeSplit",
+ |
+
| 632 | ++ |
+ contains = "Split",+ |
+
| 633 | ++ |
+ representation(+ |
+
| 634 | ++ |
+ default_rowlabel = "character",+ |
+
| 635 | ++ |
+ include_NAs = "logical",+ |
+
| 636 | ++ |
+ var_label_position = "character"+ |
+
| 637 | ++ |
+ )+ |
+
| 638 | ++ |
+ )+ |
+
| 639 | ++ | + + | +
| 640 | ++ |
+ setClass("AnalyzeVarSplit",
+ |
+
| 641 | ++ |
+ contains = "VAnalyzeSplit",+ |
+
| 642 | ++ |
+ representation(analysis_fun = "function")+ |
+
| 643 | ++ |
+ )+ |
+
| 644 | ++ | + + | +
| 645 | ++ |
+ setClass("AnalyzeColVarSplit",
+ |
+
| 646 | ++ |
+ contains = "VAnalyzeSplit",+ |
+
| 647 | ++ |
+ representation(analysis_fun = "list")+ |
+
| 648 | ++ |
+ )+ |
+
| 649 | ++ | + + | +
| 650 | ++ |
+ #' Define a subset tabulation/analysis+ |
+
| 651 | ++ |
+ #'+ |
+
| 652 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 653 | ++ |
+ #' @inheritParams constr_args+ |
+
| 654 | ++ |
+ #' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`.+ |
+
| 655 | ++ |
+ #'+ |
+
| 656 | ++ |
+ #' @return An `AnalyzeVarSplit` object.+ |
+
| 657 | ++ |
+ #'+ |
+
| 658 | ++ |
+ #' @author Gabriel Becker+ |
+
| 659 | ++ |
+ #' @export+ |
+
| 660 | ++ |
+ #' @rdname avarspl+ |
+
| 661 | ++ |
+ AnalyzeVarSplit <- function(var,+ |
+
| 662 | ++ |
+ split_label = var,+ |
+
| 663 | ++ |
+ afun,+ |
+
| 664 | ++ |
+ defrowlab = "",+ |
+
| 665 | ++ |
+ cfun = NULL,+ |
+
| 666 | ++ |
+ cformat = NULL,+ |
+
| 667 | ++ |
+ split_format = NULL,+ |
+
| 668 | ++ |
+ split_na_str = NA_character_,+ |
+
| 669 | ++ |
+ inclNAs = FALSE,+ |
+
| 670 | ++ |
+ split_name = var,+ |
+
| 671 | ++ |
+ extra_args = list(),+ |
+
| 672 | ++ |
+ indent_mod = 0L,+ |
+
| 673 | ++ |
+ label_pos = "default",+ |
+
| 674 | ++ |
+ cvar = "",+ |
+
| 675 | ++ |
+ section_div = NA_character_) {
+ |
+
| 676 | +332x | +
+ check_ok_label(split_label)+ |
+
| 677 | +332x | +
+ label_pos <- match.arg(label_pos, c("default", label_pos_values))
+ |
+
| 678 | +332x | +
+ if (!any(nzchar(defrowlab))) {
+ |
+
| 679 | +1x | +
+ defrowlab <- as.character(substitute(afun))+ |
+
| 680 | +1x | +
+ if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
+ |
+
| 681 | +! | +
+ defrowlab <- ""+ |
+
| 682 | ++ |
+ }+ |
+
| 683 | ++ |
+ }+ |
+
| 684 | +332x | +
+ new("AnalyzeVarSplit",
+ |
+
| 685 | +332x | +
+ payload = var,+ |
+
| 686 | +332x | +
+ split_label = split_label,+ |
+
| 687 | +332x | +
+ content_fun = cfun,+ |
+
| 688 | +332x | +
+ analysis_fun = afun,+ |
+
| 689 | +332x | +
+ content_format = cformat,+ |
+
| 690 | +332x | +
+ split_format = split_format,+ |
+
| 691 | +332x | +
+ split_na_str = split_na_str,+ |
+
| 692 | +332x | +
+ default_rowlabel = defrowlab,+ |
+
| 693 | +332x | +
+ include_NAs = inclNAs,+ |
+
| 694 | +332x | +
+ name = split_name,+ |
+
| 695 | +332x | +
+ label_children = FALSE,+ |
+
| 696 | +332x | +
+ extra_args = extra_args,+ |
+
| 697 | +332x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 698 | +332x | +
+ content_indent_modifier = 0L,+ |
+
| 699 | +332x | +
+ var_label_position = label_pos,+ |
+
| 700 | +332x | +
+ content_var = cvar,+ |
+
| 701 | +332x | +
+ page_title_prefix = NA_character_,+ |
+
| 702 | +332x | +
+ child_section_div = section_div,+ |
+
| 703 | +332x | +
+ child_show_colcounts = FALSE,+ |
+
| 704 | +332x | +
+ child_colcount_format = NA_character_+ |
+
| 705 | +332x | +
+ ) ## no content_extra_args+ |
+
| 706 | ++ |
+ }+ |
+
| 707 | ++ | + + | +
| 708 | ++ |
+ #' Define a subset tabulation/analysis+ |
+
| 709 | ++ |
+ #'+ |
+
| 710 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 711 | ++ |
+ #' @inheritParams constr_args+ |
+
| 712 | ++ |
+ #'+ |
+
| 713 | ++ |
+ #' @author Gabriel Becker+ |
+
| 714 | ++ |
+ #' @export+ |
+
| 715 | ++ |
+ #' @rdname avarspl+ |
+
| 716 | ++ |
+ AnalyzeColVarSplit <- function(afun,+ |
+
| 717 | ++ |
+ defrowlab = "",+ |
+
| 718 | ++ |
+ cfun = NULL,+ |
+
| 719 | ++ |
+ cformat = NULL,+ |
+
| 720 | ++ |
+ split_format = NULL,+ |
+
| 721 | ++ |
+ split_na_str = NA_character_,+ |
+
| 722 | ++ |
+ inclNAs = FALSE,+ |
+
| 723 | ++ |
+ split_name = "",+ |
+
| 724 | ++ |
+ extra_args = list(),+ |
+
| 725 | ++ |
+ indent_mod = 0L,+ |
+
| 726 | ++ |
+ label_pos = "default",+ |
+
| 727 | ++ |
+ cvar = "",+ |
+
| 728 | ++ |
+ section_div = NA_character_) {
+ |
+
| 729 | +23x | +
+ label_pos <- match.arg(label_pos, c("default", label_pos_values))
+ |
+
| 730 | +23x | +
+ new("AnalyzeColVarSplit",
+ |
+
| 731 | +23x | +
+ payload = NA_character_,+ |
+
| 732 | +23x | +
+ split_label = "",+ |
+
| 733 | +23x | +
+ content_fun = cfun,+ |
+
| 734 | +23x | +
+ analysis_fun = afun,+ |
+
| 735 | +23x | +
+ content_format = cformat,+ |
+
| 736 | +23x | +
+ split_format = split_format,+ |
+
| 737 | +23x | +
+ split_na_str = split_na_str,+ |
+
| 738 | +23x | +
+ default_rowlabel = defrowlab,+ |
+
| 739 | +23x | +
+ include_NAs = inclNAs,+ |
+
| 740 | +23x | +
+ name = split_name,+ |
+
| 741 | +23x | +
+ label_children = FALSE,+ |
+
| 742 | +23x | +
+ extra_args = extra_args,+ |
+
| 743 | +23x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 744 | +23x | +
+ content_indent_modifier = 0L,+ |
+
| 745 | +23x | +
+ var_label_position = label_pos,+ |
+
| 746 | +23x | +
+ content_var = cvar,+ |
+
| 747 | +23x | +
+ page_title_prefix = NA_character_,+ |
+
| 748 | +23x | +
+ child_section_div = section_div,+ |
+
| 749 | +23x | +
+ child_show_colcounts = FALSE,+ |
+
| 750 | +23x | +
+ child_colcount_format = NA_character_+ |
+
| 751 | +23x | +
+ ) ## no content_extra_args+ |
+
| 752 | ++ |
+ }+ |
+
| 753 | ++ | + + | +
| 754 | ++ |
+ setClass("CompoundSplit",
+ |
+
| 755 | ++ |
+ contains = "Split",+ |
+
| 756 | ++ |
+ validity = function(object) are(object@payload, "Split")+ |
+
| 757 | ++ |
+ )+ |
+
| 758 | ++ | + + | +
| 759 | ++ |
+ setClass("AnalyzeMultiVars", contains = "CompoundSplit")
+ |
+
| 760 | ++ | + + | +
| 761 | ++ |
+ .repoutlst <- function(x, nv) {
+ |
+
| 762 | +1824x | +
+ if (!is.function(x) && length(x) == nv) {
+ |
+
| 763 | +876x | +
+ return(x)+ |
+
| 764 | ++ |
+ }+ |
+
| 765 | +948x | +
+ if (!is(x, "list")) {
+ |
+
| 766 | +948x | +
+ x <- list(x)+ |
+
| 767 | ++ |
+ }+ |
+
| 768 | +948x | +
+ rep(x, length.out = nv)+ |
+
| 769 | ++ |
+ }+ |
+
| 770 | ++ | + + | +
| 771 | ++ |
+ .uncompound <- function(csplit) {
+ |
+
| 772 | +61x | +
+ if (is(csplit, "list")) {
+ |
+
| 773 | +3x | +
+ return(unlist(lapply(csplit, .uncompound)))+ |
+
| 774 | ++ |
+ }+ |
+
| 775 | ++ | + + | +
| 776 | +58x | +
+ if (!is(csplit, "CompoundSplit")) {
+ |
+
| 777 | +57x | +
+ return(csplit)+ |
+
| 778 | ++ |
+ }+ |
+
| 779 | ++ | + + | +
| 780 | +1x | +
+ pld <- spl_payload(csplit)+ |
+
| 781 | +1x | +
+ done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit"))+ |
+
| 782 | +1x | +
+ if (done) {
+ |
+
| 783 | +1x | +
+ pld+ |
+
| 784 | ++ |
+ } else {
+ |
+
| 785 | +! | +
+ unlist(lapply(pld, .uncompound))+ |
+
| 786 | ++ |
+ }+ |
+
| 787 | ++ |
+ }+ |
+
| 788 | ++ | + + | +
| 789 | ++ |
+ strip_compound_name <- function(obj) {
+ |
+
| 790 | +11x | +
+ nm <- obj_name(obj)+ |
+
| 791 | +11x | +
+ gsub("^ma_", "", nm)
+ |
+
| 792 | ++ |
+ }+ |
+
| 793 | ++ | + + | +
| 794 | ++ |
+ make_ma_name <- function(spl, pld = spl_payload(spl)) {
+ |
+
| 795 | +3x | +
+ paste(+ |
+
| 796 | +3x | +
+ c(+ |
+
| 797 | +3x | +
+ "ma",+ |
+
| 798 | +3x | +
+ vapply(pld, strip_compound_name, "")+ |
+
| 799 | ++ |
+ ),+ |
+
| 800 | +3x | +
+ collapse = "_"+ |
+
| 801 | ++ |
+ )+ |
+
| 802 | ++ |
+ }+ |
+
| 803 | ++ | + + | +
| 804 | ++ |
+ #' @param .payload (`list`)\cr used internally, not intended to be set by end users.+ |
+
| 805 | ++ |
+ #'+ |
+
| 806 | ++ |
+ #' @return An `AnalyzeMultiVars` split object.+ |
+
| 807 | ++ |
+ #'+ |
+
| 808 | ++ |
+ #' @export+ |
+
| 809 | ++ |
+ #' @rdname avarspl+ |
+
| 810 | ++ |
+ AnalyzeMultiVars <- function(var,+ |
+
| 811 | ++ |
+ split_label = "",+ |
+
| 812 | ++ |
+ afun,+ |
+
| 813 | ++ |
+ defrowlab = "",+ |
+
| 814 | ++ |
+ cfun = NULL,+ |
+
| 815 | ++ |
+ cformat = NULL,+ |
+
| 816 | ++ |
+ split_format = NULL,+ |
+
| 817 | ++ |
+ split_na_str = NA_character_,+ |
+
| 818 | ++ |
+ inclNAs = FALSE,+ |
+
| 819 | ++ |
+ .payload = NULL,+ |
+
| 820 | ++ |
+ split_name = NULL,+ |
+
| 821 | ++ |
+ extra_args = list(),+ |
+
| 822 | ++ |
+ indent_mod = 0L,+ |
+
| 823 | ++ |
+ child_labels = c("default", "topleft", "visible", "hidden"),
+ |
+
| 824 | ++ |
+ child_names = var,+ |
+
| 825 | ++ |
+ cvar = "",+ |
+
| 826 | ++ |
+ section_div = NA_character_) {
+ |
+
| 827 | ++ |
+ ## NB we used to resolve to strict TRUE/FALSE for label visibillity+ |
+
| 828 | ++ |
+ ## in this function but that was too greedy for repeated+ |
+
| 829 | ++ |
+ ## analyze calls, so that now occurs in the tabulation machinery+ |
+
| 830 | ++ |
+ ## when the table is actually being built.+ |
+
| 831 | ++ |
+ ## show_kidlabs = .labelkids_helper(match.arg(child_labels))+ |
+
| 832 | +328x | +
+ child_labels <- match.arg(child_labels)+ |
+
| 833 | +328x | +
+ show_kidlabs <- child_labels+ |
+
| 834 | +328x | +
+ if (is.null(.payload)) {
+ |
+
| 835 | +304x | +
+ nv <- length(var)+ |
+
| 836 | +304x | +
+ defrowlab <- .repoutlst(defrowlab, nv)+ |
+
| 837 | +304x | +
+ afun <- .repoutlst(afun, nv)+ |
+
| 838 | +304x | +
+ split_label <- .repoutlst(split_label, nv)+ |
+
| 839 | +304x | +
+ check_ok_label(split_label, multi_ok = TRUE)+ |
+
| 840 | +304x | +
+ cfun <- .repoutlst(cfun, nv)+ |
+
| 841 | +304x | +
+ cformat <- .repoutlst(cformat, nv)+ |
+
| 842 | ++ |
+ ## split_format = .repoutlst(split_format, nv)+ |
+
| 843 | +304x | +
+ inclNAs <- .repoutlst(inclNAs, nv)+ |
+
| 844 | +304x | +
+ section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div+ |
+
| 845 | +304x | +
+ pld <- mapply(AnalyzeVarSplit,+ |
+
| 846 | +304x | +
+ var = var,+ |
+
| 847 | +304x | +
+ split_name = child_names,+ |
+
| 848 | +304x | +
+ split_label = split_label,+ |
+
| 849 | +304x | +
+ afun = afun,+ |
+
| 850 | +304x | +
+ defrowlab = defrowlab,+ |
+
| 851 | +304x | +
+ cfun = cfun,+ |
+
| 852 | +304x | +
+ cformat = cformat,+ |
+
| 853 | ++ |
+ ## split_format = split_format,+ |
+
| 854 | +304x | +
+ inclNAs = inclNAs,+ |
+
| 855 | +304x | +
+ MoreArgs = list(+ |
+
| 856 | +304x | +
+ extra_args = extra_args,+ |
+
| 857 | +304x | +
+ indent_mod = indent_mod,+ |
+
| 858 | +304x | +
+ label_pos = show_kidlabs,+ |
+
| 859 | +304x | +
+ split_format = split_format,+ |
+
| 860 | +304x | +
+ split_na_str = split_na_str,+ |
+
| 861 | +304x | +
+ section_div = section_div_if_multivar+ |
+
| 862 | +304x | +
+ ), ## rvis),+ |
+
| 863 | +304x | +
+ SIMPLIFY = FALSE+ |
+
| 864 | ++ |
+ )+ |
+
| 865 | ++ |
+ } else {
+ |
+
| 866 | ++ |
+ ## we're combining existing splits here+ |
+
| 867 | +24x | +
+ pld <- unlist(lapply(.payload, .uncompound))+ |
+
| 868 | ++ | + + | +
| 869 | ++ |
+ ## only override the childen being combined if the constructor+ |
+
| 870 | ++ |
+ ## was passed a non-default value for child_labels+ |
+
| 871 | ++ |
+ ## and the child was at NA before+ |
+
| 872 | +24x | +
+ pld <- lapply(+ |
+
| 873 | +24x | +
+ pld,+ |
+
| 874 | +24x | +
+ function(x) {
+ |
+
| 875 | +48x | +
+ rvis <- label_position(x) ## labelrow_visible(x)+ |
+
| 876 | +48x | +
+ if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
+ |
+
| 877 | +! | +
+ if (identical(rvis, "default")) { ## ois.na(rvis))
+ |
+
| 878 | +! | +
+ rvis <- show_kidlabs+ |
+
| 879 | ++ |
+ }+ |
+
| 880 | ++ |
+ }+ |
+
| 881 | +48x | +
+ label_position(x) <- rvis+ |
+
| 882 | +48x | +
+ x+ |
+
| 883 | ++ |
+ }+ |
+
| 884 | ++ |
+ )+ |
+
| 885 | ++ |
+ }+ |
+
| 886 | +328x | +
+ if (length(pld) == 1) {
+ |
+
| 887 | +281x | +
+ ret <- pld[[1]]+ |
+
| 888 | ++ |
+ } else {
+ |
+
| 889 | +47x | +
+ if (is.null(split_name)) {
+ |
+
| 890 | +47x | +
+ split_name <- paste(c("ma", vapply(pld, obj_name, "")),
+ |
+
| 891 | +47x | +
+ collapse = "_"+ |
+
| 892 | ++ |
+ )+ |
+
| 893 | ++ |
+ }+ |
+
| 894 | +47x | +
+ ret <- new("AnalyzeMultiVars",
+ |
+
| 895 | +47x | +
+ payload = pld,+ |
+
| 896 | +47x | +
+ split_label = "",+ |
+
| 897 | +47x | +
+ split_format = NULL,+ |
+
| 898 | +47x | +
+ split_na_str = split_na_str,+ |
+
| 899 | +47x | +
+ content_fun = NULL,+ |
+
| 900 | +47x | +
+ content_format = NULL,+ |
+
| 901 | ++ |
+ ## I beleive this is superfluous now+ |
+
| 902 | ++ |
+ ## the payloads carry aroudn the real instructions+ |
+
| 903 | ++ |
+ ## XXX+ |
+
| 904 | +47x | +
+ label_children = .labelkids_helper(show_kidlabs),+ |
+
| 905 | +47x | +
+ split_label_position = "hidden", ## XXX is this right?+ |
+
| 906 | +47x | +
+ name = split_name,+ |
+
| 907 | +47x | +
+ extra_args = extra_args,+ |
+
| 908 | ++ |
+ ## modifier applied on splits in payload+ |
+
| 909 | +47x | +
+ indent_modifier = 0L,+ |
+
| 910 | +47x | +
+ content_indent_modifier = 0L,+ |
+
| 911 | +47x | +
+ content_var = cvar,+ |
+
| 912 | +47x | +
+ page_title_prefix = NA_character_,+ |
+
| 913 | +47x | +
+ child_section_div = section_div+ |
+
| 914 | ++ |
+ )+ |
+
| 915 | ++ |
+ }+ |
+
| 916 | +328x | +
+ ret+ |
+
| 917 | ++ |
+ }+ |
+
| 918 | ++ | + + | +
| 919 | ++ |
+ setClass("VarLevWBaselineSplit",
+ |
+
| 920 | ++ |
+ contains = "VarLevelSplit",+ |
+
| 921 | ++ |
+ representation(+ |
+
| 922 | ++ |
+ var = "character",+ |
+
| 923 | ++ |
+ ref_group_value = "character"+ |
+
| 924 | ++ |
+ )+ |
+
| 925 | ++ |
+ )+ |
+
| 926 | ++ | + + | +
| 927 | ++ |
+ #' @rdname VarLevelSplit+ |
+
| 928 | ++ |
+ #' @export+ |
+
| 929 | ++ |
+ VarLevWBaselineSplit <- function(var,+ |
+
| 930 | ++ |
+ ref_group,+ |
+
| 931 | ++ |
+ labels_var = var,+ |
+
| 932 | ++ |
+ split_label,+ |
+
| 933 | ++ |
+ split_fun = NULL,+ |
+
| 934 | ++ |
+ label_fstr = "%s - %s",+ |
+
| 935 | ++ |
+ ## not needed I Think...+ |
+
| 936 | ++ |
+ cfun = NULL,+ |
+
| 937 | ++ |
+ cformat = NULL,+ |
+
| 938 | ++ |
+ cna_str = NA_character_,+ |
+
| 939 | ++ |
+ cvar = "",+ |
+
| 940 | ++ |
+ split_format = NULL,+ |
+
| 941 | ++ |
+ split_na_str = NA_character_,+ |
+
| 942 | ++ |
+ valorder = NULL,+ |
+
| 943 | ++ |
+ split_name = var,+ |
+
| 944 | ++ |
+ extra_args = list(),+ |
+
| 945 | ++ |
+ show_colcounts = FALSE,+ |
+
| 946 | ++ |
+ colcount_format = NULL) {
+ |
+
| 947 | +10x | +
+ check_ok_label(split_label)+ |
+
| 948 | +10x | +
+ new("VarLevWBaselineSplit",
+ |
+
| 949 | +10x | +
+ payload = var,+ |
+
| 950 | +10x | +
+ ref_group_value = ref_group,+ |
+
| 951 | ++ |
+ ## This will occur at the row level not on the column split, for now+ |
+
| 952 | ++ |
+ ## TODO revisit this to confirm its right+ |
+
| 953 | ++ |
+ ## comparison_func = comparison,+ |
+
| 954 | ++ |
+ # label_format = label_fstr,+ |
+
| 955 | +10x | +
+ value_label_var = labels_var,+ |
+
| 956 | +10x | +
+ split_label = split_label,+ |
+
| 957 | +10x | +
+ content_fun = cfun,+ |
+
| 958 | +10x | +
+ content_format = cformat,+ |
+
| 959 | +10x | +
+ content_na_str = cna_str,+ |
+
| 960 | +10x | +
+ split_format = split_format,+ |
+
| 961 | +10x | +
+ split_na_str = split_na_str,+ |
+
| 962 | +10x | +
+ split_fun = split_fun,+ |
+
| 963 | +10x | +
+ name = split_name,+ |
+
| 964 | +10x | +
+ label_children = FALSE,+ |
+
| 965 | +10x | +
+ extra_args = extra_args,+ |
+
| 966 | ++ |
+ ## this is always a column split+ |
+
| 967 | +10x | +
+ indent_modifier = 0L,+ |
+
| 968 | +10x | +
+ content_indent_modifier = 0L,+ |
+
| 969 | +10x | +
+ content_var = cvar,+ |
+
| 970 | ++ |
+ ## so long as this is columnspace only+ |
+
| 971 | +10x | +
+ page_title_prefix = NA_character_,+ |
+
| 972 | +10x | +
+ child_section_div = NA_character_,+ |
+
| 973 | +10x | +
+ child_show_colcounts = show_colcounts,+ |
+
| 974 | +10x | +
+ child_colcount_format = colcount_format+ |
+
| 975 | ++ |
+ )+ |
+
| 976 | ++ |
+ }+ |
+
| 977 | ++ | + + | +
| 978 | ++ |
+ .chkname <- function(nm) {
+ |
+
| 979 | +18841x | +
+ if (is.null(nm)) {
+ |
+
| 980 | +! | +
+ nm <- ""+ |
+
| 981 | ++ |
+ }+ |
+
| 982 | +18841x | +
+ if (length(nm) != 1) {
+ |
+
| 983 | +! | +
+ stop("name is not of length one")
+ |
+
| 984 | +18841x | +
+ } else if (is.na(nm)) {
+ |
+
| 985 | +! | +
+ warning("Got missing value for name, converting to characters '<NA>'")
+ |
+
| 986 | +! | +
+ nm <- "<NA>"+ |
+
| 987 | ++ |
+ }+ |
+
| 988 | +18841x | +
+ nm+ |
+
| 989 | ++ |
+ }+ |
+
| 990 | ++ | + + | +
| 991 | ++ |
+ ### Tree Position Representation+ |
+
| 992 | ++ |
+ ###+ |
+
| 993 | ++ |
+ ### Class(es) that represent position with in a+ |
+
| 994 | ++ |
+ ### tree as parallel vectors of Split objects and+ |
+
| 995 | ++ |
+ ### values chosen at that split, plus labeling info+ |
+
| 996 | ++ |
+ TreePos <- function(spls = list(),+ |
+
| 997 | ++ |
+ svals = list(),+ |
+
| 998 | ++ |
+ svlabels = character(),+ |
+
| 999 | ++ |
+ sub = NULL) {
+ |
+
| 1000 | +1743x | +
+ check_ok_label(svlabels, multi_ok = TRUE)+ |
+
| 1001 | +1743x | +
+ svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr))+ |
+
| 1002 | +1743x | +
+ if (is.null(sub)) {
+ |
+
| 1003 | +376x | +
+ if (length(spls) > 0) {
+ |
+
| 1004 | +! | +
+ sub <- make_pos_subset(+ |
+
| 1005 | +! | +
+ spls = spls,+ |
+
| 1006 | +! | +
+ svals = svals+ |
+
| 1007 | ++ |
+ )+ |
+
| 1008 | ++ |
+ } else {
+ |
+
| 1009 | +376x | +
+ sub <- expression(TRUE)+ |
+
| 1010 | ++ |
+ }+ |
+
| 1011 | ++ |
+ }+ |
+
| 1012 | +1743x | +
+ new("TreePos",
+ |
+
| 1013 | +1743x | +
+ splits = spls, s_values = svals,+ |
+
| 1014 | +1743x | +
+ sval_labels = svlabels,+ |
+
| 1015 | +1743x | +
+ subset = sub+ |
+
| 1016 | ++ |
+ )+ |
+
| 1017 | ++ |
+ }+ |
+
| 1018 | ++ | + + | +
| 1019 | ++ |
+ ## Tree position convenience functions+ |
+
| 1020 | ++ |
+ ##+ |
+
| 1021 | ++ |
+ make_child_pos <- function(parpos,+ |
+
| 1022 | ++ |
+ newspl,+ |
+
| 1023 | ++ |
+ newval,+ |
+
| 1024 | ++ |
+ newlab = newval,+ |
+
| 1025 | ++ |
+ newextra = list()) {
+ |
+
| 1026 | +1367x | +
+ if (!is(newval, "SplitValue")) {
+ |
+
| 1027 | +! | +
+ nsplitval <- SplitValue(newval, extr = newextra, label = newlab)+ |
+
| 1028 | ++ |
+ } else {
+ |
+
| 1029 | +1367x | +
+ nsplitval <- newval+ |
+
| 1030 | ++ |
+ }+ |
+
| 1031 | +1367x | +
+ check_ok_label(newlab)+ |
+
| 1032 | +1367x | +
+ newpos <- TreePos(+ |
+
| 1033 | +1367x | +
+ spls = c(pos_splits(parpos), newspl),+ |
+
| 1034 | +1367x | +
+ svals = c(pos_splvals(parpos), nsplitval),+ |
+
| 1035 | +1367x | +
+ svlabels = c(pos_splval_labels(parpos), newlab),+ |
+
| 1036 | +1367x | +
+ sub = .combine_subset_exprs(+ |
+
| 1037 | +1367x | +
+ pos_subset(parpos),+ |
+
| 1038 | ++ |
+ ## this will grab the value's custom subset expression if present+ |
+
| 1039 | +1367x | +
+ make_subset_expr(newspl, nsplitval)+ |
+
| 1040 | ++ |
+ )+ |
+
| 1041 | ++ |
+ )+ |
+
| 1042 | +1367x | +
+ newpos+ |
+
| 1043 | ++ |
+ }+ |
+
| 1044 | ++ | + + | +
| 1045 | ++ |
+ ## Virtual Classes for Tree Nodes and Layouts =================================+ |
+
| 1046 | ++ |
+ ##+ |
+
| 1047 | ++ |
+ ## Virtual class hiearchy for the various types of trees in use in the S4+ |
+
| 1048 | ++ |
+ ## implementation of the TableTree machinery+ |
+
| 1049 | ++ | + + | +
| 1050 | ++ |
+ ## core basics+ |
+
| 1051 | ++ |
+ setClass("VNodeInfo",
+ |
+
| 1052 | ++ |
+ contains = "VIRTUAL",+ |
+
| 1053 | ++ |
+ representation(+ |
+
| 1054 | ++ |
+ level = "integer",+ |
+
| 1055 | ++ |
+ name = "character" ## ,+ |
+
| 1056 | ++ |
+ ## label = "character"+ |
+
| 1057 | ++ |
+ )+ |
+
| 1058 | ++ |
+ )+ |
+
| 1059 | ++ | + + | +
| 1060 | ++ |
+ setClass("VTree",
+ |
+
| 1061 | ++ |
+ contains = c("VIRTUAL", "VNodeInfo"),
+ |
+
| 1062 | ++ |
+ representation(children = "list")+ |
+
| 1063 | ++ |
+ )+ |
+
| 1064 | ++ | + + | +
| 1065 | ++ |
+ setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))
+ |
+
| 1066 | ++ | + + | +
| 1067 | ++ |
+ ## Layout trees =================================+ |
+
| 1068 | ++ | + + | +
| 1069 | ++ |
+ # setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))
+ |
+
| 1070 | ++ | + + | +
| 1071 | ++ |
+ setClass("VLayoutLeaf",
+ |
+
| 1072 | ++ |
+ contains = c("VIRTUAL", "VLeaf"),
+ |
+
| 1073 | ++ |
+ representation(+ |
+
| 1074 | ++ |
+ pos_in_tree = "TreePos",+ |
+
| 1075 | ++ |
+ label = "character"+ |
+
| 1076 | ++ |
+ )+ |
+
| 1077 | ++ |
+ )+ |
+
| 1078 | ++ | + + | +
| 1079 | ++ |
+ setClass("VLayoutTree",
+ |
+
| 1080 | ++ |
+ contains = c("VIRTUAL", "VTree"),
+ |
+
| 1081 | ++ |
+ representation(+ |
+
| 1082 | ++ |
+ split = "Split",+ |
+
| 1083 | ++ |
+ pos_in_tree = "TreePos",+ |
+
| 1084 | ++ |
+ label = "character"+ |
+
| 1085 | ++ |
+ )+ |
+
| 1086 | ++ |
+ )+ |
+
| 1087 | ++ | + + | +
| 1088 | ++ |
+ setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))
+ |
+
| 1089 | ++ | + + | +
| 1090 | ++ |
+ ## LayoutAxisTree classes =================================+ |
+
| 1091 | ++ | + + | +
| 1092 | ++ |
+ setOldClass("function")
+ |
+
| 1093 | ++ |
+ setOldClass("NULL")
+ |
+
| 1094 | ++ |
+ setClassUnion("FunctionOrNULL", c("function", "NULL"))
+ |
+
| 1095 | ++ | + + | +
| 1096 | ++ |
+ setClass("LayoutAxisTree",
+ |
+
| 1097 | ++ |
+ contains = "VLayoutTree",+ |
+
| 1098 | ++ |
+ representation(summary_func = "FunctionOrNULL"),+ |
+
| 1099 | ++ |
+ validity = function(object) {
+ |
+
| 1100 | ++ |
+ all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf")))+ |
+
| 1101 | ++ |
+ }+ |
+
| 1102 | ++ |
+ )+ |
+
| 1103 | ++ | + + | +
| 1104 | ++ |
+ ## this is only used for columns!!!!+ |
+
| 1105 | ++ |
+ setClass("LayoutAxisLeaf",
+ |
+
| 1106 | ++ |
+ contains = "VLayoutLeaf", ## "VNodeInfo",+ |
+
| 1107 | ++ |
+ representation(+ |
+
| 1108 | ++ |
+ func = "function",+ |
+
| 1109 | ++ |
+ display_columncounts = "logical",+ |
+
| 1110 | ++ |
+ columncount_format = "FormatSpec", # character",+ |
+
| 1111 | ++ |
+ col_footnotes = "list",+ |
+
| 1112 | ++ |
+ column_count = "integer"+ |
+
| 1113 | ++ |
+ )+ |
+
| 1114 | ++ |
+ )+ |
+
| 1115 | ++ | + + | +
| 1116 | ++ |
+ setClass("LayoutColTree",
+ |
+
| 1117 | ++ |
+ contains = "LayoutAxisTree",+ |
+
| 1118 | ++ |
+ representation(+ |
+
| 1119 | ++ |
+ display_columncounts = "logical",+ |
+
| 1120 | ++ |
+ columncount_format = "FormatSpec", # "character",+ |
+
| 1121 | ++ |
+ col_footnotes = "list",+ |
+
| 1122 | ++ |
+ column_count = "integer"+ |
+
| 1123 | ++ |
+ )+ |
+
| 1124 | ++ |
+ )+ |
+
| 1125 | ++ | + + | +
| 1126 | ++ |
+ setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
+ |
+
| 1127 | ++ |
+ LayoutColTree <- function(lev = 0L,+ |
+
| 1128 | ++ |
+ name = obj_name(spl),+ |
+
| 1129 | ++ |
+ label = obj_label(spl),+ |
+
| 1130 | ++ |
+ kids = list(),+ |
+
| 1131 | ++ |
+ spl = EmptyAllSplit,+ |
+
| 1132 | ++ |
+ tpos = TreePos(),+ |
+
| 1133 | ++ |
+ summary_function = NULL,+ |
+
| 1134 | ++ |
+ disp_ccounts = FALSE,+ |
+
| 1135 | ++ |
+ colcount_format = NULL,+ |
+
| 1136 | ++ |
+ footnotes = list(),+ |
+
| 1137 | ++ |
+ colcount) { ## ,
+ |
+
| 1138 | ++ |
+ ## sub = expression(TRUE),+ |
+
| 1139 | ++ |
+ ## svar = NA_character_,+ |
+
| 1140 | ++ |
+ ## slab = NA_character_) {
+ |
+
| 1141 | +610x | +
+ if (is.null(spl)) {
+ |
+
| 1142 | +! | +
+ stop(+ |
+
| 1143 | +! | +
+ "LayoutColTree constructor got NULL for spl. ", # nocov+ |
+
| 1144 | +! | +
+ "This should never happen. Please contact the maintainer."+ |
+
| 1145 | ++ |
+ )+ |
+
| 1146 | ++ |
+ } # nocov+ |
+
| 1147 | +610x | +
+ footnotes <- make_ref_value(footnotes)+ |
+
| 1148 | +610x | +
+ check_ok_label(label)+ |
+
| 1149 | +610x | +
+ new("LayoutColTree",
+ |
+
| 1150 | +610x | +
+ level = lev, children = kids,+ |
+
| 1151 | +610x | +
+ name = .chkname(name),+ |
+
| 1152 | +610x | +
+ summary_func = summary_function,+ |
+
| 1153 | +610x | +
+ pos_in_tree = tpos,+ |
+
| 1154 | +610x | +
+ split = spl,+ |
+
| 1155 | ++ |
+ ## subset = sub,+ |
+
| 1156 | ++ |
+ ## splitvar = svar,+ |
+
| 1157 | +610x | +
+ label = label,+ |
+
| 1158 | +610x | +
+ display_columncounts = disp_ccounts,+ |
+
| 1159 | +610x | +
+ columncount_format = colcount_format,+ |
+
| 1160 | +610x | +
+ col_footnotes = footnotes,+ |
+
| 1161 | +610x | +
+ column_count = colcount+ |
+
| 1162 | ++ |
+ )+ |
+
| 1163 | ++ |
+ }+ |
+
| 1164 | ++ | + + | +
| 1165 | ++ |
+ LayoutColLeaf <- function(lev = 0L,+ |
+
| 1166 | ++ |
+ name = label,+ |
+
| 1167 | ++ |
+ label = "",+ |
+
| 1168 | ++ |
+ tpos = TreePos(),+ |
+
| 1169 | ++ |
+ colcount,+ |
+
| 1170 | ++ |
+ disp_ccounts = FALSE,+ |
+
| 1171 | ++ |
+ colcount_format = NULL) {
+ |
+
| 1172 | +1135x | +
+ check_ok_label(label)+ |
+
| 1173 | +1135x | +
+ new("LayoutColLeaf",
+ |
+
| 1174 | +1135x | +
+ level = lev, name = .chkname(name), label = label,+ |
+
| 1175 | +1135x | +
+ pos_in_tree = tpos,+ |
+
| 1176 | +1135x | +
+ column_count = colcount,+ |
+
| 1177 | +1135x | +
+ display_columncounts = disp_ccounts,+ |
+
| 1178 | +1135x | +
+ columncount_format = colcount_format+ |
+
| 1179 | ++ |
+ )+ |
+
| 1180 | ++ |
+ }+ |
+
| 1181 | ++ | + + | +
| 1182 | ++ |
+ ## Instantiated column info class ==============================================+ |
+
| 1183 | ++ |
+ ##+ |
+
| 1184 | ++ |
+ ## This is so we don't need multiple arguments+ |
+
| 1185 | ++ |
+ ## in the recursive functions that track+ |
+
| 1186 | ++ |
+ ## various aspects of the column layout+ |
+
| 1187 | ++ |
+ ## once its applied to the data.+ |
+
| 1188 | ++ | + + | +
| 1189 | ++ |
+ #' Instantiated column info+ |
+
| 1190 | ++ |
+ #'+ |
+
| 1191 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1192 | ++ |
+ #'+ |
+
| 1193 | ++ |
+ #' @exportClass InstantiatedColumnInfo+ |
+
| 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 | ++ | + + | +
| 1210 | ++ |
+ #' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object.+ |
+
| 1211 | ++ |
+ #' @param csubs (`list`)\cr a list of subsetting expressions.+ |
+
| 1212 | ++ |
+ #' @param extras (`list`)\cr extra arguments associated with the columns.+ |
+
| 1213 | ++ |
+ #' @param cnts (`integer`)\cr counts.+ |
+
| 1214 | ++ |
+ #' @param total_cnt (`integer(1)`)\cr total observations represented across all columns.+ |
+
| 1215 | ++ |
+ #' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated+ |
+
| 1216 | ++ |
+ #' table is printed.+ |
+
| 1217 | ++ |
+ #' @param countformat (`string`)\cr format for the counts if they are displayed.+ |
+
| 1218 | ++ |
+ #' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults+ |
+
| 1219 | ++ |
+ #' to `""`.+ |
+
| 1220 | ++ |
+ #'+ |
+
| 1221 | ++ |
+ #' @return An `InstantiateadColumnInfo` object.+ |
+
| 1222 | ++ |
+ #'+ |
+
| 1223 | ++ |
+ #' @export+ |
+
| 1224 | ++ |
+ #' @rdname cinfo+ |
+
| 1225 | ++ |
+ InstantiatedColumnInfo <- function(treelyt = LayoutColTree(colcount = total_cnt),+ |
+
| 1226 | ++ |
+ csubs = list(expression(TRUE)),+ |
+
| 1227 | ++ |
+ extras = list(list()),+ |
+
| 1228 | ++ |
+ cnts = NA_integer_,+ |
+
| 1229 | ++ |
+ total_cnt = NA_integer_,+ |
+
| 1230 | ++ |
+ dispcounts = FALSE,+ |
+
| 1231 | ++ |
+ countformat = "(N=xx)",+ |
+
| 1232 | ++ |
+ count_na_str = "",+ |
+
| 1233 | ++ |
+ topleft = character()) {
+ |
+
| 1234 | +644x | +
+ leaves <- collect_leaves(treelyt)+ |
+
| 1235 | +644x | +
+ nl <- length(leaves)+ |
+
| 1236 | +644x | +
+ extras <- rep(extras, length.out = nl)+ |
+
| 1237 | +644x | +
+ cnts <- rep(cnts, length.out = nl)+ |
+
| 1238 | +644x | +
+ csubs <- rep(csubs, length.out = nl)+ |
+
| 1239 | ++ | + + | +
| 1240 | +644x | +
+ nleaves <- length(leaves)+ |
+
| 1241 | +644x | +
+ snas <- sum(is.na(cnts))+ |
+
| 1242 | +644x | +
+ if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
+ |
+
| 1243 | +! | +
+ stop(+ |
+
| 1244 | +! | +
+ "Mismatching number of columns indicated by: csubs [",+ |
+
| 1245 | +! | +
+ length(csubs), "], ",+ |
+
| 1246 | +! | +
+ "treelyt [", nl, "], extras [", length(extras),+ |
+
| 1247 | +! | +
+ "] and counts [", cnts, "]."+ |
+
| 1248 | ++ |
+ )+ |
+
| 1249 | ++ |
+ }+ |
+
| 1250 | +644x | +
+ if (snas != 0 && snas != nleaves) {
+ |
+
| 1251 | +2x | +
+ warning(+ |
+
| 1252 | +2x | +
+ "Mixture of missing and non-missing column counts when ",+ |
+
| 1253 | +2x | +
+ "creating column info."+ |
+
| 1254 | ++ |
+ )+ |
+
| 1255 | ++ |
+ }+ |
+
| 1256 | ++ | + + | +
| 1257 | +644x | +
+ if (!is.na(dispcounts)) {
+ |
+
| 1258 | +406x | +
+ pths <- col_paths(treelyt)+ |
+
| 1259 | +406x | +
+ for (path in pths) {
+ |
+
| 1260 | +905x | +
+ colcount_visible(treelyt, path) <- dispcounts+ |
+
| 1261 | ++ |
+ }+ |
+
| 1262 | ++ |
+ } else { ## na leaves the children as they are and dispcols goes to whether any of them are displayed for the leaves
+ |
+
| 1263 | +238x | +
+ dispcounts <- any(vapply(leaves, disp_ccounts, NA))+ |
+
| 1264 | ++ |
+ }+ |
+
| 1265 | ++ | + + | +
| 1266 | +644x | +
+ new("InstantiatedColumnInfo",
+ |
+
| 1267 | +644x | +
+ tree_layout = treelyt,+ |
+
| 1268 | +644x | +
+ subset_exprs = csubs,+ |
+
| 1269 | +644x | +
+ cextra_args = extras,+ |
+
| 1270 | +644x | +
+ counts = cnts,+ |
+
| 1271 | +644x | +
+ total_count = total_cnt,+ |
+
| 1272 | +644x | +
+ display_columncounts = dispcounts,+ |
+
| 1273 | +644x | +
+ columncount_format = countformat,+ |
+
| 1274 | +644x | +
+ columncount_na_str = count_na_str,+ |
+
| 1275 | +644x | +
+ top_left = topleft+ |
+
| 1276 | ++ |
+ )+ |
+
| 1277 | ++ |
+ }+ |
+
| 1278 | ++ | + + | +
| 1279 | ++ |
+ ## TableTrees and row classes ==================================================+ |
+
| 1280 | ++ |
+ ## XXX Rowspans as implemented dont really work+ |
+
| 1281 | ++ |
+ ## they're aren't attached to the right data structures+ |
+
| 1282 | ++ |
+ ## during conversions.+ |
+
| 1283 | ++ | + + | +
| 1284 | ++ |
+ ## FIXME: if we ever actually need row spanning+ |
+
| 1285 | ++ |
+ setClass("VTableNodeInfo",
+ |
+
| 1286 | ++ |
+ contains = c("VNodeInfo", "VIRTUAL"),
+ |
+
| 1287 | ++ |
+ representation(+ |
+
| 1288 | ++ |
+ ## col_layout = "VLayoutNode",+ |
+
| 1289 | ++ |
+ col_info = "InstantiatedColumnInfo",+ |
+
| 1290 | ++ |
+ format = "FormatSpec",+ |
+
| 1291 | ++ |
+ na_str = "character",+ |
+
| 1292 | ++ |
+ indent_modifier = "integer",+ |
+
| 1293 | ++ |
+ table_inset = "integer"+ |
+
| 1294 | ++ |
+ )+ |
+
| 1295 | ++ |
+ )+ |
+
| 1296 | ++ | + + | +
| 1297 | ++ |
+ setClass("TableRow",
+ |
+
| 1298 | ++ |
+ contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
+ |
+
| 1299 | ++ |
+ representation(+ |
+
| 1300 | ++ |
+ leaf_value = "ANY",+ |
+
| 1301 | ++ |
+ var_analyzed = "character",+ |
+
| 1302 | ++ |
+ ## var_label = "character",+ |
+
| 1303 | ++ |
+ label = "character",+ |
+
| 1304 | ++ |
+ row_footnotes = "list",+ |
+
| 1305 | ++ |
+ trailing_section_div = "character"+ |
+
| 1306 | ++ |
+ )+ |
+
| 1307 | ++ |
+ )+ |
+
| 1308 | ++ | + + | +
| 1309 | ++ |
+ ## TableTree Core Non-Virtual Classes ==============+ |
+
| 1310 | ++ |
+ ##+ |
+
| 1311 | ++ |
+ #' Row classes and constructors+ |
+
| 1312 | ++ |
+ #'+ |
+
| 1313 | ++ |
+ #' @inheritParams constr_args+ |
+
| 1314 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1315 | ++ |
+ #' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only).+ |
+
| 1316 | ++ |
+ #'+ |
+
| 1317 | ++ |
+ #' @return A formal object representing a table row of the constructed type.+ |
+
| 1318 | ++ |
+ #'+ |
+
| 1319 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1320 | ++ |
+ #' @export+ |
+
| 1321 | ++ |
+ #' @rdname rowclasses+ |
+
| 1322 | ++ |
+ LabelRow <- function(lev = 1L,+ |
+
| 1323 | ++ |
+ label = "",+ |
+
| 1324 | ++ |
+ name = label,+ |
+
| 1325 | ++ |
+ vis = !is.na(label) && nzchar(label),+ |
+
| 1326 | ++ |
+ cinfo = EmptyColInfo,+ |
+
| 1327 | ++ |
+ indent_mod = 0L,+ |
+
| 1328 | ++ |
+ table_inset = 0L,+ |
+
| 1329 | ++ |
+ trailing_section_div = NA_character_) {
+ |
+
| 1330 | +4711x | +
+ check_ok_label(label)+ |
+
| 1331 | +4711x | +
+ new("LabelRow",
+ |
+
| 1332 | +4711x | +
+ leaf_value = list(),+ |
+
| 1333 | +4711x | +
+ level = lev,+ |
+
| 1334 | +4711x | +
+ label = label,+ |
+
| 1335 | ++ |
+ ## XXX this means that a label row and its talbe can have the same name....+ |
+
| 1336 | ++ |
+ ## XXX that is bad but how bad remains to be seen+ |
+
| 1337 | ++ |
+ ## XXX+ |
+
| 1338 | +4711x | +
+ name = .chkname(name),+ |
+
| 1339 | +4711x | +
+ col_info = cinfo,+ |
+
| 1340 | +4711x | +
+ visible = vis,+ |
+
| 1341 | +4711x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 1342 | +4711x | +
+ table_inset = as.integer(table_inset),+ |
+
| 1343 | +4711x | +
+ trailing_section_div = trailing_section_div+ |
+
| 1344 | ++ |
+ )+ |
+
| 1345 | ++ |
+ }+ |
+
| 1346 | ++ | + + | +
| 1347 | ++ |
+ #' Row constructors and classes+ |
+
| 1348 | ++ |
+ #'+ |
+
| 1349 | ++ |
+ #' @rdname rowclasses+ |
+
| 1350 | ++ |
+ #' @exportClass DataRow+ |
+
| 1351 | ++ |
+ setClass("DataRow",
+ |
+
| 1352 | ++ |
+ contains = "TableRow",+ |
+
| 1353 | ++ |
+ representation(colspans = "integer") ## ,+ |
+
| 1354 | ++ |
+ ## pos_in_tree = "TableRowPos"),+ |
+
| 1355 | ++ |
+ ## validity = function(object) {
+ |
+
| 1356 | ++ |
+ ## lcsp = length(object@colspans)+ |
+
| 1357 | ++ |
+ ## length(lcsp == 0) || lcsp == length(object@leaf_value)+ |
+
| 1358 | ++ |
+ ## }+ |
+
| 1359 | ++ |
+ )+ |
+
| 1360 | ++ | + + | +
| 1361 | ++ |
+ #' @rdname rowclasses+ |
+
| 1362 | ++ |
+ #' @exportClass ContentRow+ |
+
| 1363 | ++ |
+ setClass("ContentRow",
+ |
+
| 1364 | ++ |
+ contains = "TableRow",+ |
+
| 1365 | ++ |
+ representation(colspans = "integer") ## ,+ |
+
| 1366 | ++ |
+ ## pos_in_tree = "TableRowPos"),+ |
+
| 1367 | ++ |
+ ## validity = function(object) {
+ |
+
| 1368 | ++ |
+ ## lcsp = length(object@colspans)+ |
+
| 1369 | ++ |
+ ## length(lcsp == 0) || lcsp == length(object@leaf_value)+ |
+
| 1370 | ++ |
+ ## }+ |
+
| 1371 | ++ |
+ )+ |
+
| 1372 | ++ | + + | +
| 1373 | ++ |
+ #' @rdname rowclasses+ |
+
| 1374 | ++ |
+ #' @exportClass LabelRow+ |
+
| 1375 | ++ |
+ setClass("LabelRow",
+ |
+
| 1376 | ++ |
+ contains = "TableRow",+ |
+
| 1377 | ++ |
+ representation(visible = "logical")+ |
+
| 1378 | ++ |
+ )+ |
+
| 1379 | ++ | + + | +
| 1380 | ++ |
+ #' @param klass (`character`)\cr internal detail.+ |
+
| 1381 | ++ |
+ #'+ |
+
| 1382 | ++ |
+ #' @export+ |
+
| 1383 | ++ |
+ #' @rdname rowclasses+ |
+
| 1384 | ++ |
+ .tablerow <- function(vals = list(),+ |
+
| 1385 | ++ |
+ name = "",+ |
+
| 1386 | ++ |
+ lev = 1L,+ |
+
| 1387 | ++ |
+ label = name,+ |
+
| 1388 | ++ |
+ cspan = rep(1L, length(vals)),+ |
+
| 1389 | ++ |
+ cinfo = EmptyColInfo,+ |
+
| 1390 | ++ |
+ var = NA_character_,+ |
+
| 1391 | ++ |
+ format = NULL,+ |
+
| 1392 | ++ |
+ na_str = NA_character_,+ |
+
| 1393 | ++ |
+ klass,+ |
+
| 1394 | ++ |
+ indent_mod = 0L,+ |
+
| 1395 | ++ |
+ footnotes = list(),+ |
+
| 1396 | ++ |
+ table_inset = 0L,+ |
+
| 1397 | ++ |
+ trailing_section_div = NA_character_) {
+ |
+
| 1398 | +3254x | +
+ if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
+ |
+
| 1399 | +257x | +
+ name <- label+ |
+
| 1400 | ++ |
+ }+ |
+
| 1401 | +3254x | +
+ vals <- lapply(vals, rcell)+ |
+
| 1402 | +3254x | +
+ rlabels <- unique(unlist(lapply(vals, obj_label)))+ |
+
| 1403 | +3254x | +
+ if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
+ |
+
| 1404 | +! | +
+ label <- rlabels[nzchar(rlabels)]+ |
+
| 1405 | ++ |
+ }+ |
+
| 1406 | +3254x | +
+ if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
+ |
+
| 1407 | +2996x | +
+ cspan <- vapply(vals, cell_cspan, 0L)+ |
+
| 1408 | ++ |
+ }+ |
+
| 1409 | ++ | + + | +
| 1410 | +3254x | +
+ check_ok_label(label)+ |
+
| 1411 | +3254x | +
+ rw <- new(klass,+ |
+
| 1412 | +3254x | +
+ leaf_value = vals,+ |
+
| 1413 | +3254x | +
+ name = .chkname(name),+ |
+
| 1414 | +3254x | +
+ level = lev,+ |
+
| 1415 | +3254x | +
+ label = .chkname(label),+ |
+
| 1416 | +3254x | +
+ colspans = cspan,+ |
+
| 1417 | +3254x | +
+ col_info = cinfo,+ |
+
| 1418 | +3254x | +
+ var_analyzed = var,+ |
+
| 1419 | ++ |
+ ## these are set in set_format_recursive below+ |
+
| 1420 | +3254x | +
+ format = NULL,+ |
+
| 1421 | +3254x | +
+ na_str = NA_character_,+ |
+
| 1422 | +3254x | +
+ indent_modifier = indent_mod,+ |
+
| 1423 | +3254x | +
+ row_footnotes = footnotes,+ |
+
| 1424 | +3254x | +
+ table_inset = table_inset,+ |
+
| 1425 | +3254x | +
+ trailing_section_div = trailing_section_div+ |
+
| 1426 | ++ |
+ )+ |
+
| 1427 | +3254x | +
+ rw <- set_format_recursive(rw, format, na_str, FALSE)+ |
+
| 1428 | +3254x | +
+ rw+ |
+
| 1429 | ++ |
+ }+ |
+
| 1430 | ++ | + + | +
| 1431 | ++ |
+ #' @param ... additional parameters passed to shared constructor (`.tablerow`).+ |
+
| 1432 | ++ |
+ #'+ |
+
| 1433 | ++ |
+ #' @export+ |
+
| 1434 | ++ |
+ #' @rdname rowclasses+ |
+
| 1435 | +2730x | +
+ DataRow <- function(...) .tablerow(..., klass = "DataRow")+ |
+
| 1436 | ++ | + + | +
| 1437 | ++ |
+ #' @export+ |
+
| 1438 | ++ |
+ #' @rdname rowclasses+ |
+
| 1439 | +524x | +
+ ContentRow <- function(...) .tablerow(..., klass = "ContentRow")+ |
+
| 1440 | ++ | + + | +
| 1441 | ++ |
+ setClass("VTitleFooter",
+ |
+
| 1442 | ++ |
+ contains = "VIRTUAL",+ |
+
| 1443 | ++ |
+ representation(+ |
+
| 1444 | ++ |
+ main_title = "character",+ |
+
| 1445 | ++ |
+ subtitles = "character",+ |
+
| 1446 | ++ |
+ main_footer = "character",+ |
+
| 1447 | ++ |
+ provenance_footer = "character"+ |
+
| 1448 | ++ |
+ )+ |
+
| 1449 | ++ |
+ )+ |
+
| 1450 | ++ | + + | +
| 1451 | ++ |
+ setClass("VTableTree",
+ |
+
| 1452 | ++ |
+ contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
+ |
+
| 1453 | ++ |
+ representation(+ |
+
| 1454 | ++ |
+ children = "list",+ |
+
| 1455 | ++ |
+ rowspans = "data.frame",+ |
+
| 1456 | ++ |
+ labelrow = "LabelRow",+ |
+
| 1457 | ++ |
+ page_titles = "character",+ |
+
| 1458 | ++ |
+ horizontal_sep = "character",+ |
+
| 1459 | ++ |
+ header_section_div = "character",+ |
+
| 1460 | ++ |
+ trailing_section_div = "character"+ |
+
| 1461 | ++ |
+ )+ |
+
| 1462 | ++ |
+ )+ |
+
| 1463 | ++ | + + | +
| 1464 | ++ |
+ setClassUnion("IntegerOrNull", c("integer", "NULL"))
+ |
+
| 1465 | ++ |
+ ## covered because it's ElementaryTable's validity method but covr misses it+ |
+
| 1466 | ++ |
+ ## nocov start+ |
+
| 1467 | ++ |
+ etable_validity <- function(object) {
+ |
+
| 1468 | ++ |
+ kids <- tree_children(object)+ |
+
| 1469 | ++ |
+ all(sapply(+ |
+
| 1470 | ++ |
+ kids,+ |
+
| 1471 | ++ |
+ function(k) {
+ |
+
| 1472 | ++ |
+ (is(k, "DataRow") || is(k, "ContentRow"))+ |
+
| 1473 | ++ |
+ }+ |
+
| 1474 | ++ |
+ )) ### &&+ |
+
| 1475 | ++ |
+ }+ |
+
| 1476 | ++ |
+ ## nocov end+ |
+
| 1477 | ++ | + + | +
| 1478 | ++ |
+ #' `TableTree` classes+ |
+
| 1479 | ++ |
+ #'+ |
+
| 1480 | ++ |
+ #' @return A formal object representing a populated table.+ |
+
| 1481 | ++ |
+ #'+ |
+
| 1482 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1483 | ++ |
+ #' @exportClass ElementaryTable+ |
+
| 1484 | ++ |
+ #' @rdname tabclasses+ |
+
| 1485 | ++ |
+ setClass("ElementaryTable",
+ |
+
| 1486 | ++ |
+ contains = "VTableTree",+ |
+
| 1487 | ++ |
+ representation(var_analyzed = "character"),+ |
+
| 1488 | ++ |
+ validity = etable_validity ## function(object) {
+ |
+
| 1489 | ++ |
+ )+ |
+
| 1490 | ++ | + + | +
| 1491 | ++ |
+ .enforce_valid_kids <- function(lst, colinfo) {
+ |
+
| 1492 | ++ |
+ ## colinfo+ |
+
| 1493 | +5877x | +
+ if (!no_colinfo(colinfo)) {
+ |
+
| 1494 | +5877x | +
+ lst <- lapply(+ |
+
| 1495 | +5877x | +
+ lst,+ |
+
| 1496 | +5877x | +
+ function(x) {
+ |
+
| 1497 | +7322x | +
+ if (no_colinfo(x)) {
+ |
+
| 1498 | +208x | +
+ col_info(x) <- colinfo+ |
+
| 1499 | +7114x | +
+ } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
+ |
+
| 1500 | ++ |
+ ## split functions from function factories (e.g. add_combo_levels)+ |
+
| 1501 | ++ |
+ ## have different environments so we can't use identical here+ |
+
| 1502 | ++ |
+ ## all.equal requires the **values within the closures** to be the+ |
+
| 1503 | ++ |
+ ## same but not the actual enclosing environments.+ |
+
| 1504 | +! | +
+ stop(+ |
+
| 1505 | +! | +
+ "attempted to add child with non-matching, non-empty ",+ |
+
| 1506 | +! | +
+ "column info to an existing table"+ |
+
| 1507 | ++ |
+ )+ |
+
| 1508 | ++ |
+ }+ |
+
| 1509 | +7322x | +
+ x+ |
+
| 1510 | ++ |
+ }+ |
+
| 1511 | ++ |
+ )+ |
+
| 1512 | ++ |
+ }+ |
+
| 1513 | ++ | + + | +
| 1514 | +5877x | +
+ if (are(lst, "ElementaryTable") &&+ |
+
| 1515 | +5877x | +
+ all(sapply(lst, function(tb) {
+ |
+
| 1516 | +1014x | +
+ nrow(tb) <= 1 && identical(obj_name(tb), "")+ |
+
| 1517 | ++ |
+ }))) {
+ |
+
| 1518 | +1562x | +
+ lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]]))+ |
+
| 1519 | ++ |
+ }+ |
+
| 1520 | +5877x | +
+ if (length(lst) == 0) {
+ |
+
| 1521 | +1562x | +
+ return(list())+ |
+
| 1522 | ++ |
+ }+ |
+
| 1523 | ++ |
+ ## names+ |
+
| 1524 | +4315x | +
+ realnames <- sapply(lst, obj_name)+ |
+
| 1525 | +4315x | +
+ lstnames <- names(lst)+ |
+
| 1526 | +4315x | +
+ if (is.null(lstnames)) {
+ |
+
| 1527 | +1850x | +
+ names(lst) <- realnames+ |
+
| 1528 | +2465x | +
+ } else if (!identical(realnames, lstnames)) {
+ |
+
| 1529 | +2465x | +
+ names(lst) <- realnames+ |
+
| 1530 | ++ |
+ }+ |
+
| 1531 | ++ | + + | +
| 1532 | +4315x | +
+ lst+ |
+
| 1533 | ++ |
+ }+ |
+
| 1534 | ++ | + + | +
| 1535 | ++ |
+ #' Table constructors and classes+ |
+
| 1536 | ++ |
+ #'+ |
+
| 1537 | ++ |
+ #' @inheritParams constr_args+ |
+
| 1538 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1539 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1540 | ++ |
+ #' @param rspans (`data.frame`)\cr currently stored but otherwise ignored.+ |
+
| 1541 | ++ |
+ #'+ |
+
| 1542 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1543 | ++ |
+ #' @export+ |
+
| 1544 | ++ |
+ #' @rdname tabclasses+ |
+
| 1545 | ++ |
+ ElementaryTable <- function(kids = list(),+ |
+
| 1546 | ++ |
+ name = "",+ |
+
| 1547 | ++ |
+ lev = 1L,+ |
+
| 1548 | ++ |
+ label = "",+ |
+
| 1549 | ++ |
+ labelrow = LabelRow(+ |
+
| 1550 | ++ |
+ lev = lev,+ |
+
| 1551 | ++ |
+ label = label,+ |
+
| 1552 | ++ |
+ vis = !isTRUE(iscontent) &&+ |
+
| 1553 | ++ |
+ !is.na(label) &&+ |
+
| 1554 | ++ |
+ nzchar(label)+ |
+
| 1555 | ++ |
+ ),+ |
+
| 1556 | ++ |
+ rspans = data.frame(),+ |
+
| 1557 | ++ |
+ cinfo = NULL,+ |
+
| 1558 | ++ |
+ iscontent = NA,+ |
+
| 1559 | ++ |
+ var = NA_character_,+ |
+
| 1560 | ++ |
+ format = NULL,+ |
+
| 1561 | ++ |
+ na_str = NA_character_,+ |
+
| 1562 | ++ |
+ indent_mod = 0L,+ |
+
| 1563 | ++ |
+ title = "",+ |
+
| 1564 | ++ |
+ subtitles = character(),+ |
+
| 1565 | ++ |
+ main_footer = character(),+ |
+
| 1566 | ++ |
+ prov_footer = character(),+ |
+
| 1567 | ++ |
+ header_section_div = NA_character_,+ |
+
| 1568 | ++ |
+ hsep = default_hsep(),+ |
+
| 1569 | ++ |
+ trailing_section_div = NA_character_,+ |
+
| 1570 | ++ |
+ inset = 0L) {
+ |
+
| 1571 | +3051x | +
+ check_ok_label(label)+ |
+
| 1572 | +3051x | +
+ if (is.null(cinfo)) {
+ |
+
| 1573 | +! | +
+ if (length(kids) > 0) {
+ |
+
| 1574 | +! | +
+ cinfo <- col_info(kids[[1]])+ |
+
| 1575 | ++ |
+ } else {
+ |
+
| 1576 | +! | +
+ cinfo <- EmptyColInfo+ |
+
| 1577 | ++ |
+ }+ |
+
| 1578 | ++ |
+ }+ |
+
| 1579 | ++ | + + | +
| 1580 | +3051x | +
+ if (no_colinfo(labelrow)) {
+ |
+
| 1581 | +1881x | +
+ col_info(labelrow) <- cinfo+ |
+
| 1582 | ++ |
+ }+ |
+
| 1583 | +3051x | +
+ kids <- .enforce_valid_kids(kids, cinfo)+ |
+
| 1584 | +3051x | +
+ tab <- new("ElementaryTable",
+ |
+
| 1585 | +3051x | +
+ children = kids,+ |
+
| 1586 | +3051x | +
+ name = .chkname(name),+ |
+
| 1587 | +3051x | +
+ level = lev,+ |
+
| 1588 | +3051x | +
+ labelrow = labelrow,+ |
+
| 1589 | +3051x | +
+ rowspans = rspans,+ |
+
| 1590 | +3051x | +
+ col_info = cinfo,+ |
+
| 1591 | +3051x | +
+ var_analyzed = var,+ |
+
| 1592 | ++ |
+ ## XXX these are hardcoded, because they both get set during+ |
+
| 1593 | ++ |
+ ## set_format_recursive anyway+ |
+
| 1594 | +3051x | +
+ format = NULL,+ |
+
| 1595 | +3051x | +
+ na_str = NA_character_,+ |
+
| 1596 | +3051x | +
+ table_inset = 0L,+ |
+
| 1597 | +3051x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 1598 | +3051x | +
+ main_title = title,+ |
+
| 1599 | +3051x | +
+ subtitles = subtitles,+ |
+
| 1600 | +3051x | +
+ main_footer = main_footer,+ |
+
| 1601 | +3051x | +
+ provenance_footer = prov_footer,+ |
+
| 1602 | +3051x | +
+ horizontal_sep = hsep,+ |
+
| 1603 | +3051x | +
+ header_section_div = header_section_div,+ |
+
| 1604 | +3051x | +
+ trailing_section_div = trailing_section_div+ |
+
| 1605 | ++ |
+ )+ |
+
| 1606 | +3051x | +
+ tab <- set_format_recursive(tab, format, na_str, FALSE)+ |
+
| 1607 | +3051x | +
+ table_inset(tab) <- as.integer(inset)+ |
+
| 1608 | +3051x | +
+ tab+ |
+
| 1609 | ++ |
+ }+ |
+
| 1610 | ++ | + + | +
| 1611 | ++ |
+ ttable_validity <- function(object) {
+ |
+
| 1612 | +! | +
+ all(sapply(+ |
+
| 1613 | +! | +
+ tree_children(object),+ |
+
| 1614 | +! | +
+ function(x) is(x, "VTableTree") || is(x, "TableRow")+ |
+
| 1615 | ++ |
+ ))+ |
+
| 1616 | ++ |
+ }+ |
+
| 1617 | ++ | + + | +
| 1618 | ++ |
+ .calc_cinfo <- function(cinfo, cont, kids) {
+ |
+
| 1619 | +2826x | +
+ if (!is.null(cinfo)) {
+ |
+
| 1620 | +2826x | +
+ cinfo+ |
+
| 1621 | +! | +
+ } else if (!is.null(cont)) {
+ |
+
| 1622 | +! | +
+ col_info(cont)+ |
+
| 1623 | +! | +
+ } else if (length(kids) >= 1) {
+ |
+
| 1624 | +! | +
+ col_info(kids[[1]])+ |
+
| 1625 | ++ |
+ } else {
+ |
+
| 1626 | +! | +
+ EmptyColInfo+ |
+
| 1627 | ++ |
+ }+ |
+
| 1628 | ++ |
+ }+ |
+
| 1629 | ++ | + + | +
| 1630 | ++ |
+ ## under this model, non-leaf nodes can have a content table where rollup+ |
+
| 1631 | ++ |
+ ## analyses live+ |
+
| 1632 | ++ |
+ #' @exportClass TableTree+ |
+
| 1633 | ++ |
+ #' @rdname tabclasses+ |
+
| 1634 | ++ |
+ setClass("TableTree",
+ |
+
| 1635 | ++ |
+ contains = c("VTableTree"),
+ |
+
| 1636 | ++ |
+ representation(+ |
+
| 1637 | ++ |
+ content = "ElementaryTable",+ |
+
| 1638 | ++ |
+ page_title_prefix = "character"+ |
+
| 1639 | ++ |
+ ),+ |
+
| 1640 | ++ |
+ validity = ttable_validity+ |
+
| 1641 | ++ |
+ )+ |
+
| 1642 | ++ | + + | +
| 1643 | ++ |
+ #' @export+ |
+
| 1644 | ++ |
+ #' @rdname tabclasses+ |
+
| 1645 | ++ |
+ TableTree <- function(kids = list(),+ |
+
| 1646 | ++ |
+ name = if (!is.na(var)) var else "",+ |
+
| 1647 | ++ |
+ cont = EmptyElTable,+ |
+
| 1648 | ++ |
+ lev = 1L,+ |
+
| 1649 | ++ |
+ label = name,+ |
+
| 1650 | ++ |
+ labelrow = LabelRow(+ |
+
| 1651 | ++ |
+ lev = lev,+ |
+
| 1652 | ++ |
+ label = label,+ |
+
| 1653 | ++ |
+ vis = nrow(cont) == 0 && !is.na(label) &&+ |
+
| 1654 | ++ |
+ nzchar(label)+ |
+
| 1655 | ++ |
+ ),+ |
+
| 1656 | ++ |
+ rspans = data.frame(),+ |
+
| 1657 | ++ |
+ iscontent = NA,+ |
+
| 1658 | ++ |
+ var = NA_character_,+ |
+
| 1659 | ++ |
+ cinfo = NULL,+ |
+
| 1660 | ++ |
+ format = NULL,+ |
+
| 1661 | ++ |
+ na_str = NA_character_,+ |
+
| 1662 | ++ |
+ indent_mod = 0L,+ |
+
| 1663 | ++ |
+ title = "",+ |
+
| 1664 | ++ |
+ subtitles = character(),+ |
+
| 1665 | ++ |
+ main_footer = character(),+ |
+
| 1666 | ++ |
+ prov_footer = character(),+ |
+
| 1667 | ++ |
+ page_title = NA_character_,+ |
+
| 1668 | ++ |
+ hsep = default_hsep(),+ |
+
| 1669 | ++ |
+ header_section_div = NA_character_,+ |
+
| 1670 | ++ |
+ trailing_section_div = NA_character_,+ |
+
| 1671 | ++ |
+ inset = 0L) {
+ |
+
| 1672 | +2826x | +
+ check_ok_label(label)+ |
+
| 1673 | +2826x | +
+ cinfo <- .calc_cinfo(cinfo, cont, kids)+ |
+
| 1674 | ++ | + + | +
| 1675 | +2826x | +
+ kids <- .enforce_valid_kids(kids, cinfo)+ |
+
| 1676 | +2826x | +
+ if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
+ |
+
| 1677 | +! | +
+ stop("Got table tree with content table and content position")
+ |
+
| 1678 | ++ |
+ }+ |
+
| 1679 | +2826x | +
+ if (no_colinfo(labelrow)) {
+ |
+
| 1680 | +1599x | +
+ col_info(labelrow) <- cinfo+ |
+
| 1681 | ++ |
+ }+ |
+
| 1682 | +2826x | +
+ if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
+ |
+
| 1683 | +1153x | +
+ if (!is.na(page_title)) {
+ |
+
| 1684 | +! | +
+ stop("Got a page title prefix for an Elementary Table")
+ |
+
| 1685 | ++ |
+ }+ |
+
| 1686 | ++ |
+ ## constructor takes care of recursive format application+ |
+
| 1687 | +1153x | +
+ ElementaryTable(+ |
+
| 1688 | +1153x | +
+ kids = kids,+ |
+
| 1689 | +1153x | +
+ name = .chkname(name),+ |
+
| 1690 | +1153x | +
+ lev = lev,+ |
+
| 1691 | +1153x | +
+ labelrow = labelrow,+ |
+
| 1692 | +1153x | +
+ rspans = rspans,+ |
+
| 1693 | +1153x | +
+ cinfo = cinfo,+ |
+
| 1694 | +1153x | +
+ var = var,+ |
+
| 1695 | +1153x | +
+ format = format,+ |
+
| 1696 | +1153x | +
+ na_str = na_str,+ |
+
| 1697 | +1153x | +
+ indent_mod = indent_mod,+ |
+
| 1698 | +1153x | +
+ title = title,+ |
+
| 1699 | +1153x | +
+ subtitles = subtitles,+ |
+
| 1700 | +1153x | +
+ main_footer = main_footer,+ |
+
| 1701 | +1153x | +
+ prov_footer = prov_footer,+ |
+
| 1702 | +1153x | +
+ hsep = hsep,+ |
+
| 1703 | +1153x | +
+ header_section_div = header_section_div,+ |
+
| 1704 | +1153x | +
+ trailing_section_div = trailing_section_div,+ |
+
| 1705 | +1153x | +
+ inset = inset+ |
+
| 1706 | ++ |
+ )+ |
+
| 1707 | ++ |
+ } else {
+ |
+
| 1708 | +1673x | +
+ tab <- new("TableTree",
+ |
+
| 1709 | +1673x | +
+ content = cont,+ |
+
| 1710 | +1673x | +
+ children = kids,+ |
+
| 1711 | +1673x | +
+ name = .chkname(name),+ |
+
| 1712 | +1673x | +
+ level = lev,+ |
+
| 1713 | +1673x | +
+ labelrow = labelrow,+ |
+
| 1714 | +1673x | +
+ rowspans = rspans,+ |
+
| 1715 | +1673x | +
+ col_info = cinfo,+ |
+
| 1716 | +1673x | +
+ format = NULL,+ |
+
| 1717 | +1673x | +
+ na_str = na_str,+ |
+
| 1718 | +1673x | +
+ table_inset = 0L,+ |
+
| 1719 | +1673x | +
+ indent_modifier = as.integer(indent_mod),+ |
+
| 1720 | +1673x | +
+ main_title = title,+ |
+
| 1721 | +1673x | +
+ subtitles = subtitles,+ |
+
| 1722 | +1673x | +
+ main_footer = main_footer,+ |
+
| 1723 | +1673x | +
+ provenance_footer = prov_footer,+ |
+
| 1724 | +1673x | +
+ page_title_prefix = page_title,+ |
+
| 1725 | +1673x | +
+ horizontal_sep = "-",+ |
+
| 1726 | +1673x | +
+ header_section_div = header_section_div,+ |
+
| 1727 | +1673x | +
+ trailing_section_div = trailing_section_div+ |
+
| 1728 | +1673x | +
+ ) ## this is overridden below to get recursiveness+ |
+
| 1729 | +1673x | +
+ tab <- set_format_recursive(tab, format, na_str, FALSE)+ |
+
| 1730 | ++ | + + | +
| 1731 | ++ |
+ ## these is recursive+ |
+
| 1732 | ++ |
+ ## XXX combine these probably+ |
+
| 1733 | +1673x | +
+ horizontal_sep(tab) <- hsep+ |
+
| 1734 | +1673x | +
+ table_inset(tab) <- as.integer(inset)+ |
+
| 1735 | +1673x | +
+ tab+ |
+
| 1736 | ++ |
+ }+ |
+
| 1737 | ++ |
+ }+ |
+
| 1738 | ++ | + + | +
| 1739 | ++ |
+ ### Pre-Data Layout Declaration Classes+ |
+
| 1740 | ++ |
+ ###+ |
+
| 1741 | ++ |
+ ### Notably these are NOT represented as trees+ |
+
| 1742 | ++ |
+ ### because without data we cannot know what the+ |
+
| 1743 | ++ |
+ ### children should be.+ |
+
| 1744 | ++ | + + | +
| 1745 | ++ |
+ ## Vector (ordered list) of splits.+ |
+
| 1746 | ++ |
+ ##+ |
+
| 1747 | ++ |
+ ## This is a vector (ordered list) of splits to be+ |
+
| 1748 | ++ |
+ ## applied recursively to the data when provided.+ |
+
| 1749 | ++ |
+ ##+ |
+
| 1750 | ++ |
+ ## For convenience, if this is length 1, it can contain+ |
+
| 1751 | ++ |
+ ## a pre-existing TableTree/ElementaryTable.+ |
+
| 1752 | ++ |
+ ## This is used for add_existing_table in colby_constructors.R+ |
+
| 1753 | ++ | + + | +
| 1754 | ++ |
+ setClass("SplitVector",
+ |
+
| 1755 | ++ |
+ contains = "list",+ |
+
| 1756 | ++ |
+ validity = function(object) {
+ |
+
| 1757 | ++ |
+ if (length(object) >= 1) {
+ |
+
| 1758 | ++ |
+ lst <- tail(object, 1)[[1]]+ |
+
| 1759 | ++ |
+ } else {
+ |
+
| 1760 | ++ |
+ lst <- NULL+ |
+
| 1761 | ++ |
+ }+ |
+
| 1762 | ++ |
+ all(sapply(head(object, -1), is, "Split")) &&+ |
+
| 1763 | ++ |
+ (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo"))+ |
+
| 1764 | ++ |
+ }+ |
+
| 1765 | ++ |
+ )+ |
+
| 1766 | ++ | + + | +
| 1767 | ++ |
+ SplitVector <- function(x = NULL,+ |
+
| 1768 | ++ |
+ ...,+ |
+
| 1769 | ++ |
+ lst = list(...)) {
+ |
+
| 1770 | +2473x | +
+ if (!is.null(x)) {
+ |
+
| 1771 | +448x | +
+ lst <- unlist(c(list(x), lst), recursive = FALSE)+ |
+
| 1772 | ++ |
+ }+ |
+
| 1773 | +2473x | +
+ new("SplitVector", lst)
+ |
+
| 1774 | ++ |
+ }+ |
+
| 1775 | ++ | + + | +
| 1776 | ++ |
+ avar_noneorlast <- function(vec) {
+ |
+
| 1777 | +1003x | +
+ if (!is(vec, "SplitVector")) {
+ |
+
| 1778 | +! | +
+ return(FALSE)+ |
+
| 1779 | ++ |
+ }+ |
+
| 1780 | +1003x | +
+ if (length(vec) == 0) {
+ |
+
| 1781 | +654x | +
+ return(TRUE)+ |
+
| 1782 | ++ |
+ }+ |
+
| 1783 | +349x | +
+ isavar <- which(sapply(vec, is, "AnalyzeVarSplit"))+ |
+
| 1784 | +349x | +
+ (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec))+ |
+
| 1785 | ++ |
+ }+ |
+
| 1786 | ++ | + + | +
| 1787 | ++ |
+ setClass("PreDataAxisLayout",
+ |
+
| 1788 | ++ |
+ contains = "list",+ |
+
| 1789 | ++ |
+ representation(root_split = "ANY"),+ |
+
| 1790 | ++ |
+ validity = function(object) {
+ |
+
| 1791 | ++ |
+ allleafs <- unlist(object, recursive = TRUE)+ |
+
| 1792 | ++ |
+ all(sapply(object, avar_noneorlast)) &&+ |
+
| 1793 | ++ |
+ all(sapply(+ |
+
| 1794 | ++ |
+ allleafs,+ |
+
| 1795 | ++ |
+ ## remember existing table trees can be added to layouts+ |
+
| 1796 | ++ |
+ ## for now...+ |
+
| 1797 | ++ |
+ function(x) is(x, "Split") || is(x, "VTableTree")+ |
+
| 1798 | ++ |
+ ))+ |
+
| 1799 | ++ |
+ }+ |
+
| 1800 | ++ |
+ )+ |
+
| 1801 | ++ | + + | +
| 1802 | ++ |
+ setClass("PreDataColLayout",
+ |
+
| 1803 | ++ |
+ contains = "PreDataAxisLayout",+ |
+
| 1804 | ++ |
+ representation(+ |
+
| 1805 | ++ |
+ display_columncounts = "logical",+ |
+
| 1806 | ++ |
+ columncount_format = "FormatSpec" # "character"+ |
+
| 1807 | ++ |
+ )+ |
+
| 1808 | ++ |
+ )+ |
+
| 1809 | ++ | + + | +
| 1810 | ++ |
+ setClass("PreDataRowLayout", contains = "PreDataAxisLayout")
+ |
+
| 1811 | ++ | + + | +
| 1812 | ++ |
+ PreDataColLayout <- function(x = SplitVector(),+ |
+
| 1813 | ++ |
+ rtsp = RootSplit(),+ |
+
| 1814 | ++ |
+ ...,+ |
+
| 1815 | ++ |
+ lst = list(x, ...),+ |
+
| 1816 | ++ |
+ disp_colcounts = NA,+ |
+
| 1817 | ++ |
+ colcount_format = "(N=xx)") {
+ |
+
| 1818 | +322x | +
+ ret <- new("PreDataColLayout", lst,
+ |
+
| 1819 | +322x | +
+ display_columncounts = disp_colcounts,+ |
+
| 1820 | +322x | +
+ columncount_format = colcount_format+ |
+
| 1821 | ++ |
+ )+ |
+
| 1822 | +322x | +
+ ret@root_split <- rtsp+ |
+
| 1823 | +322x | +
+ ret+ |
+
| 1824 | ++ |
+ }+ |
+
| 1825 | ++ | + + | +
| 1826 | ++ |
+ PreDataRowLayout <- function(x = SplitVector(),+ |
+
| 1827 | ++ |
+ root = RootSplit(),+ |
+
| 1828 | ++ |
+ ...,+ |
+
| 1829 | ++ |
+ lst = list(x, ...)) {
+ |
+
| 1830 | +658x | +
+ new("PreDataRowLayout", lst, root_split = root)
+ |
+
| 1831 | ++ |
+ }+ |
+
| 1832 | ++ | + + | +
| 1833 | ++ |
+ setClass("PreDataTableLayouts",
+ |
+
| 1834 | ++ |
+ contains = "VTitleFooter",+ |
+
| 1835 | ++ |
+ representation(+ |
+
| 1836 | ++ |
+ row_layout = "PreDataRowLayout",+ |
+
| 1837 | ++ |
+ col_layout = "PreDataColLayout",+ |
+
| 1838 | ++ |
+ top_left = "character",+ |
+
| 1839 | ++ |
+ header_section_div = "character",+ |
+
| 1840 | ++ |
+ top_level_section_div = "character",+ |
+
| 1841 | ++ |
+ table_inset = "integer"+ |
+
| 1842 | ++ |
+ )+ |
+
| 1843 | ++ |
+ )+ |
+
| 1844 | ++ | + + | +
| 1845 | ++ |
+ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),+ |
+
| 1846 | ++ |
+ clayout = PreDataColLayout(),+ |
+
| 1847 | ++ |
+ topleft = character(),+ |
+
| 1848 | ++ |
+ title = "",+ |
+
| 1849 | ++ |
+ subtitles = character(),+ |
+
| 1850 | ++ |
+ main_footer = character(),+ |
+
| 1851 | ++ |
+ prov_footer = character(),+ |
+
| 1852 | ++ |
+ header_section_div = NA_character_,+ |
+
| 1853 | ++ |
+ top_level_section_div = NA_character_,+ |
+
| 1854 | ++ |
+ table_inset = 0L) {
+ |
+
| 1855 | +322x | +
+ new("PreDataTableLayouts",
+ |
+
| 1856 | +322x | +
+ row_layout = rlayout,+ |
+
| 1857 | +322x | +
+ col_layout = clayout,+ |
+
| 1858 | +322x | +
+ top_left = topleft,+ |
+
| 1859 | +322x | +
+ main_title = title,+ |
+
| 1860 | +322x | +
+ subtitles = subtitles,+ |
+
| 1861 | +322x | +
+ main_footer = main_footer,+ |
+
| 1862 | +322x | +
+ provenance_footer = prov_footer,+ |
+
| 1863 | +322x | +
+ header_section_div = header_section_div,+ |
+
| 1864 | +322x | +
+ top_level_section_div = top_level_section_div,+ |
+
| 1865 | +322x | +
+ table_inset = table_inset+ |
+
| 1866 | ++ |
+ )+ |
+
| 1867 | ++ |
+ }+ |
+
| 1868 | ++ | + + | +
| 1869 | ++ |
+ ## setClass("CellValue", contains = "ValueWrapper",
+ |
+
| 1870 | ++ |
+ ## representation(format = "FormatSpec",+ |
+
| 1871 | ++ |
+ ## colspan = "integerOrNULL",+ |
+
| 1872 | ++ |
+ ## label = "characterOrNULL"),+ |
+
| 1873 | ++ |
+ ## prototype = list(label ="", colspan = NULL, format = NULL))+ |
+
| 1874 | ++ | + + | +
| 1875 | ++ |
+ setOldClass("CellValue")
+ |
+
| 1876 | ++ | + + | +
| 1877 | ++ |
+ #' Length of a Cell value+ |
+
| 1878 | ++ |
+ #'+ |
+
| 1879 | ++ |
+ #' @param x (`CellValue`)\cr a `CellValue` object.+ |
+
| 1880 | ++ |
+ #'+ |
+
| 1881 | ++ |
+ #' @return Always returns `1L`.+ |
+
| 1882 | ++ |
+ #'+ |
+
| 1883 | ++ |
+ #' @exportMethod length+ |
+
| 1884 | ++ |
+ setMethod(+ |
+
| 1885 | ++ |
+ "length", "CellValue",+ |
+
| 1886 | +! | +
+ function(x) 1L+ |
+
| 1887 | ++ |
+ )+ |
+
| 1888 | ++ | + + | +
| 1889 | ++ |
+ setClass("RefFootnote", representation(
+ |
+
| 1890 | ++ |
+ value = "character",+ |
+
| 1891 | ++ |
+ index = "integer",+ |
+
| 1892 | ++ |
+ symbol = "character"+ |
+
| 1893 | ++ |
+ ))+ |
+
| 1894 | ++ | + + | +
| 1895 | ++ |
+ RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
+ |
+
| 1896 | +56x | +
+ if (is(note, "RefFootnote")) {
+ |
+
| 1897 | +28x | +
+ return(note)+ |
+
| 1898 | +28x | +
+ } else if (length(note) == 0) {
+ |
+
| 1899 | +! | +
+ return(NULL)+ |
+
| 1900 | ++ |
+ }+ |
+
| 1901 | +28x | +
+ if (length(symbol) != 1L) {
+ |
+
| 1902 | +! | +
+ stop(+ |
+
| 1903 | +! | +
+ "Referential footnote can only have a single string as its index.",+ |
+
| 1904 | +! | +
+ " Got char vector of length ", length(index)+ |
+
| 1905 | ++ |
+ )+ |
+
| 1906 | ++ |
+ }+ |
+
| 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 | +! | +
+ "referential footnote index symbols. Got string '", index, "'."+ |
+
| 1911 | ++ |
+ )+ |
+
| 1912 | ++ |
+ }+ |
+
| 1913 | ++ | + + | +
| 1914 | +28x | +
+ new("RefFootnote", value = note, index = index, symbol = symbol)
+ |
+
| 1915 | ++ |
+ }+ |
+
| 1916 | ++ | + + | +
| 1917 | ++ |
+ #' Constructor for Cell Value+ |
+
| 1918 | ++ |
+ #'+ |
+
| 1919 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1920 | ++ |
+ #' @inheritParams rcell+ |
+
| 1921 | ++ |
+ #' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted.+ |
+
| 1922 | ++ |
+ #'+ |
+
| 1923 | ++ |
+ #' @return An object representing the value within a single cell within a populated table. The underlying structure+ |
+
| 1924 | ++ |
+ #' of this object is an implementation detail and should not be relied upon beyond calling accessors for the class.+ |
+
| 1925 | ++ |
+ #'+ |
+
| 1926 | ++ |
+ #' @export+ |
+
| 1927 | ++ | + + | +
| 1928 | ++ |
+ ## Class definition+ |
+
| 1929 | ++ |
+ ## [[1]] list: cell value+ |
+
| 1930 | ++ |
+ ## format : format for cell+ |
+
| 1931 | ++ |
+ ## colspan: column span info for cell+ |
+
| 1932 | ++ |
+ ## label: row label to be used for parent row+ |
+
| 1933 | ++ |
+ ## indent_mod: indent modifier to be used for parent row+ |
+
| 1934 | ++ |
+ CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,+ |
+
| 1935 | ++ |
+ indent_mod = NULL, footnotes = NULL,+ |
+
| 1936 | ++ |
+ align = NULL, format_na_str = NULL) {
+ |
+
| 1937 | +12626x | +
+ if (is.null(colspan)) {
+ |
+
| 1938 | +! | +
+ colspan <- 1L+ |
+
| 1939 | ++ |
+ }+ |
+
| 1940 | +12626x | +
+ if (!is.null(colspan) && !is(colspan, "integer")) {
+ |
+
| 1941 | +10x | +
+ colspan <- as.integer(colspan)+ |
+
| 1942 | ++ |
+ }+ |
+
| 1943 | ++ |
+ ## if we're not given a label but the value has one associated with+ |
+
| 1944 | ++ |
+ ## it we use that.+ |
+
| 1945 | ++ |
+ ## NB: we need to be able to override a non-empty label with an empty one+ |
+
| 1946 | ++ |
+ ## so we can't have "" mean "not given a label" here+ |
+
| 1947 | +12626x | +
+ if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
+ |
+
| 1948 | +2x | +
+ label <- obj_label(val)+ |
+
| 1949 | ++ |
+ }+ |
+
| 1950 | +12626x | +
+ if (!is.list(footnotes)) {
+ |
+
| 1951 | +9x | +
+ footnotes <- lapply(footnotes, RefFootnote)+ |
+
| 1952 | ++ |
+ }+ |
+
| 1953 | +12626x | +
+ check_ok_label(label)+ |
+
| 1954 | +12626x | +
+ ret <- structure(list(val),+ |
+
| 1955 | +12626x | +
+ format = format, colspan = colspan,+ |
+
| 1956 | +12626x | +
+ label = label,+ |
+
| 1957 | +12626x | +
+ indent_mod = indent_mod, footnotes = footnotes,+ |
+
| 1958 | +12626x | +
+ align = align,+ |
+
| 1959 | +12626x | +
+ format_na_str = format_na_str,+ |
+
| 1960 | +12626x | +
+ class = "CellValue"+ |
+
| 1961 | ++ |
+ )+ |
+
| 1962 | +12626x | +
+ ret+ |
+
| 1963 | ++ |
+ }+ |
+
| 1964 | ++ | + + | +
| 1965 | ++ |
+ #' @method print CellValue+ |
+
| 1966 | ++ |
+ #'+ |
+
| 1967 | ++ |
+ #' @export+ |
+
| 1968 | ++ |
+ print.CellValue <- function(x, ...) {
+ |
+
| 1969 | +! | +
+ cat(paste("rcell:", format_rcell(x), "\n"))
+ |
+
| 1970 | +! | +
+ invisible(x)+ |
+
| 1971 | ++ |
+ }+ |
+
| 1972 | ++ | + + | +
| 1973 | ++ |
+ ## too slow+ |
+
| 1974 | ++ |
+ # setClass("RowsVerticalSection", contains = "list",
+ |
+
| 1975 | ++ |
+ # representation = list(row_names = "characterOrNULL",+ |
+
| 1976 | ++ |
+ # row_labels = "characterOrNULL",+ |
+
| 1977 | ++ |
+ # row_formats = "ANY",+ |
+
| 1978 | ++ |
+ # indent_mods = "integerOrNULL"))+ |
+
| 1979 | ++ | + + | +
| 1980 | ++ |
+ setOldClass("RowsVerticalSection")
+ |
+
| 1981 | ++ |
+ RowsVerticalSection <- function(values,+ |
+
| 1982 | ++ |
+ names = names(values),+ |
+
| 1983 | ++ |
+ labels = NULL,+ |
+
| 1984 | ++ |
+ indent_mods = NULL,+ |
+
| 1985 | ++ |
+ formats = NULL,+ |
+
| 1986 | ++ |
+ footnotes = NULL,+ |
+
| 1987 | ++ |
+ format_na_strs = NULL) {
+ |
+
| 1988 | +5775x | +
+ stopifnot(is(values, "list"))+ |
+
| 1989 | ++ |
+ ## innernms <- value_names(values)+ |
+
| 1990 | ++ | + + | +
| 1991 | +5775x | +
+ if (is.null(labels)) {
+ |
+
| 1992 | +2554x | +
+ labels <- names(values)+ |
+
| 1993 | ++ |
+ }+ |
+
| 1994 | +5775x | +
+ if (is.null(names) && all(nzchar(labels))) {
+ |
+
| 1995 | +3265x | +
+ names <- labels+ |
+
| 1996 | +2510x | +
+ } else if (is.null(labels) && !is.null(names)) {
+ |
+
| 1997 | +15x | +
+ labels <- names+ |
+
| 1998 | ++ |
+ }+ |
+
| 1999 | ++ | + + | +
| 2000 | +5775x | +
+ if (!is.null(indent_mods)) {
+ |
+
| 2001 | +68x | +
+ indent_mods <- as.integer(indent_mods)+ |
+
| 2002 | ++ |
+ }+ |
+
| 2003 | +5775x | +
+ check_ok_label(labels, multi_ok = TRUE)+ |
+
| 2004 | +5774x | +
+ structure(values,+ |
+
| 2005 | +5774x | +
+ class = "RowsVerticalSection", row_names = names,+ |
+
| 2006 | +5774x | +
+ row_labels = labels, indent_mods = indent_mods,+ |
+
| 2007 | +5774x | +
+ row_formats = formats,+ |
+
| 2008 | +5774x | +
+ row_na_strs = format_na_strs,+ |
+
| 2009 | +5774x | +
+ row_footnotes = lapply(+ |
+
| 2010 | +5774x | +
+ footnotes,+ |
+
| 2011 | ++ |
+ ## cause each row needs to accept+ |
+
| 2012 | ++ |
+ ## a *list* of row footnotes+ |
+
| 2013 | +5774x | +
+ function(fns) lapply(fns, RefFootnote)+ |
+
| 2014 | ++ |
+ )+ |
+
| 2015 | ++ |
+ )+ |
+
| 2016 | ++ |
+ }+ |
+
| 2017 | ++ | + + | +
| 2018 | ++ |
+ #' @method print RowsVerticalSection+ |
+
| 2019 | ++ |
+ #'+ |
+
| 2020 | ++ |
+ #' @export+ |
+
| 2021 | ++ |
+ print.RowsVerticalSection <- function(x, ...) {
+ |
+
| 2022 | +1x | +
+ cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
+ |
+
| 2023 | +1x | +
+ "---------\n",+ |
+
| 2024 | +1x | +
+ sep = ""+ |
+
| 2025 | ++ |
+ )+ |
+
| 2026 | +1x | +
+ print(data.frame(+ |
+
| 2027 | +1x | +
+ row_name = attr(x, "row_names", exact = TRUE),+ |
+
| 2028 | +1x | +
+ formatted_cell = vapply(x, format_rcell, character(1)),+ |
+
| 2029 | +1x | +
+ indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)),+ |
+
| 2030 | +1x | +
+ row_label = attr(x, "row_labels", exact = TRUE),+ |
+
| 2031 | +1x | +
+ stringsAsFactors = FALSE,+ |
+
| 2032 | +1x | +
+ row.names = NULL+ |
+
| 2033 | +1x | +
+ ), row.names = TRUE)+ |
+
| 2034 | +1x | +
+ invisible(x)+ |
+
| 2035 | ++ |
+ }+ |
+
| 2036 | ++ | + + | +
| 2037 | ++ |
+ #### Empty default objects to avoid repeated calls+ |
+
| 2038 | ++ |
+ ## EmptyColInfo <- InstantiatedColumnInfo()+ |
+
| 2039 | ++ |
+ ## EmptyElTable <- ElementaryTable()+ |
+
| 2040 | ++ |
+ ## EmptyRootSplit <- RootSplit()+ |
+
| 2041 | ++ |
+ ## EmptyAllSplit <- AllSplit()+ |
+
| 1 | ++ |
+ match_extra_args <- function(f,+ |
+
| 2 | ++ |
+ .N_col,+ |
+
| 3 | ++ |
+ .N_total,+ |
+
| 4 | ++ |
+ .all_col_exprs,+ |
+
| 5 | ++ |
+ .all_col_counts,+ |
+
| 6 | ++ |
+ .var,+ |
+
| 7 | ++ |
+ .ref_group = NULL,+ |
+
| 8 | ++ |
+ .alt_df_row = NULL,+ |
+
| 9 | ++ |
+ .alt_df = NULL,+ |
+
| 10 | ++ |
+ .ref_full = NULL,+ |
+
| 11 | ++ |
+ .in_ref_col = NULL,+ |
+
| 12 | ++ |
+ .spl_context = NULL,+ |
+
| 13 | ++ |
+ .N_row,+ |
+
| 14 | ++ |
+ .df_row,+ |
+
| 15 | ++ |
+ extras) {
+ |
+
| 16 | ++ |
+ # This list is always present+ |
+
| 17 | +5734x | +
+ possargs <- c(+ |
+
| 18 | +5734x | +
+ list(+ |
+
| 19 | +5734x | +
+ .N_col = .N_col,+ |
+
| 20 | +5734x | +
+ .N_total = .N_total,+ |
+
| 21 | +5734x | +
+ .N_row = .N_row,+ |
+
| 22 | +5734x | +
+ .df_row = .df_row,+ |
+
| 23 | +5734x | +
+ .all_col_exprs = .all_col_exprs,+ |
+
| 24 | +5734x | +
+ .all_col_counts = .all_col_counts+ |
+
| 25 | ++ |
+ ),+ |
+
| 26 | +5734x | +
+ extras+ |
+
| 27 | ++ |
+ )+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ ## specialized arguments that must be named in formals, cannot go+ |
+
| 30 | ++ |
+ ## anonymously into ...+ |
+
| 31 | +5734x | +
+ if (!is.null(.var) && nzchar(.var)) {
+ |
+
| 32 | +4502x | +
+ possargs <- c(possargs, list(.var = .var))+ |
+
| 33 | ++ |
+ }+ |
+
| 34 | +5734x | +
+ if (!is.null(.ref_group)) {
+ |
+
| 35 | +1797x | +
+ possargs <- c(possargs, list(.ref_group = .ref_group))+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | +5734x | +
+ if (!is.null(.alt_df_row)) {
+ |
+
| 38 | +105x | +
+ possargs <- c(possargs, list(.alt_df_row = .alt_df_row))+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | +5734x | +
+ if (!is.null(.alt_df)) {
+ |
+
| 41 | +105x | +
+ possargs <- c(possargs, list(.alt_df = .alt_df))+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | +5734x | +
+ if (!is.null(.ref_full)) {
+ |
+
| 44 | +141x | +
+ possargs <- c(possargs, list(.ref_full = .ref_full))+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | +5734x | +
+ if (!is.null(.in_ref_col)) {
+ |
+
| 47 | +141x | +
+ possargs <- c(possargs, list(.in_ref_col = .in_ref_col))+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ # Special case: .spl_context+ |
+
| 51 | +5734x | +
+ if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
+ |
+
| 52 | +5734x | +
+ possargs <- c(possargs, list(.spl_context = .spl_context))+ |
+
| 53 | ++ |
+ } else {
+ |
+
| 54 | +! | +
+ possargs$.spl_context <- NULL+ |
+
| 55 | ++ |
+ }+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # Extra args handling+ |
+
| 58 | +5734x | +
+ formargs <- formals(f)+ |
+
| 59 | +5734x | +
+ formnms <- names(formargs)+ |
+
| 60 | +5734x | +
+ exnms <- names(extras)+ |
+
| 61 | +5734x | +
+ if (is.null(formargs)) {
+ |
+
| 62 | +190x | +
+ return(NULL)+ |
+
| 63 | +5544x | +
+ } else if ("..." %in% names(formargs)) {
+ |
+
| 64 | +4842x | +
+ formnms <- c(formnms, exnms[nzchar(exnms)])+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | +5544x | +
+ possargs[names(possargs) %in% formnms]+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ #' @noRd+ |
+
| 70 | ++ |
+ #' @return A `RowsVerticalSection` object representing the `k x 1` section of the+ |
+
| 71 | ++ |
+ #' table being generated, with `k` the number of rows the analysis function+ |
+
| 72 | ++ |
+ #' generates.+ |
+
| 73 | ++ |
+ gen_onerv <- function(csub, col, count, cextr, cpath,+ |
+
| 74 | ++ |
+ dfpart, func, totcount, splextra,+ |
+
| 75 | ++ |
+ all_col_exprs,+ |
+
| 76 | ++ |
+ all_col_counts,+ |
+
| 77 | ++ |
+ takesdf = .takes_df(func),+ |
+
| 78 | ++ |
+ baselinedf,+ |
+
| 79 | ++ |
+ alt_dfpart,+ |
+
| 80 | ++ |
+ inclNAs,+ |
+
| 81 | ++ |
+ col_parent_inds,+ |
+
| 82 | ++ |
+ spl_context) {
+ |
+
| 83 | +5734x | +
+ if (NROW(spl_context) > 0) {
+ |
+
| 84 | +5713x | +
+ spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".")+ |
+
| 85 | +5713x | +
+ spl_context$cur_col_subset <- col_parent_inds+ |
+
| 86 | +5713x | +
+ spl_context$cur_col_expr <- list(csub)+ |
+
| 87 | +5713x | +
+ spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L)+ |
+
| 88 | +5713x | +
+ spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)])+ |
+
| 89 | +5713x | +
+ spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)])+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ # Making .alt_df from alt_dfpart (i.e. .alt_df_row)+ |
+
| 93 | +5734x | +
+ if (NROW(alt_dfpart) > 0) {
+ |
+
| 94 | +105x | +
+ alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE]+ |
+
| 95 | +105x | +
+ if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
+ |
+
| 96 | +99x | +
+ alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), ,+ |
+
| 97 | +99x | +
+ drop = FALSE+ |
+
| 98 | ++ |
+ ]+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | ++ |
+ } else {
+ |
+
| 101 | +5629x | +
+ alt_dfpart_fil <- alt_dfpart+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ ## workaround for https://github.com/insightsengineering/rtables/issues/159+ |
+
| 105 | +5734x | +
+ if (NROW(dfpart) > 0) {
+ |
+
| 106 | +4882x | +
+ inds <- eval(csub, envir = dfpart)+ |
+
| 107 | +4882x | +
+ dat <- dfpart[inds, , drop = FALSE]+ |
+
| 108 | ++ |
+ } else {
+ |
+
| 109 | +852x | +
+ dat <- dfpart+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | +5734x | +
+ if (!is.null(col) && !inclNAs) {
+ |
+
| 112 | +4476x | +
+ dat <- dat[!is.na(dat[[col]]), , drop = FALSE]+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ | + + | +
| 115 | +5734x | +
+ fullrefcoldat <- cextr$.ref_full+ |
+
| 116 | +5734x | +
+ if (!is.null(fullrefcoldat)) {
+ |
+
| 117 | +141x | +
+ cextr$.ref_full <- NULL+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | +5734x | +
+ inrefcol <- cextr$.in_ref_col+ |
+
| 120 | +5734x | +
+ if (!is.null(fullrefcoldat)) {
+ |
+
| 121 | +141x | +
+ cextr$.in_ref_col <- NULL+ |
+
| 122 | ++ |
+ }+ |
+
| 123 | ++ | + + | +
| 124 | +5734x | +
+ exargs <- c(cextr, splextra)+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ ## behavior for x/df and ref-data (full and group)+ |
+
| 127 | ++ |
+ ## match+ |
+
| 128 | +5734x | +
+ if (!is.null(col) && !takesdf) {
+ |
+
| 129 | +3583x | +
+ dat <- dat[[col]]+ |
+
| 130 | +3583x | +
+ fullrefcoldat <- fullrefcoldat[[col]]+ |
+
| 131 | +3583x | +
+ baselinedf <- baselinedf[[col]]+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | +5734x | +
+ args <- list(dat)+ |
+
| 134 | ++ | + + | +
| 135 | +5734x | +
+ names(all_col_counts) <- names(all_col_exprs)+ |
+
| 136 | ++ | + + | +
| 137 | +5734x | +
+ exargs <- match_extra_args(func,+ |
+
| 138 | +5734x | +
+ .N_col = count,+ |
+
| 139 | +5734x | +
+ .N_total = totcount,+ |
+
| 140 | +5734x | +
+ .all_col_exprs = all_col_exprs,+ |
+
| 141 | +5734x | +
+ .all_col_counts = all_col_counts,+ |
+
| 142 | +5734x | +
+ .var = col,+ |
+
| 143 | +5734x | +
+ .ref_group = baselinedf,+ |
+
| 144 | +5734x | +
+ .alt_df_row = alt_dfpart,+ |
+
| 145 | +5734x | +
+ .alt_df = alt_dfpart_fil,+ |
+
| 146 | +5734x | +
+ .ref_full = fullrefcoldat,+ |
+
| 147 | +5734x | +
+ .in_ref_col = inrefcol,+ |
+
| 148 | +5734x | +
+ .N_row = NROW(dfpart),+ |
+
| 149 | +5734x | +
+ .df_row = dfpart,+ |
+
| 150 | +5734x | +
+ .spl_context = spl_context,+ |
+
| 151 | +5734x | +
+ extras = c(+ |
+
| 152 | +5734x | +
+ cextr,+ |
+
| 153 | +5734x | +
+ splextra+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | ++ | + + | +
| 157 | +5734x | +
+ args <- c(args, exargs)+ |
+
| 158 | ++ | + + | +
| 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 | ++ |
+ }+ |
+
| 164 | +3732x | +
+ ret <- in_rows(+ |
+
| 165 | +3732x | +
+ .list = val,+ |
+
| 166 | +3732x | +
+ .labels = unlist(value_labels(val)),+ |
+
| 167 | +3732x | +
+ .names = names(val)+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ |
+ } else {
+ |
+
| 170 | +1999x | +
+ ret <- val+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | +5731x | +
+ ret+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ | + + | +
| 175 | ++ |
+ strip_multivar_suffix <- function(x) {
+ |
+
| 176 | +228x | +
+ gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | ++ | + + | +
| 179 | ++ |
+ ## Generate all values (one for each column) for one or more rows+ |
+
| 180 | ++ |
+ ## by calling func once per column (as defined by cinfo)+ |
+
| 181 | ++ |
+ #' @noRd+ |
+
| 182 | ++ |
+ #' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table.+ |
+
| 183 | ++ |
+ gen_rowvalues <- function(dfpart,+ |
+
| 184 | ++ |
+ datcol,+ |
+
| 185 | ++ |
+ cinfo,+ |
+
| 186 | ++ |
+ func,+ |
+
| 187 | ++ |
+ splextra,+ |
+
| 188 | ++ |
+ takesdf = NULL,+ |
+
| 189 | ++ |
+ baselines,+ |
+
| 190 | ++ |
+ alt_dfpart,+ |
+
| 191 | ++ |
+ inclNAs,+ |
+
| 192 | ++ |
+ spl_context = spl_context) {
+ |
+
| 193 | +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)+ |
+
| 197 | ++ |
+ ## XXX I don't think this is used anywhere???+ |
+
| 198 | ++ |
+ ## splextra = c(splextra, list(.spl_context = spl_context))+ |
+
| 199 | +1571x | +
+ totcount <- col_total(cinfo)+ |
+
| 200 | ++ | + + | +
| 201 | +1571x | +
+ colleaves <- collect_leaves(cinfo@tree_layout)+ |
+
| 202 | ++ | + + | +
| 203 | +1571x | +
+ gotflist <- is.list(func)+ |
+
| 204 | ++ | + + | +
| 205 | ++ |
+ ## one set of named args to be applied to all columns+ |
+
| 206 | +1571x | +
+ if (!is.null(names(splextra))) {
+ |
+
| 207 | +25x | +
+ splextra <- list(splextra)+ |
+
| 208 | ++ |
+ } else {
+ |
+
| 209 | +1546x | +
+ length(splextra) <- ncol(cinfo)+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | ++ | + + | +
| 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 | ++ |
+ }+ |
+
| 217 | ++ |
+ ## if(length(func)) == 1 && names(spl)+ |
+
| 218 | ++ |
+ ## splextra = list(splextra)+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ ## we are in analyze_colvars, so we have to match+ |
+
| 221 | ++ |
+ ## the exargs value by position for each column repeatedly+ |
+
| 222 | ++ |
+ ## across the higher level col splits.+ |
+
| 223 | +1571x | +
+ if (!is.null(datcol) && is.na(datcol)) {
+ |
+
| 224 | +54x | +
+ datcol <- character(length(colleaves))+ |
+
| 225 | +54x | +
+ exargs <- vector("list", length(colleaves))
+ |
+
| 226 | +54x | +
+ for (i in seq_along(colleaves)) {
+ |
+
| 227 | +228x | +
+ x <- colleaves[[i]]+ |
+
| 228 | ++ | + + | +
| 229 | +228x | +
+ pos <- tree_pos(x)+ |
+
| 230 | +228x | +
+ spls <- pos_splits(pos)+ |
+
| 231 | ++ |
+ ## values have the suffix but we are populating datacol+ |
+
| 232 | ++ |
+ ## so it has to match var numbers so strip the suffixes back off+ |
+
| 233 | +228x | +
+ splvals <- strip_multivar_suffix(rawvalues(pos))+ |
+
| 234 | +228x | +
+ n <- length(spls)+ |
+
| 235 | +228x | +
+ datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
+ |
+
| 236 | +228x | +
+ splvals[n]+ |
+
| 237 | ++ |
+ } else {
+ |
+
| 238 | +228x | +
+ NA_character_+ |
+
| 239 | ++ |
+ }+ |
+
| 240 | +228x | +
+ argpos <- match(datcol[i], spl_payload(spls[[n]]))+ |
+
| 241 | ++ |
+ ## single bracket here because assigning NULL into a list removes+ |
+
| 242 | ++ |
+ ## the position entirely+ |
+
| 243 | +228x | +
+ exargs[i] <- if (argpos <= length(splextra)) {
+ |
+
| 244 | +228x | +
+ splextra[argpos]+ |
+
| 245 | ++ |
+ } else {
+ |
+
| 246 | +! | +
+ list(NULL)+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | ++ |
+ }+ |
+
| 249 | ++ |
+ ## })+ |
+
| 250 | +54x | +
+ if (all(is.na(datcol))) {
+ |
+
| 251 | +! | +
+ datcol <- list(NULL)+ |
+
| 252 | +54x | +
+ } else if (any(is.na(datcol))) {
+ |
+
| 253 | +! | +
+ stop("mix of var and non-var columns with NA analysis rowvara")
+ |
+
| 254 | ++ |
+ }+ |
+
| 255 | ++ |
+ } else {
+ |
+
| 256 | +1517x | +
+ exargs <- splextra+ |
+
| 257 | +1517x | +
+ if (is.null(datcol)) {
+ |
+
| 258 | +332x | +
+ datcol <- list(NULL)+ |
+
| 259 | ++ |
+ }+ |
+
| 260 | +1517x | +
+ datcol <- rep(datcol, length(colexprs))+ |
+
| 261 | ++ |
+ ## if(gotflist)+ |
+
| 262 | ++ |
+ ## length(exargs) <- length(func) ## func is a list+ |
+
| 263 | +1517x | +
+ exargs <- rep(exargs, length.out = length(colexprs))+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | +1571x | +
+ allfuncs <- rep(func, length.out = length(colexprs))+ |
+
| 266 | ++ | + + | +
| 267 | +1571x | +
+ if (is.null(takesdf)) {
+ |
+
| 268 | +1102x | +
+ takesdf <- .takes_df(allfuncs)+ |
+
| 269 | ++ |
+ }+ |
+
| 270 | ++ | + + | +
| 271 | +1571x | +
+ rawvals <- mapply(gen_onerv,+ |
+
| 272 | +1571x | +
+ csub = colexprs,+ |
+
| 273 | +1571x | +
+ col = datcol,+ |
+
| 274 | +1571x | +
+ count = colcounts,+ |
+
| 275 | +1571x | +
+ cextr = colextras,+ |
+
| 276 | +1571x | +
+ cpath = cpaths,+ |
+
| 277 | +1571x | +
+ baselinedf = baselines,+ |
+
| 278 | +1571x | +
+ alt_dfpart = list(alt_dfpart),+ |
+
| 279 | +1571x | +
+ func = allfuncs,+ |
+
| 280 | +1571x | +
+ takesdf = takesdf,+ |
+
| 281 | +1571x | +
+ col_parent_inds = spl_context[, names(colexprs),+ |
+
| 282 | +1571x | +
+ drop = FALSE+ |
+
| 283 | ++ |
+ ],+ |
+
| 284 | +1571x | +
+ all_col_exprs = list(colexprs),+ |
+
| 285 | +1571x | +
+ all_col_counts = list(colcounts),+ |
+
| 286 | +1571x | +
+ splextra = exargs,+ |
+
| 287 | +1571x | +
+ MoreArgs = list(+ |
+
| 288 | +1571x | +
+ dfpart = dfpart,+ |
+
| 289 | +1571x | +
+ totcount = totcount,+ |
+
| 290 | +1571x | +
+ inclNAs = inclNAs,+ |
+
| 291 | +1571x | +
+ spl_context = spl_context+ |
+
| 292 | ++ |
+ ),+ |
+
| 293 | +1571x | +
+ SIMPLIFY = FALSE+ |
+
| 294 | ++ |
+ )+ |
+
| 295 | ++ | + + | +
| 296 | +1568x | +
+ names(rawvals) <- names(colexprs)+ |
+
| 297 | +1568x | +
+ rawvals+ |
+
| 298 | ++ |
+ }+ |
+
| 299 | ++ | + + | +
| 300 | ++ |
+ .strip_lst_rvals <- function(lst) {
+ |
+
| 301 | +! | +
+ lapply(lst, rawvalues)+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | ++ |
+ #' @noRd+ |
+
| 305 | ++ |
+ #' @return A list of table rows, even when only one is generated.+ |
+
| 306 | ++ |
+ .make_tablerows <- function(dfpart,+ |
+
| 307 | ++ |
+ alt_dfpart,+ |
+
| 308 | ++ |
+ func,+ |
+
| 309 | ++ |
+ cinfo,+ |
+
| 310 | ++ |
+ datcol = NULL,+ |
+
| 311 | ++ |
+ lev = 1L,+ |
+
| 312 | ++ |
+ rvlab = NA_character_,+ |
+
| 313 | ++ |
+ format = NULL,+ |
+
| 314 | ++ |
+ defrowlabs = NULL,+ |
+
| 315 | ++ |
+ rowconstr = DataRow,+ |
+
| 316 | ++ |
+ splextra = list(),+ |
+
| 317 | ++ |
+ takesdf = NULL,+ |
+
| 318 | ++ |
+ baselines = replicate(+ |
+
| 319 | ++ |
+ length(col_exprs(cinfo)),+ |
+
| 320 | ++ |
+ list(dfpart[0, ])+ |
+
| 321 | ++ |
+ ),+ |
+
| 322 | ++ |
+ inclNAs,+ |
+
| 323 | ++ |
+ spl_context = context_df_row(cinfo = cinfo)) {
+ |
+
| 324 | +1571x | +
+ if (is.null(datcol) && !is.na(rvlab)) {
+ |
+
| 325 | +! | +
+ stop("NULL datcol but non-na rowvar label")
+ |
+
| 326 | ++ |
+ }+ |
+
| 327 | +1571x | +
+ if (!is.null(datcol) && !is.na(datcol)) {
+ |
+
| 328 | +1185x | +
+ if (!all(datcol %in% names(dfpart))) {
+ |
+
| 329 | +! | +
+ stop(+ |
+
| 330 | +! | +
+ "specified analysis variable (", datcol,
+ |
+
| 331 | +! | +
+ ") not present in data"+ |
+
| 332 | ++ |
+ )+ |
+
| 333 | ++ |
+ }+ |
+
| 334 | ++ | + + | +
| 335 | +1185x | +
+ rowvar <- datcol+ |
+
| 336 | ++ |
+ } else {
+ |
+
| 337 | +386x | +
+ rowvar <- NA_character_+ |
+
| 338 | ++ |
+ }+ |
+
| 339 | ++ | + + | +
| 340 | +1571x | +
+ rawvals <- gen_rowvalues(dfpart,+ |
+
| 341 | +1571x | +
+ alt_dfpart = alt_dfpart,+ |
+
| 342 | +1571x | +
+ datcol = datcol,+ |
+
| 343 | +1571x | +
+ cinfo = cinfo,+ |
+
| 344 | +1571x | +
+ func = func,+ |
+
| 345 | +1571x | +
+ splextra = splextra,+ |
+
| 346 | +1571x | +
+ takesdf = takesdf,+ |
+
| 347 | +1571x | +
+ baselines = baselines,+ |
+
| 348 | +1571x | +
+ inclNAs = inclNAs,+ |
+
| 349 | +1571x | +
+ spl_context = spl_context+ |
+
| 350 | ++ |
+ )+ |
+
| 351 | ++ | + + | +
| 352 | ++ |
+ ## if(is.null(rvtypes))+ |
+
| 353 | ++ |
+ ## rvtypes = rep(NA_character_, length(rawvals))+ |
+
| 354 | +1568x | +
+ lens <- vapply(rawvals, length, NA_integer_)+ |
+
| 355 | +1568x | +
+ unqlens <- unique(lens)+ |
+
| 356 | ++ |
+ ## length 0 returns are ok to not match cause they are+ |
+
| 357 | ++ |
+ ## just empty space we can fill in as needed.+ |
+
| 358 | +1568x | +
+ if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
+ |
+
| 359 | ++ |
+ ## (0 %in% unqlens && length(unqlens) != 2)) {
+ |
+
| 360 | +1x | +
+ stop(+ |
+
| 361 | +1x | +
+ "Number of rows generated by analysis function do not match ",+ |
+
| 362 | +1x | +
+ "across all columns. ",+ |
+
| 363 | +1x | +
+ if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
+ |
+
| 364 | +! | +
+ paste(+ |
+
| 365 | +! | +
+ "\nPerhaps convert analysis variable", datcol,+ |
+
| 366 | +! | +
+ "to a factor?"+ |
+
| 367 | ++ |
+ )+ |
+
| 368 | ++ |
+ }+ |
+
| 369 | ++ |
+ )+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | +1567x | +
+ maxind <- match(max(unqlens), lens)+ |
+
| 372 | ++ | + + | +
| 373 | ++ |
+ ## look if we got labels, if not apply the+ |
+
| 374 | ++ |
+ ## default row labels+ |
+
| 375 | ++ |
+ ## this is guaranteed to be a RowsVerticalSection object.+ |
+
| 376 | +1567x | +
+ rv1col <- rawvals[[maxind]]+ |
+
| 377 | ++ |
+ ## nocov start+ |
+
| 378 | ++ |
+ if (!is(rv1col, "RowsVerticalSection")) {
+ |
+
| 379 | ++ |
+ stop(+ |
+
| 380 | ++ |
+ "gen_rowvalues appears to have generated something that was not ",+ |
+
| 381 | ++ |
+ "a RowsVerticalSection object. Please contact the maintainer."+ |
+
| 382 | ++ |
+ )+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ |
+ # nocov end+ |
+
| 385 | ++ | + + | +
| 386 | +1567x | +
+ labels <- value_labels(rv1col)+ |
+
| 387 | ++ | + + | +
| 388 | +1567x | +
+ ncrows <- max(unqlens)+ |
+
| 389 | +1567x | +
+ if (ncrows == 0) {
+ |
+
| 390 | +! | +
+ return(list())+ |
+
| 391 | ++ |
+ }+ |
+
| 392 | +1567x | +
+ stopifnot(ncrows > 0)+ |
+
| 393 | ++ | + + | +
| 394 | +1567x | +
+ if (is.null(labels)) {
+ |
+
| 395 | +207x | +
+ if (length(rawvals[[maxind]]) == length(defrowlabs)) {
+ |
+
| 396 | +199x | +
+ labels <- defrowlabs+ |
+
| 397 | ++ |
+ } else {
+ |
+
| 398 | +8x | +
+ labels <- rep("", ncrows)
+ |
+
| 399 | ++ |
+ }+ |
+
| 400 | ++ |
+ }+ |
+
| 401 | ++ | + + | +
| 402 | +1567x | +
+ rfootnotes <- rep(list(list(), length(rv1col)))+ |
+
| 403 | +1567x | +
+ nms <- value_names(rv1col)+ |
+
| 404 | +1567x | +
+ rfootnotes <- row_footnotes(rv1col)+ |
+
| 405 | ++ | + + | +
| 406 | +1567x | +
+ imods <- indent_mod(rv1col) ## rv1col@indent_mods+ |
+
| 407 | +1567x | +
+ unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE)+ |
+
| 408 | ++ | + + | +
| 409 | +1567x | +
+ formatvec <- NULL+ |
+
| 410 | +1567x | +
+ if (!is.null(format)) {
+ |
+
| 411 | +200x | +
+ if (is.function(format)) {
+ |
+
| 412 | +1x | +
+ format <- list(format)+ |
+
| 413 | ++ |
+ }+ |
+
| 414 | +200x | +
+ formatvec <- rep(format, length.out = ncrows)+ |
+
| 415 | ++ |
+ }+ |
+
| 416 | ++ | + + | +
| 417 | +1567x | +
+ trows <- lapply(1:ncrows, function(i) {
+ |
+
| 418 | +2532x | +
+ rowvals <- lapply(unwrapped_vals, function(colvals) {
+ |
+
| 419 | +9046x | +
+ colvals[[i]]+ |
+
| 420 | ++ |
+ })+ |
+
| 421 | +2532x | +
+ imod <- unique(vapply(rowvals, indent_mod, 0L))+ |
+
| 422 | +2532x | +
+ if (length(imod) != 1) {
+ |
+
| 423 | +! | +
+ stop(+ |
+
| 424 | +! | +
+ "Different cells in the same row appear to have been given ",+ |
+
| 425 | +! | +
+ "different indent_mod values"+ |
+
| 426 | ++ |
+ )+ |
+
| 427 | ++ |
+ }+ |
+
| 428 | +2532x | +
+ rowconstr(+ |
+
| 429 | +2532x | +
+ vals = rowvals,+ |
+
| 430 | +2532x | +
+ cinfo = cinfo,+ |
+
| 431 | +2532x | +
+ lev = lev,+ |
+
| 432 | +2532x | +
+ label = labels[i],+ |
+
| 433 | +2532x | +
+ name = nms[i], ## labels[i], ## XXX this is probably wrong?!+ |
+
| 434 | +2532x | +
+ var = rowvar,+ |
+
| 435 | +2532x | +
+ format = formatvec[[i]],+ |
+
| 436 | +2532x | +
+ indent_mod = imods[[i]] %||% 0L,+ |
+
| 437 | +2532x | +
+ footnotes = rfootnotes[[i]] ## one bracket so list+ |
+
| 438 | ++ |
+ )+ |
+
| 439 | ++ |
+ })+ |
+
| 440 | +1567x | +
+ trows+ |
+
| 441 | ++ |
+ }+ |
+
| 442 | ++ | + + | +
| 443 | ++ |
+ .make_caller <- function(parent_cfun, clabelstr = "") {
+ |
+
| 444 | +480x | +
+ formalnms <- names(formals(parent_cfun))+ |
+
| 445 | ++ |
+ ## note the <- here+ |
+
| 446 | +480x | +
+ if (!is.na(dotspos <- match("...", formalnms))) {
+ |
+
| 447 | +1x | +
+ toremove <- dotspos+ |
+
| 448 | ++ |
+ } else {
+ |
+
| 449 | +479x | +
+ toremove <- NULL+ |
+
| 450 | ++ |
+ }+ |
+
| 451 | ++ | + + | +
| 452 | +480x | +
+ labelstrpos <- match("labelstr", names(formals(parent_cfun)))
+ |
+
| 453 | +480x | +
+ if (is.na(labelstrpos)) {
+ |
+
| 454 | +! | +
+ stop(+ |
+
| 455 | +! | +
+ "content function does not appear to accept the labelstr",+ |
+
| 456 | +! | +
+ "arguent"+ |
+
| 457 | ++ |
+ )+ |
+
| 458 | ++ |
+ }+ |
+
| 459 | +480x | +
+ toremove <- c(toremove, labelstrpos)+ |
+
| 460 | +480x | +
+ formalnms <- formalnms[-1 * toremove]+ |
+
| 461 | ++ | + + | +
| 462 | +480x | +
+ caller <- eval(parser_helper(text = paste(+ |
+
| 463 | +480x | +
+ "function() { parent_cfun(",
+ |
+
| 464 | +480x | +
+ paste(formalnms, "=",+ |
+
| 465 | +480x | +
+ formalnms,+ |
+
| 466 | +480x | +
+ collapse = ", "+ |
+
| 467 | ++ |
+ ),+ |
+
| 468 | +480x | +
+ ", labelstr = clabelstr, ...)}"+ |
+
| 469 | ++ |
+ )))+ |
+
| 470 | +480x | +
+ formals(caller) <- c(+ |
+
| 471 | +480x | +
+ formals(parent_cfun)[-labelstrpos],+ |
+
| 472 | +480x | +
+ alist("..." = )
+ |
+
| 473 | +480x | +
+ ) # nolint+ |
+
| 474 | +480x | +
+ caller+ |
+
| 475 | ++ |
+ }+ |
+
| 476 | ++ | + + | +
| 477 | ++ |
+ # Makes content table xxx renaming+ |
+
| 478 | ++ |
+ .make_ctab <- function(df,+ |
+
| 479 | ++ |
+ lvl, ## treepos,+ |
+
| 480 | ++ |
+ name,+ |
+
| 481 | ++ |
+ label,+ |
+
| 482 | ++ |
+ cinfo,+ |
+
| 483 | ++ |
+ parent_cfun = NULL,+ |
+
| 484 | ++ |
+ format = NULL,+ |
+
| 485 | ++ |
+ na_str = NA_character_,+ |
+
| 486 | ++ |
+ indent_mod = 0L,+ |
+
| 487 | ++ |
+ cvar = NULL,+ |
+
| 488 | ++ |
+ inclNAs,+ |
+
| 489 | ++ |
+ alt_df,+ |
+
| 490 | ++ |
+ extra_args,+ |
+
| 491 | ++ |
+ spl_context = context_df_row(cinfo = cinfo)) {
+ |
+
| 492 | +1834x | +
+ if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
+ |
+
| 493 | +1665x | +
+ cvar <- NULL+ |
+
| 494 | ++ |
+ }+ |
+
| 495 | +1834x | +
+ if (!is.null(parent_cfun)) {
+ |
+
| 496 | ++ |
+ ## cfunc <- .make_caller(parent_cfun, label)+ |
+
| 497 | +469x | +
+ cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label)+ |
+
| 498 | +469x | +
+ contkids <- tryCatch(+ |
+
| 499 | +469x | +
+ .make_tablerows(df,+ |
+
| 500 | +469x | +
+ lev = lvl,+ |
+
| 501 | +469x | +
+ func = cfunc,+ |
+
| 502 | +469x | +
+ cinfo = cinfo,+ |
+
| 503 | +469x | +
+ rowconstr = ContentRow,+ |
+
| 504 | +469x | +
+ datcol = cvar,+ |
+
| 505 | +469x | +
+ takesdf = rep(.takes_df(cfunc),+ |
+
| 506 | +469x | +
+ length.out = ncol(cinfo)+ |
+
| 507 | ++ |
+ ),+ |
+
| 508 | +469x | +
+ inclNAs = FALSE,+ |
+
| 509 | +469x | +
+ alt_dfpart = alt_df,+ |
+
| 510 | +469x | +
+ splextra = extra_args,+ |
+
| 511 | +469x | +
+ spl_context = spl_context+ |
+
| 512 | ++ |
+ ),+ |
+
| 513 | +469x | +
+ error = function(e) e+ |
+
| 514 | ++ |
+ )+ |
+
| 515 | +469x | +
+ if (is(contkids, "error")) {
+ |
+
| 516 | +1x | +
+ stop("Error in content (summary) function: ", contkids$message,
+ |
+
| 517 | +1x | +
+ "\n\toccured at path: ",+ |
+
| 518 | +1x | +
+ spl_context_to_disp_path(spl_context),+ |
+
| 519 | +1x | +
+ call. = FALSE+ |
+
| 520 | ++ |
+ )+ |
+
| 521 | ++ |
+ }+ |
+
| 522 | ++ |
+ } else {
+ |
+
| 523 | +1365x | +
+ contkids <- list()+ |
+
| 524 | ++ |
+ }+ |
+
| 525 | +1833x | +
+ ctab <- ElementaryTable(+ |
+
| 526 | +1833x | +
+ kids = contkids,+ |
+
| 527 | +1833x | +
+ name = paste0(name, "@content"),+ |
+
| 528 | +1833x | +
+ lev = lvl,+ |
+
| 529 | +1833x | +
+ labelrow = LabelRow(),+ |
+
| 530 | +1833x | +
+ cinfo = cinfo,+ |
+
| 531 | +1833x | +
+ iscontent = TRUE,+ |
+
| 532 | +1833x | +
+ format = format,+ |
+
| 533 | +1833x | +
+ indent_mod = indent_mod,+ |
+
| 534 | +1833x | +
+ na_str = na_str+ |
+
| 535 | ++ |
+ )+ |
+
| 536 | +1833x | +
+ ctab+ |
+
| 537 | ++ |
+ }+ |
+
| 538 | ++ | + + | +
| 539 | ++ |
+ .make_analyzed_tab <- function(df,+ |
+
| 540 | ++ |
+ alt_df,+ |
+
| 541 | ++ |
+ spl,+ |
+
| 542 | ++ |
+ cinfo,+ |
+
| 543 | ++ |
+ partlabel = "",+ |
+
| 544 | ++ |
+ dolab = TRUE,+ |
+
| 545 | ++ |
+ lvl,+ |
+
| 546 | ++ |
+ baselines,+ |
+
| 547 | ++ |
+ spl_context) {
+ |
+
| 548 | +1103x | +
+ stopifnot(is(spl, "VAnalyzeSplit"))+ |
+
| 549 | +1103x | +
+ check_validsplit(spl, df)+ |
+
| 550 | +1102x | +
+ defrlabel <- spl@default_rowlabel+ |
+
| 551 | +1102x | +
+ if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
+ |
+
| 552 | +! | +
+ defrlabel <- partlabel+ |
+
| 553 | ++ |
+ }+ |
+
| 554 | +1102x | +
+ kids <- tryCatch(+ |
+
| 555 | +1102x | +
+ .make_tablerows(df,+ |
+
| 556 | +1102x | +
+ func = analysis_fun(spl),+ |
+
| 557 | +1102x | +
+ defrowlabs = defrlabel, # XXX+ |
+
| 558 | +1102x | +
+ cinfo = cinfo,+ |
+
| 559 | +1102x | +
+ datcol = spl_payload(spl),+ |
+
| 560 | +1102x | +
+ lev = lvl + 1L,+ |
+
| 561 | +1102x | +
+ format = obj_format(spl),+ |
+
| 562 | +1102x | +
+ splextra = split_exargs(spl),+ |
+
| 563 | +1102x | +
+ baselines = baselines,+ |
+
| 564 | +1102x | +
+ alt_dfpart = alt_df,+ |
+
| 565 | +1102x | +
+ inclNAs = avar_inclNAs(spl),+ |
+
| 566 | +1102x | +
+ spl_context = spl_context+ |
+
| 567 | ++ |
+ ),+ |
+
| 568 | +1102x | +
+ error = function(e) e+ |
+
| 569 | ++ |
+ )+ |
+
| 570 | ++ | + + | +
| 571 | ++ |
+ # Adding section_div for DataRows (analyze leaves)+ |
+
| 572 | +1102x | +
+ kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow")+ |
+
| 573 | ++ | + + | +
| 574 | +1102x | +
+ if (is(kids, "error")) {
+ |
+
| 575 | +3x | +
+ stop("Error applying analysis function (var - ",
+ |
+
| 576 | +3x | +
+ spl_payload(spl) %||% "colvars", "): ", kids$message,+ |
+
| 577 | +3x | +
+ "\n\toccured at (row) path: ",+ |
+
| 578 | +3x | +
+ spl_context_to_disp_path(spl_context),+ |
+
| 579 | +3x | +
+ call. = FALSE+ |
+
| 580 | ++ |
+ )+ |
+
| 581 | ++ |
+ }+ |
+
| 582 | +1099x | +
+ lab <- obj_label(spl)+ |
+
| 583 | +1099x | +
+ ret <- TableTree(+ |
+
| 584 | +1099x | +
+ kids = kids,+ |
+
| 585 | +1099x | +
+ name = obj_name(spl),+ |
+
| 586 | +1099x | +
+ label = lab,+ |
+
| 587 | +1099x | +
+ lev = lvl,+ |
+
| 588 | +1099x | +
+ cinfo = cinfo,+ |
+
| 589 | +1099x | +
+ format = obj_format(spl),+ |
+
| 590 | +1099x | +
+ na_str = obj_na_str(spl),+ |
+
| 591 | +1099x | +
+ indent_mod = indent_mod(spl)+ |
+
| 592 | ++ |
+ )+ |
+
| 593 | ++ | + + | +
| 594 | +1099x | +
+ labelrow_visible(ret) <- dolab+ |
+
| 595 | +1099x | +
+ ret+ |
+
| 596 | ++ |
+ }+ |
+
| 597 | ++ | + + | +
| 598 | ++ |
+ #' @param ... all arguments to `recurse_applysplit`, methods may only use some of them.+ |
+
| 599 | ++ |
+ #' @return A `list` of children to place at this level.+ |
+
| 600 | ++ |
+ #'+ |
+
| 601 | ++ |
+ #' @noRd+ |
+
| 602 | ++ |
+ setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
+ |
+
| 603 | +1626x | +
+ standardGeneric(".make_split_kids")
+ |
+
| 604 | ++ |
+ })+ |
+
| 605 | ++ | + + | +
| 606 | ++ |
+ ## single AnalyzeSplit+ |
+
| 607 | ++ |
+ setMethod(+ |
+
| 608 | ++ |
+ ".make_split_kids", "VAnalyzeSplit",+ |
+
| 609 | ++ |
+ function(spl,+ |
+
| 610 | ++ |
+ have_controws, ## unused here+ |
+
| 611 | ++ |
+ make_lrow, ## unused here+ |
+
| 612 | ++ |
+ ...,+ |
+
| 613 | ++ |
+ df,+ |
+
| 614 | ++ |
+ alt_df,+ |
+
| 615 | ++ |
+ lvl,+ |
+
| 616 | ++ |
+ name,+ |
+
| 617 | ++ |
+ cinfo,+ |
+
| 618 | ++ |
+ baselines,+ |
+
| 619 | ++ |
+ spl_context,+ |
+
| 620 | ++ |
+ nsibs = 0) {
+ |
+
| 621 | +1103x | +
+ spvis <- labelrow_visible(spl)+ |
+
| 622 | +1103x | +
+ if (is.na(spvis)) {
+ |
+
| 623 | +182x | +
+ spvis <- nsibs > 0+ |
+
| 624 | ++ |
+ }+ |
+
| 625 | ++ | + + | +
| 626 | +1103x | +
+ ret <- .make_analyzed_tab(+ |
+
| 627 | +1103x | +
+ df = df,+ |
+
| 628 | +1103x | +
+ alt_df,+ |
+
| 629 | +1103x | +
+ spl = spl,+ |
+
| 630 | +1103x | +
+ cinfo = cinfo,+ |
+
| 631 | +1103x | +
+ lvl = lvl + 1L,+ |
+
| 632 | +1103x | +
+ dolab = spvis,+ |
+
| 633 | +1103x | +
+ partlabel = obj_label(spl),+ |
+
| 634 | +1103x | +
+ baselines = baselines,+ |
+
| 635 | +1103x | +
+ spl_context = spl_context+ |
+
| 636 | ++ |
+ )+ |
+
| 637 | +1099x | +
+ indent_mod(ret) <- indent_mod(spl)+ |
+
| 638 | ++ | + + | +
| 639 | +1099x | +
+ kids <- list(ret)+ |
+
| 640 | +1099x | +
+ names(kids) <- obj_name(ret)+ |
+
| 641 | +1099x | +
+ kids+ |
+
| 642 | ++ |
+ }+ |
+
| 643 | ++ |
+ )+ |
+
| 644 | ++ | + + | +
| 645 | ++ |
+ # Adding section_divisors to TableRow+ |
+
| 646 | ++ |
+ .set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
+ |
+
| 647 | +1599x | +
+ if (!is.na(trailing_section_div_char)) {
+ |
+
| 648 | +29x | +
+ lst <- lapply(+ |
+
| 649 | +29x | +
+ lst,+ |
+
| 650 | +29x | +
+ function(k) {
+ |
+
| 651 | +70x | +
+ if (is(k, allowed_class)) {
+ |
+
| 652 | +70x | +
+ trailing_section_div(k) <- trailing_section_div_char+ |
+
| 653 | ++ |
+ }+ |
+
| 654 | +70x | +
+ k+ |
+
| 655 | ++ |
+ }+ |
+
| 656 | ++ |
+ )+ |
+
| 657 | ++ |
+ }+ |
+
| 658 | +1599x | +
+ lst+ |
+
| 659 | ++ |
+ }+ |
+
| 660 | ++ | + + | +
| 661 | ++ |
+ ## 1 or more AnalyzeSplits+ |
+
| 662 | ++ |
+ setMethod(+ |
+
| 663 | ++ |
+ ".make_split_kids", "AnalyzeMultiVars",+ |
+
| 664 | ++ |
+ function(spl,+ |
+
| 665 | ++ |
+ have_controws,+ |
+
| 666 | ++ |
+ make_lrow, ## used here+ |
+
| 667 | ++ |
+ spl_context,+ |
+
| 668 | ++ |
+ ...) { ## all passed directly down to VAnalyzeSplit method
+ |
+
| 669 | +98x | +
+ avspls <- spl_payload(spl)+ |
+
| 670 | ++ | + + | +
| 671 | +98x | +
+ nspl <- length(avspls)+ |
+
| 672 | ++ | + + | +
| 673 | +98x | +
+ kids <- unlist(lapply(avspls,+ |
+
| 674 | +98x | +
+ .make_split_kids,+ |
+
| 675 | +98x | +
+ nsibs = nspl - 1,+ |
+
| 676 | +98x | +
+ have_controws = have_controws,+ |
+
| 677 | +98x | +
+ make_lrow = make_lrow,+ |
+
| 678 | +98x | +
+ spl_context = spl_context,+ |
+
| 679 | ++ |
+ ...+ |
+
| 680 | ++ |
+ ))+ |
+
| 681 | ++ | + + | +
| 682 | +98x | +
+ kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree")+ |
+
| 683 | ++ | + + | +
| 684 | ++ |
+ ## XXX this seems like it should be identical not !identical+ |
+
| 685 | ++ |
+ ## TODO FIXME+ |
+
| 686 | +98x | +
+ if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
+ |
+
| 687 | ++ |
+ ## we only analyzed one var so+ |
+
| 688 | ++ |
+ ## we don't need an extra wrapper table+ |
+
| 689 | ++ |
+ ## in the structure+ |
+
| 690 | +! | +
+ stopifnot(identical(+ |
+
| 691 | +! | +
+ obj_name(kids[[1]]),+ |
+
| 692 | +! | +
+ spl_payload(spl)+ |
+
| 693 | ++ |
+ ))+ |
+
| 694 | +! | +
+ return(kids[[1]])+ |
+
| 695 | ++ |
+ }+ |
+
| 696 | ++ |
+ ## this will be the variables+ |
+
| 697 | ++ |
+ ## nms = sapply(spl_payload(spl), spl_payload)+ |
+
| 698 | ++ | + + | +
| 699 | +98x | +
+ nms <- vapply(kids, obj_name, "")+ |
+
| 700 | +98x | +
+ labs <- vapply(kids, obj_label, "")+ |
+
| 701 | +98x | +
+ if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
+ |
+
| 702 | +1x | +
+ warning("Non-unique sibling analysis table names. Using Labels ",
+ |
+
| 703 | +1x | +
+ "instead. Use the table_names argument to analyze to avoid ",+ |
+
| 704 | +1x | +
+ "this when analyzing the same variable multiple times.",+ |
+
| 705 | +1x | +
+ "\n\toccured at (row) path: ",+ |
+
| 706 | +1x | +
+ spl_context_to_disp_path(spl_context),+ |
+
| 707 | +1x | +
+ call. = FALSE+ |
+
| 708 | ++ |
+ )+ |
+
| 709 | +1x | +
+ kids <- mapply(function(k, nm) {
+ |
+
| 710 | +2x | +
+ obj_name(k) <- nm+ |
+
| 711 | +2x | +
+ k+ |
+
| 712 | +1x | +
+ }, k = kids, nm = labs, SIMPLIFY = FALSE)+ |
+
| 713 | +1x | +
+ nms <- labs+ |
+
| 714 | ++ |
+ }+ |
+
| 715 | ++ | + + | +
| 716 | +98x | +
+ nms[is.na(nms)] <- ""+ |
+
| 717 | ++ | + + | +
| 718 | +98x | +
+ names(kids) <- nms+ |
+
| 719 | +98x | +
+ kids+ |
+
| 720 | ++ |
+ }+ |
+
| 721 | ++ |
+ )+ |
+
| 722 | ++ | + + | +
| 723 | ++ |
+ setMethod(+ |
+
| 724 | ++ |
+ ".make_split_kids", "Split",+ |
+
| 725 | ++ |
+ function(spl,+ |
+
| 726 | ++ |
+ have_controws,+ |
+
| 727 | ++ |
+ make_lrow,+ |
+
| 728 | ++ |
+ ...,+ |
+
| 729 | ++ |
+ splvec, ## passed to recursive_applysplit+ |
+
| 730 | ++ |
+ df, ## used to apply split+ |
+
| 731 | ++ |
+ alt_df, ## used to apply split for alternative df+ |
+
| 732 | ++ |
+ lvl, ## used to calculate innerlev+ |
+
| 733 | ++ |
+ cinfo, ## used for sanity check+ |
+
| 734 | ++ |
+ baselines, ## used to calc new baselines+ |
+
| 735 | ++ |
+ spl_context) {
+ |
+
| 736 | ++ |
+ ## do the core splitting of data into children for this split+ |
+
| 737 | +425x | +
+ rawpart <- do_split(spl, df, spl_context = spl_context)+ |
+
| 738 | +414x | +
+ dataspl <- rawpart[["datasplit"]]+ |
+
| 739 | ++ |
+ ## these are SplitValue objects+ |
+
| 740 | +414x | +
+ splvals <- rawpart[["values"]]+ |
+
| 741 | +414x | +
+ partlabels <- rawpart[["labels"]]+ |
+
| 742 | +414x | +
+ if (is.factor(partlabels)) {
+ |
+
| 743 | +! | +
+ partlabels <- as.character(partlabels)+ |
+
| 744 | ++ |
+ }+ |
+
| 745 | +414x | +
+ nms <- unlist(value_names(splvals))+ |
+
| 746 | +414x | +
+ if (is.factor(nms)) {
+ |
+
| 747 | +! | +
+ nms <- as.character(nms)+ |
+
| 748 | ++ |
+ }+ |
+
| 749 | ++ | + + | +
| 750 | ++ |
+ ## Get new baseline values+ |
+
| 751 | ++ |
+ ##+ |
+
| 752 | ++ |
+ ## XXX this is a lot of data churn, if it proves too slow+ |
+
| 753 | ++ |
+ ## we can+ |
+
| 754 | ++ |
+ ## a) check if any of the analyses (i.e. the afuns) need the baseline in this+ |
+
| 755 | ++ |
+ ## splitvec and not do any of this if not, or+ |
+
| 756 | ++ |
+ ## b) refactor row splitting to behave like column splitting+ |
+
| 757 | ++ |
+ ##+ |
+
| 758 | ++ |
+ ## (b) seems the better design but is a major reworking of the guts of how+ |
+
| 759 | ++ |
+ ## rtables tabulation works+ |
+
| 760 | ++ |
+ ## (a) will only help if analyses that use baseline+ |
+
| 761 | ++ |
+ ## info are mixed with those who don't.+ |
+
| 762 | +414x | +
+ newbl_raw <- lapply(baselines, function(dat) {
+ |
+
| 763 | ++ |
+ # If no ref_group is specified+ |
+
| 764 | +1481x | +
+ if (is.null(dat)) {
+ |
+
| 765 | +1461x | +
+ return(NULL)+ |
+
| 766 | ++ |
+ }+ |
+
| 767 | ++ | + + | +
| 768 | ++ |
+ ## apply the same splitting on the+ |
+
| 769 | +20x | +
+ bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]],+ |
+
| 770 | +20x | +
+ error = function(e) e+ |
+
| 771 | ++ |
+ )+ |
+
| 772 | ++ | + + | +
| 773 | ++ |
+ # Error localization+ |
+
| 774 | +20x | +
+ if (is(bldataspl, "error")) {
+ |
+
| 775 | +! | +
+ stop("Following error encountered in splitting .ref_group (baselines): ",
+ |
+
| 776 | +! | +
+ bldataspl$message,+ |
+
| 777 | +! | +
+ call. = FALSE+ |
+
| 778 | ++ |
+ )+ |
+
| 779 | ++ |
+ }+ |
+
| 780 | ++ | + + | +
| 781 | ++ |
+ ## we only keep the ones corresponding with actual data splits+ |
+
| 782 | +20x | +
+ res <- lapply(+ |
+
| 783 | +20x | +
+ names(dataspl),+ |
+
| 784 | +20x | +
+ function(nm) {
+ |
+
| 785 | +52x | +
+ if (nm %in% names(bldataspl)) {
+ |
+
| 786 | +52x | +
+ bldataspl[[nm]]+ |
+
| 787 | ++ |
+ } else {
+ |
+
| 788 | +! | +
+ dataspl[[1]][0, ]+ |
+
| 789 | ++ |
+ }+ |
+
| 790 | ++ |
+ }+ |
+
| 791 | ++ |
+ )+ |
+
| 792 | ++ | + + | +
| 793 | +20x | +
+ names(res) <- names(dataspl)+ |
+
| 794 | +20x | +
+ res+ |
+
| 795 | ++ |
+ })+ |
+
| 796 | ++ | + + | +
| 797 | +414x | +
+ newbaselines <- lapply(names(dataspl), function(nm) {
+ |
+
| 798 | +1234x | +
+ lapply(newbl_raw, function(rawdat) {
+ |
+
| 799 | +4384x | +
+ if (nm %in% names(rawdat)) {
+ |
+
| 800 | +52x | +
+ rawdat[[nm]]+ |
+
| 801 | ++ |
+ } else {
+ |
+
| 802 | +4332x | +
+ rawdat[[1]][0, ]+ |
+
| 803 | ++ |
+ }+ |
+
| 804 | ++ |
+ })+ |
+
| 805 | ++ |
+ })+ |
+
| 806 | ++ | + + | +
| 807 | +414x | +
+ if (length(newbaselines) != length(dataspl)) {
+ |
+
| 808 | +! | +
+ stop(+ |
+
| 809 | +! | +
+ "Baselines (ref_group) after row split does not have",+ |
+
| 810 | +! | +
+ " the same number of levels of input data split. ",+ |
+
| 811 | +! | +
+ "Contact the maintainer."+ |
+
| 812 | +! | +
+ ) # nocov+ |
+
| 813 | ++ |
+ }+ |
+
| 814 | +414x | +
+ if (!(length(newbaselines) == 0 ||+ |
+
| 815 | +414x | +
+ identical(+ |
+
| 816 | +414x | +
+ unique(sapply(newbaselines, length)),+ |
+
| 817 | +414x | +
+ length(col_exprs(cinfo))+ |
+
| 818 | ++ |
+ ))) {
+ |
+
| 819 | +! | +
+ stop(+ |
+
| 820 | +! | +
+ "Baselines (ref_group) do not have the same number of columns",+ |
+
| 821 | +! | +
+ " in each split. Contact the maintainer."+ |
+
| 822 | +! | +
+ ) # nocov+ |
+
| 823 | ++ |
+ }+ |
+
| 824 | ++ | + + | +
| 825 | ++ |
+ # If params are not present do not do the calculation+ |
+
| 826 | +414x | +
+ acdf_param <- check_afun_cfun_params(+ |
+
| 827 | +414x | +
+ SplitVector(spl, splvec),+ |
+
| 828 | +414x | +
+ c(".alt_df", ".alt_df_row")
+ |
+
| 829 | ++ |
+ )+ |
+
| 830 | ++ | + + | +
| 831 | ++ |
+ # Apply same split for alt_counts_df+ |
+
| 832 | +414x | +
+ if (!is.null(alt_df) && any(acdf_param)) {
+ |
+
| 833 | +17x | +
+ alt_dfpart <- tryCatch(+ |
+
| 834 | +17x | +
+ do_split(spl, alt_df,+ |
+
| 835 | +17x | +
+ spl_context = spl_context+ |
+
| 836 | +17x | +
+ )[["datasplit"]],+ |
+
| 837 | +17x | +
+ error = function(e) e+ |
+
| 838 | ++ |
+ )+ |
+
| 839 | ++ | + + | +
| 840 | ++ |
+ # Removing NA rows - to explore why this happens at all in a split+ |
+
| 841 | ++ |
+ # This would be a fix but it is done in post-processing instead of pre-proc -> xxx+ |
+
| 842 | ++ |
+ # x alt_dfpart <- lapply(alt_dfpart, function(data) {
+ |
+
| 843 | ++ |
+ # x data[!apply(is.na(data), 1, all), ]+ |
+
| 844 | ++ |
+ # x })+ |
+
| 845 | ++ | + + | +
| 846 | ++ |
+ # Error localization+ |
+
| 847 | +17x | +
+ if (is(alt_dfpart, "error")) {
+ |
+
| 848 | +2x | +
+ stop("Following error encountered in splitting alt_counts_df: ",
+ |
+
| 849 | +2x | +
+ alt_dfpart$message,+ |
+
| 850 | +2x | +
+ call. = FALSE+ |
+
| 851 | ++ |
+ )+ |
+
| 852 | ++ |
+ }+ |
+
| 853 | ++ |
+ # Error if split does not have the same values in the alt_df (and order)+ |
+
| 854 | ++ |
+ # The following breaks if there are different levels (do_split returns empty list)+ |
+
| 855 | ++ |
+ # or if there are different number of the same levels. Added handling of NAs+ |
+
| 856 | ++ |
+ # in the values of the factor when is all only NAs+ |
+
| 857 | +15x | +
+ is_all_na <- all(is.na(alt_df[[spl_payload(spl)]]))+ |
+
| 858 | ++ | + + | +
| 859 | +15x | +
+ if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) {
+ |
+
| 860 | +5x | +
+ alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]])+ |
+
| 861 | +5x | +
+ end_part <- ""+ |
+
| 862 | ++ | + + | +
| 863 | +5x | +
+ if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
+ |
+
| 864 | +2x | +
+ end_part <- paste0(+ |
+
| 865 | +2x | +
+ " and following levels: ",+ |
+
| 866 | +2x | +
+ paste_vec(levels(alt_df_spl_vals))+ |
+
| 867 | ++ |
+ )+ |
+
| 868 | ++ |
+ }+ |
+
| 869 | ++ | + + | +
| 870 | +5x | +
+ if (is_all_na) {
+ |
+
| 871 | +2x | +
+ end_part <- ". Found only NAs in alt_counts_df split"+ |
+
| 872 | ++ |
+ }+ |
+
| 873 | ++ | + + | +
| 874 | +5x | +
+ stop(+ |
+
| 875 | +5x | +
+ "alt_counts_df split variable(s) [", spl_payload(spl),+ |
+
| 876 | +5x | +
+ "] (in split ", as.character(class(spl)),+ |
+
| 877 | +5x | +
+ ") does not have the same factor levels of df.\ndf has c(", '"',
+ |
+
| 878 | +5x | +
+ paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ",+ |
+
| 879 | +5x | +
+ ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""),+ |
+
| 880 | +5x | +
+ " unique values", end_part+ |
+
| 881 | ++ |
+ )+ |
+
| 882 | ++ |
+ }+ |
+
| 883 | ++ |
+ } else {
+ |
+
| 884 | +397x | +
+ alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl))+ |
+
| 885 | ++ |
+ }+ |
+
| 886 | ++ | + + | +
| 887 | ++ | + + | +
| 888 | +407x | +
+ innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow)+ |
+
| 889 | ++ |
+ ## do full recursive_applysplit on each part of the split defined by spl+ |
+
| 890 | +407x | +
+ inner <- unlist(mapply(+ |
+
| 891 | +407x | +
+ function(dfpart, alt_dfpart, nm, label, baselines, splval) {
+ |
+
| 892 | +1192x | +
+ rsplval <- context_df_row(+ |
+
| 893 | +1192x | +
+ split = obj_name(spl),+ |
+
| 894 | +1192x | +
+ value = value_names(splval),+ |
+
| 895 | +1192x | +
+ full_parent_df = list(dfpart),+ |
+
| 896 | +1192x | +
+ cinfo = cinfo+ |
+
| 897 | ++ |
+ )+ |
+
| 898 | ++ | + + | +
| 899 | ++ |
+ ## if(length(rsplval) > 0)+ |
+
| 900 | ++ |
+ ## rsplval <- setNames(rsplval, obj_name(spl))+ |
+
| 901 | +1192x | +
+ recursive_applysplit(+ |
+
| 902 | +1192x | +
+ df = dfpart,+ |
+
| 903 | +1192x | +
+ alt_df = alt_dfpart,+ |
+
| 904 | +1192x | +
+ name = nm,+ |
+
| 905 | +1192x | +
+ lvl = innerlev,+ |
+
| 906 | +1192x | +
+ splvec = splvec,+ |
+
| 907 | +1192x | +
+ cinfo = cinfo,+ |
+
| 908 | +1192x | +
+ make_lrow = label_kids(spl),+ |
+
| 909 | +1192x | +
+ parent_cfun = content_fun(spl),+ |
+
| 910 | +1192x | +
+ cformat = content_format(spl),+ |
+
| 911 | +1192x | +
+ cna_str = content_na_str(spl),+ |
+
| 912 | +1192x | +
+ partlabel = label,+ |
+
| 913 | +1192x | +
+ cindent_mod = content_indent_mod(spl),+ |
+
| 914 | +1192x | +
+ cvar = content_var(spl),+ |
+
| 915 | +1192x | +
+ baselines = baselines,+ |
+
| 916 | +1192x | +
+ cextra_args = content_extra_args(spl),+ |
+
| 917 | ++ |
+ ## splval should still be retaining its name+ |
+
| 918 | +1192x | +
+ spl_context = rbind(spl_context, rsplval)+ |
+
| 919 | ++ |
+ )+ |
+
| 920 | ++ |
+ },+ |
+
| 921 | +407x | +
+ dfpart = dataspl,+ |
+
| 922 | +407x | +
+ alt_dfpart = alt_dfpart,+ |
+
| 923 | +407x | +
+ label = partlabels,+ |
+
| 924 | +407x | +
+ nm = nms,+ |
+
| 925 | +407x | +
+ baselines = newbaselines,+ |
+
| 926 | +407x | +
+ splval = splvals,+ |
+
| 927 | +407x | +
+ SIMPLIFY = FALSE+ |
+
| 928 | ++ |
+ ))+ |
+
| 929 | ++ | + + | +
| 930 | ++ |
+ # Setting the kids section separator if they inherits VTableTree+ |
+
| 931 | +399x | +
+ inner <- .set_kids_section_div(+ |
+
| 932 | +399x | +
+ inner,+ |
+
| 933 | +399x | +
+ trailing_section_div_char = spl_section_div(spl),+ |
+
| 934 | +399x | +
+ allowed_class = "VTableTree"+ |
+
| 935 | ++ |
+ )+ |
+
| 936 | ++ | + + | +
| 937 | ++ |
+ ## This is where we need to build the structural tables+ |
+
| 938 | ++ |
+ ## even if they are invisible because their labels are not+ |
+
| 939 | ++ |
+ ## not shown.+ |
+
| 940 | +399x | +
+ innertab <- TableTree(+ |
+
| 941 | +399x | +
+ kids = inner,+ |
+
| 942 | +399x | +
+ name = obj_name(spl),+ |
+
| 943 | +399x | +
+ labelrow = LabelRow(+ |
+
| 944 | +399x | +
+ label = obj_label(spl),+ |
+
| 945 | +399x | +
+ vis = isTRUE(vis_label(spl))+ |
+
| 946 | ++ |
+ ),+ |
+
| 947 | +399x | +
+ cinfo = cinfo,+ |
+
| 948 | +399x | +
+ iscontent = FALSE,+ |
+
| 949 | +399x | +
+ indent_mod = indent_mod(spl),+ |
+
| 950 | +399x | +
+ page_title = ptitle_prefix(spl)+ |
+
| 951 | ++ |
+ )+ |
+
| 952 | ++ |
+ ## kids = inner+ |
+
| 953 | +399x | +
+ kids <- list(innertab)+ |
+
| 954 | +399x | +
+ kids+ |
+
| 955 | ++ |
+ }+ |
+
| 956 | ++ |
+ )+ |
+
| 957 | ++ | + + | +
| 958 | ++ |
+ context_df_row <- function(split = character(),+ |
+
| 959 | ++ |
+ value = character(),+ |
+
| 960 | ++ |
+ full_parent_df = list(),+ |
+
| 961 | ++ |
+ cinfo = NULL) {
+ |
+
| 962 | +2889x | +
+ ret <- data.frame(+ |
+
| 963 | +2889x | +
+ split = split,+ |
+
| 964 | +2889x | +
+ value = value,+ |
+
| 965 | +2889x | +
+ full_parent_df = I(full_parent_df),+ |
+
| 966 | ++ |
+ # parent_cold_inds = I(parent_col_inds),+ |
+
| 967 | +2889x | +
+ stringsAsFactors = FALSE+ |
+
| 968 | ++ |
+ )+ |
+
| 969 | +2889x | +
+ if (nrow(ret) > 0) {
+ |
+
| 970 | +2876x | +
+ ret$all_cols_n <- nrow(full_parent_df[[1]])+ |
+
| 971 | ++ |
+ } else {
+ |
+
| 972 | +13x | +
+ ret$all_cols_n <- integer() ## should this be numeric??? This never happens+ |
+
| 973 | ++ |
+ }+ |
+
| 974 | ++ | + + | +
| 975 | +2889x | +
+ if (!is.null(cinfo)) {
+ |
+
| 976 | +1518x | +
+ if (nrow(ret) > 0) {
+ |
+
| 977 | +1509x | +
+ colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
+ |
+
| 978 | +5354x | +
+ vals <- eval(e, envir = full_parent_df[[1]])+ |
+
| 979 | +5354x | +
+ if (identical(vals, TRUE)) {
+ |
+
| 980 | +545x | +
+ vals <- rep(vals, length.out = nrow(full_parent_df[[1]]))+ |
+
| 981 | ++ |
+ }+ |
+
| 982 | +5354x | +
+ I(list(vals))+ |
+
| 983 | ++ |
+ }))+ |
+
| 984 | ++ |
+ } else {
+ |
+
| 985 | +9x | +
+ colcols <- as.data.frame(rep(list(logical()), ncol(cinfo)))+ |
+
| 986 | ++ |
+ }+ |
+
| 987 | +1518x | +
+ names(colcols) <- names(col_exprs(cinfo))+ |
+
| 988 | +1518x | +
+ ret <- cbind(ret, colcols)+ |
+
| 989 | ++ |
+ }+ |
+
| 990 | +2889x | +
+ ret+ |
+
| 991 | ++ |
+ }+ |
+
| 992 | ++ | + + | +
| 993 | ++ |
+ recursive_applysplit <- function(df,+ |
+
| 994 | ++ |
+ lvl = 0L,+ |
+
| 995 | ++ |
+ alt_df,+ |
+
| 996 | ++ |
+ splvec,+ |
+
| 997 | ++ |
+ name,+ |
+
| 998 | ++ |
+ # label,+ |
+
| 999 | ++ |
+ make_lrow = NA,+ |
+
| 1000 | ++ |
+ partlabel = "",+ |
+
| 1001 | ++ |
+ cinfo,+ |
+
| 1002 | ++ |
+ parent_cfun = NULL,+ |
+
| 1003 | ++ |
+ cformat = NULL,+ |
+
| 1004 | ++ |
+ cna_str = NA_character_,+ |
+
| 1005 | ++ |
+ cindent_mod = 0L,+ |
+
| 1006 | ++ |
+ cextra_args = list(),+ |
+
| 1007 | ++ |
+ cvar = NULL,+ |
+
| 1008 | ++ |
+ baselines = lapply(+ |
+
| 1009 | ++ |
+ col_extra_args(cinfo),+ |
+
| 1010 | ++ |
+ function(x) x$.ref_full+ |
+
| 1011 | ++ |
+ ),+ |
+
| 1012 | ++ |
+ spl_context = context_df_row(cinfo = cinfo),+ |
+
| 1013 | ++ |
+ no_outer_tbl = FALSE,+ |
+
| 1014 | ++ |
+ parent_sect_split = NA_character_) {
+ |
+
| 1015 | ++ |
+ ## pre-existing table was added to the layout+ |
+
| 1016 | +1518x | +
+ if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
+ |
+
| 1017 | +1x | +
+ return(splvec[[1]])+ |
+
| 1018 | ++ |
+ }+ |
+
| 1019 | ++ | + + | +
| 1020 | ++ |
+ ## the content function is the one from the PREVIOUS+ |
+
| 1021 | ++ |
+ ## split, i.e. the one whose children we are now constructing+ |
+
| 1022 | ++ |
+ ## this is a bit annoying but makes the semantics for+ |
+
| 1023 | ++ |
+ ## declaring layouts much more sane.+ |
+
| 1024 | +1517x | +
+ ctab <- .make_ctab(df,+ |
+
| 1025 | +1517x | +
+ lvl = lvl,+ |
+
| 1026 | +1517x | +
+ name = name,+ |
+
| 1027 | +1517x | +
+ label = partlabel,+ |
+
| 1028 | +1517x | +
+ cinfo = cinfo,+ |
+
| 1029 | +1517x | +
+ parent_cfun = parent_cfun,+ |
+
| 1030 | +1517x | +
+ format = cformat,+ |
+
| 1031 | +1517x | +
+ na_str = cna_str,+ |
+
| 1032 | +1517x | +
+ indent_mod = cindent_mod,+ |
+
| 1033 | +1517x | +
+ cvar = cvar,+ |
+
| 1034 | +1517x | +
+ alt_df = alt_df,+ |
+
| 1035 | +1517x | +
+ extra_args = cextra_args,+ |
+
| 1036 | +1517x | +
+ spl_context = spl_context+ |
+
| 1037 | ++ |
+ )+ |
+
| 1038 | ++ | + + | +
| 1039 | +1516x | +
+ nonroot <- lvl != 0L+ |
+
| 1040 | ++ | + + | +
| 1041 | +1516x | +
+ if (is.na(make_lrow)) {
+ |
+
| 1042 | +1211x | +
+ make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE+ |
+
| 1043 | ++ |
+ }+ |
+
| 1044 | ++ |
+ ## never print an empty row label for root.+ |
+
| 1045 | +1516x | +
+ if (make_lrow && partlabel == "" && !nonroot) {
+ |
+
| 1046 | +6x | +
+ make_lrow <- FALSE+ |
+
| 1047 | ++ |
+ }+ |
+
| 1048 | ++ | + + | +
| 1049 | +1516x | +
+ if (length(splvec) == 0L) {
+ |
+
| 1050 | +99x | +
+ kids <- list()+ |
+
| 1051 | +99x | +
+ imod <- 0L+ |
+
| 1052 | +99x | +
+ spl <- NULL+ |
+
| 1053 | ++ |
+ } else {
+ |
+
| 1054 | +1417x | +
+ spl <- splvec[[1]]+ |
+
| 1055 | +1417x | +
+ splvec <- splvec[-1]+ |
+
| 1056 | ++ | + + | +
| 1057 | ++ |
+ ## we pass this everything recursive_applysplit received and+ |
+
| 1058 | ++ |
+ ## it all gets passed around through ... as needed+ |
+
| 1059 | ++ |
+ ## to the various methods of .make_split_kids+ |
+
| 1060 | +1417x | +
+ kids <- .make_split_kids(+ |
+
| 1061 | +1417x | +
+ spl = spl,+ |
+
| 1062 | +1417x | +
+ df = df,+ |
+
| 1063 | +1417x | +
+ alt_df = alt_df,+ |
+
| 1064 | +1417x | +
+ lvl = lvl,+ |
+
| 1065 | +1417x | +
+ splvec = splvec,+ |
+
| 1066 | +1417x | +
+ name = name,+ |
+
| 1067 | +1417x | +
+ make_lrow = make_lrow,+ |
+
| 1068 | +1417x | +
+ partlabel = partlabel,+ |
+
| 1069 | +1417x | +
+ cinfo = cinfo,+ |
+
| 1070 | +1417x | +
+ parent_cfun = parent_cfun,+ |
+
| 1071 | +1417x | +
+ cformat = cformat,+ |
+
| 1072 | +1417x | +
+ cindent_mod = cindent_mod,+ |
+
| 1073 | +1417x | +
+ cextra_args = cextra_args, cvar = cvar,+ |
+
| 1074 | +1417x | +
+ baselines = baselines,+ |
+
| 1075 | +1417x | +
+ spl_context = spl_context,+ |
+
| 1076 | +1417x | +
+ have_controws = nrow(ctab) > 0+ |
+
| 1077 | ++ |
+ )+ |
+
| 1078 | +1387x | +
+ imod <- 0L+ |
+
| 1079 | ++ |
+ } ## end length(splvec)+ |
+
| 1080 | ++ | + + | +
| 1081 | +1486x | +
+ if (is.na(make_lrow)) {
+ |
+
| 1082 | +! | +
+ make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE+ |
+
| 1083 | ++ |
+ }+ |
+
| 1084 | ++ |
+ ## never print an empty row label for root.+ |
+
| 1085 | +1486x | +
+ if (make_lrow && partlabel == "" && !nonroot) {
+ |
+
| 1086 | +! | +
+ make_lrow <- FALSE+ |
+
| 1087 | ++ |
+ }+ |
+
| 1088 | ++ | + + | +
| 1089 | ++ |
+ ## this is only true when called from build_table and the first split+ |
+
| 1090 | ++ |
+ ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split.+ |
+
| 1091 | ++ |
+ ## in that case we would be "double creating" the structural+ |
+
| 1092 | ++ |
+ ## subtable+ |
+
| 1093 | +1486x | +
+ if (no_outer_tbl) {
+ |
+
| 1094 | +277x | +
+ ret <- kids[[1]]+ |
+
| 1095 | +277x | +
+ indent_mod(ret) <- indent_mod(spl)+ |
+
| 1096 | +1209x | +
+ } else if (nrow(ctab) > 0L || length(kids) > 0L) {
+ |
+
| 1097 | ++ |
+ ## previously we checked if the child had an identical label+ |
+
| 1098 | ++ |
+ ## but I don't think thats needed anymore.+ |
+
| 1099 | +1209x | +
+ tlabel <- partlabel+ |
+
| 1100 | +1209x | +
+ ret <- TableTree(+ |
+
| 1101 | +1209x | +
+ cont = ctab,+ |
+
| 1102 | +1209x | +
+ kids = kids,+ |
+
| 1103 | +1209x | +
+ name = name,+ |
+
| 1104 | +1209x | +
+ label = tlabel, # partlabel,+ |
+
| 1105 | +1209x | +
+ lev = lvl,+ |
+
| 1106 | +1209x | +
+ iscontent = FALSE,+ |
+
| 1107 | +1209x | +
+ labelrow = LabelRow(+ |
+
| 1108 | +1209x | +
+ lev = lvl,+ |
+
| 1109 | +1209x | +
+ label = tlabel,+ |
+
| 1110 | +1209x | +
+ cinfo = cinfo,+ |
+
| 1111 | +1209x | +
+ vis = make_lrow+ |
+
| 1112 | ++ |
+ ),+ |
+
| 1113 | +1209x | +
+ cinfo = cinfo,+ |
+
| 1114 | +1209x | +
+ indent_mod = imod+ |
+
| 1115 | ++ |
+ )+ |
+
| 1116 | ++ |
+ } else {
+ |
+
| 1117 | +! | +
+ ret <- NULL+ |
+
| 1118 | ++ |
+ }+ |
+
| 1119 | ++ | + + | +
| 1120 | ++ |
+ ## if(!is.null(spl) && !is.na(spl_section_sep(spl)))+ |
+
| 1121 | ++ |
+ ## ret <- apply_kids_section_sep(ret, spl_section_sep(spl))+ |
+
| 1122 | ++ |
+ ## ## message(sprintf("indent modifier: %d", indentmod))
+ |
+
| 1123 | ++ |
+ ## if(!is.null(ret))+ |
+
| 1124 | ++ |
+ ## indent_mod(ret) = indentmod+ |
+
| 1125 | +1486x | +
+ ret+ |
+
| 1126 | ++ |
+ }+ |
+
| 1127 | ++ | + + | +
| 1128 | ++ |
+ #' Create a table from a layout and data+ |
+
| 1129 | ++ |
+ #'+ |
+
| 1130 | ++ |
+ #' Layouts are used to describe a table pre-data. `build_table` is used to create a table+ |
+
| 1131 | ++ |
+ #' using a layout and a dataset.+ |
+
| 1132 | ++ |
+ #'+ |
+
| 1133 | ++ |
+ #' @inheritParams gen_args+ |
+
| 1134 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 1135 | ++ |
+ #' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
+ |
+
| 1136 | ++ |
+ #' *for leaf-columns only* which override those calculated automatically during tabulation. Must specify+ |
+
| 1137 | ++ |
+ #' "counts" for *all* leaf-columns if non-`NULL`. `NA` elements will be replaced with the automatically+ |
+
| 1138 | ++ |
+ #' calculated counts. Turns on display of leaf-column counts when non-`NULL`.+ |
+
| 1139 | ++ |
+ #' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`.+ |
+
| 1140 | ++ |
+ #' @param ... ignored.+ |
+
| 1141 | ++ |
+ #'+ |
+
| 1142 | ++ |
+ #' @details+ |
+
| 1143 | ++ |
+ #' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting+ |
+
| 1144 | ++ |
+ #' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and+ |
+
| 1145 | ++ |
+ #' counting the observations in each resulting subset.+ |
+
| 1146 | ++ |
+ #'+ |
+
| 1147 | ++ |
+ #' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have+ |
+
| 1148 | ++ |
+ #' been calculated based on `df` and simply re-used for the count calculation.+ |
+
| 1149 | ++ |
+ #'+ |
+
| 1150 | ++ |
+ #' @note+ |
+
| 1151 | ++ |
+ #' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called+ |
+
| 1152 | ++ |
+ #' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation+ |
+
| 1153 | ++ |
+ #' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the+ |
+
| 1154 | ++ |
+ #' only way to ensure overridden counts are fully respected.+ |
+
| 1155 | ++ |
+ #'+ |
+
| 1156 | ++ |
+ #' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations+ |
+
| 1157 | ++ |
+ #' declared in `lyt` to the data `df`.+ |
+
| 1158 | ++ |
+ #'+ |
+
| 1159 | ++ |
+ #' @examples+ |
+
| 1160 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 1161 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 1162 | ++ |
+ #' analyze("Sepal.Length", afun = function(x) {
+ |
+
| 1163 | ++ |
+ #' list(+ |
+
| 1164 | ++ |
+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ |
+
| 1165 | ++ |
+ #' "range" = diff(range(x))+ |
+
| 1166 | ++ |
+ #' )+ |
+
| 1167 | ++ |
+ #' })+ |
+
| 1168 | ++ |
+ #' lyt+ |
+
| 1169 | ++ |
+ #'+ |
+
| 1170 | ++ |
+ #' tbl <- build_table(lyt, iris)+ |
+
| 1171 | ++ |
+ #' tbl+ |
+
| 1172 | ++ |
+ #'+ |
+
| 1173 | ++ |
+ #' # analyze multiple variables+ |
+
| 1174 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 1175 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 1176 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
+ |
+
| 1177 | ++ |
+ #' list(+ |
+
| 1178 | ++ |
+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ |
+
| 1179 | ++ |
+ #' "range" = diff(range(x))+ |
+
| 1180 | ++ |
+ #' )+ |
+
| 1181 | ++ |
+ #' })+ |
+
| 1182 | ++ |
+ #'+ |
+
| 1183 | ++ |
+ #' tbl2 <- build_table(lyt2, iris)+ |
+
| 1184 | ++ |
+ #' tbl2+ |
+
| 1185 | ++ |
+ #'+ |
+
| 1186 | ++ |
+ #' # an example more relevant for clinical trials with column counts+ |
+
| 1187 | ++ |
+ #' lyt3 <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 1188 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 1189 | ++ |
+ #' analyze("AGE", afun = function(x) {
+ |
+
| 1190 | ++ |
+ #' setNames(as.list(fivenum(x)), c(+ |
+
| 1191 | ++ |
+ #' "minimum", "lower-hinge", "median",+ |
+
| 1192 | ++ |
+ #' "upper-hinge", "maximum"+ |
+
| 1193 | ++ |
+ #' ))+ |
+
| 1194 | ++ |
+ #' })+ |
+
| 1195 | ++ |
+ #'+ |
+
| 1196 | ++ |
+ #' tbl3 <- build_table(lyt3, DM)+ |
+
| 1197 | ++ |
+ #' tbl3+ |
+
| 1198 | ++ |
+ #'+ |
+
| 1199 | ++ |
+ #' tbl4 <- build_table(lyt3, subset(DM, AGE > 40))+ |
+
| 1200 | ++ |
+ #' tbl4+ |
+
| 1201 | ++ |
+ #'+ |
+
| 1202 | ++ |
+ #' # with column counts calculated based on different data+ |
+
| 1203 | ++ |
+ #' miniDM <- DM[sample(1:NROW(DM), 100), ]+ |
+
| 1204 | ++ |
+ #' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM)+ |
+
| 1205 | ++ |
+ #' tbl5+ |
+
| 1206 | ++ |
+ #'+ |
+
| 1207 | ++ |
+ #' tbl6 <- build_table(lyt3, DM, col_counts = 1:3)+ |
+
| 1208 | ++ |
+ #' tbl6+ |
+
| 1209 | ++ |
+ #'+ |
+
| 1210 | ++ |
+ #' @author Gabriel Becker+ |
+
| 1211 | ++ |
+ #' @export+ |
+
| 1212 | ++ |
+ build_table <- function(lyt, df,+ |
+
| 1213 | ++ |
+ alt_counts_df = NULL,+ |
+
| 1214 | ++ |
+ col_counts = NULL,+ |
+
| 1215 | ++ |
+ col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df),+ |
+
| 1216 | ++ |
+ topleft = NULL,+ |
+
| 1217 | ++ |
+ hsep = default_hsep(),+ |
+
| 1218 | ++ |
+ ...) {
+ |
+
| 1219 | +337x | +
+ if (!is(lyt, "PreDataTableLayouts")) {
+ |
+
| 1220 | +! | +
+ stop(+ |
+
| 1221 | +! | +
+ "lyt must be a PreDataTableLayouts object. Got object of class ",+ |
+
| 1222 | +! | +
+ class(lyt)+ |
+
| 1223 | ++ |
+ )+ |
+
| 1224 | ++ |
+ }+ |
+
| 1225 | ++ | + + | +
| 1226 | ++ |
+ ## if no columns are defined (e.g. because lyt is NULL)+ |
+
| 1227 | ++ |
+ ## add a single overall column as the "most basic"+ |
+
| 1228 | ++ |
+ ## table column structure that makes sense+ |
+
| 1229 | +337x | +
+ clyt <- clayout(lyt)+ |
+
| 1230 | +337x | +
+ if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
+ |
+
| 1231 | +105x | +
+ clyt[[1]] <- add_overall_col(clyt[[1]], "")+ |
+
| 1232 | +105x | +
+ clayout(lyt) <- clyt+ |
+
| 1233 | ++ |
+ }+ |
+
| 1234 | ++ | + + | +
| 1235 | ++ |
+ ## do checks and defensive programming now that we have the data+ |
+
| 1236 | +337x | +
+ lyt <- fix_dyncuts(lyt, df)+ |
+
| 1237 | +337x | +
+ lyt <- set_def_child_ord(lyt, df)+ |
+
| 1238 | +336x | +
+ lyt <- fix_analyze_vis(lyt)+ |
+
| 1239 | +336x | +
+ df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts))+ |
+
| 1240 | +327x | +
+ alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
+ |
+
| 1241 | +327x | +
+ if (any(alt_params) && is.null(alt_counts_df)) {
+ |
+
| 1242 | +2x | +
+ stop(+ |
+
| 1243 | +2x | +
+ "Layout contains afun/cfun functions that have optional parameters ",+ |
+
| 1244 | +2x | +
+ ".alt_df and/or .alt_df_row, but no alt_counts_df was provided in ",+ |
+
| 1245 | +2x | +
+ "build_table()."+ |
+
| 1246 | ++ |
+ )+ |
+
| 1247 | ++ |
+ }+ |
+
| 1248 | ++ | + + | +
| 1249 | +325x | +
+ rtpos <- TreePos()+ |
+
| 1250 | +325x | +
+ cinfo <- create_colinfo(lyt, df, rtpos,+ |
+
| 1251 | +325x | +
+ counts = col_counts,+ |
+
| 1252 | +325x | +
+ alt_counts_df = alt_counts_df,+ |
+
| 1253 | +325x | +
+ total = col_total,+ |
+
| 1254 | +325x | +
+ topleft+ |
+
| 1255 | ++ |
+ )+ |
+
| 1256 | +317x | +
+ if (!is.null(col_counts)) {
+ |
+
| 1257 | +3x | +
+ toreplace <- !is.na(col_counts)+ |
+
| 1258 | +3x | +
+ newccs <- col_counts(cinfo) ## old actual counts+ |
+
| 1259 | +3x | +
+ newccs[toreplace] <- col_counts[toreplace]+ |
+
| 1260 | +3x | +
+ col_counts(cinfo) <- newccs+ |
+
| 1261 | +3x | +
+ leaf_paths <- col_paths(cinfo)+ |
+
| 1262 | +3x | +
+ for (pth in leaf_paths) {
+ |
+
| 1263 | +21x | +
+ colcount_visible(cinfo, pth) <- TRUE+ |
+
| 1264 | ++ |
+ }+ |
+
| 1265 | ++ |
+ }+ |
+
| 1266 | +317x | +
+ rlyt <- rlayout(lyt)+ |
+
| 1267 | +317x | +
+ rtspl <- root_spl(rlyt)+ |
+
| 1268 | +317x | +
+ ctab <- .make_ctab(df, 0L,+ |
+
| 1269 | +317x | +
+ alt_df = NULL,+ |
+
| 1270 | +317x | +
+ name = "root",+ |
+
| 1271 | +317x | +
+ label = "",+ |
+
| 1272 | +317x | +
+ cinfo = cinfo, ## cexprs, ctree,+ |
+
| 1273 | +317x | +
+ parent_cfun = content_fun(rtspl),+ |
+
| 1274 | +317x | +
+ format = content_format(rtspl),+ |
+
| 1275 | +317x | +
+ na_str = content_na_str(rtspl),+ |
+
| 1276 | +317x | +
+ indent_mod = 0L,+ |
+
| 1277 | +317x | +
+ cvar = content_var(rtspl),+ |
+
| 1278 | +317x | +
+ extra_args = content_extra_args(rtspl)+ |
+
| 1279 | ++ |
+ )+ |
+
| 1280 | ++ | + + | +
| 1281 | +317x | +
+ kids <- lapply(seq_along(rlyt), function(i) {
+ |
+
| 1282 | +340x | +
+ splvec <- rlyt[[i]]+ |
+
| 1283 | +340x | +
+ if (length(splvec) == 0) {
+ |
+
| 1284 | +14x | +
+ return(NULL)+ |
+
| 1285 | ++ |
+ }+ |
+
| 1286 | +326x | +
+ firstspl <- splvec[[1]]+ |
+
| 1287 | +326x | +
+ nm <- obj_name(firstspl)+ |
+
| 1288 | ++ |
+ ## XXX unused, probably shouldn't be?+ |
+
| 1289 | ++ |
+ ## this seems to be covered by grabbing the partlabel+ |
+
| 1290 | ++ |
+ ## TODO confirm this+ |
+
| 1291 | ++ |
+ ## lab <- obj_label(firstspl)+ |
+
| 1292 | +326x | +
+ recursive_applysplit(+ |
+
| 1293 | +326x | +
+ df = df, lvl = 0L,+ |
+
| 1294 | +326x | +
+ alt_df = alt_counts_df,+ |
+
| 1295 | +326x | +
+ name = nm,+ |
+
| 1296 | +326x | +
+ splvec = splvec,+ |
+
| 1297 | +326x | +
+ cinfo = cinfo,+ |
+
| 1298 | ++ |
+ ## XXX are these ALWAYS right?+ |
+
| 1299 | +326x | +
+ make_lrow = label_kids(firstspl),+ |
+
| 1300 | +326x | +
+ parent_cfun = NULL,+ |
+
| 1301 | +326x | +
+ cformat = content_format(firstspl),+ |
+
| 1302 | +326x | +
+ cna_str = content_na_str(firstspl),+ |
+
| 1303 | +326x | +
+ cvar = content_var(firstspl),+ |
+
| 1304 | +326x | +
+ cextra_args = content_extra_args(firstspl),+ |
+
| 1305 | +326x | +
+ spl_context = context_df_row(+ |
+
| 1306 | +326x | +
+ split = "root", value = "root",+ |
+
| 1307 | +326x | +
+ full_parent_df = list(df),+ |
+
| 1308 | +326x | +
+ cinfo = cinfo+ |
+
| 1309 | ++ |
+ ),+ |
+
| 1310 | ++ |
+ ## we DO want the 'outer table' if the first+ |
+
| 1311 | ++ |
+ ## one is a multi-analyze+ |
+
| 1312 | +326x | +
+ no_outer_tbl = !is(firstspl, "AnalyzeMultiVars")+ |
+
| 1313 | ++ |
+ )+ |
+
| 1314 | ++ |
+ })+ |
+
| 1315 | +294x | +
+ kids <- kids[!sapply(kids, is.null)]+ |
+
| 1316 | +280x | +
+ if (length(kids) > 0) names(kids) <- sapply(kids, obj_name)+ |
+
| 1317 | ++ | + + | +
| 1318 | ++ |
+ # top level divisor+ |
+
| 1319 | +294x | +
+ if (!is.na(top_level_section_div(lyt))) {
+ |
+
| 1320 | +2x | +
+ kids <- lapply(kids, function(first_level_kids) {
+ |
+
| 1321 | +4x | +
+ trailing_section_div(first_level_kids) <- top_level_section_div(lyt)+ |
+
| 1322 | +4x | +
+ first_level_kids+ |
+
| 1323 | ++ |
+ })+ |
+
| 1324 | ++ |
+ }+ |
+
| 1325 | ++ | + + | +
| 1326 | +294x | +
+ if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
+ |
+
| 1327 | +251x | +
+ tab <- kids[[1]]+ |
+
| 1328 | +251x | +
+ main_title(tab) <- main_title(lyt)+ |
+
| 1329 | +251x | +
+ subtitles(tab) <- subtitles(lyt)+ |
+
| 1330 | +251x | +
+ main_footer(tab) <- main_footer(lyt)+ |
+
| 1331 | +251x | +
+ prov_footer(tab) <- prov_footer(lyt)+ |
+
| 1332 | +251x | +
+ header_section_div(tab) <- header_section_div(lyt)+ |
+
| 1333 | ++ |
+ } else {
+ |
+
| 1334 | +43x | +
+ tab <- TableTree(+ |
+
| 1335 | +43x | +
+ cont = ctab,+ |
+
| 1336 | +43x | +
+ kids = kids,+ |
+
| 1337 | +43x | +
+ lev = 0L,+ |
+
| 1338 | +43x | +
+ name = "root",+ |
+
| 1339 | +43x | +
+ label = "",+ |
+
| 1340 | +43x | +
+ iscontent = FALSE,+ |
+
| 1341 | +43x | +
+ cinfo = cinfo,+ |
+
| 1342 | +43x | +
+ format = obj_format(rtspl),+ |
+
| 1343 | +43x | +
+ na_str = obj_na_str(rtspl),+ |
+
| 1344 | +43x | +
+ title = main_title(lyt),+ |
+
| 1345 | +43x | +
+ subtitles = subtitles(lyt),+ |
+
| 1346 | +43x | +
+ main_footer = main_footer(lyt),+ |
+
| 1347 | +43x | +
+ prov_footer = prov_footer(lyt),+ |
+
| 1348 | +43x | +
+ header_section_div = header_section_div(lyt)+ |
+
| 1349 | ++ |
+ )+ |
+
| 1350 | ++ |
+ }+ |
+
| 1351 | ++ | + + | +
| 1352 | ++ |
+ ## This seems to be unneeded, not clear what 'top_left' check it refers to+ |
+
| 1353 | ++ |
+ ## but both top_left taller than column headers and very long topleft are now+ |
+
| 1354 | ++ |
+ ## allowed, so this is just wasted computation.+ |
+
| 1355 | ++ | + + | +
| 1356 | ++ |
+ ## ## this is where the top_left check lives right now. refactor later maybe+ |
+
| 1357 | ++ |
+ ## ## but now just call it so the error gets thrown when I want it to+ |
+
| 1358 | ++ |
+ ## unused <- matrix_form(tab)+ |
+
| 1359 | +294x | +
+ tab <- update_ref_indexing(tab)+ |
+
| 1360 | +294x | +
+ horizontal_sep(tab) <- hsep+ |
+
| 1361 | +294x | +
+ if (table_inset(lyt) > 0) {
+ |
+
| 1362 | +1x | +
+ table_inset(tab) <- table_inset(lyt)+ |
+
| 1363 | ++ |
+ }+ |
+
| 1364 | +294x | +
+ tab+ |
+
| 1365 | ++ |
+ }+ |
+
| 1366 | ++ | + + | +
| 1367 | ++ |
+ # fix_split_vars ----+ |
+
| 1368 | ++ |
+ # These checks guarantee that all the split variables are present in the data.+ |
+
| 1369 | ++ |
+ # No generic is needed because it is not dependent on the input layout but+ |
+
| 1370 | ++ |
+ # on the df.+ |
+
| 1371 | ++ |
+ fix_one_split_var <- function(spl, df, char_ok = TRUE) {
+ |
+
| 1372 | +547x | +
+ var <- spl_payload(spl)+ |
+
| 1373 | +547x | +
+ if (!(var %in% names(df))) {
+ |
+
| 1374 | +2x | +
+ stop("Split variable [", var, "] not found in data being tabulated.")
+ |
+
| 1375 | ++ |
+ }+ |
+
| 1376 | +545x | +
+ varvec <- df[[var]]+ |
+
| 1377 | +545x | +
+ if (!is(varvec, "character") && !is.factor(varvec)) {
+ |
+
| 1378 | +1x | +
+ message(sprintf(+ |
+
| 1379 | +1x | +
+ paste(+ |
+
| 1380 | +1x | +
+ "Split var [%s] was not character or factor.",+ |
+
| 1381 | +1x | +
+ "Converting to factor"+ |
+
| 1382 | ++ |
+ ),+ |
+
| 1383 | +1x | +
+ var+ |
+
| 1384 | ++ |
+ ))+ |
+
| 1385 | +1x | +
+ varvec <- factor(varvec)+ |
+
| 1386 | +1x | +
+ df[[var]] <- varvec+ |
+
| 1387 | +544x | +
+ } else if (is(varvec, "character") && !char_ok) {
+ |
+
| 1388 | +1x | +
+ stop(+ |
+
| 1389 | +1x | +
+ "Overriding column counts is not supported when splitting on ",+ |
+
| 1390 | +1x | +
+ "character variables.\n Please convert all column split variables to ",+ |
+
| 1391 | +1x | +
+ "factors."+ |
+
| 1392 | ++ |
+ )+ |
+
| 1393 | ++ |
+ }+ |
+
| 1394 | ++ | + + | +
| 1395 | +544x | +
+ if (is.factor(varvec)) {
+ |
+
| 1396 | +386x | +
+ levs <- levels(varvec)+ |
+
| 1397 | ++ |
+ } else {
+ |
+
| 1398 | +158x | +
+ levs <- unique(varvec)+ |
+
| 1399 | ++ |
+ }+ |
+
| 1400 | +544x | +
+ if (!all(nzchar(levs))) {
+ |
+
| 1401 | +4x | +
+ stop(+ |
+
| 1402 | +4x | +
+ "Got empty string level in splitting variable ", var,+ |
+
| 1403 | +4x | +
+ " This is not supported.\nIf display as an empty level is ",+ |
+
| 1404 | +4x | +
+ "desired use a value-labeling variable."+ |
+
| 1405 | ++ |
+ )+ |
+
| 1406 | ++ |
+ }+ |
+
| 1407 | ++ | + + | +
| 1408 | ++ |
+ ## handle label var+ |
+
| 1409 | +540x | +
+ lblvar <- spl_label_var(spl)+ |
+
| 1410 | +540x | +
+ have_lblvar <- !identical(var, lblvar)+ |
+
| 1411 | +540x | +
+ if (have_lblvar) {
+ |
+
| 1412 | +85x | +
+ if (!(lblvar %in% names(df))) {
+ |
+
| 1413 | +1x | +
+ stop(+ |
+
| 1414 | +1x | +
+ "Value label variable [", lblvar,+ |
+
| 1415 | +1x | +
+ "] not found in data being tabulated."+ |
+
| 1416 | ++ |
+ )+ |
+
| 1417 | ++ |
+ }+ |
+
| 1418 | +84x | +
+ lblvec <- df[[lblvar]]+ |
+
| 1419 | +84x | +
+ tab <- table(varvec, lblvec)+ |
+
| 1420 | ++ | + + | +
| 1421 | +84x | +
+ if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
+ |
+
| 1422 | +1x | +
+ stop(sprintf(+ |
+
| 1423 | +1x | +
+ paste(+ |
+
| 1424 | +1x | +
+ "There does not appear to be a 1-1",+ |
+
| 1425 | +1x | +
+ "correspondence between values in split var",+ |
+
| 1426 | +1x | +
+ "[%s] and label var [%s]"+ |
+
| 1427 | ++ |
+ ),+ |
+
| 1428 | +1x | +
+ var, lblvar+ |
+
| 1429 | ++ |
+ ))+ |
+
| 1430 | ++ |
+ }+ |
+
| 1431 | ++ | + + | +
| 1432 | +83x | +
+ if (!is(lblvec, "character") && !is.factor(lblvec)) {
+ |
+
| 1433 | +! | +
+ message(sprintf(+ |
+
| 1434 | +! | +
+ paste(+ |
+
| 1435 | +! | +
+ "Split label var [%s] was not character or",+ |
+
| 1436 | +! | +
+ "factor. Converting to factor"+ |
+
| 1437 | ++ |
+ ),+ |
+
| 1438 | +! | +
+ var+ |
+
| 1439 | ++ |
+ ))+ |
+
| 1440 | +! | +
+ lblvec <- factor(lblvec)+ |
+
| 1441 | +! | +
+ df[[lblvar]] <- lblvec+ |
+
| 1442 | ++ |
+ }+ |
+
| 1443 | ++ |
+ }+ |
+
| 1444 | ++ | + + | +
| 1445 | +538x | +
+ df+ |
+
| 1446 | ++ |
+ }+ |
+
| 1447 | ++ | + + | +
| 1448 | ++ |
+ fix_split_vars <- function(lyt, df, char_ok) {
+ |
+
| 1449 | +336x | +
+ df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok)+ |
+
| 1450 | +332x | +
+ df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE)+ |
+
| 1451 | +327x | +
+ df+ |
+
| 1452 | ++ | + + | +
| 1453 | ++ |
+ ## clyt <- clayout(lyt)+ |
+
| 1454 | ++ |
+ ## rlyt <- rlayout(lyt)+ |
+
| 1455 | ++ | + + | +
| 1456 | ++ |
+ ## allspls <- unlist(list(clyt, rlyt))+ |
+
| 1457 | ++ |
+ ## VarLevelSplit includes sublclass VarLevWBaselineSplit+ |
+
| 1458 | ++ |
+ }+ |
+
| 1459 | ++ | + + | +
| 1460 | ++ |
+ fix_split_vars_inner <- function(lyt, df, char_ok) {
+ |
+
| 1461 | +668x | +
+ stopifnot(is(lyt, "PreDataAxisLayout"))+ |
+
| 1462 | +668x | +
+ allspls <- unlist(lyt)+ |
+
| 1463 | +668x | +
+ varspls <- allspls[sapply(allspls, is, "VarLevelSplit")]+ |
+
| 1464 | +668x | +
+ unqvarinds <- !duplicated(sapply(varspls, spl_payload))+ |
+
| 1465 | +668x | +
+ unqvarspls <- varspls[unqvarinds]+ |
+
| 1466 | +547x | +
+ for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok)+ |
+
| 1467 | ++ | + + | +
| 1468 | +659x | +
+ df+ |
+
| 1469 | ++ |
+ }+ |
+
| 1470 | ++ | + + | +
| 1471 | ++ |
+ # set_def_child_ord ----+ |
+
| 1472 | ++ |
+ ## the table is built by recursively splitting the data and doing things to each+ |
+
| 1473 | ++ |
+ ## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to+ |
+
| 1474 | ++ |
+ ## be the same in all the different partitions. This addresses that.+ |
+
| 1475 | ++ |
+ setGeneric(+ |
+
| 1476 | ++ |
+ "set_def_child_ord",+ |
+
| 1477 | +3818x | +
+ function(lyt, df) standardGeneric("set_def_child_ord")
+ |
+
| 1478 | ++ |
+ )+ |
+
| 1479 | ++ | + + | +
| 1480 | ++ |
+ setMethod(+ |
+
| 1481 | ++ |
+ "set_def_child_ord", "PreDataTableLayouts",+ |
+
| 1482 | ++ |
+ function(lyt, df) {
+ |
+
| 1483 | +337x | +
+ clayout(lyt) <- set_def_child_ord(clayout(lyt), df)+ |
+
| 1484 | +336x | +
+ rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df)+ |
+
| 1485 | +336x | +
+ lyt+ |
+
| 1486 | ++ |
+ }+ |
+
| 1487 | ++ |
+ )+ |
+
| 1488 | ++ | + + | +
| 1489 | ++ |
+ setMethod(+ |
+
| 1490 | ++ |
+ "set_def_child_ord", "PreDataAxisLayout",+ |
+
| 1491 | ++ |
+ function(lyt, df) {
+ |
+
| 1492 | +1000x | +
+ lyt@.Data <- lapply(lyt, set_def_child_ord, df = df)+ |
+
| 1493 | +999x | +
+ lyt+ |
+
| 1494 | ++ |
+ }+ |
+
| 1495 | ++ |
+ )+ |
+
| 1496 | ++ | + + | +
| 1497 | ++ |
+ setMethod(+ |
+
| 1498 | ++ |
+ "set_def_child_ord", "SplitVector",+ |
+
| 1499 | ++ |
+ function(lyt, df) {
+ |
+
| 1500 | +1040x | +
+ lyt[] <- lapply(lyt, set_def_child_ord, df = df)+ |
+
| 1501 | +1039x | +
+ lyt+ |
+
| 1502 | ++ |
+ }+ |
+
| 1503 | ++ |
+ )+ |
+
| 1504 | ++ | + + | +
| 1505 | ++ |
+ ## for most split types, don't do anything+ |
+
| 1506 | ++ |
+ ## becuause their ordering already isn't data-based+ |
+
| 1507 | ++ |
+ setMethod(+ |
+
| 1508 | ++ |
+ "set_def_child_ord", "ANY",+ |
+
| 1509 | +610x | +
+ function(lyt, df) lyt+ |
+
| 1510 | ++ |
+ )+ |
+
| 1511 | ++ | + + | +
| 1512 | ++ |
+ setMethod(+ |
+
| 1513 | ++ |
+ "set_def_child_ord", "VarLevelSplit",+ |
+
| 1514 | ++ |
+ function(lyt, df) {
+ |
+
| 1515 | +814x | +
+ if (!is.null(spl_child_order(lyt))) {
+ |
+
| 1516 | +267x | +
+ return(lyt)+ |
+
| 1517 | ++ |
+ }+ |
+
| 1518 | ++ | + + | +
| 1519 | +547x | +
+ vec <- df[[spl_payload(lyt)]]+ |
+
| 1520 | +547x | +
+ vals <- if (is.factor(vec)) {
+ |
+
| 1521 | +387x | +
+ levels(vec)+ |
+
| 1522 | ++ |
+ } else {
+ |
+
| 1523 | +160x | +
+ unique(vec)+ |
+
| 1524 | ++ |
+ }+ |
+
| 1525 | +547x | +
+ spl_child_order(lyt) <- vals+ |
+
| 1526 | +547x | +
+ lyt+ |
+
| 1527 | ++ |
+ }+ |
+
| 1528 | ++ |
+ )+ |
+
| 1529 | ++ | + + | +
| 1530 | ++ |
+ setMethod(+ |
+
| 1531 | ++ |
+ "set_def_child_ord", "VarLevWBaselineSplit",+ |
+
| 1532 | ++ |
+ function(lyt, df) {
+ |
+
| 1533 | +17x | +
+ bline <- spl_ref_group(lyt)+ |
+
| 1534 | +17x | +
+ if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
+ |
+
| 1535 | +6x | +
+ return(lyt)+ |
+
| 1536 | ++ |
+ }+ |
+
| 1537 | ++ | + + | +
| 1538 | +11x | +
+ if (!is.null(split_fun(lyt))) {
+ |
+
| 1539 | ++ |
+ ## expensive but sadly necessary, I think+ |
+
| 1540 | +3x | +
+ pinfo <- do_split(lyt, df, spl_context = context_df_row())+ |
+
| 1541 | +3x | +
+ vals <- sort(unlist(value_names(pinfo$values)))+ |
+
| 1542 | ++ |
+ } else {
+ |
+
| 1543 | +8x | +
+ vec <- df[[spl_payload(lyt)]]+ |
+
| 1544 | +8x | +
+ vals <- if (is.factor(vec)) {
+ |
+
| 1545 | +5x | +
+ levels(vec)+ |
+
| 1546 | ++ |
+ } else {
+ |
+
| 1547 | +3x | +
+ unique(vec)+ |
+
| 1548 | ++ |
+ }+ |
+
| 1549 | ++ |
+ }+ |
+
| 1550 | +11x | +
+ if (!bline %in% vals) {
+ |
+
| 1551 | +1x | +
+ stop(paste0(+ |
+
| 1552 | +1x | +
+ 'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data."+ |
+
| 1553 | ++ |
+ ))+ |
+
| 1554 | ++ |
+ }+ |
+
| 1555 | +10x | +
+ spl_child_order(lyt) <- vals+ |
+
| 1556 | +10x | +
+ lyt+ |
+
| 1557 | ++ |
+ }+ |
+
| 1558 | ++ |
+ )+ |
+
| 1559 | ++ | + + | +
| 1560 | ++ |
+ splitvec_to_coltree <- function(df, splvec, pos = NULL,+ |
+
| 1561 | ++ |
+ lvl = 1L, label = "",+ |
+
| 1562 | ++ |
+ spl_context = context_df_row(cinfo = NULL),+ |
+
| 1563 | ++ |
+ alt_counts_df = df,+ |
+
| 1564 | ++ |
+ global_cc_format) {
+ |
+
| 1565 | +1738x | +
+ stopifnot(+ |
+
| 1566 | +1738x | +
+ lvl <= length(splvec) + 1L,+ |
+
| 1567 | +1738x | +
+ is(splvec, "SplitVector")+ |
+
| 1568 | ++ |
+ )+ |
+
| 1569 | ++ | + + | +
| 1570 | ++ | + + | +
| 1571 | +1738x | +
+ if (lvl == length(splvec) + 1L) {
+ |
+
| 1572 | ++ |
+ ## XXX this should be a LayoutColree I Think.+ |
+
| 1573 | +1135x | +
+ nm <- unlist(tail(value_names(pos), 1)) %||% ""+ |
+
| 1574 | +1135x | +
+ spl <- tail(pos_splits(pos), 1)[[1]]+ |
+
| 1575 | +1135x | +
+ fmt <- colcount_format(spl) %||% global_cc_format+ |
+
| 1576 | +1135x | +
+ LayoutColLeaf(+ |
+
| 1577 | +1135x | +
+ lev = lvl - 1L,+ |
+
| 1578 | +1135x | +
+ label = label,+ |
+
| 1579 | +1135x | +
+ tpos = pos,+ |
+
| 1580 | +1135x | +
+ name = nm,+ |
+
| 1581 | +1135x | +
+ colcount = NROW(alt_counts_df),+ |
+
| 1582 | +1135x | +
+ disp_ccounts = disp_ccounts(spl),+ |
+
| 1583 | +1135x | +
+ colcount_format = fmt+ |
+
| 1584 | ++ |
+ )+ |
+
| 1585 | ++ |
+ } else {
+ |
+
| 1586 | +603x | +
+ spl <- splvec[[lvl]]+ |
+
| 1587 | +603x | +
+ nm <- if (is.null(pos) || length(pos_splits(pos)) == 0) {
+ |
+
| 1588 | +375x | +
+ obj_name(spl)+ |
+
| 1589 | ++ |
+ } else {
+ |
+
| 1590 | +228x | +
+ unlist(tail(+ |
+
| 1591 | +228x | +
+ value_names(pos),+ |
+
| 1592 | +228x | +
+ 1+ |
+
| 1593 | ++ |
+ ))+ |
+
| 1594 | ++ |
+ }+ |
+
| 1595 | +603x | +
+ rawpart <- do_split(spl, df,+ |
+
| 1596 | +603x | +
+ trim = FALSE,+ |
+
| 1597 | +603x | +
+ spl_context = spl_context+ |
+
| 1598 | ++ |
+ )+ |
+
| 1599 | +600x | +
+ datparts <- rawpart[["datasplit"]]+ |
+
| 1600 | +600x | +
+ vals <- rawpart[["values"]]+ |
+
| 1601 | +600x | +
+ labs <- rawpart[["labels"]]+ |
+
| 1602 | ++ | + + | +
| 1603 | +600x | +
+ force(alt_counts_df)+ |
+
| 1604 | +600x | +
+ kids <- mapply(+ |
+
| 1605 | +600x | +
+ function(dfpart, value, partlab) {
+ |
+
| 1606 | ++ |
+ ## we could pass subset expression in here but the spec+ |
+
| 1607 | ++ |
+ ## currently doesn't call for it in column space+ |
+
| 1608 | +1367x | +
+ newprev <- context_df_row(+ |
+
| 1609 | +1367x | +
+ split = obj_name(spl),+ |
+
| 1610 | +1367x | +
+ value = value_names(value),+ |
+
| 1611 | +1367x | +
+ full_parent_df = list(dfpart),+ |
+
| 1612 | +1367x | +
+ cinfo = NULL+ |
+
| 1613 | ++ |
+ )+ |
+
| 1614 | ++ |
+ ## subset expressions handled inside make_child_pos,+ |
+
| 1615 | ++ |
+ ## value is (optionally, for the moment) carrying it around+ |
+
| 1616 | +1367x | +
+ newpos <- make_child_pos(pos, spl, value, partlab)+ |
+
| 1617 | +1367x | +
+ acdf_subset_expr <- make_subset_expr(spl, value)+ |
+
| 1618 | +1367x | +
+ new_acdf_subset <- try(eval(acdf_subset_expr, alt_counts_df), silent = TRUE)+ |
+
| 1619 | +1367x | +
+ if (is(new_acdf_subset, "try-error")) {
+ |
+
| 1620 | +4x | +
+ stop(sprintf(+ |
+
| 1621 | +4x | +
+ paste(+ |
+
| 1622 | +4x | +
+ ifelse(identical(df, alt_counts_df), "df", "alt_counts_df"),+ |
+
| 1623 | +4x | +
+ "appears incompatible with column-split",+ |
+
| 1624 | +4x | +
+ "structure. Offending column subset",+ |
+
| 1625 | +4x | +
+ "expression: %s\nOriginal error",+ |
+
| 1626 | +4x | +
+ "message: %s"+ |
+
| 1627 | +4x | +
+ ), deparse(acdf_subset_expr[[1]]),+ |
+
| 1628 | +4x | +
+ conditionMessage(attr(new_acdf_subset, "condition"))+ |
+
| 1629 | ++ |
+ ))+ |
+
| 1630 | ++ |
+ }+ |
+
| 1631 | ++ | + + | +
| 1632 | +1363x | +
+ splitvec_to_coltree(dfpart, splvec, newpos,+ |
+
| 1633 | +1363x | +
+ lvl + 1L, partlab,+ |
+
| 1634 | +1363x | +
+ spl_context = rbind(spl_context, newprev),+ |
+
| 1635 | +1363x | +
+ alt_counts_df = alt_counts_df[new_acdf_subset, , drop = FALSE],+ |
+
| 1636 | +1363x | +
+ global_cc_format = global_cc_format+ |
+
| 1637 | ++ |
+ )+ |
+
| 1638 | ++ |
+ },+ |
+
| 1639 | +600x | +
+ dfpart = datparts, value = vals,+ |
+
| 1640 | +600x | +
+ partlab = labs, SIMPLIFY = FALSE+ |
+
| 1641 | ++ |
+ )+ |
+
| 1642 | +594x | +
+ disp_cc <- FALSE+ |
+
| 1643 | +594x | +
+ cc_format <- global_cc_format # this doesn't matter probably, but its technically more correct+ |
+
| 1644 | +594x | +
+ if (lvl > 1) {
+ |
+
| 1645 | +226x | +
+ disp_cc <- disp_ccounts(splvec[[lvl - 1]])+ |
+
| 1646 | +226x | +
+ cc_format <- colcount_format(splvec[[lvl - 1]]) %||% global_cc_format+ |
+
| 1647 | ++ |
+ }+ |
+
| 1648 | ++ | + + | +
| 1649 | +594x | +
+ names(kids) <- value_names(vals)+ |
+
| 1650 | +594x | +
+ LayoutColTree(+ |
+
| 1651 | +594x | +
+ lev = lvl, label = label,+ |
+
| 1652 | +594x | +
+ spl = spl,+ |
+
| 1653 | +594x | +
+ kids = kids, tpos = pos,+ |
+
| 1654 | +594x | +
+ name = nm,+ |
+
| 1655 | +594x | +
+ summary_function = content_fun(spl),+ |
+
| 1656 | +594x | +
+ colcount = NROW(alt_counts_df),+ |
+
| 1657 | +594x | +
+ disp_ccounts = disp_cc,+ |
+
| 1658 | +594x | +
+ colcount_format = cc_format+ |
+
| 1659 | ++ |
+ )+ |
+
| 1660 | ++ |
+ }+ |
+
| 1661 | ++ |
+ }+ |
+
| 1662 | ++ | + + | +
| 1663 | ++ |
+ # fix_analyze_vis ----+ |
+
| 1664 | ++ |
+ ## now that we know for sure the number of siblings+ |
+
| 1665 | ++ |
+ ## collaplse NAs to TRUE/FALSE for whether+ |
+
| 1666 | ++ |
+ ## labelrows should be visible for ElementaryTables+ |
+
| 1667 | ++ |
+ ## generatead from analyzing a single variable+ |
+
| 1668 | +1031x | +
+ setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))
+ |
+
| 1669 | ++ | + + | +
| 1670 | ++ |
+ setMethod(+ |
+
| 1671 | ++ |
+ "fix_analyze_vis", "PreDataTableLayouts",+ |
+
| 1672 | ++ |
+ function(lyt) {
+ |
+
| 1673 | +336x | +
+ rlayout(lyt) <- fix_analyze_vis(rlayout(lyt))+ |
+
| 1674 | +336x | +
+ lyt+ |
+
| 1675 | ++ |
+ }+ |
+
| 1676 | ++ |
+ )+ |
+
| 1677 | ++ | + + | +
| 1678 | ++ |
+ setMethod(+ |
+
| 1679 | ++ |
+ "fix_analyze_vis", "PreDataRowLayout",+ |
+
| 1680 | ++ |
+ function(lyt) {
+ |
+
| 1681 | +336x | +
+ splvecs <- lapply(lyt, fix_analyze_vis)+ |
+
| 1682 | +336x | +
+ PreDataRowLayout(+ |
+
| 1683 | +336x | +
+ root = root_spl(lyt),+ |
+
| 1684 | +336x | +
+ lst = splvecs+ |
+
| 1685 | ++ |
+ )+ |
+
| 1686 | ++ |
+ }+ |
+
| 1687 | ++ |
+ )+ |
+
| 1688 | ++ | + + | +
| 1689 | ++ |
+ setMethod(+ |
+
| 1690 | ++ |
+ "fix_analyze_vis", "SplitVector",+ |
+
| 1691 | ++ |
+ function(lyt) {
+ |
+
| 1692 | +359x | +
+ len <- length(lyt)+ |
+
| 1693 | +359x | +
+ if (len == 0) {
+ |
+
| 1694 | +14x | +
+ return(lyt)+ |
+
| 1695 | ++ |
+ }+ |
+
| 1696 | +345x | +
+ lastspl <- lyt[[len]]+ |
+
| 1697 | +345x | +
+ if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
+ |
+
| 1698 | +73x | +
+ return(lyt)+ |
+
| 1699 | ++ |
+ }+ |
+
| 1700 | ++ | + + | +
| 1701 | +272x | +
+ if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
+ |
+
| 1702 | ++ |
+ ## labelrow_visible(lastspl) = FALSE+ |
+
| 1703 | +266x | +
+ labelrow_visible(lastspl) <- "hidden"+ |
+
| 1704 | +6x | +
+ } else if (is(lastspl, "AnalyzeMultiVar")) {
+ |
+
| 1705 | +! | +
+ pld <- spl_payload(lastspl)+ |
+
| 1706 | +! | +
+ newpld <- lapply(pld, function(sp, havesibs) {
+ |
+
| 1707 | +! | +
+ if (is.na(labelrow_visible(sp))) {
+ |
+
| 1708 | +! | +
+ labelrow_visible(sp) <- havesibs+ |
+
| 1709 | ++ |
+ }+ |
+
| 1710 | +! | +
+ }, havesibs = len > 1)+ |
+
| 1711 | +! | +
+ spl_payload(lastspl) <- newpld+ |
+
| 1712 | ++ |
+ ## pretty sure this isn't needed...+ |
+
| 1713 | +! | +
+ if (is.na(label_kids(lastspl))) {
+ |
+
| 1714 | +! | +
+ label_kids(lastspl) <- len > 1+ |
+
| 1715 | ++ |
+ }+ |
+
| 1716 | ++ |
+ }+ |
+
| 1717 | +272x | +
+ lyt[[len]] <- lastspl+ |
+
| 1718 | +272x | +
+ lyt+ |
+
| 1719 | ++ |
+ }+ |
+
| 1720 | ++ |
+ )+ |
+
| 1721 | ++ | + + | +
| 1722 | ++ |
+ # check_afun_cfun_params ----+ |
+
| 1723 | ++ | + + | +
| 1724 | ++ |
+ # This checks if the input params are used anywhere in cfun/afun+ |
+
| 1725 | ++ |
+ setGeneric("check_afun_cfun_params", function(lyt, params) {
+ |
+
| 1726 | +3188x | +
+ standardGeneric("check_afun_cfun_params")
+ |
+
| 1727 | ++ |
+ })+ |
+
| 1728 | ++ | + + | +
| 1729 | ++ |
+ setMethod(+ |
+
| 1730 | ++ |
+ "check_afun_cfun_params", "PreDataTableLayouts",+ |
+
| 1731 | ++ |
+ function(lyt, params) {
+ |
+
| 1732 | ++ |
+ # clayout does not have analysis functions+ |
+
| 1733 | +327x | +
+ check_afun_cfun_params(rlayout(lyt), params)+ |
+
| 1734 | ++ |
+ }+ |
+
| 1735 | ++ |
+ )+ |
+
| 1736 | ++ | + + | +
| 1737 | ++ |
+ setMethod(+ |
+
| 1738 | ++ |
+ "check_afun_cfun_params", "PreDataRowLayout",+ |
+
| 1739 | ++ |
+ function(lyt, params) {
+ |
+
| 1740 | +327x | +
+ ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params)+ |
+
| 1741 | +327x | +
+ r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params)+ |
+
| 1742 | +327x | +
+ Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l))+ |
+
| 1743 | ++ |
+ }+ |
+
| 1744 | ++ |
+ )+ |
+
| 1745 | ++ | + + | +
| 1746 | ++ |
+ # Main function for checking parameters+ |
+
| 1747 | ++ |
+ setMethod(+ |
+
| 1748 | ++ |
+ "check_afun_cfun_params", "SplitVector",+ |
+
| 1749 | ++ |
+ function(lyt, params) {
+ |
+
| 1750 | +764x | +
+ param_l <- lapply(lyt, check_afun_cfun_params, params = params)+ |
+
| 1751 | +764x | +
+ Reduce(`|`, param_l)+ |
+
| 1752 | ++ |
+ }+ |
+
| 1753 | ++ |
+ )+ |
+
| 1754 | ++ | + + | +
| 1755 | ++ |
+ # Helper function for check_afun_cfun_params+ |
+
| 1756 | ++ |
+ .afun_cfun_switch <- function(spl_i) {
+ |
+
| 1757 | +1769x | +
+ if (is(spl_i, "VAnalyzeSplit")) {
+ |
+
| 1758 | +593x | +
+ analysis_fun(spl_i)+ |
+
| 1759 | ++ |
+ } else {
+ |
+
| 1760 | +1176x | +
+ content_fun(spl_i)+ |
+
| 1761 | ++ |
+ }+ |
+
| 1762 | ++ |
+ }+ |
+
| 1763 | ++ | + + | +
| 1764 | ++ |
+ # Extreme case that happens only when using add_existing_table+ |
+
| 1765 | ++ |
+ setMethod(+ |
+
| 1766 | ++ |
+ "check_afun_cfun_params", "VTableTree",+ |
+
| 1767 | ++ |
+ function(lyt, params) {
+ |
+
| 1768 | +1x | +
+ setNames(logical(length(params)), params) # All FALSE+ |
+
| 1769 | ++ |
+ }+ |
+
| 1770 | ++ |
+ )+ |
+
| 1771 | ++ | + + | +
| 1772 | ++ |
+ setMethod(+ |
+
| 1773 | ++ |
+ "check_afun_cfun_params", "Split",+ |
+
| 1774 | ++ |
+ function(lyt, params) {
+ |
+
| 1775 | ++ |
+ # Extract function in the split+ |
+
| 1776 | +1769x | +
+ fnc <- .afun_cfun_switch(lyt)+ |
+
| 1777 | ++ | + + | +
| 1778 | ++ |
+ # For each parameter, check if it is called+ |
+
| 1779 | +1769x | +
+ sapply(params, function(pai) any(unlist(func_takes(fnc, pai))))+ |
+
| 1780 | ++ |
+ }+ |
+
| 1781 | ++ |
+ )+ |
+
| 1782 | ++ | + + | +
| 1783 | ++ |
+ # Helper functions ----+ |
+
| 1784 | ++ | + + | +
| 1785 | +231x | +
+ count <- function(df, ...) NROW(df)+ |
+
| 1786 | ++ | + + | +
| 1787 | ++ |
+ guess_format <- function(val) {
+ |
+
| 1788 | +1054x | +
+ if (length(val) == 1) {
+ |
+
| 1789 | +1042x | +
+ if (is.integer(val) || !is.numeric(val)) {
+ |
+
| 1790 | +226x | +
+ "xx"+ |
+
| 1791 | ++ |
+ } else {
+ |
+
| 1792 | +816x | +
+ "xx.xx"+ |
+
| 1793 | ++ |
+ }+ |
+
| 1794 | +12x | +
+ } else if (length(val) == 2) {
+ |
+
| 1795 | +12x | +
+ "xx.x / xx.x"+ |
+
| 1796 | +! | +
+ } else if (length(val) == 3) {
+ |
+
| 1797 | +! | +
+ "xx.x (xx.x - xx.x)"+ |
+
| 1798 | ++ |
+ } else {
+ |
+
| 1799 | +! | +
+ stop("got value of length > 3")
+ |
+
| 1800 | ++ |
+ }+ |
+
| 1801 | ++ |
+ }+ |
+
| 1802 | ++ | + + | +
| 1803 | ++ |
+ .quick_afun <- function(afun, lbls) {
+ |
+
| 1804 | +14x | +
+ if (.takes_df(afun)) {
+ |
+
| 1805 | +5x | +
+ function(df, .spl_context, ...) {
+ |
+
| 1806 | +226x | +
+ if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
+ |
+
| 1807 | +222x | +
+ lbls <- tail(.spl_context$value, 1)+ |
+
| 1808 | ++ |
+ }+ |
+
| 1809 | +226x | +
+ if (".spl_context" %in% names(formals(afun))) {
+ |
+
| 1810 | +! | +
+ res <- afun(df = df, .spl_context = .spl_context, ...)+ |
+
| 1811 | ++ |
+ } else {
+ |
+
| 1812 | +226x | +
+ res <- afun(df = df, ...)+ |
+
| 1813 | ++ |
+ }+ |
+
| 1814 | +226x | +
+ if (is(res, "RowsVerticalSection")) {
+ |
+
| 1815 | +! | +
+ ret <- res+ |
+
| 1816 | ++ |
+ } else {
+ |
+
| 1817 | +226x | +
+ if (!is.list(res)) {
+ |
+
| 1818 | +226x | +
+ ret <- rcell(res, label = lbls, format = guess_format(res))+ |
+
| 1819 | ++ |
+ } else {
+ |
+
| 1820 | +! | +
+ if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ |
+
| 1821 | +! | +
+ names(res) <- lbls+ |
+
| 1822 | ++ |
+ }+ |
+
| 1823 | +! | +
+ ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))+ |
+
| 1824 | ++ |
+ }+ |
+
| 1825 | ++ |
+ }+ |
+
| 1826 | +226x | +
+ ret+ |
+
| 1827 | ++ |
+ }+ |
+
| 1828 | ++ |
+ } else {
+ |
+
| 1829 | +9x | +
+ function(x, .spl_context, ...) {
+ |
+
| 1830 | +387x | +
+ if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
+ |
+
| 1831 | +225x | +
+ lbls <- tail(.spl_context$value, 1)+ |
+
| 1832 | ++ |
+ }+ |
+
| 1833 | +387x | +
+ if (".spl_context" %in% names(formals(afun))) {
+ |
+
| 1834 | +! | +
+ res <- afun(x = x, .spl_context = .spl_context, ...)+ |
+
| 1835 | ++ |
+ } else {
+ |
+
| 1836 | +387x | +
+ res <- afun(x = x, ...)+ |
+
| 1837 | ++ |
+ }+ |
+
| 1838 | +387x | +
+ if (is(res, "RowsVerticalSection")) {
+ |
+
| 1839 | +! | +
+ ret <- res+ |
+
| 1840 | ++ |
+ } else {
+ |
+
| 1841 | +387x | +
+ if (!is.list(res)) {
+ |
+
| 1842 | +297x | +
+ ret <- rcell(res, label = lbls, format = guess_format(res))+ |
+
| 1843 | ++ |
+ } else {
+ |
+
| 1844 | +90x | +
+ if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ |
+
| 1845 | +9x | +
+ names(res) <- lbls+ |
+
| 1846 | ++ |
+ }+ |
+
| 1847 | +90x | +
+ ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))+ |
+
| 1848 | ++ |
+ }+ |
+
| 1849 | ++ |
+ }+ |
+
| 1850 | +387x | +
+ ret+ |
+
| 1851 | ++ |
+ }+ |
+
| 1852 | ++ |
+ }+ |
+
| 1853 | ++ |
+ }+ |
+
| 1854 | ++ | + + | +
| 1855 | ++ |
+ # qtable ----+ |
+
| 1856 | ++ | + + | +
| 1857 | ++ |
+ n_cells_res <- function(res) {
+ |
+
| 1858 | +8x | +
+ ans <- 1L+ |
+
| 1859 | +8x | +
+ if (is.list(res)) {
+ |
+
| 1860 | +4x | +
+ ans <- length(res)+ |
+
| 1861 | +4x | +
+ } else if (is(res, "RowsVerticalSection")) {
+ |
+
| 1862 | +! | +
+ ans <- length(res$values)+ |
+
| 1863 | ++ |
+ } # XXX penetrating the abstraction+ |
+
| 1864 | +8x | +
+ ans+ |
+
| 1865 | ++ |
+ }+ |
+
| 1866 | ++ | + + | +
| 1867 | ++ |
+ #' Generalized frequency table+ |
+
| 1868 | ++ |
+ #'+ |
+
| 1869 | ++ |
+ #' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and+ |
+
| 1870 | ++ |
+ #' column space can be facetted by variables, and an analysis function can be specified. The function then builds a+ |
+
| 1871 | ++ |
+ #' layout with the specified layout and applies it to the data provided.+ |
+
| 1872 | ++ |
+ #'+ |
+
| 1873 | ++ |
+ #' @inheritParams constr_args+ |
+
| 1874 | ++ |
+ #' @inheritParams basic_table+ |
+
| 1875 | ++ |
+ #' @param row_vars (`character`)\cr the names of variables to be used in row facetting.+ |
+
| 1876 | ++ |
+ #' @param col_vars (`character`)\cr the names of variables to be used in column facetting.+ |
+
| 1877 | ++ |
+ #' @param data (`data.frame`)\cr the data to tabulate.+ |
+
| 1878 | ++ |
+ #' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`.+ |
+
| 1879 | ++ |
+ #' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must+ |
+
| 1880 | ++ |
+ #' match the number of rows generated by `afun`.+ |
+
| 1881 | ++ |
+ #' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis+ |
+
| 1882 | ++ |
+ #' function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas+ |
+
| 1883 | ++ |
+ #' lists are interpreted as multiple cells.+ |
+
| 1884 | ++ |
+ #' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to+ |
+
| 1885 | ++ |
+ #' `TRUE`.+ |
+
| 1886 | ++ |
+ #' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to+ |
+
| 1887 | ++ |
+ #' `FALSE`.+ |
+
| 1888 | ++ |
+ #' @param ... additional arguments passed to `afun`.+ |
+
| 1889 | ++ |
+ #' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users.+ |
+
| 1890 | ++ |
+ #'+ |
+
| 1891 | ++ |
+ #' @details+ |
+
| 1892 | ++ |
+ #' This function creates a table with a single top-level structure in both row and column dimensions involving faceting+ |
+
| 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+ |
+
| 1896 | ++ |
+ #' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row+ |
+
| 1897 | ++ |
+ #' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun`+ |
+
| 1898 | ++ |
+ #' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row+ |
+
| 1899 | ++ |
+ #' labels and the deepest-nested facet row labels will be visible.+ |
+
| 1900 | ++ |
+ #'+ |
+
| 1901 | ++ |
+ #' The table will be annotated in the top-left area with an informative label displaying the analysis variable+ |
+
| 1902 | ++ |
+ #' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception+ |
+
| 1903 | ++ |
+ #' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and+ |
+
| 1904 | ++ |
+ #' an `afun` which returns a single row.+ |
+
| 1905 | ++ |
+ #'+ |
+
| 1906 | ++ |
+ #' @return+ |
+
| 1907 | ++ |
+ #' * `qtable` returns a built `TableTree` object representing the desired table+ |
+
| 1908 | ++ |
+ #' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for+ |
+
| 1909 | ++ |
+ #' passing to [build_table()].+ |
+
| 1910 | ++ |
+ #'+ |
+
| 1911 | ++ |
+ #' @examples+ |
+
| 1912 | ++ |
+ #' qtable(ex_adsl)+ |
+
| 1913 | ++ |
+ #' qtable(ex_adsl, row_vars = "ARM")+ |
+
| 1914 | ++ |
+ #' qtable(ex_adsl, col_vars = "ARM")+ |
+
| 1915 | ++ |
+ #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM")+ |
+
| 1916 | ++ |
+ #' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
+ |
+
| 1917 | ++ |
+ #' qtable(ex_adsl,+ |
+
| 1918 | ++ |
+ #' row_vars = c("COUNTRY", "SEX"),
+ |
+
| 1919 | ++ |
+ #' col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
+ |
+
| 1920 | ++ |
+ #' )+ |
+
| 1921 | ++ |
+ #' summary_list <- function(x, ...) as.list(summary(x))+ |
+
| 1922 | ++ |
+ #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list)+ |
+
| 1923 | ++ |
+ #' suppressWarnings(qtable(ex_adsl,+ |
+
| 1924 | ++ |
+ #' row_vars = "SEX",+ |
+
| 1925 | ++ |
+ #' col_vars = "ARM", avar = "AGE", afun = range+ |
+
| 1926 | ++ |
+ #' ))+ |
+
| 1927 | ++ |
+ #'+ |
+
| 1928 | ++ |
+ #' @export+ |
+
| 1929 | ++ |
+ qtable_layout <- function(data,+ |
+
| 1930 | ++ |
+ row_vars = character(),+ |
+
| 1931 | ++ |
+ col_vars = character(),+ |
+
| 1932 | ++ |
+ avar = NULL,+ |
+
| 1933 | ++ |
+ row_labels = NULL,+ |
+
| 1934 | ++ |
+ afun = NULL,+ |
+
| 1935 | ++ |
+ summarize_groups = FALSE,+ |
+
| 1936 | ++ |
+ title = "",+ |
+
| 1937 | ++ |
+ subtitles = character(),+ |
+
| 1938 | ++ |
+ main_footer = character(),+ |
+
| 1939 | ++ |
+ prov_footer = character(),+ |
+
| 1940 | ++ |
+ show_colcounts = TRUE,+ |
+
| 1941 | ++ |
+ drop_levels = TRUE,+ |
+
| 1942 | ++ |
+ ...,+ |
+
| 1943 | ++ |
+ .default_rlabel = NULL) {
+ |
+
| 1944 | +16x | +
+ subafun <- substitute(afun)+ |
+
| 1945 | +16x | +
+ if (!is.null(.default_rlabel)) {
+ |
+
| 1946 | +16x | +
+ dflt_row_lbl <- .default_rlabel+ |
+
| 1947 | ++ |
+ } else if (+ |
+
| 1948 | +! | +
+ is.name(subafun) &&+ |
+
| 1949 | +! | +
+ is.function(afun) &&+ |
+
| 1950 | ++ |
+ ## this is gross. basically testing+ |
+
| 1951 | ++ |
+ ## if the symbol we have corresponds+ |
+
| 1952 | ++ |
+ ## in some meaningful way to the function+ |
+
| 1953 | ++ |
+ ## we will be calling.+ |
+
| 1954 | +! | +
+ identical(+ |
+
| 1955 | +! | +
+ mget(+ |
+
| 1956 | +! | +
+ as.character(subafun),+ |
+
| 1957 | +! | +
+ mode = "function",+ |
+
| 1958 | +! | +
+ envir = parent.frame(1),+ |
+
| 1959 | +! | +
+ ifnotfound = list(NULL),+ |
+
| 1960 | +! | +
+ inherits = TRUE+ |
+
| 1961 | +! | +
+ )[[1]],+ |
+
| 1962 | +! | +
+ afun+ |
+
| 1963 | ++ |
+ )+ |
+
| 1964 | ++ |
+ ) {
+ |
+
| 1965 | +! | +
+ dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")+ |
+
| 1966 | ++ |
+ } else {
+ |
+
| 1967 | +! | +
+ dflt_row_lbl <- if (is.null(avar)) "count" else avar+ |
+
| 1968 | ++ |
+ }+ |
+
| 1969 | ++ | + + | +
| 1970 | +16x | +
+ if (is.null(afun)) {
+ |
+
| 1971 | +5x | +
+ afun <- count+ |
+
| 1972 | ++ |
+ }+ |
+
| 1973 | ++ | + + | +
| 1974 | +16x | +
+ if (is.null(avar)) {
+ |
+
| 1975 | +5x | +
+ avar <- names(data)[1]+ |
+
| 1976 | ++ |
+ }+ |
+
| 1977 | +16x | +
+ fakeres <- afun(data[[avar]], ...)+ |
+
| 1978 | +16x | +
+ multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups+ |
+
| 1979 | ++ |
+ ## this is before we plug in the default so if not specified by the user+ |
+
| 1980 | ++ |
+ ## explicitly, row_labels is NULL at this point.+ |
+
| 1981 | +16x | +
+ if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
+ |
+
| 1982 | +2x | +
+ stop(+ |
+
| 1983 | +2x | +
+ "Length of row_labels (",
+ |
+
| 1984 | +2x | +
+ length(row_labels),+ |
+
| 1985 | +2x | +
+ ") does not agree with number of rows generated by analysis function (",
+ |
+
| 1986 | +2x | +
+ n_cells_res(fakeres),+ |
+
| 1987 | ++ |
+ ")."+ |
+
| 1988 | ++ |
+ )+ |
+
| 1989 | ++ |
+ }+ |
+
| 1990 | ++ | + + | +
| 1991 | +14x | +
+ if (is.null(row_labels)) {
+ |
+
| 1992 | +10x | +
+ row_labels <- dflt_row_lbl+ |
+
| 1993 | ++ |
+ }+ |
+
| 1994 | ++ | + + | +
| 1995 | +14x | +
+ lyt <- basic_table(+ |
+
| 1996 | +14x | +
+ title = title,+ |
+
| 1997 | +14x | +
+ subtitles = subtitles,+ |
+
| 1998 | +14x | +
+ main_footer = main_footer,+ |
+
| 1999 | +14x | +
+ prov_footer = prov_footer,+ |
+
| 2000 | +14x | +
+ show_colcounts = show_colcounts+ |
+
| 2001 | ++ |
+ )+ |
+
| 2002 | ++ | + + | +
| 2003 | +14x | +
+ for (var in col_vars) lyt <- split_cols_by(lyt, var)+ |
+
| 2004 | ++ | + + | +
| 2005 | +14x | +
+ for (var in head(row_vars, -1)) {
+ |
+
| 2006 | +4x | +
+ lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL)+ |
+
| 2007 | +4x | +
+ if (summarize_groups) {
+ |
+
| 2008 | +2x | +
+ lyt <- summarize_row_groups(lyt)+ |
+
| 2009 | ++ |
+ }+ |
+
| 2010 | ++ |
+ }+ |
+
| 2011 | ++ | + + | +
| 2012 | +14x | +
+ tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character()+ |
+
| 2013 | +14x | +
+ if (length(row_vars) > 0) {
+ |
+
| 2014 | +10x | +
+ if (!multirow) {
+ |
+
| 2015 | ++ |
+ ## in the single row in splitting case, we use the row label as the topleft+ |
+
| 2016 | ++ |
+ ## and the split values as the row labels for a more compact apeparance+ |
+
| 2017 | +6x | +
+ tleft <- row_labels+ |
+
| 2018 | +6x | +
+ row_labels <- NA_character_+ |
+
| 2019 | +6x | +
+ lyt <- split_rows_by(+ |
+
| 2020 | +6x | +
+ lyt, tail(row_vars, 1),+ |
+
| 2021 | +6x | +
+ split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden"+ |
+
| 2022 | ++ |
+ )+ |
+
| 2023 | ++ |
+ } else {
+ |
+
| 2024 | +4x | +
+ lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL)+ |
+
| 2025 | ++ |
+ }+ |
+
| 2026 | +10x | +
+ if (summarize_groups) {
+ |
+
| 2027 | +2x | +
+ lyt <- summarize_row_groups(lyt)+ |
+
| 2028 | ++ |
+ }+ |
+
| 2029 | ++ |
+ }+ |
+
| 2030 | +14x | +
+ inner_afun <- .quick_afun(afun, row_labels)+ |
+
| 2031 | +14x | +
+ lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...))+ |
+
| 2032 | +14x | +
+ lyt <- append_topleft(lyt, tleft)+ |
+
| 2033 | ++ |
+ }+ |
+
| 2034 | ++ | + + | +
| 2035 | ++ |
+ #' @rdname qtable_layout+ |
+
| 2036 | ++ |
+ #' @export+ |
+
| 2037 | ++ |
+ qtable <- function(data,+ |
+
| 2038 | ++ |
+ row_vars = character(),+ |
+
| 2039 | ++ |
+ col_vars = character(),+ |
+
| 2040 | ++ |
+ avar = NULL,+ |
+
| 2041 | ++ |
+ row_labels = NULL,+ |
+
| 2042 | ++ |
+ afun = NULL,+ |
+
| 2043 | ++ |
+ summarize_groups = FALSE,+ |
+
| 2044 | ++ |
+ title = "",+ |
+
| 2045 | ++ |
+ subtitles = character(),+ |
+
| 2046 | ++ |
+ main_footer = character(),+ |
+
| 2047 | ++ |
+ prov_footer = character(),+ |
+
| 2048 | ++ |
+ show_colcounts = TRUE,+ |
+
| 2049 | ++ |
+ drop_levels = TRUE,+ |
+
| 2050 | ++ |
+ ...) {
+ |
+
| 2051 | ++ |
+ ## this involves substitution so it needs to appear in both functions. Gross but true.+ |
+
| 2052 | +16x | +
+ subafun <- substitute(afun)+ |
+
| 2053 | ++ |
+ if (+ |
+
| 2054 | +16x | +
+ is.name(subafun) && is.function(afun) &&+ |
+
| 2055 | ++ |
+ ## this is gross. basically testing+ |
+
| 2056 | ++ |
+ ## if the symbol we have corresponds+ |
+
| 2057 | ++ |
+ ## in some meaningful way to the function+ |
+
| 2058 | ++ |
+ ## 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+ |
+
| 2065 | ++ |
+ )+ |
+
| 2066 | ++ |
+ ) {
+ |
+
| 2067 | +11x | +
+ dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")+ |
+
| 2068 | ++ |
+ } 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,+ |
+
| 2081 | +16x | +
+ subtitles = subtitles,+ |
+
| 2082 | +16x | +
+ main_footer = main_footer,+ |
+
| 2083 | +16x | +
+ prov_footer = prov_footer,+ |
+
| 2084 | +16x | +
+ show_colcounts = show_colcounts,+ |
+
| 2085 | +16x | +
+ drop_levels = drop_levels,+ |
+
| 2086 | ++ |
+ ...,+ |
+
| 2087 | +16x | +
+ .default_rlabel = dflt_row_lbl+ |
+
| 2088 | ++ |
+ )+ |
+
| 2089 | +14x | +
+ build_table(lyt, data)+ |
+
| 2090 | ++ |
+ }+ |
+
| 1 | ++ |
+ treestruct <- function(obj, ind = 0L) {
+ |
+
| 2 | +19x | +
+ nc <- ncol(obj)+ |
+
| 3 | +19x | +
+ cat(rep(" ", times = ind),
+ |
+
| 4 | +19x | +
+ sprintf("[%s] %s", class(obj), obj_name(obj)),
+ |
+
| 5 | +19x | +
+ sep = ""+ |
+
| 6 | ++ |
+ )+ |
+
| 7 | +19x | +
+ if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
+ |
+
| 8 | +6x | +
+ crows <- nrow(content_table(obj))+ |
+
| 9 | +6x | +
+ ccols <- if (crows == 0) 0 else nc+ |
+
| 10 | +6x | +
+ cat(sprintf(+ |
+
| 11 | +6x | +
+ " [cont: %d x %d]",+ |
+
| 12 | +6x | +
+ crows, ccols+ |
+
| 13 | ++ |
+ ))+ |
+
| 14 | ++ |
+ }+ |
+
| 15 | +19x | +
+ if (is(obj, "VTableTree") && length(tree_children(obj))) {
+ |
+
| 16 | +19x | +
+ kids <- tree_children(obj)+ |
+
| 17 | +19x | +
+ if (are(kids, "TableRow")) {
+ |
+
| 18 | +9x | +
+ cat(sprintf(+ |
+
| 19 | +9x | +
+ " (%d x %d)\n",+ |
+
| 20 | +9x | +
+ length(kids), nc+ |
+
| 21 | ++ |
+ ))+ |
+
| 22 | ++ |
+ } else {
+ |
+
| 23 | +10x | +
+ cat("\n")
+ |
+
| 24 | +10x | +
+ lapply(kids, treestruct, ind = ind + 1)+ |
+
| 25 | ++ |
+ }+ |
+
| 26 | ++ |
+ }+ |
+
| 27 | +19x | +
+ invisible(NULL)+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ setGeneric(+ |
+
| 31 | ++ |
+ "ploads_to_str",+ |
+
| 32 | +103x | +
+ function(x, collapse = ":") standardGeneric("ploads_to_str")
+ |
+
| 33 | ++ |
+ )+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ setMethod(+ |
+
| 36 | ++ |
+ "ploads_to_str", "Split",+ |
+
| 37 | ++ |
+ function(x, collapse = ":") {
+ |
+
| 38 | +52x | +
+ paste(sapply(spl_payload(x), ploads_to_str),+ |
+
| 39 | +52x | +
+ collapse = collapse+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | ++ |
+ )+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ setMethod(+ |
+
| 45 | ++ |
+ "ploads_to_str", "CompoundSplit",+ |
+
| 46 | ++ |
+ function(x, collapse = ":") {
+ |
+
| 47 | +6x | +
+ paste(sapply(spl_payload(x), ploads_to_str),+ |
+
| 48 | +6x | +
+ collapse = collapse+ |
+
| 49 | ++ |
+ )+ |
+
| 50 | ++ |
+ }+ |
+
| 51 | ++ |
+ )+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ setMethod(+ |
+
| 54 | ++ |
+ "ploads_to_str", "list",+ |
+
| 55 | ++ |
+ function(x, collapse = ":") {
+ |
+
| 56 | +! | +
+ stop("Please contact the maintainer")
+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ setMethod(+ |
+
| 61 | ++ |
+ "ploads_to_str", "SplitVector",+ |
+
| 62 | ++ |
+ function(x, collapse = ":") {
+ |
+
| 63 | +8x | +
+ sapply(x, ploads_to_str)+ |
+
| 64 | ++ |
+ }+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ setMethod(+ |
+
| 68 | ++ |
+ "ploads_to_str", "ANY",+ |
+
| 69 | ++ |
+ function(x, collapse = ":") {
+ |
+
| 70 | +37x | +
+ paste(x)+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ | + + | +
| 74 | +47x | +
+ setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ setMethod(+ |
+
| 77 | ++ |
+ "payloadmsg", "VarLevelSplit",+ |
+
| 78 | ++ |
+ function(spl) {
+ |
+
| 79 | +45x | +
+ spl_payload(spl)+ |
+
| 80 | ++ |
+ }+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ setMethod(+ |
+
| 84 | ++ |
+ "payloadmsg", "MultiVarSplit",+ |
+
| 85 | +2x | +
+ function(spl) "var"+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ setMethod(+ |
+
| 89 | ++ |
+ "payloadmsg", "VarLevWBaselineSplit",+ |
+
| 90 | ++ |
+ function(spl) {
+ |
+
| 91 | +! | +
+ paste0(+ |
+
| 92 | +! | +
+ spl_payload(spl), "[bsl ",+ |
+
| 93 | +! | +
+ spl@ref_group_value, # XXX XXX+ |
+
| 94 | ++ |
+ "]"+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ setMethod(+ |
+
| 100 | ++ |
+ "payloadmsg", "ManualSplit",+ |
+
| 101 | +! | +
+ function(spl) "mnl"+ |
+
| 102 | ++ |
+ )+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ setMethod(+ |
+
| 105 | ++ |
+ "payloadmsg", "AllSplit",+ |
+
| 106 | +! | +
+ function(spl) "all"+ |
+
| 107 | ++ |
+ )+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ setMethod(+ |
+
| 110 | ++ |
+ "payloadmsg", "ANY",+ |
+
| 111 | ++ |
+ function(spl) {
+ |
+
| 112 | +! | +
+ warning("don't know how to make payload print message for Split of class", class(spl))
+ |
+
| 113 | +! | +
+ "XXX"+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ spldesc <- function(spl, value = "") {
+ |
+
| 118 | +32x | +
+ value <- rawvalues(value)+ |
+
| 119 | +32x | +
+ payloadmsg <- payloadmsg(spl)+ |
+
| 120 | +32x | +
+ format <- "%s (%s)"+ |
+
| 121 | +32x | +
+ sprintf(+ |
+
| 122 | +32x | +
+ format,+ |
+
| 123 | +32x | +
+ value,+ |
+
| 124 | +32x | +
+ payloadmsg+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ layoutmsg <- function(obj) {
+ |
+
| 129 | ++ |
+ ## if(!is(obj, "VLayoutNode"))+ |
+
| 130 | ++ |
+ ## stop("how did a non layoutnode object get in docatlayout??")
+ |
+
| 131 | ++ | + + | +
| 132 | +28x | +
+ pos <- tree_pos(obj)+ |
+
| 133 | +28x | +
+ spllst <- pos_splits(pos)+ |
+
| 134 | +28x | +
+ spvallst <- pos_splvals(pos)+ |
+
| 135 | +28x | +
+ if (is(obj, "LayoutAxisTree")) {
+ |
+
| 136 | +12x | +
+ kids <- tree_children(obj)+ |
+
| 137 | +12x | +
+ return(unlist(lapply(kids, layoutmsg)))+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ | + + | +
| 140 | +16x | +
+ msg <- paste(+ |
+
| 141 | +16x | +
+ collapse = " -> ",+ |
+
| 142 | +16x | +
+ mapply(spldesc,+ |
+
| 143 | +16x | +
+ spl = spllst,+ |
+
| 144 | +16x | +
+ value = spvallst+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ )+ |
+
| 147 | +16x | +
+ msg+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ setMethod(+ |
+
| 151 | ++ |
+ "show", "LayoutAxisTree",+ |
+
| 152 | ++ |
+ function(object) {
+ |
+
| 153 | +2x | +
+ msg <- layoutmsg(object)+ |
+
| 154 | +2x | +
+ cat(msg, "\n")+ |
+
| 155 | +2x | +
+ invisible(object)+ |
+
| 156 | ++ |
+ }+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ | + + | +
| 159 | ++ | + + | +
| 160 | ++ |
+ #' Display column tree structure+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' Displays the tree structure of the columns of a+ |
+
| 163 | ++ |
+ #' table or column structure object.+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @inheritParams gen_args+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @return Nothing, called for its side effect of displaying+ |
+
| 168 | ++ |
+ #' a summary to the terminal.+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @examples+ |
+
| 171 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 172 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 173 | ++ |
+ #' split_cols_by("STRATA1") %>%
+ |
+
| 174 | ++ |
+ #' split_cols_by("SEX", nested = FALSE) %>%
+ |
+
| 175 | ++ |
+ #' analyze("AGE")
+ |
+
| 176 | ++ |
+ #'+ |
+
| 177 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 178 | ++ |
+ #' coltree_structure(tbl)+ |
+
| 179 | ++ |
+ #' @export+ |
+
| 180 | ++ |
+ coltree_structure <- function(obj) {
+ |
+
| 181 | +1x | +
+ ctree <- coltree(obj)+ |
+
| 182 | +1x | +
+ cat(layoutmsg2(ctree))+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ lastposmsg <- function(pos) {
+ |
+
| 186 | +6x | +
+ spls <- pos_splits(pos)+ |
+
| 187 | +6x | +
+ splvals <- value_names(pos_splvals(pos))+ |
+
| 188 | +6x | +
+ indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "),+ |
+
| 189 | +6x | +
+ spl = spls,+ |
+
| 190 | +6x | +
+ valnm = splvals,+ |
+
| 191 | +6x | +
+ SIMPLIFY = FALSE+ |
+
| 192 | ++ |
+ ))+ |
+
| 193 | +6x | +
+ paste(indiv_msgs, collapse = " -> ")+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ | + + | +
| 196 | ++ |
+ layoutmsg2 <- function(obj, level = 1) {
+ |
+
| 197 | +7x | +
+ nm <- obj_name(obj)+ |
+
| 198 | +7x | +
+ pos <- tree_pos(obj)+ |
+
| 199 | +7x | +
+ nopos <- identical(pos, EmptyTreePos)+ |
+
| 200 | ++ | + + | +
| 201 | +7x | +
+ msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
+ |
+
| 202 | +7x | +
+ if (is(obj, "LayoutAxisTree")) {
+ |
+
| 203 | +3x | +
+ kids <- tree_children(obj)+ |
+
| 204 | +3x | +
+ msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1)))+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | +7x | +
+ msg+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ | + + | +
| 209 | +46x | +
+ setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ setMethod(+ |
+
| 212 | ++ |
+ "spltype_abbrev", "VarLevelSplit",+ |
+
| 213 | +4x | +
+ function(obj) "lvls"+ |
+
| 214 | ++ |
+ )+ |
+
| 215 | ++ | + + | +
| 216 | ++ |
+ setMethod(+ |
+
| 217 | ++ |
+ "spltype_abbrev", "VarLevWBaselineSplit",+ |
+
| 218 | +5x | +
+ function(obj) paste("ref_group", obj@ref_group_value)
+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ | + + | +
| 221 | ++ |
+ setMethod(+ |
+
| 222 | ++ |
+ "spltype_abbrev", "MultiVarSplit",+ |
+
| 223 | +! | +
+ function(obj) "vars"+ |
+
| 224 | ++ |
+ )+ |
+
| 225 | ++ | + + | +
| 226 | ++ |
+ setMethod(+ |
+
| 227 | ++ |
+ "spltype_abbrev", "VarStaticCutSplit",+ |
+
| 228 | +10x | +
+ function(obj) "scut"+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ | + + | +
| 231 | ++ |
+ setMethod(+ |
+
| 232 | ++ |
+ "spltype_abbrev", "VarDynCutSplit",+ |
+
| 233 | +5x | +
+ function(obj) "dcut"+ |
+
| 234 | ++ |
+ )+ |
+
| 235 | ++ |
+ setMethod(+ |
+
| 236 | ++ |
+ "spltype_abbrev", "AllSplit",+ |
+
| 237 | +15x | +
+ function(obj) "all obs"+ |
+
| 238 | ++ |
+ )+ |
+
| 239 | ++ |
+ ## setMethod("spltype_abbrev", "NULLSplit",
+ |
+
| 240 | ++ |
+ ## function(obj) "no obs")+ |
+
| 241 | ++ | + + | +
| 242 | ++ |
+ setMethod(+ |
+
| 243 | ++ |
+ "spltype_abbrev", "AnalyzeVarSplit",+ |
+
| 244 | +1x | +
+ function(obj) "** analysis **"+ |
+
| 245 | ++ |
+ )+ |
+
| 246 | ++ | + + | +
| 247 | ++ |
+ setMethod(+ |
+
| 248 | ++ |
+ "spltype_abbrev", "CompoundSplit",+ |
+
| 249 | +! | +
+ function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ | + + | +
| 252 | ++ |
+ setMethod(+ |
+
| 253 | ++ |
+ "spltype_abbrev", "AnalyzeMultiVars",+ |
+
| 254 | +6x | +
+ function(obj) "** multivar analysis **"+ |
+
| 255 | ++ |
+ )+ |
+
| 256 | ++ |
+ setMethod(+ |
+
| 257 | ++ |
+ "spltype_abbrev", "AnalyzeColVarSplit",+ |
+
| 258 | +! | +
+ function(obj) "** col-var analysis **"+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ | + + | +
| 261 | ++ |
+ docat_splitvec <- function(object, indent = 0) {
+ |
+
| 262 | +8x | +
+ if (indent > 0) {
+ |
+
| 263 | +! | +
+ cat(rep(" ", times = indent), sep = "")
+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | +8x | +
+ if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
+ |
+
| 266 | +! | +
+ tab <- object[[1]]+ |
+
| 267 | +! | +
+ msg <- sprintf(+ |
+
| 268 | +! | +
+ "A Pre-Existing Table [%d x %d]",+ |
+
| 269 | +! | +
+ nrow(tab), ncol(tab)+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ |
+ } else {
+ |
+
| 272 | +8x | +
+ plds <- ploads_to_str(object) ## lapply(object, spl_payload))+ |
+
| 273 | ++ | + + | +
| 274 | +8x | +
+ tabbrev <- sapply(object, spltype_abbrev)+ |
+
| 275 | +8x | +
+ msg <- paste(+ |
+
| 276 | +8x | +
+ collapse = " -> ",+ |
+
| 277 | +8x | +
+ paste0(plds, " (", tabbrev, ")")
+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ }+ |
+
| 280 | +8x | +
+ cat(msg, "\n")+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | ++ | + + | +
| 283 | ++ |
+ setMethod(+ |
+
| 284 | ++ |
+ "show", "SplitVector",+ |
+
| 285 | ++ |
+ function(object) {
+ |
+
| 286 | +1x | +
+ cat("A SplitVector Pre-defining a Tree Structure\n\n")
+ |
+
| 287 | +1x | +
+ docat_splitvec(object)+ |
+
| 288 | +1x | +
+ cat("\n")
+ |
+
| 289 | +1x | +
+ invisible(object)+ |
+
| 290 | ++ |
+ }+ |
+
| 291 | ++ |
+ )+ |
+
| 292 | ++ | + + | +
| 293 | ++ |
+ docat_predataxis <- function(object, indent = 0) {
+ |
+
| 294 | +6x | +
+ lapply(object, docat_splitvec)+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ setMethod(+ |
+
| 298 | ++ |
+ "show", "PreDataColLayout",+ |
+
| 299 | ++ |
+ function(object) {
+ |
+
| 300 | +1x | +
+ cat("A Pre-data Column Layout Object\n\n")
+ |
+
| 301 | +1x | +
+ docat_predataxis(object)+ |
+
| 302 | +1x | +
+ invisible(object)+ |
+
| 303 | ++ |
+ }+ |
+
| 304 | ++ |
+ )+ |
+
| 305 | ++ | + + | +
| 306 | ++ |
+ setMethod(+ |
+
| 307 | ++ |
+ "show", "PreDataRowLayout",+ |
+
| 308 | ++ |
+ function(object) {
+ |
+
| 309 | +1x | +
+ cat("A Pre-data Row Layout Object\n\n")
+ |
+
| 310 | +1x | +
+ docat_predataxis(object)+ |
+
| 311 | +1x | +
+ invisible(object)+ |
+
| 312 | ++ |
+ }+ |
+
| 313 | ++ |
+ )+ |
+
| 314 | ++ | + + | +
| 315 | ++ |
+ setMethod(+ |
+
| 316 | ++ |
+ "show", "PreDataTableLayouts",+ |
+
| 317 | ++ |
+ function(object) {
+ |
+
| 318 | +2x | +
+ cat("A Pre-data Table Layout\n")
+ |
+
| 319 | +2x | +
+ cat("\nColumn-Split Structure:\n")
+ |
+
| 320 | +2x | +
+ docat_predataxis(object@col_layout)+ |
+
| 321 | +2x | +
+ cat("\nRow-Split Structure:\n")
+ |
+
| 322 | +2x | +
+ docat_predataxis(object@row_layout)+ |
+
| 323 | +2x | +
+ cat("\n")
+ |
+
| 324 | +2x | +
+ invisible(object)+ |
+
| 325 | ++ |
+ }+ |
+
| 326 | ++ |
+ )+ |
+
| 327 | ++ | + + | +
| 328 | ++ |
+ setMethod(+ |
+
| 329 | ++ |
+ "show", "InstantiatedColumnInfo",+ |
+
| 330 | ++ |
+ function(object) {
+ |
+
| 331 | +2x | +
+ layoutmsg <- layoutmsg(coltree(object))+ |
+
| 332 | +2x | +
+ cat("An InstantiatedColumnInfo object",
+ |
+
| 333 | +2x | +
+ "Columns:",+ |
+
| 334 | +2x | +
+ layoutmsg,+ |
+
| 335 | +2x | +
+ if (disp_ccounts(object)) {
+ |
+
| 336 | +2x | +
+ paste(+ |
+
| 337 | +2x | +
+ "ColumnCounts:\n",+ |
+
| 338 | +2x | +
+ paste(col_counts(object),+ |
+
| 339 | +2x | +
+ collapse = ", "+ |
+
| 340 | ++ |
+ )+ |
+
| 341 | ++ |
+ )+ |
+
| 342 | ++ |
+ },+ |
+
| 343 | ++ |
+ "",+ |
+
| 344 | +2x | +
+ sep = "\n"+ |
+
| 345 | ++ |
+ )+ |
+
| 346 | +2x | +
+ invisible(object)+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | ++ |
+ )+ |
+
| 349 | ++ | + + | +
| 350 | ++ |
+ #' @rdname int_methods+ |
+
| 351 | ++ |
+ setMethod("print", "VTableTree", function(x, ...) {
+ |
+
| 352 | +5x | +
+ msg <- toString(x, ...)+ |
+
| 353 | +4x | +
+ cat(msg)+ |
+
| 354 | +4x | +
+ invisible(x)+ |
+
| 355 | ++ |
+ })+ |
+
| 356 | ++ | + + | +
| 357 | ++ |
+ #' @rdname int_methods+ |
+
| 358 | ++ |
+ setMethod("show", "VTableTree", function(object) {
+ |
+
| 359 | +! | +
+ cat(toString(object))+ |
+
| 360 | +! | +
+ invisible(object)+ |
+
| 361 | ++ |
+ })+ |
+
| 362 | ++ | + + | +
| 363 | ++ |
+ setMethod("show", "TableRow", function(object) {
+ |
+
| 364 | +1x | +
+ cat(sprintf(+ |
+
| 365 | +1x | +
+ "[%s indent_mod %d]: %s %s\n",+ |
+
| 366 | +1x | +
+ class(object),+ |
+
| 367 | +1x | +
+ indent_mod(object),+ |
+
| 368 | +1x | +
+ obj_label(object),+ |
+
| 369 | +1x | +
+ paste(as.vector(get_formatted_cells(object)),+ |
+
| 370 | +1x | +
+ collapse = " "+ |
+
| 371 | ++ |
+ )+ |
+
| 372 | ++ |
+ ))+ |
+
| 373 | +1x | +
+ invisible(object)+ |
+
| 374 | ++ |
+ })+ |
+
| 1 | ++ |
+ ## Rules for pagination+ |
+
| 2 | ++ |
+ ##+ |
+
| 3 | ++ |
+ ## 1. user defined number of lines per page+ |
+
| 4 | ++ |
+ ## 2. all lines have the same height+ |
+
| 5 | ++ |
+ ## 3. header always reprinted on all pages+ |
+
| 6 | ++ |
+ ## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE)+ |
+
| 7 | ++ |
+ ## 5. Never (?) break on a "label"/content row+ |
+
| 8 | ++ |
+ ## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table.+ |
+
| 9 | ++ |
+ ##+ |
+
| 10 | ++ |
+ ## Current behavior: paginate_ttree takes a TableTree object and+ |
+
| 11 | ++ |
+ ## returns a list of rtable (S3) objects for printing.+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ #' @inheritParams formatters::nlines+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @rdname formatters_methods+ |
+
| 16 | ++ |
+ #' @aliases nlines,TableRow-method+ |
+
| 17 | ++ |
+ #' @exportMethod nlines+ |
+
| 18 | ++ |
+ setMethod(+ |
+
| 19 | ++ |
+ "nlines", "TableRow",+ |
+
| 20 | ++ |
+ function(x, colwidths, max_width, fontspec, col_gap = 3) {
+ |
+
| 21 | +10370x | +
+ fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) ++ |
+
| 22 | +10370x | +
+ sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))+ |
+
| 23 | +10370x | +
+ fcells <- as.vector(get_formatted_cells(x))+ |
+
| 24 | +10370x | +
+ spans <- row_cspans(x)+ |
+
| 25 | +10370x | +
+ have_cw <- !is.null(colwidths)+ |
+
| 26 | ++ |
+ ## handle spanning so that the projected word-wrapping from nlines is correct+ |
+
| 27 | +10370x | +
+ if (any(spans > 1)) {
+ |
+
| 28 | +10x | +
+ new_fcells <- character(length(spans))+ |
+
| 29 | +10x | +
+ new_colwidths <- numeric(length(spans))+ |
+
| 30 | +10x | +
+ cur_fcells <- fcells+ |
+
| 31 | +10x | +
+ cur_colwidths <- colwidths[-1] ## not the row labels they can't span+ |
+
| 32 | +10x | +
+ for (i in seq_along(spans)) {
+ |
+
| 33 | +24x | +
+ spi <- spans[i]+ |
+
| 34 | +24x | +
+ new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop+ |
+
| 35 | +24x | +
+ new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1)+ |
+
| 36 | +24x | +
+ cur_fcells <- tail(cur_fcells, -1 * spi)+ |
+
| 37 | +24x | +
+ cur_colwidths <- tail(cur_colwidths, -1 * spi)+ |
+
| 38 | ++ |
+ }+ |
+
| 39 | +10x | +
+ if (have_cw) {
+ |
+
| 40 | +4x | +
+ colwidths <- c(colwidths[1], new_colwidths)+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | +10x | +
+ fcells <- new_fcells+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE),+ |
+
| 46 | ++ |
+ ## length,+ |
+
| 47 | ++ |
+ ## 1L))+ |
+
| 48 | +10370x | +
+ rowext <- max(+ |
+
| 49 | +10370x | +
+ unlist(+ |
+
| 50 | +10370x | +
+ mapply(+ |
+
| 51 | +10370x | +
+ function(s, w) {
+ |
+
| 52 | +56089x | +
+ nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec)+ |
+
| 53 | ++ |
+ },+ |
+
| 54 | +10370x | +
+ s = c(obj_label(x), fcells),+ |
+
| 55 | +10370x | +
+ w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
+ |
+
| 56 | +10370x | +
+ SIMPLIFY = FALSE+ |
+
| 57 | ++ |
+ )+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ | + + | +
| 61 | +10370x | +
+ rowext + fns+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ |
+ )+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' @export+ |
+
| 66 | ++ |
+ #' @rdname formatters_methods+ |
+
| 67 | ++ |
+ setMethod(+ |
+
| 68 | ++ |
+ "nlines", "LabelRow",+ |
+
| 69 | ++ |
+ function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
+ |
+
| 70 | +3224x | +
+ if (labelrow_visible(x)) {
+ |
+
| 71 | +3224x | +
+ nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) ++ |
+
| 72 | +3224x | +
+ sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))+ |
+
| 73 | ++ |
+ } else {
+ |
+
| 74 | +! | +
+ 0L+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ #' @export+ |
+
| 80 | ++ |
+ #' @rdname formatters_methods+ |
+
| 81 | ++ |
+ setMethod(+ |
+
| 82 | ++ |
+ "nlines", "RefFootnote",+ |
+
| 83 | ++ |
+ function(x, colwidths, max_width, fontspec, col_gap = NULL) {
+ |
+
| 84 | +294x | +
+ nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ #' @export+ |
+
| 89 | ++ |
+ #' @rdname formatters_methods+ |
+
| 90 | ++ |
+ setMethod(+ |
+
| 91 | ++ |
+ "nlines", "InstantiatedColumnInfo",+ |
+
| 92 | ++ |
+ 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+ |
+
| 103 | ++ |
+ ),+ |
+
| 104 | +10x | +
+ nlines(tl[i],+ |
+
| 105 | +10x | +
+ colwidths = colwidths[1],+ |
+
| 106 | +10x | +
+ fontspec = fontspec+ |
+
| 107 | ++ |
+ )+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ |
+ },+ |
+
| 110 | +6x | +
+ 1L+ |
+
| 111 | ++ |
+ )+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ ## lfs <- collect_leaves(coltree(x))+ |
+
| 114 | ++ |
+ ## depths <- sapply(lfs, function(l) length(pos_splits(l)))+ |
+
| 115 | ++ | + + | +
| 116 | +6x | +
+ coldf <- make_col_df(x, colwidths = colwidths)+ |
+
| 117 | +6x | +
+ have_fnotes <- length(unlist(coldf$col_fnotes)) > 0+ |
+
| 118 | ++ |
+ ## ret <- max(depths, length(top_left(x))) ++ |
+
| 119 | ++ |
+ ## divider_height(x)+ |
+
| 120 | +6x | +
+ ret <- sum(main_nls, divider_height(x))+ |
+
| 121 | +6x | +
+ if (have_fnotes) {
+ |
+
| 122 | +! | +
+ ret <- sum(+ |
+
| 123 | +! | +
+ ret,+ |
+
| 124 | +! | +
+ vapply(unlist(coldf$col_fnotes),+ |
+
| 125 | +! | +
+ nlines,+ |
+
| 126 | +! | +
+ 1,+ |
+
| 127 | +! | +
+ max_width = max_width,+ |
+
| 128 | +! | +
+ fontspec = fontspec+ |
+
| 129 | ++ |
+ ),+ |
+
| 130 | +! | +
+ 2 * divider_height(x)+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | +6x | +
+ ret+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ col_dfrow <- function(col,+ |
+
| 138 | ++ |
+ nm = obj_name(col),+ |
+
| 139 | ++ |
+ lab = obj_label(col),+ |
+
| 140 | ++ |
+ cnum,+ |
+
| 141 | ++ |
+ pth = NULL,+ |
+
| 142 | ++ |
+ sibpos = NA_integer_,+ |
+
| 143 | ++ |
+ nsibs = NA_integer_,+ |
+
| 144 | ++ |
+ leaf_indices = cnum,+ |
+
| 145 | ++ |
+ span = length(leaf_indices),+ |
+
| 146 | ++ |
+ col_fnotes = list(),+ |
+
| 147 | ++ |
+ col_count = facet_colcount(col, NULL),+ |
+
| 148 | ++ |
+ ccount_visible = disp_ccounts(col),+ |
+
| 149 | ++ |
+ ccount_format = colcount_format(col),+ |
+
| 150 | ++ |
+ ccount_na_str,+ |
+
| 151 | ++ |
+ global_cc_format) {
+ |
+
| 152 | +12671x | +
+ if (is.null(pth)) {
+ |
+
| 153 | +12029x | +
+ pth <- pos_to_path(tree_pos(col))+ |
+
| 154 | ++ |
+ }+ |
+
| 155 | +12671x | +
+ data.frame(+ |
+
| 156 | +12671x | +
+ stringsAsFactors = FALSE,+ |
+
| 157 | +12671x | +
+ name = nm,+ |
+
| 158 | +12671x | +
+ label = lab,+ |
+
| 159 | +12671x | +
+ abs_pos = cnum,+ |
+
| 160 | +12671x | +
+ path = I(list(pth)),+ |
+
| 161 | +12671x | +
+ pos_in_siblings = sibpos,+ |
+
| 162 | +12671x | +
+ n_siblings = nsibs,+ |
+
| 163 | +12671x | +
+ leaf_indices = I(list(leaf_indices)),+ |
+
| 164 | +12671x | +
+ total_span = span,+ |
+
| 165 | +12671x | +
+ col_fnotes = I(list(col_fnotes)),+ |
+
| 166 | +12671x | +
+ n_col_fnotes = length(col_fnotes),+ |
+
| 167 | +12671x | +
+ col_count = col_count,+ |
+
| 168 | +12671x | +
+ ccount_visible = ccount_visible,+ |
+
| 169 | +12671x | +
+ ccount_format = ccount_format %||% global_cc_format,+ |
+
| 170 | +12671x | +
+ ccount_na_str = ccount_na_str+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | ++ |
+ }+ |
+
| 173 | ++ | + + | +
| 174 | ++ |
+ pos_to_path <- function(pos) {
+ |
+
| 175 | +46123x | +
+ spls <- pos_splits(pos)+ |
+
| 176 | +46123x | +
+ vals <- pos_splvals(pos)+ |
+
| 177 | ++ | + + | +
| 178 | +46123x | +
+ path <- character()+ |
+
| 179 | +46123x | +
+ for (i in seq_along(spls)) {
+ |
+
| 180 | +58287x | +
+ nm <- obj_name(spls[[i]])+ |
+
| 181 | +58287x | +
+ val_i <- value_names(vals[[i]])+ |
+
| 182 | +58287x | +
+ path <- c(+ |
+
| 183 | +58287x | +
+ path,+ |
+
| 184 | +58287x | +
+ obj_name(spls[[i]]),+ |
+
| 185 | ++ |
+ ## rawvalues(vals[[i]]))+ |
+
| 186 | +58287x | +
+ if (!is.na(val_i)) val_i+ |
+
| 187 | ++ |
+ )+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | +46123x | +
+ path+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ | + + | +
| 192 | ++ |
+ # make_row_df ---------------------------------------------------------------+ |
+
| 193 | ++ | + + | +
| 194 | ++ |
+ #' @inherit formatters::make_row_df+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ # #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and+ |
+
| 197 | ++ |
+ # #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination.+ |
+
| 198 | ++ |
+ # #'+ |
+
| 199 | ++ |
+ # #' @return a data.frame of row/column-structure information used by the pagination machinery.+ |
+
| 200 | ++ |
+ # #'+ |
+
| 201 | ++ |
+ # #' @export+ |
+
| 202 | ++ |
+ # #' @name make_row_df+ |
+
| 203 | ++ |
+ # #' @rdname make_row_df+ |
+
| 204 | ++ |
+ # #' @aliases make_row_df,VTableTree-method+ |
+
| 205 | ++ |
+ #' @rdname formatters_methods+ |
+
| 206 | ++ |
+ #' @exportMethod make_row_df+ |
+
| 207 | ++ |
+ setMethod(+ |
+
| 208 | ++ |
+ "make_row_df", "VTableTree",+ |
+
| 209 | ++ |
+ function(tt,+ |
+
| 210 | ++ |
+ colwidths = NULL,+ |
+
| 211 | ++ |
+ visible_only = TRUE,+ |
+
| 212 | ++ |
+ rownum = 0,+ |
+
| 213 | ++ |
+ indent = 0L,+ |
+
| 214 | ++ |
+ path = character(),+ |
+
| 215 | ++ |
+ incontent = FALSE,+ |
+
| 216 | ++ |
+ repr_ext = 0L,+ |
+
| 217 | ++ |
+ repr_inds = integer(),+ |
+
| 218 | ++ |
+ sibpos = NA_integer_,+ |
+
| 219 | ++ |
+ nsibs = NA_integer_,+ |
+
| 220 | ++ |
+ max_width = NULL,+ |
+
| 221 | ++ |
+ fontspec = NULL,+ |
+
| 222 | ++ |
+ col_gap = 3) {
+ |
+
| 223 | +9215x | +
+ indent <- indent + indent_mod(tt)+ |
+
| 224 | ++ |
+ ## retained for debugging info+ |
+
| 225 | +9215x | +
+ orig_rownum <- rownum # nolint+ |
+
| 226 | +9215x | +
+ if (incontent) {
+ |
+
| 227 | +1268x | +
+ path <- c(path, "@content")+ |
+
| 228 | +7947x | +
+ } 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+ |
+
| 230 | +7899x | +
+ path <- c(path, obj_name(tt))+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | +9215x | +
+ ret <- list()+ |
+
| 233 | ++ | + + | +
| 234 | ++ |
+ ## note this is the **table** not the label row+ |
+
| 235 | +9215x | +
+ if (!visible_only) {
+ |
+
| 236 | +21x | +
+ ret <- c(+ |
+
| 237 | +21x | +
+ ret,+ |
+
| 238 | +21x | +
+ list(pagdfrow(+ |
+
| 239 | +21x | +
+ rnum = NA,+ |
+
| 240 | +21x | +
+ nm = obj_name(tt),+ |
+
| 241 | +21x | +
+ lab = "",+ |
+
| 242 | +21x | +
+ pth = path,+ |
+
| 243 | +21x | +
+ colwidths = colwidths,+ |
+
| 244 | +21x | +
+ repext = repr_ext,+ |
+
| 245 | +21x | +
+ repind = list(repr_inds),+ |
+
| 246 | +21x | +
+ extent = 0,+ |
+
| 247 | +21x | +
+ indent = indent,+ |
+
| 248 | +21x | +
+ rclass = class(tt), sibpos = sibpos,+ |
+
| 249 | +21x | +
+ nsibs = nsibs,+ |
+
| 250 | +21x | +
+ nrowrefs = 0L,+ |
+
| 251 | +21x | +
+ ncellrefs = 0L,+ |
+
| 252 | +21x | +
+ nreflines = 0L,+ |
+
| 253 | +21x | +
+ fontspec = fontspec+ |
+
| 254 | ++ |
+ ))+ |
+
| 255 | ++ |
+ )+ |
+
| 256 | ++ |
+ }+ |
+
| 257 | +9215x | +
+ if (labelrow_visible(tt)) {
+ |
+
| 258 | +3204x | +
+ lr <- tt_labelrow(tt)+ |
+
| 259 | +3204x | +
+ newdf <- make_row_df(lr,+ |
+
| 260 | +3204x | +
+ colwidths = colwidths,+ |
+
| 261 | +3204x | +
+ visible_only = visible_only,+ |
+
| 262 | +3204x | +
+ rownum = rownum,+ |
+
| 263 | +3204x | +
+ indent = indent,+ |
+
| 264 | +3204x | +
+ path = path,+ |
+
| 265 | +3204x | +
+ incontent = TRUE,+ |
+
| 266 | +3204x | +
+ repr_ext = repr_ext,+ |
+
| 267 | +3204x | +
+ repr_inds = repr_inds,+ |
+
| 268 | +3204x | +
+ max_width = max_width,+ |
+
| 269 | +3204x | +
+ fontspec = fontspec+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | +3204x | +
+ rownum <- max(newdf$abs_rownumber, na.rm = TRUE)+ |
+
| 272 | ++ | + + | +
| 273 | +3204x | +
+ ret <- c(+ |
+
| 274 | +3204x | +
+ ret,+ |
+
| 275 | +3204x | +
+ list(newdf)+ |
+
| 276 | ++ |
+ )+ |
+
| 277 | +3204x | +
+ repr_ext <- repr_ext + 1L+ |
+
| 278 | +3204x | +
+ repr_inds <- c(repr_inds, rownum)+ |
+
| 279 | +3204x | +
+ indent <- indent + 1L+ |
+
| 280 | ++ |
+ }+ |
+
| 281 | ++ | + + | +
| 282 | +9215x | +
+ if (NROW(content_table(tt)) > 0) {
+ |
+
| 283 | +1268x | +
+ ct_tt <- content_table(tt)+ |
+
| 284 | +1268x | +
+ cind <- indent + indent_mod(ct_tt)+ |
+
| 285 | +1268x | +
+ trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt))+ |
+
| 286 | +1268x | +
+ contdf <- make_row_df(ct_tt,+ |
+
| 287 | +1268x | +
+ colwidths = colwidths,+ |
+
| 288 | +1268x | +
+ visible_only = visible_only,+ |
+
| 289 | +1268x | +
+ rownum = rownum,+ |
+
| 290 | +1268x | +
+ indent = cind,+ |
+
| 291 | +1268x | +
+ path = path,+ |
+
| 292 | +1268x | +
+ incontent = TRUE,+ |
+
| 293 | +1268x | +
+ repr_ext = repr_ext,+ |
+
| 294 | +1268x | +
+ repr_inds = repr_inds,+ |
+
| 295 | +1268x | +
+ max_width = max_width,+ |
+
| 296 | +1268x | +
+ fontspec = fontspec+ |
+
| 297 | ++ |
+ )+ |
+
| 298 | +1268x | +
+ crnums <- contdf$abs_rownumber+ |
+
| 299 | +1268x | +
+ crnums <- crnums[!is.na(crnums)]+ |
+
| 300 | ++ | + + | +
| 301 | +1268x | +
+ newrownum <- max(crnums, na.rm = TRUE)+ |
+
| 302 | +1268x | +
+ if (is.finite(newrownum)) {
+ |
+
| 303 | +1268x | +
+ rownum <- newrownum+ |
+
| 304 | +1268x | +
+ repr_ext <- repr_ext + length(crnums)+ |
+
| 305 | +1268x | +
+ repr_inds <- c(repr_inds, crnums)+ |
+
| 306 | ++ |
+ }+ |
+
| 307 | +1268x | +
+ ret <- c(ret, list(contdf))+ |
+
| 308 | +1268x | +
+ indent <- cind + 1+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | ++ | + + | +
| 311 | +9215x | +
+ allkids <- tree_children(tt)+ |
+
| 312 | +9215x | +
+ newnsibs <- length(allkids)+ |
+
| 313 | +9215x | +
+ for (i in seq_along(allkids)) {
+ |
+
| 314 | +17516x | +
+ kid <- allkids[[i]]+ |
+
| 315 | +17516x | +
+ kiddfs <- make_row_df(kid,+ |
+
| 316 | +17516x | +
+ colwidths = colwidths,+ |
+
| 317 | +17516x | +
+ visible_only = visible_only,+ |
+
| 318 | +17516x | +
+ rownum = force(rownum),+ |
+
| 319 | +17516x | +
+ indent = indent, ## + 1,+ |
+
| 320 | +17516x | +
+ path = path,+ |
+
| 321 | +17516x | +
+ incontent = incontent,+ |
+
| 322 | +17516x | +
+ repr_ext = repr_ext,+ |
+
| 323 | +17516x | +
+ repr_inds = repr_inds,+ |
+
| 324 | +17516x | +
+ nsibs = newnsibs,+ |
+
| 325 | +17516x | +
+ sibpos = i,+ |
+
| 326 | +17516x | +
+ max_width = max_width,+ |
+
| 327 | +17516x | +
+ fontspec = fontspec+ |
+
| 328 | ++ |
+ )+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ # print(kiddfs$abs_rownumber)+ |
+
| 331 | +17516x | +
+ rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)+ |
+
| 332 | +17516x | +
+ ret <- c(ret, list(kiddfs))+ |
+
| 333 | ++ |
+ }+ |
+
| 334 | ++ | + + | +
| 335 | +9215x | +
+ ret <- do.call(rbind, ret)+ |
+
| 336 | ++ | + + | +
| 337 | ++ |
+ # Case where it has Elementary table or VTableTree section_div it is overridden+ |
+
| 338 | +9215x | +
+ if (!is.na(trailing_section_div(tt))) {
+ |
+
| 339 | +110x | +
+ ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt)+ |
+
| 340 | ++ |
+ }+ |
+
| 341 | +9215x | +
+ ret+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | ++ |
+ )+ |
+
| 344 | ++ | + + | +
| 345 | ++ |
+ # #' @exportMethod make_row_df+ |
+
| 346 | ++ |
+ #' @inherit formatters::make_row_df+ |
+
| 347 | ++ |
+ #'+ |
+
| 348 | ++ |
+ #' @export+ |
+
| 349 | ++ |
+ #' @rdname formatters_methods+ |
+
| 350 | ++ |
+ setMethod(+ |
+
| 351 | ++ |
+ "make_row_df", "TableRow",+ |
+
| 352 | ++ |
+ function(tt, colwidths = NULL, visible_only = TRUE,+ |
+
| 353 | ++ |
+ rownum = 0,+ |
+
| 354 | ++ |
+ indent = 0L,+ |
+
| 355 | ++ |
+ path = "root",+ |
+
| 356 | ++ |
+ incontent = FALSE,+ |
+
| 357 | ++ |
+ repr_ext = 0L,+ |
+
| 358 | ++ |
+ repr_inds = integer(),+ |
+
| 359 | ++ |
+ sibpos = NA_integer_,+ |
+
| 360 | ++ |
+ nsibs = NA_integer_,+ |
+
| 361 | ++ |
+ max_width = NULL,+ |
+
| 362 | ++ |
+ fontspec,+ |
+
| 363 | ++ |
+ col_gap = 3) {
+ |
+
| 364 | +10360x | +
+ indent <- indent + indent_mod(tt)+ |
+
| 365 | +10360x | +
+ rownum <- rownum + 1+ |
+
| 366 | +10360x | +
+ rrefs <- row_footnotes(tt)+ |
+
| 367 | +10360x | +
+ crefs <- cell_footnotes(tt)+ |
+
| 368 | +10360x | +
+ reflines <- sum(+ |
+
| 369 | +10360x | +
+ sapply(+ |
+
| 370 | +10360x | +
+ c(rrefs, crefs),+ |
+
| 371 | +10360x | +
+ nlines,+ |
+
| 372 | +10360x | +
+ colwidths = colwidths,+ |
+
| 373 | +10360x | +
+ max_width = max_width,+ |
+
| 374 | +10360x | +
+ fontspec = fontspec,+ |
+
| 375 | +10360x | +
+ col_gap = col_gap+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | +10360x | +
+ ) ## col_gap not strictly necessary as these aren't rows, but why not+ |
+
| 378 | +10360x | +
+ ret <- pagdfrow(+ |
+
| 379 | +10360x | +
+ row = tt,+ |
+
| 380 | +10360x | +
+ rnum = rownum,+ |
+
| 381 | +10360x | +
+ colwidths = colwidths,+ |
+
| 382 | +10360x | +
+ sibpos = sibpos,+ |
+
| 383 | +10360x | +
+ nsibs = nsibs,+ |
+
| 384 | +10360x | +
+ pth = c(path, unname(obj_name(tt))),+ |
+
| 385 | +10360x | +
+ repext = repr_ext,+ |
+
| 386 | +10360x | +
+ repind = repr_inds,+ |
+
| 387 | +10360x | +
+ indent = indent,+ |
+
| 388 | +10360x | +
+ extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),+ |
+
| 389 | ++ |
+ ## these two are unlist calls cause they come in lists even with no footnotes+ |
+
| 390 | +10360x | +
+ nrowrefs = length(rrefs),+ |
+
| 391 | +10360x | +
+ ncellrefs = length(unlist(crefs)),+ |
+
| 392 | +10360x | +
+ nreflines = reflines,+ |
+
| 393 | +10360x | +
+ trailing_sep = trailing_section_div(tt),+ |
+
| 394 | +10360x | +
+ fontspec = fontspec+ |
+
| 395 | ++ |
+ )+ |
+
| 396 | +10360x | +
+ ret+ |
+
| 397 | ++ |
+ }+ |
+
| 398 | ++ |
+ )+ |
+
| 399 | ++ | + + | +
| 400 | ++ |
+ # #' @exportMethod make_row_df+ |
+
| 401 | ++ |
+ #' @export+ |
+
| 402 | ++ |
+ #' @rdname formatters_methods+ |
+
| 403 | ++ |
+ setMethod(+ |
+
| 404 | ++ |
+ "make_row_df", "LabelRow",+ |
+
| 405 | ++ |
+ function(tt, colwidths = NULL, visible_only = TRUE,+ |
+
| 406 | ++ |
+ rownum = 0,+ |
+
| 407 | ++ |
+ indent = 0L,+ |
+
| 408 | ++ |
+ path = "root",+ |
+
| 409 | ++ |
+ incontent = FALSE,+ |
+
| 410 | ++ |
+ repr_ext = 0L,+ |
+
| 411 | ++ |
+ repr_inds = integer(),+ |
+
| 412 | ++ |
+ sibpos = NA_integer_,+ |
+
| 413 | ++ |
+ nsibs = NA_integer_,+ |
+
| 414 | ++ |
+ max_width = NULL,+ |
+
| 415 | ++ |
+ fontspec,+ |
+
| 416 | ++ |
+ col_gap = 3) {
+ |
+
| 417 | +3224x | +
+ rownum <- rownum + 1+ |
+
| 418 | +3224x | +
+ indent <- indent + indent_mod(tt)+ |
+
| 419 | +3224x | +
+ ret <- pagdfrow(tt,+ |
+
| 420 | +3224x | +
+ extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),+ |
+
| 421 | +3224x | +
+ rnum = rownum,+ |
+
| 422 | +3224x | +
+ colwidths = colwidths,+ |
+
| 423 | +3224x | +
+ sibpos = sibpos,+ |
+
| 424 | +3224x | +
+ nsibs = nsibs,+ |
+
| 425 | +3224x | +
+ pth = path,+ |
+
| 426 | +3224x | +
+ repext = repr_ext,+ |
+
| 427 | +3224x | +
+ repind = repr_inds,+ |
+
| 428 | +3224x | +
+ indent = indent,+ |
+
| 429 | +3224x | +
+ nrowrefs = length(row_footnotes(tt)),+ |
+
| 430 | +3224x | +
+ ncellrefs = 0L,+ |
+
| 431 | +3224x | +
+ nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_,+ |
+
| 432 | +3224x | +
+ colwidths = colwidths,+ |
+
| 433 | +3224x | +
+ max_width = max_width,+ |
+
| 434 | +3224x | +
+ fontspec = fontspec,+ |
+
| 435 | +3224x | +
+ col_gap = col_gap+ |
+
| 436 | ++ |
+ )),+ |
+
| 437 | +3224x | +
+ trailing_sep = trailing_section_div(tt),+ |
+
| 438 | +3224x | +
+ fontspec = fontspec+ |
+
| 439 | ++ |
+ )+ |
+
| 440 | +3224x | +
+ if (!labelrow_visible(tt)) {
+ |
+
| 441 | +! | +
+ ret <- ret[0, , drop = FALSE]+ |
+
| 442 | ++ |
+ }+ |
+
| 443 | +3224x | +
+ ret+ |
+
| 444 | ++ |
+ }+ |
+
| 445 | ++ |
+ )+ |
+
| 446 | ++ | + + | +
| 447 | ++ |
+ setGeneric("inner_col_df", function(ct,
+ |
+
| 448 | ++ |
+ colwidths = NULL,+ |
+
| 449 | ++ |
+ visible_only = TRUE,+ |
+
| 450 | ++ |
+ colnum = 0L,+ |
+
| 451 | ++ |
+ sibpos = NA_integer_,+ |
+
| 452 | ++ |
+ nsibs = NA_integer_,+ |
+
| 453 | ++ |
+ ncolref = 0L,+ |
+
| 454 | ++ |
+ na_str,+ |
+
| 455 | ++ |
+ global_cc_format) {
+ |
+
| 456 | +18760x | +
+ standardGeneric("inner_col_df")
+ |
+
| 457 | ++ |
+ })+ |
+
| 458 | ++ | + + | +
| 459 | ++ |
+ #' Column layout summary+ |
+
| 460 | ++ |
+ #'+ |
+
| 461 | ++ |
+ #' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a+ |
+
| 462 | ++ |
+ #' `data.frame`.+ |
+
| 463 | ++ |
+ #'+ |
+
| 464 | ++ |
+ #' @inheritParams formatters::make_row_df+ |
+
| 465 | ++ |
+ #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for+ |
+
| 466 | ++ |
+ #' column counts if one is not specified for an individual column count.+ |
+
| 467 | ++ |
+ #' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this.+ |
+
| 468 | ++ |
+ #' @export+ |
+
| 469 | ++ |
+ make_col_df <- function(tt,+ |
+
| 470 | ++ |
+ colwidths = NULL,+ |
+
| 471 | ++ |
+ visible_only = TRUE,+ |
+
| 472 | ++ |
+ na_str = "",+ |
+
| 473 | ++ |
+ ccount_format = colcount_format(tt) %||% "(N=xx)") {
+ |
+
| 474 | +3399x | +
+ ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object+ |
+
| 475 | +3399x | +
+ rows <- inner_col_df(ctree,+ |
+
| 476 | ++ |
+ ## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)),+ |
+
| 477 | +3399x | +
+ colwidths = colwidths,+ |
+
| 478 | +3399x | +
+ visible_only = visible_only,+ |
+
| 479 | +3399x | +
+ colnum = 1L,+ |
+
| 480 | +3399x | +
+ sibpos = 1L,+ |
+
| 481 | +3399x | +
+ nsibs = 1L,+ |
+
| 482 | +3399x | +
+ na_str = na_str,+ |
+
| 483 | +3399x | +
+ global_cc_format = ccount_format+ |
+
| 484 | +3399x | +
+ ) ## nsiblings includes current so 1 means "only child"+ |
+
| 485 | ++ | + + | +
| 486 | +3399x | +
+ do.call(rbind, rows)+ |
+
| 487 | ++ |
+ }+ |
+
| 488 | ++ | + + | +
| 489 | ++ |
+ setMethod(+ |
+
| 490 | ++ |
+ "inner_col_df", "LayoutColLeaf",+ |
+
| 491 | ++ |
+ function(ct, colwidths, visible_only,+ |
+
| 492 | ++ |
+ colnum,+ |
+
| 493 | ++ |
+ sibpos,+ |
+
| 494 | ++ |
+ nsibs,+ |
+
| 495 | ++ |
+ na_str,+ |
+
| 496 | ++ |
+ global_cc_format) {
+ |
+
| 497 | +12029x | +
+ list(col_dfrow(+ |
+
| 498 | +12029x | +
+ col = ct,+ |
+
| 499 | +12029x | +
+ cnum = colnum,+ |
+
| 500 | +12029x | +
+ sibpos = sibpos,+ |
+
| 501 | +12029x | +
+ nsibs = nsibs,+ |
+
| 502 | +12029x | +
+ leaf_indices = colnum,+ |
+
| 503 | +12029x | +
+ col_fnotes = col_footnotes(ct),+ |
+
| 504 | +12029x | +
+ ccount_na_str = na_str,+ |
+
| 505 | +12029x | +
+ global_cc_format = global_cc_format+ |
+
| 506 | ++ |
+ ))+ |
+
| 507 | ++ |
+ }+ |
+
| 508 | ++ |
+ )+ |
+
| 509 | ++ | + + | +
| 510 | ++ |
+ setMethod(+ |
+
| 511 | ++ |
+ "inner_col_df", "LayoutColTree",+ |
+
| 512 | ++ |
+ function(ct, colwidths, visible_only,+ |
+
| 513 | ++ |
+ colnum,+ |
+
| 514 | ++ |
+ sibpos,+ |
+
| 515 | ++ |
+ nsibs,+ |
+
| 516 | ++ |
+ na_str,+ |
+
| 517 | ++ |
+ global_cc_format) {
+ |
+
| 518 | +6731x | +
+ kids <- tree_children(ct)+ |
+
| 519 | +6731x | +
+ ret <- vector("list", length(kids))
+ |
+
| 520 | +6731x | +
+ for (i in seq_along(kids)) {
+ |
+
| 521 | +15361x | +
+ k <- kids[[i]]+ |
+
| 522 | +15361x | +
+ newrows <- do.call(+ |
+
| 523 | +15361x | +
+ rbind,+ |
+
| 524 | +15361x | +
+ inner_col_df(k,+ |
+
| 525 | +15361x | +
+ colnum = colnum,+ |
+
| 526 | +15361x | +
+ sibpos = i,+ |
+
| 527 | +15361x | +
+ nsibs = length(kids),+ |
+
| 528 | +15361x | +
+ visible_only = visible_only,+ |
+
| 529 | +15361x | +
+ na_str = na_str,+ |
+
| 530 | +15361x | +
+ global_cc_format = global_cc_format+ |
+
| 531 | ++ |
+ )+ |
+
| 532 | ++ |
+ )+ |
+
| 533 | +15361x | +
+ colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1+ |
+
| 534 | +15361x | +
+ ret[[i]] <- newrows+ |
+
| 535 | ++ |
+ }+ |
+
| 536 | ++ | + + | +
| 537 | +6731x | +
+ if (!visible_only) {
+ |
+
| 538 | +1296x | +
+ allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)]))+ |
+
| 539 | +1296x | +
+ thispth <- pos_to_path(tree_pos(ct))+ |
+
| 540 | +1296x | +
+ if (any(nzchar(thispth))) {
+ |
+
| 541 | +642x | +
+ thisone <- list(col_dfrow(+ |
+
| 542 | +642x | +
+ col = ct,+ |
+
| 543 | +642x | +
+ cnum = NA_integer_,+ |
+
| 544 | +642x | +
+ leaf_indices = allindices,+ |
+
| 545 | +642x | +
+ sibpos = sibpos,+ |
+
| 546 | +642x | +
+ nsibs = nsibs,+ |
+
| 547 | +642x | +
+ pth = thispth,+ |
+
| 548 | +642x | +
+ col_fnotes = col_footnotes(ct),+ |
+
| 549 | +642x | +
+ ccount_na_str = na_str,+ |
+
| 550 | +642x | +
+ global_cc_format = global_cc_format+ |
+
| 551 | ++ |
+ ))+ |
+
| 552 | +642x | +
+ ret <- c(thisone, ret)+ |
+
| 553 | ++ |
+ }+ |
+
| 554 | ++ |
+ }+ |
+
| 555 | ++ | + + | +
| 556 | +6731x | +
+ ret+ |
+
| 557 | ++ |
+ }+ |
+
| 558 | ++ |
+ )+ |
+
| 559 | ++ | + + | +
| 560 | ++ |
+ ## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND+ |
+
| 561 | ++ |
+ ## title/subtitle!!!!!+ |
+
| 562 | ++ |
+ .header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
+ |
+
| 563 | +3x | +
+ cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ |
+
| 564 | +3x | +
+ if (any(nzchar(all_titles(tt)))) {
+ |
+
| 565 | ++ |
+ ## +1 is for blank line between subtitles and divider+ |
+
| 566 | +2x | +
+ tlines <- sum(nlines(all_titles(tt),+ |
+
| 567 | +2x | +
+ colwidths = colwidths,+ |
+
| 568 | +2x | +
+ max_width = max_width,+ |
+
| 569 | +2x | +
+ fontspec = fontspec+ |
+
| 570 | +2x | +
+ )) + divider_height(tt) + 1L+ |
+
| 571 | ++ |
+ } else {
+ |
+
| 572 | +1x | +
+ tlines <- 0+ |
+
| 573 | ++ |
+ }+ |
+
| 574 | +3x | +
+ ret <- cinfo_lines + tlines+ |
+
| 575 | +3x | +
+ if (verbose) {
+ |
+
| 576 | +! | +
+ message(+ |
+
| 577 | +! | +
+ "Lines required for header content: ",+ |
+
| 578 | +! | +
+ ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")"+ |
+
| 579 | ++ |
+ )+ |
+
| 580 | ++ |
+ }+ |
+
| 581 | +3x | +
+ ret+ |
+
| 582 | ++ |
+ }+ |
+
| 583 | ++ | + + | +
| 584 | ++ |
+ ## this is ***only*** lines that are expected to be repeated on multiple pages:+ |
+
| 585 | ++ |
+ ## main footer, prov footer, and referential footnotes on **columns**+ |
+
| 586 | ++ | + + | +
| 587 | ++ |
+ .footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
+ |
+
| 588 | +3x | +
+ flines <- nlines(main_footer(tt),+ |
+
| 589 | +3x | +
+ colwidths = colwidths,+ |
+
| 590 | +3x | +
+ max_width = max_width - table_inset(tt),+ |
+
| 591 | +3x | +
+ fontspec = fontspec+ |
+
| 592 | ++ |
+ ) ++ |
+
| 593 | +3x | +
+ nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ |
+
| 594 | +3x | +
+ if (flines > 0) {
+ |
+
| 595 | +2x | +
+ dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)+ |
+
| 596 | +2x | +
+ flines <- flines + dl_contrib + 1L+ |
+
| 597 | ++ |
+ }+ |
+
| 598 | ++ | + + | +
| 599 | +3x | +
+ if (verbose) {
+ |
+
| 600 | +! | +
+ message(+ |
+
| 601 | +! | +
+ "Determining lines required for footer content",+ |
+
| 602 | +! | +
+ if (have_cfnotes) " [column fnotes present]",+ |
+
| 603 | +! | +
+ ": ", flines, " lines"+ |
+
| 604 | ++ |
+ )+ |
+
| 605 | ++ |
+ }+ |
+
| 606 | ++ | + + | +
| 607 | +3x | +
+ flines+ |
+
| 608 | ++ |
+ }+ |
+
| 609 | ++ | + + | +
| 610 | ++ |
+ # Pagination ---------------------------------------------------------------+ |
+
| 611 | ++ | + + | +
| 612 | ++ |
+ #' Pagination of a `TableTree`+ |
+
| 613 | ++ |
+ #'+ |
+
| 614 | ++ |
+ #' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size.+ |
+
| 615 | ++ |
+ #'+ |
+
| 616 | ++ |
+ #' @inheritParams gen_args+ |
+
| 617 | ++ |
+ #' @inheritParams paginate_table+ |
+
| 618 | ++ |
+ #' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows.+ |
+
| 619 | ++ |
+ #' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a+ |
+
| 620 | ++ |
+ #' mid-subtable split to be valid. Defaults to 2.+ |
+
| 621 | ++ |
+ #' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other+ |
+
| 622 | ++ |
+ #' considerations. Defaults to none.+ |
+
| 623 | ++ |
+ #'+ |
+
| 624 | ++ |
+ #' @return+ |
+
| 625 | ++ |
+ #' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`.+ |
+
| 626 | ++ |
+ #' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`.+ |
+
| 627 | ++ |
+ #'+ |
+
| 628 | ++ |
+ #' @details+ |
+
| 629 | ++ |
+ #' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated+ |
+
| 630 | ++ |
+ #' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the+ |
+
| 631 | ++ |
+ #' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of+ |
+
| 632 | ++ |
+ #' text than rendering the table without pagination would.+ |
+
| 633 | ++ |
+ #'+ |
+
| 634 | ++ |
+ #' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content.+ |
+
| 635 | ++ |
+ #'+ |
+
| 636 | ++ |
+ #' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`).+ |
+
| 637 | ++ |
+ #'+ |
+
| 638 | ++ |
+ #' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same+ |
+
| 639 | ++ |
+ #' algorithm used for vertical pagination to it.+ |
+
| 640 | ++ |
+ #'+ |
+
| 641 | ++ |
+ #' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and+ |
+
| 642 | ++ |
+ #' characters-per-page (`cpp`) values.+ |
+
| 643 | ++ |
+ #'+ |
+
| 644 | ++ |
+ #' The full multi-direction pagination algorithm then is as follows:+ |
+
| 645 | ++ |
+ #'+ |
+
| 646 | ++ |
+ #' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns):+ |
+
| 647 | ++ |
+ #' - titles/footers/column labels, and horizontal dividers in the vertical pagination case+ |
+
| 648 | ++ |
+ #' - row-labels, table_inset, and top-left materials in the horizontal case+ |
+
| 649 | ++ |
+ #' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables.+ |
+
| 650 | ++ |
+ #' 2. Perform vertical pagination separately on each table generated in (1).+ |
+
| 651 | ++ |
+ #' 3. Perform horizontal pagination **on the entire table** and apply the results to each table+ |
+
| 652 | ++ |
+ #' page generated in (1)-(2).+ |
+
| 653 | ++ |
+ #' 4. Return a list of subtables representing full bi-directional pagination.+ |
+
| 654 | ++ |
+ #'+ |
+
| 655 | ++ |
+ #' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package:+ |
+
| 656 | ++ |
+ #'+ |
+
| 657 | ++ |
+ #' @inheritSection formatters::pagination_algo Pagination Algorithm+ |
+
| 658 | ++ |
+ #'+ |
+
| 659 | ++ |
+ #' @examples+ |
+
| 660 | ++ |
+ #' s_summary <- function(x) {
+ |
+
| 661 | ++ |
+ #' if (is.numeric(x)) {
+ |
+
| 662 | ++ |
+ #' in_rows(+ |
+
| 663 | ++ |
+ #' "n" = rcell(sum(!is.na(x)), format = "xx"),+ |
+
| 664 | ++ |
+ #' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)),+ |
+
| 665 | ++ |
+ #' format = "xx.xx (xx.xx)"+ |
+
| 666 | ++ |
+ #' ),+ |
+
| 667 | ++ |
+ #' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"),+ |
+
| 668 | ++ |
+ #' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx")+ |
+
| 669 | ++ |
+ #' )+ |
+
| 670 | ++ |
+ #' } else if (is.factor(x)) {
+ |
+
| 671 | ++ |
+ #' vs <- as.list(table(x))+ |
+
| 672 | ++ |
+ #' do.call(in_rows, lapply(vs, rcell, format = "xx"))+ |
+
| 673 | ++ |
+ #' } else {
+ |
+
| 674 | ++ |
+ #' (+ |
+
| 675 | ++ |
+ #' stop("type not supported")
+ |
+
| 676 | ++ |
+ #' )+ |
+
| 677 | ++ |
+ #' }+ |
+
| 678 | ++ |
+ #' }+ |
+
| 679 | ++ |
+ #'+ |
+
| 680 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 681 | ++ |
+ #' split_cols_by(var = "ARM") %>%+ |
+
| 682 | ++ |
+ #' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
+ |
+
| 683 | ++ |
+ #'+ |
+
| 684 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 685 | ++ |
+ #' tbl+ |
+
| 686 | ++ |
+ #'+ |
+
| 687 | ++ |
+ #' nrow(tbl)+ |
+
| 688 | ++ |
+ #'+ |
+
| 689 | ++ |
+ #' row_paths_summary(tbl)+ |
+
| 690 | ++ |
+ #'+ |
+
| 691 | ++ |
+ #' tbls <- paginate_table(tbl, lpp = 15)+ |
+
| 692 | ++ |
+ #' mf <- matrix_form(tbl, indent_rownames = TRUE)+ |
+
| 693 | ++ |
+ #' w_tbls <- propose_column_widths(mf) # so that we have the same column widths+ |
+
| 694 | ++ |
+ #'+ |
+
| 695 | ++ |
+ #'+ |
+
| 696 | ++ |
+ #' tmp <- lapply(tbls, function(tbli) {
+ |
+
| 697 | ++ |
+ #' cat(toString(tbli, widths = w_tbls))+ |
+
| 698 | ++ |
+ #' cat("\n\n")
+ |
+
| 699 | ++ |
+ #' cat("~~~~ PAGE BREAK ~~~~")
+ |
+
| 700 | ++ |
+ #' cat("\n\n")
+ |
+
| 701 | ++ |
+ #' })+ |
+
| 702 | ++ |
+ #'+ |
+
| 703 | ++ |
+ #' @rdname paginate+ |
+
| 704 | ++ |
+ #' @export+ |
+
| 705 | ++ |
+ pag_tt_indices <- function(tt,+ |
+
| 706 | ++ |
+ lpp = 15,+ |
+
| 707 | ++ |
+ min_siblings = 2,+ |
+
| 708 | ++ |
+ nosplitin = character(),+ |
+
| 709 | ++ |
+ colwidths = NULL,+ |
+
| 710 | ++ |
+ max_width = NULL,+ |
+
| 711 | ++ |
+ fontspec = NULL,+ |
+
| 712 | ++ |
+ col_gap = 3,+ |
+
| 713 | ++ |
+ verbose = FALSE) {
+ |
+
| 714 | +3x | +
+ dheight <- divider_height(tt)+ |
+
| 715 | ++ | + + | +
| 716 | ++ |
+ # 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 | ++ | + + | +
| 720 | +3x | +
+ hlines <- .header_rep_nlines(tt,+ |
+
| 721 | +3x | +
+ colwidths = colwidths, max_width = max_width,+ |
+
| 722 | +3x | +
+ verbose = verbose,+ |
+
| 723 | +3x | +
+ fontspec = fontspec+ |
+
| 724 | ++ |
+ )+ |
+
| 725 | ++ |
+ ## if(any(nzchar(all_titles(tt)))) {
+ |
+
| 726 | ++ |
+ ## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) ++ |
+
| 727 | ++ |
+ ## length(wrap_txt(all_titles(tt), max_width = max_width)) ++ |
+
| 728 | ++ |
+ ## dheight + 1L+ |
+
| 729 | ++ |
+ ## } else {
+ |
+
| 730 | ++ |
+ ## tlines <- 0+ |
+
| 731 | ++ |
+ ## }+ |
+
| 732 | ++ |
+ ## flines <- nlines(main_footer(tt), colwidths = colwidths,+ |
+
| 733 | ++ |
+ ## max_width = max_width - table_inset(tt)) ++ |
+
| 734 | ++ |
+ ## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width)+ |
+
| 735 | ++ |
+ ## if(flines > 0) {
+ |
+
| 736 | ++ |
+ ## dl_contrib <- if(have_cfnotes) 0 else dheight+ |
+
| 737 | ++ |
+ ## flines <- flines + dl_contrib + 1L+ |
+
| 738 | ++ |
+ ## }+ |
+
| 739 | +3x | +
+ flines <- .footer_rep_nlines(tt,+ |
+
| 740 | +3x | +
+ colwidths = colwidths,+ |
+
| 741 | +3x | +
+ max_width = max_width,+ |
+
| 742 | +3x | +
+ have_cfnotes = have_cfnotes,+ |
+
| 743 | +3x | +
+ fontspec = fontspec,+ |
+
| 744 | +3x | +
+ verbose = verbose+ |
+
| 745 | ++ |
+ )+ |
+
| 746 | ++ |
+ ## row lines per page+ |
+
| 747 | +3x | +
+ rlpp <- lpp - hlines - flines+ |
+
| 748 | +3x | +
+ if (verbose) {
+ |
+
| 749 | +! | +
+ message(+ |
+
| 750 | +! | +
+ "Adjusted Lines Per Page: ",+ |
+
| 751 | +! | +
+ rlpp, " (original lpp: ", lpp, ")"+ |
+
| 752 | ++ |
+ )+ |
+
| 753 | ++ |
+ }+ |
+
| 754 | +3x | +
+ pagdf <- make_row_df(tt, colwidths, max_width = max_width)+ |
+
| 755 | ++ | + + | +
| 756 | +3x | +
+ pag_indices_inner(pagdf,+ |
+
| 757 | +3x | +
+ rlpp = rlpp, min_siblings = min_siblings,+ |
+
| 758 | +3x | +
+ nosplitin = nosplitin,+ |
+
| 759 | +3x | +
+ verbose = verbose,+ |
+
| 760 | +3x | +
+ have_col_fnotes = have_cfnotes,+ |
+
| 761 | +3x | +
+ div_height = dheight,+ |
+
| 762 | +3x | +
+ col_gap = col_gap,+ |
+
| 763 | +3x | +
+ has_rowlabels = TRUE+ |
+
| 764 | ++ |
+ )+ |
+
| 765 | ++ |
+ }+ |
+
| 766 | ++ | + + | +
| 767 | ++ |
+ copy_title_footer <- function(to, from, newptitle) {
+ |
+
| 768 | +18x | +
+ main_title(to) <- main_title(from)+ |
+
| 769 | +18x | +
+ subtitles(to) <- subtitles(from)+ |
+
| 770 | +18x | +
+ page_titles(to) <- c(page_titles(from), newptitle)+ |
+
| 771 | +18x | +
+ main_footer(to) <- main_footer(from)+ |
+
| 772 | +18x | +
+ prov_footer(to) <- prov_footer(from)+ |
+
| 773 | +18x | +
+ to+ |
+
| 774 | ++ |
+ }+ |
+
| 775 | ++ | + + | +
| 776 | ++ |
+ pag_btw_kids <- function(tt) {
+ |
+
| 777 | +8x | +
+ pref <- ptitle_prefix(tt)+ |
+
| 778 | +8x | +
+ lapply(+ |
+
| 779 | +8x | +
+ tree_children(tt),+ |
+
| 780 | +8x | +
+ function(tbl) {
+ |
+
| 781 | +18x | +
+ tbl <- copy_title_footer(+ |
+
| 782 | +18x | +
+ tbl, tt,+ |
+
| 783 | +18x | +
+ paste(pref, obj_label(tbl), sep = ": ")+ |
+
| 784 | ++ |
+ )+ |
+
| 785 | +18x | +
+ labelrow_visible(tbl) <- FALSE+ |
+
| 786 | +18x | +
+ tbl+ |
+
| 787 | ++ |
+ }+ |
+
| 788 | ++ |
+ )+ |
+
| 789 | ++ |
+ }+ |
+
| 790 | ++ | + + | +
| 791 | ++ |
+ force_paginate <- function(tt,+ |
+
| 792 | ++ |
+ force_pag = vapply(tree_children(tt), has_force_pag, NA),+ |
+
| 793 | ++ |
+ verbose = FALSE) {
+ |
+
| 794 | ++ |
+ ## forced pagination is happening at this+ |
+
| 795 | +113x | +
+ if (has_force_pag(tt)) {
+ |
+
| 796 | +8x | +
+ ret <- pag_btw_kids(tt)+ |
+
| 797 | +8x | +
+ return(unlist(lapply(ret, force_paginate)))+ |
+
| 798 | ++ |
+ }+ |
+
| 799 | +105x | +
+ chunks <- list()+ |
+
| 800 | +105x | +
+ kinds <- seq_along(force_pag)+ |
+
| 801 | +105x | +
+ while (length(kinds) > 0) {
+ |
+
| 802 | +105x | +
+ if (force_pag[kinds[1]]) {
+ |
+
| 803 | +! | +
+ outertbl <- copy_title_footer(+ |
+
| 804 | +! | +
+ tree_children(tt)[[kinds[1]]],+ |
+
| 805 | +! | +
+ tt,+ |
+
| 806 | +! | +
+ NULL+ |
+
| 807 | ++ |
+ )+ |
+
| 808 | ++ | + + | +
| 809 | +! | +
+ chunks <- c(chunks, force_paginate(outertbl))+ |
+
| 810 | +! | +
+ kinds <- kinds[-1]+ |
+
| 811 | ++ |
+ } else {
+ |
+
| 812 | +105x | +
+ tmptbl <- tt+ |
+
| 813 | +105x | +
+ runend <- min(which(force_pag[kinds]), length(kinds))+ |
+
| 814 | +105x | +
+ useinds <- 1:runend+ |
+
| 815 | +105x | +
+ tree_children(tmptbl) <- tree_children(tt)[useinds]+ |
+
| 816 | +105x | +
+ chunks <- c(chunks, tmptbl)+ |
+
| 817 | +105x | +
+ kinds <- kinds[-useinds]+ |
+
| 818 | ++ |
+ }+ |
+
| 819 | ++ |
+ }+ |
+
| 820 | +105x | +
+ unlist(chunks, recursive = TRUE)+ |
+
| 821 | ++ |
+ }+ |
+
| 822 | ++ | + + | +
| 823 | ++ |
+ #' @importFrom formatters do_forced_paginate+ |
+
| 824 | ++ |
+ setMethod(+ |
+
| 825 | ++ |
+ "do_forced_paginate", "VTableTree",+ |
+
| 826 | +95x | +
+ function(obj) force_paginate(obj)+ |
+
| 827 | ++ |
+ )+ |
+
| 828 | ++ | + + | +
| 829 | +186x | +
+ non_null_na <- function(x) !is.null(x) && is.na(x)+ |
+
| 830 | ++ | + + | +
| 831 | ++ |
+ #' @inheritParams formatters::vert_pag_indices+ |
+
| 832 | ++ |
+ #' @inheritParams formatters::page_lcpp+ |
+
| 833 | ++ |
+ #' @inheritParams formatters::toString+ |
+
| 834 | ++ |
+ #' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination.+ |
+
| 835 | ++ |
+ #' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal+ |
+
| 836 | ++ |
+ #' pagination should be done regardless of page size.+ |
+
| 837 | ++ |
+ #'+ |
+
| 838 | ++ |
+ #' @rdname paginate+ |
+
| 839 | ++ |
+ #' @aliases paginate_table+ |
+
| 840 | ++ |
+ #' @export+ |
+
| 841 | ++ |
+ paginate_table <- function(tt,+ |
+
| 842 | ++ |
+ page_type = "letter",+ |
+
| 843 | ++ |
+ font_family = "Courier",+ |
+
| 844 | ++ |
+ font_size = 8,+ |
+
| 845 | ++ |
+ lineheight = 1,+ |
+
| 846 | ++ |
+ landscape = FALSE,+ |
+
| 847 | ++ |
+ pg_width = NULL,+ |
+
| 848 | ++ |
+ pg_height = NULL,+ |
+
| 849 | ++ |
+ margins = c(top = .5, bottom = .5, left = .75, right = .75),+ |
+
| 850 | ++ |
+ lpp = NA_integer_,+ |
+
| 851 | ++ |
+ cpp = NA_integer_,+ |
+
| 852 | ++ |
+ min_siblings = 2,+ |
+
| 853 | ++ |
+ nosplitin = character(),+ |
+
| 854 | ++ |
+ colwidths = NULL,+ |
+
| 855 | ++ |
+ tf_wrap = FALSE,+ |
+
| 856 | ++ |
+ max_width = NULL,+ |
+
| 857 | ++ |
+ fontspec = font_spec(font_family, font_size, lineheight),+ |
+
| 858 | ++ |
+ col_gap = 3,+ |
+
| 859 | ++ |
+ verbose = FALSE) {
+ |
+
| 860 | +51x | +
+ new_dev <- open_font_dev(fontspec)+ |
+
| 861 | +51x | +
+ if (new_dev) {
+ |
+
| 862 | +38x | +
+ on.exit(close_font_dev())+ |
+
| 863 | ++ |
+ }+ |
+
| 864 | ++ | + + | +
| 865 | +51x | +
+ if ((non_null_na(lpp) || non_null_na(cpp)) &&+ |
+
| 866 | +51x | +
+ (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
+ |
+
| 867 | +12x | +
+ pg_lcpp <- page_lcpp(+ |
+
| 868 | +12x | +
+ page_type = page_type,+ |
+
| 869 | +12x | +
+ font_family = font_family,+ |
+
| 870 | +12x | +
+ font_size = font_size,+ |
+
| 871 | +12x | +
+ lineheight = lineheight,+ |
+
| 872 | +12x | +
+ pg_width = pg_width,+ |
+
| 873 | +12x | +
+ pg_height = pg_height,+ |
+
| 874 | +12x | +
+ margins = margins,+ |
+
| 875 | +12x | +
+ landscape = landscape,+ |
+
| 876 | +12x | +
+ fontspec = fontspec+ |
+
| 877 | ++ |
+ )+ |
+
| 878 | ++ | + + | +
| 879 | +12x | +
+ if (non_null_na(lpp)) {
+ |
+
| 880 | +6x | +
+ lpp <- pg_lcpp$lpp+ |
+
| 881 | ++ |
+ }+ |
+
| 882 | +12x | +
+ if (is.na(cpp)) {
+ |
+
| 883 | +8x | +
+ cpp <- pg_lcpp$cpp+ |
+
| 884 | ++ |
+ }+ |
+
| 885 | ++ |
+ } else {
+ |
+
| 886 | +39x | +
+ if (non_null_na(cpp)) {
+ |
+
| 887 | +! | +
+ cpp <- NULL+ |
+
| 888 | ++ |
+ }+ |
+
| 889 | +39x | +
+ if (non_null_na(lpp)) {
+ |
+
| 890 | +! | +
+ lpp <- 70+ |
+
| 891 | ++ |
+ }+ |
+
| 892 | ++ |
+ }+ |
+
| 893 | ++ | + + | +
| 894 | +51x | +
+ if (is.null(colwidths)) {
+ |
+
| 895 | +34x | +
+ colwidths <- propose_column_widths(+ |
+
| 896 | +34x | +
+ matrix_form(+ |
+
| 897 | +34x | +
+ tt,+ |
+
| 898 | +34x | +
+ indent_rownames = TRUE,+ |
+
| 899 | +34x | +
+ fontspec = fontspec,+ |
+
| 900 | +34x | +
+ col_gap = col_gap+ |
+
| 901 | ++ |
+ ),+ |
+
| 902 | +34x | +
+ fontspec = fontspec+ |
+
| 903 | ++ |
+ )+ |
+
| 904 | ++ |
+ }+ |
+
| 905 | ++ | + + | +
| 906 | +51x | +
+ if (!tf_wrap) {
+ |
+
| 907 | +41x | +
+ if (!is.null(max_width)) {
+ |
+
| 908 | +! | +
+ warning("tf_wrap is FALSE - ignoring non-null max_width value.")
+ |
+
| 909 | ++ |
+ }+ |
+
| 910 | +41x | +
+ max_width <- NULL+ |
+
| 911 | +10x | +
+ } else if (is.null(max_width)) {
+ |
+
| 912 | +5x | +
+ max_width <- cpp+ |
+
| 913 | +5x | +
+ } else if (identical(max_width, "auto")) {
+ |
+
| 914 | ++ |
+ ## XXX this 3 is column sep width!!!!!!!+ |
+
| 915 | +! | +
+ max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1)+ |
+
| 916 | ++ |
+ }+ |
+
| 917 | +51x | +
+ if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
+ |
+
| 918 | +! | +
+ warning("max_width specified is wider than characters per page width (cpp).")
+ |
+
| 919 | ++ |
+ }+ |
+
| 920 | ++ | + + | +
| 921 | ++ |
+ ## taken care of in vert_pag_indices now+ |
+
| 922 | ++ |
+ ## if(!is.null(cpp))+ |
+
| 923 | ++ |
+ ## cpp <- cpp - table_inset(tt)+ |
+
| 924 | ++ | + + | +
| 925 | +51x | +
+ force_pag <- vapply(tree_children(tt), has_force_pag, TRUE)+ |
+
| 926 | +51x | +
+ if (has_force_pag(tt) || any(force_pag)) {
+ |
+
| 927 | +5x | +
+ spltabs <- do_forced_paginate(tt)+ |
+
| 928 | +5x | +
+ spltabs <- unlist(spltabs, recursive = TRUE)+ |
+
| 929 | +5x | +
+ ret <- lapply(spltabs, paginate_table,+ |
+
| 930 | +5x | +
+ lpp = lpp,+ |
+
| 931 | +5x | +
+ cpp = cpp,+ |
+
| 932 | +5x | +
+ min_siblings = min_siblings,+ |
+
| 933 | +5x | +
+ nosplitin = nosplitin,+ |
+
| 934 | +5x | +
+ colwidths = colwidths,+ |
+
| 935 | +5x | +
+ tf_wrap = tf_wrap,+ |
+
| 936 | +5x | +
+ max_width = max_width,+ |
+
| 937 | +5x | +
+ fontspec = fontspec,+ |
+
| 938 | +5x | +
+ verbose = verbose,+ |
+
| 939 | +5x | +
+ col_gap = col_gap+ |
+
| 940 | ++ |
+ )+ |
+
| 941 | +5x | +
+ return(unlist(ret, recursive = TRUE))+ |
+
| 942 | ++ |
+ }+ |
+
| 943 | ++ | + + | +
| 944 | +46x | +
+ inds <- paginate_indices(tt,+ |
+
| 945 | +46x | +
+ page_type = page_type,+ |
+
| 946 | +46x | +
+ fontspec = fontspec,+ |
+
| 947 | ++ |
+ ## font_family = font_family,+ |
+
| 948 | ++ |
+ ## font_size = font_size,+ |
+
| 949 | ++ |
+ ## lineheight = lineheight,+ |
+
| 950 | +46x | +
+ landscape = landscape,+ |
+
| 951 | +46x | +
+ pg_width = pg_width,+ |
+
| 952 | +46x | +
+ pg_height = pg_height,+ |
+
| 953 | +46x | +
+ margins = margins,+ |
+
| 954 | +46x | +
+ lpp = lpp,+ |
+
| 955 | +46x | +
+ cpp = cpp,+ |
+
| 956 | +46x | +
+ min_siblings = min_siblings,+ |
+
| 957 | +46x | +
+ nosplitin = nosplitin,+ |
+
| 958 | +46x | +
+ colwidths = colwidths,+ |
+
| 959 | +46x | +
+ tf_wrap = tf_wrap,+ |
+
| 960 | +46x | +
+ max_width = max_width,+ |
+
| 961 | +46x | +
+ col_gap = col_gap,+ |
+
| 962 | +46x | +
+ verbose = verbose+ |
+
| 963 | +46x | +
+ ) ## paginate_table apparently doesn't accept indent_size+ |
+
| 964 | ++ | + + | +
| 965 | +41x | +
+ res <- lapply(+ |
+
| 966 | +41x | +
+ inds$pag_row_indices,+ |
+
| 967 | +41x | +
+ function(ii) {
+ |
+
| 968 | +115x | +
+ subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]+ |
+
| 969 | +115x | +
+ lapply(+ |
+
| 970 | +115x | +
+ inds$pag_col_indices,+ |
+
| 971 | +115x | +
+ function(jj) {
+ |
+
| 972 | +214x | +
+ subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]+ |
+
| 973 | ++ |
+ }+ |
+
| 974 | ++ |
+ )+ |
+
| 975 | ++ |
+ }+ |
+
| 976 | ++ |
+ )+ |
+
| 977 | +41x | +
+ res <- unlist(res, recursive = FALSE)+ |
+
| 978 | +41x | +
+ res+ |
+
| 979 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Change indentation of all `rrows` in an `rtable`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Change indentation of all `rrows` in an `rtable`+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param x (`VTableTree`)\cr an `rtable` object.+ |
+
| 6 | ++ |
+ #' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is+ |
+
| 7 | ++ |
+ #' less than 0, the indentation is set to 0.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @return `x` with its indent modifier incremented by `by`.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @examples+ |
+
| 12 | ++ |
+ #' is_setosa <- iris$Species == "setosa"+ |
+
| 13 | ++ |
+ #' m_tbl <- rtable(+ |
+
| 14 | ++ |
+ #' header = rheader(+ |
+
| 15 | ++ |
+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ |
+
| 16 | ++ |
+ #' rrow(NULL, "mean", "median", "mean", "median")+ |
+
| 17 | ++ |
+ #' ),+ |
+
| 18 | ++ |
+ #' rrow(+ |
+
| 19 | ++ |
+ #' row.name = "All Species",+ |
+
| 20 | ++ |
+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ |
+
| 21 | ++ |
+ #' mean(iris$Petal.Length), median(iris$Petal.Length),+ |
+
| 22 | ++ |
+ #' format = "xx.xx"+ |
+
| 23 | ++ |
+ #' ),+ |
+
| 24 | ++ |
+ #' rrow(+ |
+
| 25 | ++ |
+ #' row.name = "Setosa",+ |
+
| 26 | ++ |
+ #' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),+ |
+
| 27 | ++ |
+ #' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),+ |
+
| 28 | ++ |
+ #' format = "xx.xx"+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #' indent(m_tbl)+ |
+
| 32 | ++ |
+ #' indent(m_tbl, 2)+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @export+ |
+
| 35 | ++ |
+ indent <- function(x, by = 1) {
+ |
+
| 36 | +9x | +
+ if (nrow(x) == 0 || by == 0) {
+ |
+
| 37 | +9x | +
+ return(x)+ |
+
| 38 | ++ |
+ }+ |
+
| 39 | ++ | + + | +
| 40 | +! | +
+ indent_mod(x) <- indent_mod(x) + by+ |
+
| 41 | +! | +
+ x+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' Clear all indent modifiers from a table+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @inheritParams gen_args+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @return The same class as `tt`, with all indent modifiers set to zero.+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @examples+ |
+
| 51 | ++ |
+ #' lyt1 <- basic_table() %>%+ |
+
| 52 | ++ |
+ #' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
+ |
+
| 53 | ++ |
+ #' split_rows_by("AEBODSYS", child_labels = "visible") %>%
+ |
+
| 54 | ++ |
+ #' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
+ |
+
| 55 | ++ |
+ #' analyze("AGE", indent_mod = -1L)
+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' tbl1 <- build_table(lyt1, ex_adae)+ |
+
| 58 | ++ |
+ #' tbl1+ |
+
| 59 | ++ |
+ #' clear_indent_mods(tbl1)+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' @export+ |
+
| 62 | ++ |
+ #' @rdname clear_imods+ |
+
| 63 | +40x | +
+ setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' @export+ |
+
| 66 | ++ |
+ #' @rdname clear_imods+ |
+
| 67 | ++ |
+ setMethod(+ |
+
| 68 | ++ |
+ "clear_indent_mods", "VTableTree",+ |
+
| 69 | ++ |
+ function(tt) {
+ |
+
| 70 | +25x | +
+ ct <- content_table(tt)+ |
+
| 71 | +25x | +
+ if (!is.null(ct)) {
+ |
+
| 72 | +9x | +
+ content_table(tt) <- clear_indent_mods(ct)+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | +25x | +
+ tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)+ |
+
| 75 | +25x | +
+ indent_mod(tt) <- 0L+ |
+
| 76 | +25x | +
+ tt+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ #' @export+ |
+
| 81 | ++ |
+ #' @rdname clear_imods+ |
+
| 82 | ++ |
+ setMethod(+ |
+
| 83 | ++ |
+ "clear_indent_mods", "TableRow",+ |
+
| 84 | ++ |
+ function(tt) {
+ |
+
| 85 | +15x | +
+ indent_mod(tt) <- 0L+ |
+
| 86 | +15x | +
+ tt+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ |
+ )+ |
+
| 1 | ++ |
+ # data.frame output ------------------------------------------------------------+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' Generate a result data frame+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Collection of utilities to extract `data.frame` objects from `TableTree` objects.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams gen_args+ |
+
| 8 | ++ |
+ #' @param spec (`string`)\cr the specification to use to extract the result data frame. See Details below.+ |
+
| 9 | ++ |
+ #' @param simplify (`flag`)\cr whether the result data frame should only have labels and result columns visible.+ |
+
| 10 | ++ |
+ #' @param ... additional arguments passed to spec-specific result data frame conversion function. Currently it can be+ |
+
| 11 | ++ |
+ #' one or more of the following parameters (valid only for `v0_experimental` spec. for now):+ |
+
| 12 | ++ |
+ #' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual+ |
+
| 13 | ++ |
+ #' output. This is useful when the result data frame is used for further processing.+ |
+
| 14 | ++ |
+ #' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns.+ |
+
| 15 | ++ |
+ #' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear+ |
+
| 16 | ++ |
+ #' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for+ |
+
| 17 | ++ |
+ #' column counts if `expand_colnames = TRUE`.+ |
+
| 18 | ++ |
+ #' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table,+ |
+
| 19 | ++ |
+ #' i.e. with the same precision and numbers, but in easy-to-use numeric form.+ |
+
| 20 | ++ |
+ #' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the+ |
+
| 21 | ++ |
+ #' final table.+ |
+
| 22 | ++ |
+ #' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table,+ |
+
| 23 | ++ |
+ #' but without information about the row structure. Row labels will be assigned to rows so to work well+ |
+
| 24 | ++ |
+ #' with [df_to_tt()].+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @details `as_result_df()`: Result data frame specifications may differ in the exact information+ |
+
| 27 | ++ |
+ #' they include and the form in which they represent it. Specifications whose names end in "_experimental"+ |
+
| 28 | ++ |
+ #' are subject to change without notice, but specifications without the "_experimental"+ |
+
| 29 | ++ |
+ #' suffix will remain available *including any bugs in their construction* indefinitely.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @return+ |
+
| 32 | ++ |
+ #' * `as_result_df` returns a result `data.frame`.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @seealso [df_to_tt()] when using `as_is = TRUE` and [formatters::make_row_df()] to have a comprehensive view of the+ |
+
| 35 | ++ |
+ #' hierarchical structure of the rows.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @examples+ |
+
| 38 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 39 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 40 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+
| 41 | ++ |
+ #' analyze(c("AGE", "BMRKR2"))
+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 44 | ++ |
+ #' as_result_df(tbl)+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @name data.frame_export+ |
+
| 47 | ++ |
+ #' @export+ |
+
| 48 | ++ |
+ as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) {
+ |
+
| 49 | +24x | +
+ checkmate::assert_class(tt, "VTableTree")+ |
+
| 50 | +24x | +
+ checkmate::assert_string(spec)+ |
+
| 51 | +24x | +
+ checkmate::assert_flag(simplify)+ |
+
| 52 | ++ | + + | +
| 53 | +24x | +
+ if (nrow(tt) == 0) {
+ |
+
| 54 | +2x | +
+ return(sanitize_table_struct(tt))+ |
+
| 55 | ++ |
+ }+ |
+
| 56 | ++ | + + | +
| 57 | +22x | +
+ result_df_fun <- lookup_result_df_specfun(spec)+ |
+
| 58 | +22x | +
+ out <- result_df_fun(tt, ...)+ |
+
| 59 | ++ | + + | +
| 60 | +22x | +
+ if (simplify) {
+ |
+
| 61 | +4x | +
+ out <- .simplify_result_df(out)+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ | + + | +
| 64 | +22x | +
+ out+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ # Function that selects specific outputs from the result data frame+ |
+
| 68 | ++ |
+ .simplify_result_df <- function(df) {
+ |
+
| 69 | +4x | +
+ col_df <- colnames(df)+ |
+
| 70 | +4x | +
+ row_names_col <- which(col_df == "row_name")+ |
+
| 71 | +4x | +
+ result_cols <- seq(which(col_df == "node_class") + 1, length(col_df))+ |
+
| 72 | ++ | + + | +
| 73 | +4x | +
+ df[, c(row_names_col, result_cols)]+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ # Not used in rtables+ |
+
| 77 | ++ |
+ # .split_colwidths <- function(ptabs, nctot, colwidths) {
+ |
+
| 78 | ++ |
+ # ret <- list()+ |
+
| 79 | ++ |
+ # i <- 1L+ |
+
| 80 | ++ |
+ #+ |
+
| 81 | ++ |
+ # rlw <- colwidths[1]+ |
+
| 82 | ++ |
+ # colwidths <- colwidths[-1]+ |
+
| 83 | ++ |
+ # donenc <- 0+ |
+
| 84 | ++ |
+ # while (donenc < nctot) {
+ |
+
| 85 | ++ |
+ # curnc <- NCOL(ptabs[[i]])+ |
+
| 86 | ++ |
+ # ret[[i]] <- c(rlw, colwidths[seq_len(curnc)])+ |
+
| 87 | ++ |
+ # colwidths <- colwidths[-1 * seq_len(curnc)]+ |
+
| 88 | ++ |
+ # donenc <- donenc + curnc+ |
+
| 89 | ++ |
+ # i <- i + 1+ |
+
| 90 | ++ |
+ # }+ |
+
| 91 | ++ |
+ # ret+ |
+
| 92 | ++ |
+ # }+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ #' @describeIn data.frame_export A list of functions that extract result data frames from `TableTree`s.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @return+ |
+
| 97 | ++ |
+ #' * `result_df_specs()` returns a named list of result data frame extraction functions by "specification".+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @examples+ |
+
| 100 | ++ |
+ #' result_df_specs()+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' @export+ |
+
| 103 | ++ |
+ result_df_specs <- function() {
+ |
+
| 104 | +44x | +
+ list(v0_experimental = result_df_v0_experimental)+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ lookup_result_df_specfun <- function(spec) {
+ |
+
| 108 | +22x | +
+ if (!(spec %in% names(result_df_specs()))) {
+ |
+
| 109 | +! | +
+ stop(+ |
+
| 110 | +! | +
+ "unrecognized result data frame specification: ",+ |
+
| 111 | +! | +
+ spec,+ |
+
| 112 | +! | +
+ "If that specification is correct you may need to update your version of rtables"+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | +22x | +
+ result_df_specs()[[spec]]+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ result_df_v0_experimental <- function(tt,+ |
+
| 119 | ++ |
+ as_viewer = FALSE,+ |
+
| 120 | ++ |
+ as_strings = FALSE,+ |
+
| 121 | ++ |
+ expand_colnames = FALSE,+ |
+
| 122 | ++ |
+ keep_label_rows = FALSE,+ |
+
| 123 | ++ |
+ as_is = FALSE) {
+ |
+
| 124 | +22x | +
+ checkmate::assert_flag(as_viewer)+ |
+
| 125 | +22x | +
+ checkmate::assert_flag(as_strings)+ |
+
| 126 | +22x | +
+ checkmate::assert_flag(expand_colnames)+ |
+
| 127 | +22x | +
+ checkmate::assert_flag(keep_label_rows)+ |
+
| 128 | +22x | +
+ checkmate::assert_flag(as_is)+ |
+
| 129 | ++ | + + | +
| 130 | +22x | +
+ if (as_is) {
+ |
+
| 131 | +2x | +
+ keep_label_rows <- TRUE+ |
+
| 132 | +2x | +
+ expand_colnames <- FALSE+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | ++ | + + | +
| 135 | +22x | +
+ raw_cvals <- cell_values(tt)+ |
+
| 136 | ++ |
+ ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values+ |
+
| 137 | ++ |
+ ## rather than a list of length 1 representing the single row. This is bad but may not be changeable+ |
+
| 138 | ++ |
+ ## at this point.+ |
+
| 139 | +22x | +
+ if (nrow(tt) == 1 && length(raw_cvals) > 1) {
+ |
+
| 140 | +2x | +
+ raw_cvals <- list(raw_cvals)+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | ++ |
+ # Flatten the list of lists (rows) of cell values into a data frame+ |
+
| 144 | +22x | +
+ cellvals <- as.data.frame(do.call(rbind, raw_cvals))+ |
+
| 145 | +22x | +
+ row.names(cellvals) <- NULL+ |
+
| 146 | ++ | + + | +
| 147 | +22x | +
+ if (nrow(tt) == 1 && ncol(tt) == 1) {
+ |
+
| 148 | +5x | +
+ colnames(cellvals) <- names(raw_cvals)+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | +22x | +
+ if (as_viewer || as_strings) {
+ |
+
| 152 | ++ |
+ # we keep previous calculations to check the format of the data+ |
+
| 153 | +9x | +
+ mf_tt <- matrix_form(tt)+ |
+
| 154 | +9x | +
+ mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1]+ |
+
| 155 | +9x | +
+ mf_result_chars <- .remove_empty_elements(mf_result_chars)+ |
+
| 156 | +9x | +
+ mf_result_numeric <- as.data.frame(+ |
+
| 157 | +9x | +
+ .make_numeric_char_mf(mf_result_chars)+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | +9x | +
+ mf_result_chars <- as.data.frame(mf_result_chars)+ |
+
| 160 | +9x | +
+ if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
+ |
+
| 161 | +! | +
+ stop(+ |
+
| 162 | +! | +
+ "The extracted numeric data.frame does not have the same dimension of the",+ |
+
| 163 | +! | +
+ " cell values extracted with cell_values(). This is a bug. Please report it."+ |
+
| 164 | +! | +
+ ) # nocov+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | +9x | +
+ if (as_strings) {
+ |
+
| 167 | +5x | +
+ colnames(mf_result_chars) <- colnames(cellvals)+ |
+
| 168 | +5x | +
+ cellvals <- mf_result_chars+ |
+
| 169 | ++ |
+ } else {
+ |
+
| 170 | +4x | +
+ colnames(mf_result_numeric) <- colnames(cellvals)+ |
+
| 171 | +4x | +
+ cellvals <- mf_result_numeric+ |
+
| 172 | ++ |
+ }+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ | + + | +
| 175 | +22x | +
+ rdf <- make_row_df(tt)+ |
+
| 176 | ++ | + + | +
| 177 | +22x | +
+ df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
+ |
+
| 178 | ++ |
+ # Removing initial root elements from path (out of the loop -> right maxlen)+ |
+
| 179 | +22x | +
+ df$path <- lapply(df$path, .remove_root_elems_from_path,+ |
+
| 180 | +22x | +
+ which_root_name = c("root", "rbind_root"),
+ |
+
| 181 | +22x | +
+ all = TRUE+ |
+
| 182 | ++ |
+ )+ |
+
| 183 | +22x | +
+ maxlen <- max(lengths(df$path))+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ # Loop for metadata (path and details from make_row_df)+ |
+
| 186 | +22x | +
+ metadf <- do.call(+ |
+
| 187 | +22x | +
+ rbind.data.frame,+ |
+
| 188 | +22x | +
+ lapply(+ |
+
| 189 | +22x | +
+ seq_len(NROW(df)),+ |
+
| 190 | +22x | +
+ function(ii) {
+ |
+
| 191 | +433x | +
+ handle_rdf_row(df[ii, ], maxlen = maxlen)+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ |
+ )+ |
+
| 194 | ++ |
+ )+ |
+
| 195 | ++ | + + | +
| 196 | ++ |
+ # Should we keep label rows with NAs instead of values?+ |
+
| 197 | +22x | +
+ if (keep_label_rows) {
+ |
+
| 198 | +7x | +
+ cellvals_mat_struct <- as.data.frame(+ |
+
| 199 | +7x | +
+ matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals))+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | +7x | +
+ colnames(cellvals_mat_struct) <- colnames(cellvals)+ |
+
| 202 | +7x | +
+ cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals+ |
+
| 203 | +7x | +
+ ret <- cbind(metadf, cellvals_mat_struct)+ |
+
| 204 | ++ |
+ } else {
+ |
+
| 205 | +15x | +
+ ret <- cbind(+ |
+
| 206 | +15x | +
+ metadf[metadf$node_class != "LabelRow", ],+ |
+
| 207 | +15x | +
+ cellvals+ |
+
| 208 | ++ |
+ )+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ # If we want to expand colnames+ |
+
| 212 | +22x | +
+ if (expand_colnames) {
+ |
+
| 213 | +6x | +
+ col_name_structure <- .get_formatted_colnames(clayout(tt))+ |
+
| 214 | +6x | +
+ number_of_non_data_cols <- which(colnames(ret) == "node_class")+ |
+
| 215 | +6x | +
+ if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
+ |
+
| 216 | +! | +
+ stop(+ |
+
| 217 | +! | +
+ "When expanding colnames structure, we were not able to find the same",+ |
+
| 218 | +! | +
+ " number of columns as in the result data frame. This is a bug. Please report it."+ |
+
| 219 | +! | +
+ ) # nocov+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | ++ | + + | +
| 222 | +6x | +
+ buffer_rows_for_colnames <- matrix(+ |
+
| 223 | +6x | +
+ rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
+ |
+
| 224 | +6x | +
+ nrow = NROW(col_name_structure)+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | ++ | + + | +
| 227 | +6x | +
+ header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure))+ |
+
| 228 | +6x | +
+ colnames(header_colnames_matrix) <- colnames(ret)+ |
+
| 229 | ++ | + + | +
| 230 | +6x | +
+ count_row <- NULL+ |
+
| 231 | +6x | +
+ if (disp_ccounts(tt)) {
+ |
+
| 232 | +3x | +
+ ccounts <- col_counts(tt)+ |
+
| 233 | +3x | +
+ if (as_strings) {
+ |
+
| 234 | +2x | +
+ ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ]+ |
+
| 235 | +2x | +
+ ccounts <- .remove_empty_elements(ccounts)+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | +3x | +
+ count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
+ |
+
| 238 | +3x | +
+ header_colnames_matrix <- rbind(header_colnames_matrix, count_row)+ |
+
| 239 | ++ |
+ }+ |
+
| 240 | +6x | +
+ ret <- rbind(header_colnames_matrix, ret)+ |
+
| 241 | ++ |
+ }+ |
+
| 242 | ++ | + + | +
| 243 | ++ |
+ # Using only labels for row names and losing information about paths+ |
+
| 244 | +22x | +
+ if (as_is) {
+ |
+
| 245 | +2x | +
+ tmp_rownames <- ret$label_name+ |
+
| 246 | +2x | +
+ ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))]+ |
+
| 247 | +2x | +
+ if (length(unique(tmp_rownames)) == length(tmp_rownames)) {
+ |
+
| 248 | +1x | +
+ rownames(ret) <- tmp_rownames+ |
+
| 249 | ++ |
+ } else {
+ |
+
| 250 | +1x | +
+ ret <- cbind("label_name" = tmp_rownames, ret)
+ |
+
| 251 | +1x | +
+ rownames(ret) <- NULL+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ |
+ } else {
+ |
+
| 254 | +20x | +
+ rownames(ret) <- NULL+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ | + + | +
| 257 | +22x | +
+ ret+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ | + + | +
| 260 | ++ |
+ .remove_empty_elements <- function(char_df) {
+ |
+
| 261 | +11x | +
+ if (is.null(dim(char_df))) {
+ |
+
| 262 | +5x | +
+ return(char_df[nzchar(char_df, keepNA = TRUE)])+ |
+
| 263 | ++ |
+ }+ |
+
| 264 | ++ | + + | +
| 265 | +6x | +
+ apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)])+ |
+
| 266 | ++ |
+ }+ |
+
| 267 | ++ | + + | +
| 268 | ++ |
+ # Helper function to make the character matrix numeric+ |
+
| 269 | ++ |
+ .make_numeric_char_mf <- function(char_df) {
+ |
+
| 270 | +9x | +
+ if (is.null(dim(char_df))) {
+ |
+
| 271 | +3x | +
+ return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+")))+ |
+
| 272 | ++ |
+ }+ |
+
| 273 | ++ | + + | +
| 274 | +6x | +
+ ret <- apply(char_df, 2, function(col_i) {
+ |
+
| 275 | +27x | +
+ lapply(+ |
+
| 276 | +27x | +
+ stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"),+ |
+
| 277 | +27x | +
+ as.numeric+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ })+ |
+
| 280 | ++ | + + | +
| 281 | +6x | +
+ do.call(cbind, ret)+ |
+
| 282 | ++ |
+ }+ |
+
| 283 | ++ | + + | +
| 284 | ++ |
+ make_result_df_md_colnames <- function(maxlen) {
+ |
+
| 285 | +433x | +
+ spllen <- floor((maxlen - 2) / 2)+ |
+
| 286 | +433x | +
+ ret <- character()+ |
+
| 287 | +433x | +
+ if (spllen > 0) {
+ |
+
| 288 | +387x | +
+ ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_")
+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | +433x | +
+ ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
+ |
+
| 291 | ++ |
+ }+ |
+
| 292 | ++ | + + | +
| 293 | ++ |
+ do_label_row <- function(rdfrow, maxlen) {
+ |
+
| 294 | +143x | +
+ pth <- rdfrow$path[[1]]+ |
+
| 295 | ++ |
+ # Adjusting for the fact that we have two columns for each split+ |
+
| 296 | +143x | +
+ extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2+ |
+
| 297 | ++ | + + | +
| 298 | ++ |
+ # Special cases with hidden labels+ |
+
| 299 | +143x | +
+ if (length(pth) %% 2 == 1) {
+ |
+
| 300 | +108x | +
+ extra_nas_from_splits <- extra_nas_from_splits + 1+ |
+
| 301 | ++ |
+ }+ |
+
| 302 | ++ | + + | +
| 303 | +143x | +
+ c(+ |
+
| 304 | +143x | +
+ as.list(pth[seq_len(length(pth) - 1)]),+ |
+
| 305 | +143x | +
+ as.list(replicate(extra_nas_from_splits, list(NA_character_))),+ |
+
| 306 | +143x | +
+ as.list(tail(pth, 1)),+ |
+
| 307 | +143x | +
+ list(+ |
+
| 308 | +143x | +
+ label_name = rdfrow$label,+ |
+
| 309 | +143x | +
+ row_num = rdfrow$abs_rownumber,+ |
+
| 310 | +143x | +
+ content = FALSE,+ |
+
| 311 | +143x | +
+ node_class = rdfrow$node_class+ |
+
| 312 | ++ |
+ )+ |
+
| 313 | ++ |
+ )+ |
+
| 314 | ++ |
+ }+ |
+
| 315 | ++ | + + | +
| 316 | ++ |
+ do_content_row <- function(rdfrow, maxlen) {
+ |
+
| 317 | +36x | +
+ pth <- rdfrow$path[[1]]+ |
+
| 318 | +36x | +
+ contpos <- which(pth == "@content")+ |
+
| 319 | ++ | + + | +
| 320 | +36x | +
+ seq_before <- seq_len(contpos - 1)+ |
+
| 321 | ++ | + + | +
| 322 | +36x | +
+ c(+ |
+
| 323 | +36x | +
+ as.list(pth[seq_before]),+ |
+
| 324 | +36x | +
+ as.list(replicate(maxlen - contpos, list(NA_character_))),+ |
+
| 325 | +36x | +
+ list(tail(pth, 1)),+ |
+
| 326 | +36x | +
+ list(+ |
+
| 327 | +36x | +
+ label_name = rdfrow$label,+ |
+
| 328 | +36x | +
+ row_num = rdfrow$abs_rownumber,+ |
+
| 329 | +36x | +
+ content = TRUE,+ |
+
| 330 | +36x | +
+ node_class = rdfrow$node_class+ |
+
| 331 | ++ |
+ )+ |
+
| 332 | ++ |
+ )+ |
+
| 333 | ++ |
+ }+ |
+
| 334 | ++ | + + | +
| 335 | ++ |
+ do_data_row <- function(rdfrow, maxlen) {
+ |
+
| 336 | +254x | +
+ pth <- rdfrow$path[[1]]+ |
+
| 337 | +254x | +
+ pthlen <- length(pth)+ |
+
| 338 | ++ |
+ ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame+ |
+
| 339 | +254x | +
+ if (pthlen %% 2 == 1) {
+ |
+
| 340 | +38x | +
+ pth <- pth[-1 * (pthlen - 2)]+ |
+
| 341 | ++ |
+ }+ |
+
| 342 | +254x | +
+ pthlen_new <- length(pth)+ |
+
| 343 | +33x | +
+ if (maxlen == 1) pthlen_new <- 3+ |
+
| 344 | +254x | +
+ c(+ |
+
| 345 | +254x | +
+ as.list(pth[seq_len(pthlen_new - 2)]),+ |
+
| 346 | +254x | +
+ replicate(maxlen - pthlen, list(NA_character_)),+ |
+
| 347 | +254x | +
+ as.list(tail(pth, 2)),+ |
+
| 348 | +254x | +
+ list(+ |
+
| 349 | +254x | +
+ label_name = rdfrow$label,+ |
+
| 350 | +254x | +
+ row_num = rdfrow$abs_rownumber,+ |
+
| 351 | +254x | +
+ content = FALSE,+ |
+
| 352 | +254x | +
+ node_class = rdfrow$node_class+ |
+
| 353 | ++ |
+ )+ |
+
| 354 | ++ |
+ )+ |
+
| 355 | ++ |
+ }+ |
+
| 356 | ++ | + + | +
| 357 | ++ |
+ .remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
+ |
+
| 358 | +434x | +
+ any_root_paths <- path[1] %in% which_root_name+ |
+
| 359 | +434x | +
+ if (any_root_paths) {
+ |
+
| 360 | +274x | +
+ if (isTRUE(all)) {
+ |
+
| 361 | ++ |
+ # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later)+ |
+
| 362 | +274x | +
+ root_indices <- which(path %in% which_root_name)+ |
+
| 363 | +274x | +
+ if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
+ |
+
| 364 | +! | +
+ end_point_root_headers <- which(diff(root_indices) > 1)[1]+ |
+
| 365 | ++ |
+ } else {
+ |
+
| 366 | +274x | +
+ end_point_root_headers <- length(root_indices)+ |
+
| 367 | ++ |
+ }+ |
+
| 368 | +274x | +
+ root_path_to_remove <- seq_len(end_point_root_headers)+ |
+
| 369 | ++ |
+ } else {
+ |
+
| 370 | +! | +
+ root_path_to_remove <- 1+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | +274x | +
+ path <- path[-root_path_to_remove]+ |
+
| 373 | ++ |
+ }+ |
+
| 374 | ++ | + + | +
| 375 | ++ |
+ # Fix for very edge case where we have only root elements+ |
+
| 376 | +434x | +
+ if (length(path) == 0) {
+ |
+
| 377 | +1x | +
+ path <- which_root_name[1]+ |
+
| 378 | ++ |
+ }+ |
+
| 379 | ++ | + + | +
| 380 | +434x | +
+ path+ |
+
| 381 | ++ |
+ }+ |
+
| 382 | ++ | + + | +
| 383 | ++ |
+ handle_rdf_row <- function(rdfrow, maxlen) {
+ |
+
| 384 | +433x | +
+ nclass <- rdfrow$node_class+ |
+
| 385 | ++ | + + | +
| 386 | +433x | +
+ ret <- switch(nclass,+ |
+
| 387 | +433x | +
+ LabelRow = do_label_row(rdfrow, maxlen),+ |
+
| 388 | +433x | +
+ ContentRow = do_content_row(rdfrow, maxlen),+ |
+
| 389 | +433x | +
+ DataRow = do_data_row(rdfrow, maxlen),+ |
+
| 390 | +433x | +
+ stop("Unrecognized node type in row dataframe, unable to generate result data frame")
+ |
+
| 391 | ++ |
+ )+ |
+
| 392 | +433x | +
+ setNames(ret, make_result_df_md_colnames(maxlen))+ |
+
| 393 | ++ |
+ }+ |
+
| 394 | ++ | + + | +
| 395 | ++ |
+ # Helper recurrent function to get the column names for the result data frame from the VTableTree+ |
+
| 396 | ++ |
+ .get_formatted_colnames <- function(clyt) {
+ |
+
| 397 | +41x | +
+ ret <- obj_label(clyt)+ |
+
| 398 | +41x | +
+ if (!nzchar(ret)) {
+ |
+
| 399 | +6x | +
+ ret <- NULL+ |
+
| 400 | ++ |
+ }+ |
+
| 401 | +41x | +
+ if (is.null(tree_children(clyt))) {
+ |
+
| 402 | +! | +
+ return(ret)+ |
+
| 403 | ++ |
+ } else {
+ |
+
| 404 | +41x | +
+ ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames)))+ |
+
| 405 | +41x | +
+ colnames(ret) <- NULL+ |
+
| 406 | +41x | +
+ rownames(ret) <- NULL+ |
+
| 407 | +41x | +
+ return(ret)+ |
+
| 408 | ++ |
+ }+ |
+
| 409 | ++ |
+ }+ |
+
| 410 | ++ | + + | +
| 411 | ++ |
+ #' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`.+ |
+
| 412 | ++ |
+ #'+ |
+
| 413 | ++ |
+ #' @param path_fun (`function`)\cr function to transform paths into single-string row/column names.+ |
+
| 414 | ++ |
+ #' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to+ |
+
| 415 | ++ |
+ #' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`.+ |
+
| 416 | ++ |
+ #'+ |
+
| 417 | ++ |
+ #' @return+ |
+
| 418 | ++ |
+ #' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by+ |
+
| 419 | ++ |
+ #' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed+ |
+
| 420 | ++ |
+ #' by `path_fun`).+ |
+
| 421 | ++ |
+ #'+ |
+
| 422 | ++ |
+ #' @examples+ |
+
| 423 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 424 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 425 | ++ |
+ #' analyze(c("AGE", "BMRKR2"))
+ |
+
| 426 | ++ |
+ #'+ |
+
| 427 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 428 | ++ |
+ #' path_enriched_df(tbl)+ |
+
| 429 | ++ |
+ #'+ |
+
| 430 | ++ |
+ #' @export+ |
+
| 431 | ++ |
+ path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
+ |
+
| 432 | +3x | +
+ rdf <- make_row_df(tt)+ |
+
| 433 | +3x | +
+ cdf <- make_col_df(tt)+ |
+
| 434 | +3x | +
+ cvs <- as.data.frame(do.call(rbind, cell_values(tt)))+ |
+
| 435 | +3x | +
+ cvs <- as.data.frame(lapply(cvs, value_fun))+ |
+
| 436 | +3x | +
+ row.names(cvs) <- NULL+ |
+
| 437 | +3x | +
+ colnames(cvs) <- path_fun(cdf$path)+ |
+
| 438 | +3x | +
+ preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path)+ |
+
| 439 | +3x | +
+ cbind.data.frame(row_path = preppaths, cvs)+ |
+
| 440 | ++ |
+ }+ |
+
| 441 | ++ | + + | +
| 442 | ++ |
+ .collapse_char <- "|"+ |
+
| 443 | ++ |
+ .collapse_char_esc <- "\\|"+ |
+
| 444 | ++ | + + | +
| 445 | ++ |
+ collapse_path <- function(paths) {
+ |
+
| 446 | +196x | +
+ if (is.list(paths)) {
+ |
+
| 447 | +6x | +
+ return(vapply(paths, collapse_path, ""))+ |
+
| 448 | ++ |
+ }+ |
+
| 449 | +190x | +
+ paste(paths, collapse = .collapse_char)+ |
+
| 450 | ++ |
+ }+ |
+
| 451 | ++ | + + | +
| 452 | ++ |
+ collapse_values <- function(colvals) {
+ |
+
| 453 | +13x | +
+ if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
+ |
+
| 454 | +! | +
+ return(colvals)+ |
+
| 455 | +13x | +
+ } else if (all(vapply(colvals, length, 1L) == 1)) {
+ |
+
| 456 | +1x | +
+ return(unlist(colvals))+ |
+
| 457 | ++ |
+ }+ |
+
| 458 | +12x | +
+ vapply(colvals, paste, "", collapse = .collapse_char)+ |
+
| 459 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Format `rcell` objects+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 6 | ++ |
+ #' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.+ |
+
| 7 | ++ |
+ #' @param format (`string` or `function`)\cr the format label or formatter function to+ |
+
| 8 | ++ |
+ #' apply to `x`.+ |
+
| 9 | ++ |
+ #' @param output (`string`)\cr output type.+ |
+
| 10 | ++ |
+ #' @param pr_row_format (`list`)\cr list of default formats coming from the general row.+ |
+
| 11 | ++ |
+ #' @param pr_row_na_str (`list`)\cr list of default `"NA"` strings coming from the general row.+ |
+
| 12 | ++ |
+ #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the+ |
+
| 13 | ++ |
+ #' values with formats applied. Defaults to `FALSE`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return Formatted text.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @examples+ |
+
| 18 | ++ |
+ #' cll <- CellValue(pi, format = "xx.xxx")+ |
+
| 19 | ++ |
+ #' format_rcell(cll)+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' # Cell values precedes the row values+ |
+
| 22 | ++ |
+ #' cll <- CellValue(pi, format = "xx.xxx")+ |
+
| 23 | ++ |
+ #' format_rcell(cll, pr_row_format = "xx.x")+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' # Similarly for NA values+ |
+
| 26 | ++ |
+ #' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA")+ |
+
| 27 | ++ |
+ #' format_rcell(cll, pr_row_na_str = "This is NA")+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @export+ |
+
| 30 | ++ |
+ format_rcell <- function(x, format,+ |
+
| 31 | ++ |
+ output = c("ascii", "html"),
+ |
+
| 32 | ++ |
+ na_str = obj_na_str(x) %||% "NA",+ |
+
| 33 | ++ |
+ pr_row_format = NULL,+ |
+
| 34 | ++ |
+ pr_row_na_str = NULL,+ |
+
| 35 | ++ |
+ shell = FALSE) {
+ |
+
| 36 | ++ |
+ # Check for format and parent row format+ |
+
| 37 | +100808x | +
+ format <- if (missing(format)) obj_format(x) else format+ |
+
| 38 | +100808x | +
+ if (is.null(format) && !is.null(pr_row_format)) {
+ |
+
| 39 | +72160x | +
+ format <- pr_row_format+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ |
+ # Check for na_str from parent+ |
+
| 42 | +100808x | +
+ if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
+ |
+
| 43 | +86299x | +
+ na_str <- pr_row_na_str+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ # Main call to external function or shell+ |
+
| 47 | +100808x | +
+ if (shell) {
+ |
+
| 48 | +26634x | +
+ return(format)+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | +74174x | +
+ format_value(rawvalues(x),+ |
+
| 51 | +74174x | +
+ format = format,+ |
+
| 52 | +74174x | +
+ output = output,+ |
+
| 53 | +74174x | +
+ na_str = na_str+ |
+
| 54 | ++ |
+ )+ |
+
| 55 | ++ |
+ }+ |
+
| 1 | ++ |
+ insert_brs <- function(vec) {
+ |
+
| 2 | +1021x | +
+ if (length(vec) == 1) {
+ |
+
| 3 | +1021x | +
+ ret <- list(vec)+ |
+
| 4 | ++ |
+ } else {
+ |
+
| 5 | +! | +
+ nout <- length(vec) * 2 - 1+ |
+
| 6 | +! | +
+ ret <- vector("list", nout)
+ |
+
| 7 | +! | +
+ for (i in seq_along(vec)) {
+ |
+
| 8 | +! | +
+ ret[[2 * i - 1]] <- vec[i]+ |
+
| 9 | +! | +
+ if (2 * i < nout) {
+ |
+
| 10 | +! | +
+ ret[[2 * i]] <- tags$br()+ |
+
| 11 | ++ |
+ }+ |
+
| 12 | ++ |
+ }+ |
+
| 13 | ++ |
+ }+ |
+
| 14 | +1021x | +
+ ret+ |
+
| 15 | ++ |
+ }+ |
+
| 16 | ++ | + + | +
| 17 | ++ |
+ div_helper <- function(lst, class) {
+ |
+
| 18 | +72x | +
+ do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))+ |
+
| 19 | ++ |
+ }+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ #' Convert an `rtable` object to a `shiny.tag` HTML object+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @param x (`VTableTree`)\cr a `TableTree` object.+ |
+
| 26 | ++ |
+ #' @param class_table (`character`)\cr class for `table` tag.+ |
+
| 27 | ++ |
+ #' @param class_tr (`character`)\cr class for `tr` tag.+ |
+
| 28 | ++ |
+ #' @param class_th (`character`)\cr class for `th` tag.+ |
+
| 29 | ++ |
+ #' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a+ |
+
| 30 | ++ |
+ #' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.+ |
+
| 31 | ++ |
+ #' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.+ |
+
| 32 | ++ |
+ #' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,+ |
+
| 33 | ++ |
+ #' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label+ |
+
| 34 | ++ |
+ #' rows). Defaults to `"header"`.+ |
+
| 35 | ++ |
+ #' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults+ |
+
| 36 | ++ |
+ #' to `TRUE`.+ |
+
| 37 | ++ |
+ #' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults+ |
+
| 38 | ++ |
+ #' to `FALSE`.+ |
+
| 39 | ++ |
+ #' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).+ |
+
| 40 | ++ |
+ #' Doing this keeps the structure of the cells but may depend on the output device.+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @importFrom htmltools tags+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @return A `shiny.tag` object representing `x` in HTML.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @examples+ |
+
| 47 | ++ |
+ #' tbl <- rtable(+ |
+
| 48 | ++ |
+ #' header = LETTERS[1:3],+ |
+
| 49 | ++ |
+ #' format = "xx",+ |
+
| 50 | ++ |
+ #' rrow("r1", 1, 2, 3),
+ |
+
| 51 | ++ |
+ #' rrow("r2", 4, 3, 2, indent = 1),
+ |
+
| 52 | ++ |
+ #' rrow("r3", indent = 2)
+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' as_html(tbl)+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' as_html(tbl, class_table = "table", class_tr = "row")+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' as_html(tbl, bold = c("header", "row_names"))
+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' \dontrun{
+ |
+
| 62 | ++ |
+ #' Viewer(tbl)+ |
+
| 63 | ++ |
+ #' }+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' @export+ |
+
| 66 | ++ |
+ as_html <- function(x,+ |
+
| 67 | ++ |
+ width = NULL,+ |
+
| 68 | ++ |
+ class_table = "table table-condensed table-hover",+ |
+
| 69 | ++ |
+ class_tr = NULL,+ |
+
| 70 | ++ |
+ class_th = NULL,+ |
+
| 71 | ++ |
+ link_label = NULL,+ |
+
| 72 | ++ |
+ bold = c("header"),
+ |
+
| 73 | ++ |
+ header_sep_line = TRUE,+ |
+
| 74 | ++ |
+ no_spaces_between_cells = FALSE,+ |
+
| 75 | ++ |
+ expand_newlines = FALSE) {
+ |
+
| 76 | +9x | +
+ if (is.null(x)) {
+ |
+
| 77 | +! | +
+ return(tags$p("Empty Table"))
+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | +9x | +
+ stopifnot(is(x, "VTableTree"))+ |
+
| 81 | ++ | + + | +
| 82 | +9x | +
+ mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines)+ |
+
| 83 | ++ | + + | +
| 84 | +9x | +
+ nlh <- mf_nlheader(mat)+ |
+
| 85 | +9x | +
+ nc <- ncol(x) + 1+ |
+
| 86 | +9x | +
+ nr <- length(mf_lgrouping(mat))+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions+ |
+
| 89 | +9x | +
+ cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)+ |
+
| 90 | ++ | + + | +
| 91 | +9x | +
+ for (i in seq_len(nr)) {
+ |
+
| 92 | +173x | +
+ for (j in seq_len(nc)) {
+ |
+
| 93 | +1021x | +
+ curstrs <- mf_strings(mat)[i, j]+ |
+
| 94 | +1021x | +
+ curspn <- mf_spans(mat)[i, j]+ |
+
| 95 | +1021x | +
+ algn <- mf_aligns(mat)[i, j]+ |
+
| 96 | ++ | + + | +
| 97 | +1021x | +
+ inhdr <- i <= nlh+ |
+
| 98 | +1021x | +
+ tagfun <- if (inhdr) tags$th else tags$td+ |
+
| 99 | +1021x | +
+ cells[i, j][[1]] <- tagfun(+ |
+
| 100 | +1021x | +
+ class = if (inhdr) class_th else class_tr,+ |
+
| 101 | +1021x | +
+ style = paste0("text-align: ", algn, ";"),
+ |
+
| 102 | +1021x | +
+ style = if (inhdr && !"header" %in% bold) "font-weight: normal;",+ |
+
| 103 | +1021x | +
+ style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",+ |
+
| 104 | +1021x | +
+ colspan = if (curspn != 1) curspn,+ |
+
| 105 | +1021x | +
+ insert_brs(curstrs)+ |
+
| 106 | ++ |
+ )+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | +9x | +
+ if (header_sep_line) {
+ |
+
| 111 | +9x | +
+ cells[nlh][[1]] <- htmltools::tagAppendAttributes(+ |
+
| 112 | +9x | +
+ cells[nlh, 1][[1]],+ |
+
| 113 | +9x | +
+ style = "border-bottom: 1px solid black;"+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh+ |
+
| 118 | +9x | +
+ map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)+ |
+
| 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")+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ # add indent values for headerlines+ |
+
| 123 | +9x | +
+ map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)+ |
+
| 124 | ++ | + + | +
| 125 | ++ | + + | +
| 126 | ++ |
+ # Row labels style+ |
+
| 127 | +9x | +
+ for (i in seq_len(nr)) {
+ |
+
| 128 | +173x | +
+ indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ # Apply indentation+ |
+
| 131 | +173x | +
+ if (indent > 0) {
+ |
+
| 132 | +127x | +
+ cells[i, 1][[1]] <- htmltools::tagAppendAttributes(+ |
+
| 133 | +127x | +
+ cells[i, 1][[1]],+ |
+
| 134 | +127x | +
+ style = paste0("padding-left: ", indent * 3, "ch;")
+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ # 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 | +
+ cells[i, 1][[1]],+ |
+
| 142 | +4x | +
+ style = "font-weight: bold;"+ |
+
| 143 | ++ |
+ )+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | ++ | + + | +
| 147 | ++ |
+ # label rows style+ |
+
| 148 | +9x | +
+ if ("label_rows" %in% bold) {
+ |
+
| 149 | +! | +
+ which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")+ |
+
| 150 | +! | +
+ cells[which_lbl_rows + nlh, ] <- lapply(+ |
+
| 151 | +! | +
+ cells[which_lbl_rows + nlh, ],+ |
+
| 152 | +! | +
+ htmltools::tagAppendAttributes,+ |
+
| 153 | +! | +
+ style = "font-weight: bold;"+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ |
+ }+ |
+
| 156 | ++ | + + | +
| 157 | ++ |
+ # content rows style+ |
+
| 158 | +9x | +
+ 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;"+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | ++ | + + | +
| 167 | +9x | +
+ if (any(!mat$display)) {
+ |
+
| 168 | ++ |
+ # Check that expansion kept the same display info+ |
+
| 169 | +2x | +
+ check_expansion <- c()+ |
+
| 170 | +2x | +
+ for (ii in unique(mat$line_grouping)) {
+ |
+
| 171 | +121x | +
+ 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))+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ | + + | +
| 178 | +2x | +
+ if (!all(check_expansion)) {
+ |
+
| 179 | +! | +
+ stop(+ |
+
| 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 | +! | +
+ ) # nocov+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ | + + | +
| 186 | +2x | +
+ for (ii in unique(mat$line_grouping)) {
+ |
+
| 187 | +121x | +
+ 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_+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | +9x | +
+ rows <- apply(cells, 1, function(row) {
+ |
+
| 194 | +173x | +
+ tags$tr(+ |
+
| 195 | +173x | +
+ class = class_tr,+ |
+
| 196 | +173x | +
+ style = "white-space: pre;",+ |
+
| 197 | +173x | +
+ Filter(function(x) !identical(x, NA_integer_), row)+ |
+
| 198 | ++ |
+ )+ |
+
| 199 | ++ |
+ })+ |
+
| 200 | ++ | + + | +
| 201 | +9x | +
+ hsep_line <- tags$hr(class = "solid")+ |
+
| 202 | ++ | + + | +
| 203 | +9x | +
+ hdrtag <- div_helper(+ |
+
| 204 | +9x | +
+ class = "rtables-titles-block",+ |
+
| 205 | +9x | +
+ list(+ |
+
| 206 | +9x | +
+ div_helper(+ |
+
| 207 | +9x | +
+ class = "rtables-main-titles-block",+ |
+
| 208 | +9x | +
+ lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
+ |
+
| 209 | +9x | +
+ class = "rtables-main-title"+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | ++ |
+ ),+ |
+
| 212 | +9x | +
+ div_helper(+ |
+
| 213 | +9x | +
+ class = "rtables-subtitles-block",+ |
+
| 214 | +9x | +
+ lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
+ |
+
| 215 | +9x | +
+ class = "rtables-subtitle"+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ )+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ | + + | +
| 221 | +9x | +
+ tabletag <- do.call(+ |
+
| 222 | +9x | +
+ tags$table,+ |
+
| 223 | +9x | +
+ c(+ |
+
| 224 | +9x | +
+ rows,+ |
+
| 225 | +9x | +
+ list(+ |
+
| 226 | +9x | +
+ 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)
+ |
+
| 230 | ++ |
+ ),+ |
+
| 231 | +9x | +
+ tags$caption(sprintf("(\\#tag:%s)", link_label),
+ |
+
| 232 | +9x | +
+ style = "caption-side: top;",+ |
+
| 233 | +9x | +
+ .noWS = "after-begin"+ |
+
| 234 | ++ |
+ )+ |
+
| 235 | ++ |
+ )+ |
+
| 236 | ++ |
+ )+ |
+
| 237 | ++ |
+ )+ |
+
| 238 | ++ | + + | +
| 239 | +9x | +
+ rfnotes <- div_helper(+ |
+
| 240 | +9x | +
+ class = "rtables-ref-footnotes-block",+ |
+
| 241 | +9x | +
+ lapply(mat$ref_footnotes, tags$p,+ |
+
| 242 | +9x | +
+ class = "rtables-referential-footnote"+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | ++ |
+ )+ |
+
| 245 | ++ | + + | +
| 246 | +9x | +
+ mftr <- div_helper(+ |
+
| 247 | +9x | +
+ class = "rtables-main-footers-block",+ |
+
| 248 | +9x | +
+ lapply(main_footer(x), tags$p,+ |
+
| 249 | +9x | +
+ class = "rtables-main-footer"+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ |
+ )+ |
+
| 252 | ++ | + + | +
| 253 | +9x | +
+ pftr <- div_helper(+ |
+
| 254 | +9x | +
+ class = "rtables-prov-footers-block",+ |
+
| 255 | +9x | +
+ lapply(prov_footer(x), tags$p,+ |
+
| 256 | +9x | +
+ class = "rtables-prov-footer"+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ | + + | +
| 260 | ++ |
+ ## XXX this omits the divs entirely if they are empty. Do we want that or do+ |
+
| 261 | ++ |
+ ## we want them to be there but empty??+ |
+
| 262 | +9x | +
+ ftrlst <- list(+ |
+
| 263 | +9x | +
+ if (length(mat$ref_footnotes) > 0) rfnotes,+ |
+
| 264 | +9x | +
+ if (length(mat$ref_footnotes) > 0) hsep_line,+ |
+
| 265 | +9x | +
+ if (length(main_footer(x)) > 0) mftr,+ |
+
| 266 | +9x | +
+ if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break+ |
+
| 267 | +9x | +
+ if (length(prov_footer(x)) > 0) pftr+ |
+
| 268 | ++ |
+ )+ |
+
| 269 | ++ | + + | +
| 270 | +! | +
+ if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)+ |
+
| 271 | +9x | +
+ ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]+ |
+
| 272 | ++ | + + | +
| 273 | +9x | +
+ ftrtag <- div_helper(+ |
+
| 274 | +9x | +
+ class = "rtables-footers-block",+ |
+
| 275 | +9x | +
+ ftrlst+ |
+
| 276 | ++ |
+ )+ |
+
| 277 | ++ | + + | +
| 278 | +9x | +
+ div_helper(+ |
+
| 279 | +9x | +
+ class = "rtables-all-parts-block",+ |
+
| 280 | +9x | +
+ list(+ |
+
| 281 | +9x | +
+ hdrtag,+ |
+
| 282 | +9x | +
+ tabletag,+ |
+
| 283 | +9x | +
+ ftrtag+ |
+
| 284 | ++ |
+ )+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Cell value constructors+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams compat_args+ |
+
| 6 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 7 | ++ |
+ #' @param x (`ANY`)\cr cell value.+ |
+
| 8 | ++ |
+ #' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.+ |
+
| 9 | ++ |
+ #' See [formatters::list_valid_format_labels()] for currently supported format labels.+ |
+
| 10 | ++ |
+ #' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.+ |
+
| 11 | ++ |
+ #' @param colspan (`integer(1)`)\cr column span value.+ |
+
| 12 | ++ |
+ #' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @inherit CellValue return+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @note Currently column spanning is only supported for defining header structure.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @rdname rcell+ |
+
| 19 | ++ |
+ #' @export+ |
+
| 20 | ++ |
+ rcell <- function(x,+ |
+
| 21 | ++ |
+ format = NULL,+ |
+
| 22 | ++ |
+ colspan = 1L,+ |
+
| 23 | ++ |
+ label = NULL,+ |
+
| 24 | ++ |
+ indent_mod = NULL,+ |
+
| 25 | ++ |
+ footnotes = NULL,+ |
+
| 26 | ++ |
+ align = NULL,+ |
+
| 27 | ++ |
+ format_na_str = NULL) {
+ |
+
| 28 | +31800x | +
+ if (!is.null(align)) {
+ |
+
| 29 | +56x | +
+ check_aligns(align)+ |
+
| 30 | ++ |
+ }+ |
+
| 31 | +31800x | +
+ if (is(x, "CellValue")) {
+ |
+
| 32 | +19183x | +
+ if (!is.null(label)) {
+ |
+
| 33 | +1x | +
+ obj_label(x) <- label+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | +19183x | +
+ if (colspan != 1L) {
+ |
+
| 36 | +1x | +
+ cell_cspan(x) <- colspan+ |
+
| 37 | ++ |
+ }+ |
+
| 38 | +19183x | +
+ if (!is.null(indent_mod)) {
+ |
+
| 39 | +1x | +
+ indent_mod(x) <- indent_mod+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | +19183x | +
+ if (!is.null(format)) {
+ |
+
| 42 | +1x | +
+ obj_format(x) <- format+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | +19183x | +
+ if (!is.null(footnotes)) {
+ |
+
| 45 | +366x | +
+ cell_footnotes(x) <- lapply(footnotes, RefFootnote)+ |
+
| 46 | ++ |
+ }+ |
+
| 47 | +19183x | +
+ if (!is.null(format_na_str)) {
+ |
+
| 48 | +! | +
+ obj_na_str(x) <- format_na_str+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | +19183x | +
+ ret <- x+ |
+
| 51 | ++ |
+ } else {
+ |
+
| 52 | +12617x | +
+ if (is.null(label)) {
+ |
+
| 53 | +9735x | +
+ label <- obj_label(x)+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | +12617x | +
+ if (is.null(format)) {
+ |
+
| 56 | +6779x | +
+ format <- obj_format(x)+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | +12617x | +
+ if (is.null(indent_mod)) {
+ |
+
| 59 | +12617x | +
+ indent_mod <- indent_mod(x)+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | +12617x | +
+ footnotes <- lapply(footnotes, RefFootnote)+ |
+
| 62 | +12617x | +
+ ret <- CellValue(+ |
+
| 63 | +12617x | +
+ val = x,+ |
+
| 64 | +12617x | +
+ format = format,+ |
+
| 65 | +12617x | +
+ colspan = colspan,+ |
+
| 66 | +12617x | +
+ label = label,+ |
+
| 67 | +12617x | +
+ indent_mod = indent_mod,+ |
+
| 68 | +12617x | +
+ footnotes = footnotes,+ |
+
| 69 | +12617x | +
+ format_na_str = format_na_str+ |
+
| 70 | +12617x | +
+ ) # RefFootnote(footnote))+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | +31800x | +
+ if (!is.null(align)) {
+ |
+
| 73 | +56x | +
+ cell_align(ret) <- align+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | +31800x | +
+ ret+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | ++ | + + | +
| 78 | ++ |
+ #' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be+ |
+
| 79 | ++ |
+ #' passed to this argument).+ |
+
| 80 | ++ |
+ #' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @details+ |
+
| 83 | ++ |
+ #' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should+ |
+
| 84 | ++ |
+ #' be passed the value of `.in_ref_col` when it is used.+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @rdname rcell+ |
+
| 87 | ++ |
+ #' @export+ |
+
| 88 | ++ |
+ non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,+ |
+
| 89 | ++ |
+ label = NULL, indent_mod = NULL,+ |
+
| 90 | ++ |
+ refval = NULL,+ |
+
| 91 | ++ |
+ align = "center",+ |
+
| 92 | ++ |
+ format_na_str = NULL) {
+ |
+
| 93 | +2x | +
+ val <- if (is_ref) refval else x+ |
+
| 94 | +2x | +
+ rcell(val,+ |
+
| 95 | +2x | +
+ format = format, colspan = colspan, label = label,+ |
+
| 96 | +2x | +
+ indent_mod = indent_mod, align = align,+ |
+
| 97 | +2x | +
+ format_na_str = format_na_str+ |
+
| 98 | ++ |
+ )+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ #' Create multiple rows in analysis or summary functions+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ #' Define the cells that get placed into multiple rows in `afun`.+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ #' @param ... single row defining expressions.+ |
+
| 106 | ++ |
+ #' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.+ |
+
| 107 | ++ |
+ #' @param .names (`character` or `NULL`)\cr names of the returned list/structure.+ |
+
| 108 | ++ |
+ #' @param .labels (`character` or `NULL`)\cr labels for the defined rows.+ |
+
| 109 | ++ |
+ #' @param .formats (`character` or `NULL`)\cr formats for the values.+ |
+
| 110 | ++ |
+ #' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.+ |
+
| 111 | ++ |
+ #' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*.+ |
+
| 112 | ++ |
+ #' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*.+ |
+
| 113 | ++ |
+ #' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.+ |
+
| 114 | ++ |
+ #' See [formatters::list_valid_aligns()] for currently supported alignments.+ |
+
| 115 | ++ |
+ #' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @note In post-processing, referential footnotes can also be added using row and column+ |
+
| 118 | ++ |
+ #' paths with [`fnotes_at_path<-`].+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an+ |
+
| 121 | ++ |
+ #' internal implementation detail.+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @seealso [analyze()]+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @examples+ |
+
| 126 | ++ |
+ #' in_rows(1, 2, 3, .names = c("a", "b", "c"))
+ |
+
| 127 | ++ |
+ #' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
+ |
+
| 128 | ++ |
+ #' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' in_rows(.list = list(a = 1, b = 2, c = 3))+ |
+
| 131 | ++ |
+ #' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 134 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 135 | ++ |
+ #' analyze("AGE", afun = function(x) {
+ |
+
| 136 | ++ |
+ #' in_rows(+ |
+
| 137 | ++ |
+ #' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ |
+
| 138 | ++ |
+ #' "Range" = rcell(range(x), format = "xx.xx - xx.xx")+ |
+
| 139 | ++ |
+ #' )+ |
+
| 140 | ++ |
+ #' })+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 143 | ++ |
+ #' tbl+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' @export+ |
+
| 146 | ++ |
+ in_rows <- function(..., .list = NULL, .names = NULL,+ |
+
| 147 | ++ |
+ .labels = NULL,+ |
+
| 148 | ++ |
+ .formats = NULL,+ |
+
| 149 | ++ |
+ .indent_mods = NULL,+ |
+
| 150 | ++ |
+ .cell_footnotes = list(NULL),+ |
+
| 151 | ++ |
+ .row_footnotes = list(NULL),+ |
+
| 152 | ++ |
+ .aligns = NULL,+ |
+
| 153 | ++ |
+ .format_na_strs = NULL) {
+ |
+
| 154 | +5775x | +
+ if (is.function(.formats)) {
+ |
+
| 155 | +! | +
+ .formats <- list(.formats)+ |
+
| 156 | ++ |
+ }+ |
+
| 157 | ++ | + + | +
| 158 | +5775x | +
+ l <- c(list(...), .list)+ |
+
| 159 | ++ | + + | +
| 160 | +5775x | +
+ if (missing(.names) && missing(.labels)) {
+ |
+
| 161 | +1766x | +
+ if (length(l) > 0 && is.null(names(l))) {
+ |
+
| 162 | +! | +
+ stop("need a named list")
+ |
+
| 163 | ++ |
+ } else {
+ |
+
| 164 | +1766x | +
+ .names <- names(l)+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | +1766x | +
+ stopifnot(!anyNA(.names))+ |
+
| 167 | ++ |
+ }+ |
+
| 168 | ++ | + + | +
| 169 | +5775x | +
+ if (length(l) == 0) {
+ |
+
| 170 | ++ |
+ if (+ |
+
| 171 | +! | +
+ length(.labels) > 0 ||+ |
+
| 172 | +! | +
+ length(.formats) > 0 ||+ |
+
| 173 | +! | +
+ length(.names) > 0 ||+ |
+
| 174 | +! | +
+ length(.indent_mods) > 0 ||+ |
+
| 175 | +! | +
+ length(.format_na_strs) > 0+ |
+
| 176 | ++ |
+ ) {
+ |
+
| 177 | +! | +
+ stop(+ |
+
| 178 | +! | +
+ "in_rows got 0 rows but length >0 of at least one of ",+ |
+
| 179 | +! | +
+ ".labels, .formats, .names, .indent_mods, .format_na_strs. ",+ |
+
| 180 | +! | +
+ "Does your analysis/summary function handle the 0 row ",+ |
+
| 181 | +! | +
+ "df/length 0 x case?"+ |
+
| 182 | ++ |
+ )+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | +! | +
+ l2 <- list()+ |
+
| 185 | ++ |
+ } else {
+ |
+
| 186 | +5775x | +
+ if (is.null(.formats)) {
+ |
+
| 187 | +5315x | +
+ .formats <- list(NULL)+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | +5775x | +
+ stopifnot(is.list(.cell_footnotes))+ |
+
| 190 | +5775x | +
+ if (length(.cell_footnotes) != length(l)) {
+ |
+
| 191 | +1187x | +
+ .cell_footnotes <- c(+ |
+
| 192 | +1187x | +
+ .cell_footnotes,+ |
+
| 193 | +1187x | +
+ setNames(+ |
+
| 194 | +1187x | +
+ rep(list(character()),+ |
+
| 195 | +1187x | +
+ length.out = length(setdiff(+ |
+
| 196 | +1187x | +
+ names(l),+ |
+
| 197 | +1187x | +
+ names(.cell_footnotes)+ |
+
| 198 | ++ |
+ ))+ |
+
| 199 | ++ |
+ ),+ |
+
| 200 | +1187x | +
+ setdiff(+ |
+
| 201 | +1187x | +
+ names(l),+ |
+
| 202 | +1187x | +
+ names(.cell_footnotes)+ |
+
| 203 | ++ |
+ )+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ |
+ )+ |
+
| 206 | +1187x | +
+ .cell_footnotes <- .cell_footnotes[names(l)]+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | +5775x | +
+ if (is.null(.aligns)) {
+ |
+
| 209 | +5772x | +
+ .aligns <- list(NULL)+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | +5775x | +
+ l2 <- mapply(rcell,+ |
+
| 212 | +5775x | +
+ x = l, format = .formats,+ |
+
| 213 | +5775x | +
+ footnotes = .cell_footnotes %||% list(NULL),+ |
+
| 214 | +5775x | +
+ align = .aligns,+ |
+
| 215 | +5775x | +
+ format_na_str = .format_na_strs %||% list(NULL),+ |
+
| 216 | +5775x | +
+ SIMPLIFY = FALSE+ |
+
| 217 | ++ |
+ )+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | +5775x | +
+ if (is.null(.labels)) {
+ |
+
| 220 | +2623x | +
+ objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "")+ |
+
| 221 | +2623x | +
+ if (any(nzchar(objlabs))) {
+ |
+
| 222 | +69x | +
+ .labels <- objlabs+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | ++ |
+ }+ |
+
| 225 | ++ | + + | +
| 226 | +5775x | +
+ if (is.null(.names) && !is.null(names(l))) {
+ |
+
| 227 | +97x | +
+ .names <- names(l)+ |
+
| 228 | ++ |
+ }+ |
+
| 229 | +5775x | +
+ stopifnot(is.list(.row_footnotes))+ |
+
| 230 | +5775x | +
+ if (length(.row_footnotes) != length(l2)) {
+ |
+
| 231 | +1187x | +
+ tmp <- .row_footnotes+ |
+
| 232 | +1187x | +
+ .row_footnotes <- vector("list", length(l2))
+ |
+
| 233 | +1187x | +
+ pos <- match(names(tmp), .names)+ |
+
| 234 | +1187x | +
+ nonna <- which(!is.na(pos))+ |
+
| 235 | +1187x | +
+ .row_footnotes[pos] <- tmp[nonna]+ |
+
| 236 | ++ |
+ # length(.row_footnotes) <- length(l2)+ |
+
| 237 | ++ |
+ }+ |
+
| 238 | +5775x | +
+ ret <- RowsVerticalSection(l2,+ |
+
| 239 | +5775x | +
+ names = .names,+ |
+
| 240 | +5775x | +
+ labels = .labels,+ |
+
| 241 | +5775x | +
+ indent_mods = .indent_mods,+ |
+
| 242 | +5775x | +
+ formats = .formats,+ |
+
| 243 | +5775x | +
+ footnotes = .row_footnotes,+ |
+
| 244 | +5775x | +
+ format_na_strs = .format_na_strs+ |
+
| 245 | ++ |
+ )+ |
+
| 246 | ++ |
+ ## if(!is.null(.names))+ |
+
| 247 | ++ |
+ ## names(l2) <- .names+ |
+
| 248 | ++ |
+ ## else+ |
+
| 249 | ++ |
+ ## names(l2) <- names(l)+ |
+
| 250 | +! | +
+ if (length(ret) == 0) NULL else ret+ |
+
| 251 | ++ | + + | +
| 252 | ++ |
+ ## if (length(l) == 0) NULL else l+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ | + + | +
| 255 | ++ |
+ .validate_nms <- function(vals, .stats, arg) {
+ |
+
| 256 | +268x | +
+ if (!is.null(arg)) {
+ |
+
| 257 | +112x | +
+ if (is.null(names(arg))) {
+ |
+
| 258 | +! | +
+ stopifnot(length(arg) == length(.stats))+ |
+
| 259 | +! | +
+ names(arg) <- names(vals)+ |
+
| 260 | ++ |
+ } else {
+ |
+
| 261 | +112x | +
+ lblpos <- match(names(arg), names(vals))+ |
+
| 262 | +112x | +
+ stopifnot(!anyNA(lblpos))+ |
+
| 263 | ++ |
+ }+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | +268x | +
+ arg+ |
+
| 266 | ++ |
+ }+ |
+
| 267 | ++ | + + | +
| 268 | ++ |
+ #' Create a custom analysis function wrapping an existing function+ |
+
| 269 | ++ |
+ #'+ |
+
| 270 | ++ |
+ #' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.+ |
+
| 271 | ++ |
+ #' `fun` should return a named `list`.+ |
+
| 272 | ++ |
+ #' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.+ |
+
| 273 | ++ |
+ #' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.+ |
+
| 274 | ++ |
+ #' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.+ |
+
| 275 | ++ |
+ #' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.+ |
+
| 276 | ++ |
+ #' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.+ |
+
| 277 | ++ |
+ #' @param ... additional arguments to `fun` which effectively become new defaults. These can still be+ |
+
| 278 | ++ |
+ #' overridden by `extra_args` within a split.+ |
+
| 279 | ++ |
+ #' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the+ |
+
| 280 | ++ |
+ #' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note+ |
+
| 281 | ++ |
+ #' this argument occurs after `...` so it must be *fully* specified by name when set.+ |
+
| 282 | ++ |
+ #' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.+ |
+
| 283 | ++ |
+ #'+ |
+
| 284 | ++ |
+ #' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling+ |
+
| 285 | ++ |
+ #' performed automatically.+ |
+
| 286 | ++ |
+ #'+ |
+
| 287 | ++ |
+ #' @note+ |
+
| 288 | ++ |
+ #' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than+ |
+
| 289 | ++ |
+ #' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that+ |
+
| 290 | ++ |
+ #' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,+ |
+
| 291 | ++ |
+ #' *not* the original structure returned by `fun`. See the final pair of examples below.+ |
+
| 292 | ++ |
+ #'+ |
+
| 293 | ++ |
+ #' @seealso [analyze()]+ |
+
| 294 | ++ |
+ #'+ |
+
| 295 | ++ |
+ #' @examples+ |
+
| 296 | ++ |
+ #' s_summary <- function(x) {
+ |
+
| 297 | ++ |
+ #' stopifnot(is.numeric(x))+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' list(+ |
+
| 300 | ++ |
+ #' n = sum(!is.na(x)),+ |
+
| 301 | ++ |
+ #' mean_sd = c(mean = mean(x), sd = sd(x)),+ |
+
| 302 | ++ |
+ #' min_max = range(x)+ |
+
| 303 | ++ |
+ #' )+ |
+
| 304 | ++ |
+ #' }+ |
+
| 305 | ++ |
+ #'+ |
+
| 306 | ++ |
+ #' s_summary(iris$Sepal.Length)+ |
+
| 307 | ++ |
+ #'+ |
+
| 308 | ++ |
+ #' a_summary <- make_afun(+ |
+
| 309 | ++ |
+ #' fun = s_summary,+ |
+
| 310 | ++ |
+ #' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),+ |
+
| 311 | ++ |
+ #' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")+ |
+
| 312 | ++ |
+ #' )+ |
+
| 313 | ++ |
+ #'+ |
+
| 314 | ++ |
+ #' a_summary(x = iris$Sepal.Length)+ |
+
| 315 | ++ |
+ #'+ |
+
| 316 | ++ |
+ #' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
+ |
+
| 317 | ++ |
+ #'+ |
+
| 318 | ++ |
+ #' a_summary2(x = iris$Sepal.Length)+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))+ |
+
| 321 | ++ |
+ #'+ |
+
| 322 | ++ |
+ #' s_foo <- function(df, .N_col, a = 1, b = 2) {
+ |
+
| 323 | ++ |
+ #' list(+ |
+
| 324 | ++ |
+ #' nrow_df = nrow(df),+ |
+
| 325 | ++ |
+ #' .N_col = .N_col,+ |
+
| 326 | ++ |
+ #' a = a,+ |
+
| 327 | ++ |
+ #' b = b+ |
+
| 328 | ++ |
+ #' )+ |
+
| 329 | ++ |
+ #' }+ |
+
| 330 | ++ |
+ #'+ |
+
| 331 | ++ |
+ #' s_foo(iris, 40)+ |
+
| 332 | ++ |
+ #'+ |
+
| 333 | ++ |
+ #' a_foo <- make_afun(s_foo,+ |
+
| 334 | ++ |
+ #' b = 4,+ |
+
| 335 | ++ |
+ #' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),+ |
+
| 336 | ++ |
+ #' .labels = c(+ |
+
| 337 | ++ |
+ #' nrow_df = "Nrow df",+ |
+
| 338 | ++ |
+ #' ".N_col" = "n in cols", a = "a value", b = "b value"+ |
+
| 339 | ++ |
+ #' ),+ |
+
| 340 | ++ |
+ #' .indent_mods = c(nrow_df = 2L, a = 1L)+ |
+
| 341 | ++ |
+ #' )+ |
+
| 342 | ++ |
+ #'+ |
+
| 343 | ++ |
+ #' a_foo(iris, .N_col = 40)+ |
+
| 344 | ++ |
+ #' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))+ |
+
| 345 | ++ |
+ #' a_foo2(iris, .N_col = 40)+ |
+
| 346 | ++ |
+ #'+ |
+
| 347 | ++ |
+ #' # grouping and further customization+ |
+
| 348 | ++ |
+ #' s_grp <- function(df, .N_col, a = 1, b = 2) {
+ |
+
| 349 | ++ |
+ #' list(+ |
+
| 350 | ++ |
+ #' nrow_df = nrow(df),+ |
+
| 351 | ++ |
+ #' .N_col = .N_col,+ |
+
| 352 | ++ |
+ #' letters = list(+ |
+
| 353 | ++ |
+ #' a = a,+ |
+
| 354 | ++ |
+ #' b = b+ |
+
| 355 | ++ |
+ #' )+ |
+
| 356 | ++ |
+ #' )+ |
+
| 357 | ++ |
+ #' }+ |
+
| 358 | ++ |
+ #' a_grp <- make_afun(s_grp,+ |
+
| 359 | ++ |
+ #' b = 3,+ |
+
| 360 | ++ |
+ #' .labels = c(+ |
+
| 361 | ++ |
+ #' nrow_df = "row count",+ |
+
| 362 | ++ |
+ #' .N_col = "count in column"+ |
+
| 363 | ++ |
+ #' ),+ |
+
| 364 | ++ |
+ #' .formats = c(nrow_df = "xx.", .N_col = "xx."),+ |
+
| 365 | ++ |
+ #' .indent_mods = c(letters = 1L),+ |
+
| 366 | ++ |
+ #' .ungroup_stats = "letters"+ |
+
| 367 | ++ |
+ #' )+ |
+
| 368 | ++ |
+ #' a_grp(iris, 40)+ |
+
| 369 | ++ |
+ #' a_aftergrp <- make_afun(a_grp,+ |
+
| 370 | ++ |
+ #' .stats = c("nrow_df", "b"),
+ |
+
| 371 | ++ |
+ #' .formats = c(b = "xx.")+ |
+
| 372 | ++ |
+ #' )+ |
+
| 373 | ++ |
+ #' a_aftergrp(iris, 40)+ |
+
| 374 | ++ |
+ #'+ |
+
| 375 | ++ |
+ #' s_ref <- function(x, .in_ref_col, .ref_group) {
+ |
+
| 376 | ++ |
+ #' list(+ |
+
| 377 | ++ |
+ #' mean_diff = mean(x) - mean(.ref_group)+ |
+
| 378 | ++ |
+ #' )+ |
+
| 379 | ++ |
+ #' }+ |
+
| 380 | ++ |
+ #'+ |
+
| 381 | ++ |
+ #' a_ref <- make_afun(s_ref,+ |
+
| 382 | ++ |
+ #' .labels = c(mean_diff = "Mean Difference from Ref")+ |
+
| 383 | ++ |
+ #' )+ |
+
| 384 | ++ |
+ #' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)+ |
+
| 385 | ++ |
+ #' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)+ |
+
| 386 | ++ |
+ #'+ |
+
| 387 | ++ |
+ #' @export+ |
+
| 388 | ++ |
+ make_afun <- function(fun,+ |
+
| 389 | ++ |
+ .stats = NULL,+ |
+
| 390 | ++ |
+ .formats = NULL,+ |
+
| 391 | ++ |
+ .labels = NULL,+ |
+
| 392 | ++ |
+ .indent_mods = NULL,+ |
+
| 393 | ++ |
+ .ungroup_stats = NULL,+ |
+
| 394 | ++ |
+ .format_na_strs = NULL,+ |
+
| 395 | ++ |
+ ...,+ |
+
| 396 | ++ |
+ .null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
+ |
+
| 397 | ++ |
+ ## there is a LOT more computing-on-the-language hackery in here that I+ |
+
| 398 | ++ |
+ ## would prefer, but currently this is the way I see to do everything we+ |
+
| 399 | ++ |
+ ## want to do.+ |
+
| 400 | ++ | + + | +
| 401 | ++ |
+ ## too clever by three-quarters (because half wasn't enough)+ |
+
| 402 | ++ |
+ ## gross scope hackery+ |
+
| 403 | +23x | +
+ fun_args <- force(list(...))+ |
+
| 404 | +23x | +
+ fun_fnames <- names(formals(fun))+ |
+
| 405 | ++ | + + | +
| 406 | ++ |
+ ## force EVERYTHING otherwise calling this within loops is the stuff of+ |
+
| 407 | ++ |
+ ## nightmares+ |
+
| 408 | +23x | +
+ force(.stats)+ |
+
| 409 | +23x | +
+ force(.formats)+ |
+
| 410 | +23x | +
+ force(.format_na_strs)+ |
+
| 411 | +23x | +
+ force(.labels)+ |
+
| 412 | +23x | +
+ force(.indent_mods)+ |
+
| 413 | +23x | +
+ force(.ungroup_stats)+ |
+
| 414 | +23x | +
+ force(.null_ref_cells) ## this one probably isn't needed?+ |
+
| 415 | ++ | + + | +
| 416 | +23x | +
+ ret <- function(x, ...) { ## remember formals get clobbered here
+ |
+
| 417 | ++ | + + | +
| 418 | ++ |
+ ## this helper will grab the value and wrap it in a named list if+ |
+
| 419 | ++ |
+ ## we need the variable and return list() otherwise.+ |
+
| 420 | ++ |
+ ## We define it in here so that the scoping hackery works correctly+ |
+
| 421 | +66x | +
+ .if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
+ |
+
| 422 | +660x | +
+ val <- if (nm %in% fun_fnames) get(nm) else ifnot+ |
+
| 423 | +660x | +
+ if (named_lwrap && !identical(val, ifnot)) {
+ |
+
| 424 | +78x | +
+ setNames(list(val), nm)+ |
+
| 425 | ++ |
+ } else {
+ |
+
| 426 | +582x | +
+ val+ |
+
| 427 | ++ |
+ }+ |
+
| 428 | ++ |
+ }+ |
+
| 429 | ++ | + + | +
| 430 | +66x | +
+ custargs <- fun_args+ |
+
| 431 | ++ | + + | +
| 432 | ++ |
+ ## special handling cause I need it at the bottom as well+ |
+
| 433 | +66x | +
+ in_rc_argl <- .if_in_formals(".in_ref_col")
+ |
+
| 434 | +66x | +
+ .in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE+ |
+
| 435 | ++ | + + | +
| 436 | +66x | +
+ sfunargs <- c(+ |
+
| 437 | ++ |
+ ## these are either named lists containing the arg, or list()+ |
+
| 438 | ++ |
+ ## depending on whether fun accept the argument or not+ |
+
| 439 | +66x | +
+ .if_in_formals("x"),
+ |
+
| 440 | +66x | +
+ .if_in_formals("df"),
+ |
+
| 441 | +66x | +
+ .if_in_formals(".N_col"),
+ |
+
| 442 | +66x | +
+ .if_in_formals(".N_total"),
+ |
+
| 443 | +66x | +
+ .if_in_formals(".N_row"),
+ |
+
| 444 | +66x | +
+ .if_in_formals(".ref_group"),
+ |
+
| 445 | +66x | +
+ in_rc_argl,+ |
+
| 446 | +66x | +
+ .if_in_formals(".df_row"),
+ |
+
| 447 | +66x | +
+ .if_in_formals(".var"),
+ |
+
| 448 | +66x | +
+ .if_in_formals(".ref_full")
+ |
+
| 449 | ++ |
+ )+ |
+
| 450 | ++ | + + | +
| 451 | +66x | +
+ allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
+ |
+
| 452 | ++ |
+ ## values int he actual call to this function override customization+ |
+
| 453 | ++ |
+ ## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE+ |
+
| 454 | +66x | +
+ if ("..." %in% fun_fnames) {
+ |
+
| 455 | +5x | +
+ exargs <- eval(parser_helper(text = "list(...)"))+ |
+
| 456 | +5x | +
+ custargs[names(exargs)] <- exargs+ |
+
| 457 | +5x | +
+ allvars <- unique(c(allvars, names(custargs)))+ |
+
| 458 | ++ |
+ }+ |
+
| 459 | ++ | + + | +
| 460 | +66x | +
+ for (var in allvars) {
+ |
+
| 461 | ++ |
+ ## not missing, i.e. specified in the direct call, takes precedence+ |
+
| 462 | +22x | +
+ if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
+ |
+
| 463 | +5x | +
+ sfunargs[[var]] <- get(var)+ |
+
| 464 | +17x | +
+ } else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
+ |
+
| 465 | +4x | +
+ sfunargs[[var]] <- custargs[[var]]+ |
+
| 466 | ++ |
+ }+ |
+
| 467 | ++ |
+ ## else left out so we hit the original default we inherited from fun+ |
+
| 468 | ++ |
+ }+ |
+
| 469 | ++ | + + | +
| 470 | +66x | +
+ rawvals <- do.call(fun, sfunargs)+ |
+
| 471 | ++ | + + | +
| 472 | ++ |
+ ## note single brackets here so its a list+ |
+
| 473 | ++ |
+ ## no matter what. thats important!+ |
+
| 474 | +66x | +
+ final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]+ |
+
| 475 | ++ | + + | +
| 476 | +66x | +
+ if (!is.list(rawvals)) {
+ |
+
| 477 | +! | +
+ stop("make_afun expects a function fun that always returns a list")
+ |
+
| 478 | ++ |
+ }+ |
+
| 479 | +66x | +
+ if (!is.null(.stats)) {
+ |
+
| 480 | +10x | +
+ stopifnot(all(.stats %in% names(rawvals)))+ |
+
| 481 | ++ |
+ } else {
+ |
+
| 482 | +56x | +
+ .stats <- names(rawvals)+ |
+
| 483 | ++ |
+ }+ |
+
| 484 | +66x | +
+ if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
+ |
+
| 485 | +! | +
+ stop(+ |
+
| 486 | +! | +
+ "Stats specified for ungrouping not included in non-null .stats list: ",+ |
+
| 487 | +! | +
+ setdiff(.ungroup_stats, .stats)+ |
+
| 488 | ++ |
+ )+ |
+
| 489 | ++ |
+ }+ |
+
| 490 | ++ | + + | +
| 491 | +66x | +
+ .labels <- .validate_nms(final_vals, .stats, .labels)+ |
+
| 492 | +66x | +
+ .formats <- .validate_nms(final_vals, .stats, .formats)+ |
+
| 493 | +66x | +
+ .indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)+ |
+
| 494 | +66x | +
+ .format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)+ |
+
| 495 | ++ | + + | +
| 496 | +66x | +
+ final_labels <- value_labels(final_vals)+ |
+
| 497 | +66x | +
+ final_labels[names(.labels)] <- .labels+ |
+
| 498 | ++ | + + | +
| 499 | +66x | +
+ final_formats <- lapply(final_vals, obj_format)+ |
+
| 500 | +66x | +
+ final_formats[names(.formats)] <- .formats+ |
+
| 501 | ++ | + + | +
| 502 | +66x | +
+ final_format_na_strs <- lapply(final_vals, obj_na_str)+ |
+
| 503 | +66x | +
+ final_format_na_strs[names(.format_na_strs)] <- .format_na_strs+ |
+
| 504 | ++ | + + | +
| 505 | +66x | +
+ if (is(final_vals, "RowsVerticalSection")) {
+ |
+
| 506 | +20x | +
+ final_imods <- indent_mod(final_vals)+ |
+
| 507 | ++ |
+ } else {
+ |
+
| 508 | +46x | +
+ final_imods <- vapply(final_vals, indent_mod, 1L)+ |
+
| 509 | ++ |
+ }+ |
+
| 510 | +66x | +
+ final_imods[names(.indent_mods)] <- .indent_mods+ |
+
| 511 | ++ | + + | +
| 512 | +66x | +
+ if (!is.null(.ungroup_stats)) {
+ |
+
| 513 | +2x | +
+ for (nm in .ungroup_stats) {
+ |
+
| 514 | +3x | +
+ tmp <- final_vals[[nm]]+ |
+
| 515 | +3x | +
+ if (is(tmp, "CellValue")) {
+ |
+
| 516 | +1x | +
+ tmp <- tmp[[1]]+ |
+
| 517 | +23x | +
+ } ## unwrap it+ |
+
| 518 | +3x | +
+ final_vals <- insert_replace(final_vals, nm, tmp)+ |
+
| 519 | +3x | +
+ stopifnot(all(nzchar(names(final_vals))))+ |
+
| 520 | ++ | + + | +
| 521 | +3x | +
+ final_labels <- insert_replace(+ |
+
| 522 | +3x | +
+ final_labels,+ |
+
| 523 | +3x | +
+ nm,+ |
+
| 524 | +3x | +
+ setNames(+ |
+
| 525 | +3x | +
+ value_labels(tmp),+ |
+
| 526 | +3x | +
+ names(tmp)+ |
+
| 527 | ++ |
+ )+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | +3x | +
+ final_formats <- insert_replace(+ |
+
| 530 | +3x | +
+ final_formats,+ |
+
| 531 | +3x | +
+ nm,+ |
+
| 532 | +3x | +
+ setNames(+ |
+
| 533 | +3x | +
+ rep(final_formats[nm],+ |
+
| 534 | +3x | +
+ length.out = length(tmp)+ |
+
| 535 | ++ |
+ ),+ |
+
| 536 | +3x | +
+ names(tmp)+ |
+
| 537 | ++ |
+ )+ |
+
| 538 | ++ |
+ )+ |
+
| 539 | +3x | +
+ final_format_na_strs <- insert_replace(+ |
+
| 540 | +3x | +
+ final_format_na_strs,+ |
+
| 541 | +3x | +
+ nm,+ |
+
| 542 | +3x | +
+ setNames(+ |
+
| 543 | +3x | +
+ rep(final_format_na_strs[nm],+ |
+
| 544 | +3x | +
+ length.out = length(tmp)+ |
+
| 545 | ++ |
+ ),+ |
+
| 546 | +3x | +
+ names(tmp)+ |
+
| 547 | ++ |
+ )+ |
+
| 548 | ++ |
+ )+ |
+
| 549 | +3x | +
+ final_imods <- insert_replace(+ |
+
| 550 | +3x | +
+ final_imods,+ |
+
| 551 | +3x | +
+ nm,+ |
+
| 552 | +3x | +
+ setNames(+ |
+
| 553 | +3x | +
+ rep(final_imods[nm],+ |
+
| 554 | +3x | +
+ length.out = length(tmp)+ |
+
| 555 | ++ |
+ ),+ |
+
| 556 | +3x | +
+ names(tmp)+ |
+
| 557 | ++ |
+ )+ |
+
| 558 | ++ |
+ )+ |
+
| 559 | ++ |
+ }+ |
+
| 560 | ++ |
+ }+ |
+
| 561 | +66x | +
+ rcells <- mapply(+ |
+
| 562 | +66x | +
+ function(x, f, l, na_str) {
+ |
+
| 563 | +197x | +
+ if (is(x, "CellValue")) {
+ |
+
| 564 | +65x | +
+ obj_label(x) <- l+ |
+
| 565 | +65x | +
+ obj_format(x) <- f+ |
+
| 566 | +65x | +
+ obj_na_str(x) <- na_str+ |
+
| 567 | ++ |
+ # indent_mod(x) <- im+ |
+
| 568 | +65x | +
+ x+ |
+
| 569 | +132x | +
+ } else if (.null_ref_cells) {
+ |
+
| 570 | +! | +
+ non_ref_rcell(x,+ |
+
| 571 | +! | +
+ is_ref = .in_ref_col,+ |
+
| 572 | +! | +
+ format = f, label = l,+ |
+
| 573 | +! | +
+ format_na_str = na_str+ |
+
| 574 | +! | +
+ ) # , indent_mod = im)+ |
+
| 575 | ++ |
+ } else {
+ |
+
| 576 | +132x | +
+ rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)+ |
+
| 577 | ++ |
+ }+ |
+
| 578 | ++ |
+ },+ |
+
| 579 | +66x | +
+ f = final_formats, x = final_vals,+ |
+
| 580 | +66x | +
+ l = final_labels,+ |
+
| 581 | +66x | +
+ na_str = final_format_na_strs,+ |
+
| 582 | ++ |
+ # im = final_imods,+ |
+
| 583 | +66x | +
+ SIMPLIFY = FALSE+ |
+
| 584 | ++ |
+ )+ |
+
| 585 | +66x | +
+ in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)+ |
+
| 586 | ++ |
+ }+ |
+
| 587 | +23x | +
+ formals(ret) <- formals(fun)+ |
+
| 588 | +23x | +
+ ret+ |
+
| 589 | ++ |
+ }+ |
+
| 590 | ++ | + + | +
| 591 | ++ |
+ insert_replace <- function(x, nm, newvals = x[[nm]]) {
+ |
+
| 592 | +15x | +
+ i <- match(nm, names(x))+ |
+
| 593 | +15x | +
+ if (is.na(i)) {
+ |
+
| 594 | +! | +
+ stop("name not found")
+ |
+
| 595 | ++ |
+ }+ |
+
| 596 | +15x | +
+ bef <- if (i > 1) 1:(i - 1) else numeric()+ |
+
| 597 | +15x | +
+ aft <- if (i < length(x)) (i + 1):length(x) else numeric()+ |
+
| 598 | +15x | +
+ ret <- c(x[bef], newvals, x[aft])+ |
+
| 599 | +15x | +
+ names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])+ |
+
| 600 | +15x | +
+ ret+ |
+
| 601 | ++ |
+ }+ |
+
| 602 | ++ | + + | +
| 603 | ++ |
+ parser_helper <- function(text, envir = parent.frame(2)) {
+ |
+
| 604 | +505x | +
+ parse(text = text, keep.source = FALSE)+ |
+
| 605 | ++ |
+ }+ |
+
| 606 | ++ | + + | +
| 607 | ++ |
+ length_w_name <- function(x, .parent_splval) {
+ |
+
| 608 | +! | +
+ in_rows(length(x),+ |
+
| 609 | +! | +
+ .names = value_labels(.parent_splval)+ |
+
| 610 | ++ |
+ )+ |
+
| 611 | ++ |
+ }+ |
+
| 1 | ++ |
+ # 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 | ++ |
+ #' table rows or columns, into different parts or groups (splits). You can also create your own split function if you+ |
+
| 7 | ++ |
+ #' need to create a custom division as specific as you need. Please consider reading [custom_split_funs] if+ |
+
| 8 | ++ |
+ #' 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 | ++ |
+ #' with.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @inheritParams sf_args+ |
+
| 13 | ++ |
+ #' @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 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @returns A function that can be used to split the data accordingly. The actual function signature+ |
+
| 18 | ++ |
+ #' is similar to the one you can define when creating a fully custom one. For more details see [custom_split_funs].+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @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 | ++ |
+ #' `labels = NULL`, `trim = FALSE` (last three only for internal use). See [custom_split_funs] for more details+ |
+
| 24 | ++ |
+ #' and [make_split_fun()] for a more advanced API.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @seealso [custom_split_funs], [add_overall_level()], [add_combo_levels()], and [trim_levels_to_map()].+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @name split_funcs+ |
+
| 29 | ++ |
+ NULL+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # helper fncs+ |
+
| 32 | ++ |
+ .get_unique_levels <- function(vec) {
+ |
+
| 33 | +80x | +
+ out <- if (is.factor(vec)) {
+ |
+
| 34 | +79x | +
+ levels(vec)+ |
+
| 35 | ++ |
+ } else {
+ |
+
| 36 | +1x | +
+ unique(vec)+ |
+
| 37 | ++ |
+ }+ |
+
| 38 | ++ | + + | +
| 39 | +80x | +
+ out+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ .print_setdiff_error <- function(provided, existing) {
+ |
+
| 43 | +3x | +
+ paste(setdiff(provided, existing), collapse = ", ")+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ #' @describeIn split_funcs keeps only specified levels (`only`) in the split variable. If any of the specified+ |
+
| 47 | ++ |
+ #' levels is not present, an error is returned. `reorder = TRUE` (the default) orders the split levels+ |
+
| 48 | ++ |
+ #' according to the order of `only`.+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @param only (`character`)\cr levels to retain (all others will be dropped). If none of the levels is present+ |
+
| 51 | ++ |
+ #' an empty table is returned.+ |
+
| 52 | ++ |
+ #' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the+ |
+
| 53 | ++ |
+ #' split. Defaults to `TRUE`.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @examples+ |
+
| 56 | ++ |
+ #' # keep_split_levels keeps specified levels (reorder = TRUE by default)+ |
+
| 57 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 58 | ++ |
+ #' split_rows_by("COUNTRY",
+ |
+
| 59 | ++ |
+ #' split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
+ |
+
| 60 | ++ |
+ #' ) %>%+ |
+
| 61 | ++ |
+ #' analyze("AGE")
+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 64 | ++ |
+ #' tbl+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @export+ |
+
| 67 | ++ |
+ keep_split_levels <- function(only, reorder = TRUE) {
+ |
+
| 68 | +44x | +
+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ |
+
| 69 | +72x | +
+ var <- spl_payload(spl)+ |
+
| 70 | +72x | +
+ varvec <- df[[var]]+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ # Unique values from the split variable+ |
+
| 73 | +72x | +
+ unique_vals <- .get_unique_levels(varvec)+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ # Error in case not all levels are present+ |
+
| 76 | +72x | +
+ if (!all(only %in% unique_vals)) {
+ |
+
| 77 | +2x | +
+ stop(+ |
+
| 78 | +2x | +
+ "Attempted to keep factor level(s) in split that are not present in data: \n",+ |
+
| 79 | +2x | +
+ .print_setdiff_error(only, unique_vals)+ |
+
| 80 | ++ |
+ )+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ | + + | +
| 83 | +70x | +
+ df2 <- df[varvec %in% only, ]+ |
+
| 84 | +70x | +
+ if (reorder) {
+ |
+
| 85 | +69x | +
+ df2[[var]] <- factor(df2[[var]], levels = only)+ |
+
| 86 | ++ |
+ } else {
+ |
+
| 87 | ++ |
+ # Find original order of only+ |
+
| 88 | +1x | +
+ only <- unique_vals[sort(match(only, unique_vals))]+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ | + + | +
| 91 | +70x | +
+ spl_child_order(spl) <- only+ |
+
| 92 | +70x | +
+ .apply_split_inner(spl, df2,+ |
+
| 93 | +70x | +
+ vals = only,+ |
+
| 94 | +70x | +
+ labels = labels,+ |
+
| 95 | +70x | +
+ trim = trim+ |
+
| 96 | ++ |
+ )+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ | + + | +
| 100 | ++ |
+ #' @describeIn split_funcs Removes specified levels (`excl`) from the split variable. Nothing done if not in data.+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure+ |
+
| 103 | ++ |
+ #' regardless of presence in the data).+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ #' @examples+ |
+
| 106 | ++ |
+ #' # remove_split_levels removes specified split levels+ |
+
| 107 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 108 | ++ |
+ #' split_rows_by("COUNTRY",
+ |
+
| 109 | ++ |
+ #' split_fun = remove_split_levels(c(+ |
+
| 110 | ++ |
+ #' "USA", "CAN",+ |
+
| 111 | ++ |
+ #' "CHE", "BRA"+ |
+
| 112 | ++ |
+ #' ))+ |
+
| 113 | ++ |
+ #' ) %>%+ |
+
| 114 | ++ |
+ #' analyze("AGE")
+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 117 | ++ |
+ #' tbl+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @export+ |
+
| 120 | ++ |
+ remove_split_levels <- function(excl) {
+ |
+
| 121 | +28x | +
+ stopifnot(is.character(excl))+ |
+
| 122 | +28x | +
+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ |
+
| 123 | +55x | +
+ var <- spl_payload(spl)+ |
+
| 124 | +55x | +
+ df2 <- df[!(df[[var]] %in% excl), ]+ |
+
| 125 | +55x | +
+ 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 | ++ |
+ }+ |
+
| 130 | +55x | +
+ .apply_split_inner(spl, df2,+ |
+
| 131 | +55x | +
+ vals = vals,+ |
+
| 132 | +55x | +
+ labels = labels,+ |
+
| 133 | +55x | +
+ trim = trim+ |
+
| 134 | ++ |
+ )+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' @describeIn split_funcs Drops levels that have no representation in the data.+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @examples+ |
+
| 141 | ++ |
+ #' # drop_split_levels drops levels that are not present in the data+ |
+
| 142 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 143 | ++ |
+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ |
+
| 144 | ++ |
+ #' analyze("AGE")
+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 147 | ++ |
+ #' tbl+ |
+
| 148 | ++ |
+ #'+ |
+
| 149 | ++ |
+ #' @export+ |
+
| 150 | ++ |
+ drop_split_levels <- function(df,+ |
+
| 151 | ++ |
+ spl,+ |
+
| 152 | ++ |
+ vals = NULL,+ |
+
| 153 | ++ |
+ labels = NULL,+ |
+
| 154 | ++ |
+ trim = FALSE) {
+ |
+
| 155 | +168x | +
+ var <- spl_payload(spl)+ |
+
| 156 | +168x | +
+ df2 <- df+ |
+
| 157 | +168x | +
+ df2[[var]] <- factor(df[[var]])+ |
+
| 158 | +168x | +
+ lblvar <- spl_label_var(spl)+ |
+
| 159 | +168x | +
+ if (!is.null(lblvar)) {
+ |
+
| 160 | +168x | +
+ df2[[lblvar]] <- factor(df[[lblvar]])+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ | + + | +
| 163 | +168x | +
+ .apply_split_inner(spl, df2,+ |
+
| 164 | +168x | +
+ vals = vals,+ |
+
| 165 | +168x | +
+ labels = labels,+ |
+
| 166 | +168x | +
+ trim = trim+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | ++ | + + | +
| 170 | ++ |
+ #' @describeIn split_funcs Removes specified levels `excl` and drops all levels that are+ |
+
| 171 | ++ |
+ #' not in the data.+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @examples+ |
+
| 174 | ++ |
+ #' # Removing "M" and "U" directly, then "UNDIFFERENTIATED" because not in data+ |
+
| 175 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 176 | ++ |
+ #' split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
+ |
+
| 177 | ++ |
+ #' analyze("AGE")
+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 180 | ++ |
+ #' tbl+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' @export+ |
+
| 183 | ++ |
+ drop_and_remove_levels <- function(excl) {
+ |
+
| 184 | +4x | +
+ stopifnot(is.character(excl))+ |
+
| 185 | +4x | +
+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ |
+
| 186 | +13x | +
+ var <- spl_payload(spl)+ |
+
| 187 | +13x | +
+ df2 <- df[!(df[[var]] %in% excl), ]+ |
+
| 188 | +13x | +
+ df2[[var]] <- factor(df2[[var]])+ |
+
| 189 | +13x | +
+ .apply_split_inner(+ |
+
| 190 | +13x | +
+ spl,+ |
+
| 191 | +13x | +
+ df2,+ |
+
| 192 | +13x | +
+ vals = vals,+ |
+
| 193 | +13x | +
+ labels = labels,+ |
+
| 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 | ++ |
+ #' @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 | ++ |
+ #' @param drlevels (`flag`)\cr whether levels that are not in `neworder` should be dropped.+ |
+
| 207 | ++ |
+ #' Default is `TRUE`. Note: `drlevels = TRUE` does not drop levels that are not originally in the data.+ |
+
| 208 | ++ |
+ #' Rely on pre-processing or use a combination of split functions with [make_split_fun()] to also drop+ |
+
| 209 | ++ |
+ #' unused levels.+ |
+
| 210 | ++ |
+ #'+ |
+
| 211 | ++ |
+ #' @examples+ |
+
| 212 | ++ |
+ #' # Reordering levels in split variable+ |
+
| 213 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 214 | ++ |
+ #' split_rows_by(+ |
+
| 215 | ++ |
+ #' "SEX",+ |
+
| 216 | ++ |
+ #' split_fun = reorder_split_levels(+ |
+
| 217 | ++ |
+ #' neworder = c("U", "F"),
+ |
+
| 218 | ++ |
+ #' newlabels = c(U = "Uu", `F` = "Female")+ |
+
| 219 | ++ |
+ #' )+ |
+
| 220 | ++ |
+ #' ) %>%+ |
+
| 221 | ++ |
+ #' analyze("AGE")
+ |
+
| 222 | ++ |
+ #'+ |
+
| 223 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 224 | ++ |
+ #' tbl+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' # Reordering levels in split variable but keeping all the levels+ |
+
| 227 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 228 | ++ |
+ #' split_rows_by(+ |
+
| 229 | ++ |
+ #' "SEX",+ |
+
| 230 | ++ |
+ #' split_fun = reorder_split_levels(+ |
+
| 231 | ++ |
+ #' neworder = c("U", "F"),
+ |
+
| 232 | ++ |
+ #' newlabels = c("Uu", "Female"),
+ |
+
| 233 | ++ |
+ #' drlevels = FALSE+ |
+
| 234 | ++ |
+ #' )+ |
+
| 235 | ++ |
+ #' ) %>%+ |
+
| 236 | ++ |
+ #' analyze("AGE")
+ |
+
| 237 | ++ |
+ #'+ |
+
| 238 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 239 | ++ |
+ #' tbl+ |
+
| 240 | ++ |
+ #'+ |
+
| 241 | ++ |
+ #' @export+ |
+
| 242 | ++ |
+ reorder_split_levels <- function(neworder,+ |
+
| 243 | ++ |
+ newlabels = neworder,+ |
+
| 244 | ++ |
+ drlevels = TRUE) {
+ |
+
| 245 | +8x | +
+ function(df, spl, trim, ...) {
+ |
+
| 246 | +8x | +
+ df2 <- df+ |
+
| 247 | +8x | +
+ valvec <- df2[[spl_payload(spl)]]+ |
+
| 248 | ++ | + + | +
| 249 | +8x | +
+ uni_vals <- .get_unique_levels(valvec)+ |
+
| 250 | ++ | + + | +
| 251 | ++ |
+ # No sense adding things that are not present -> creating unexpected NAs+ |
+
| 252 | +8x | +
+ if (!all(neworder %in% uni_vals)) {
+ |
+
| 253 | +1x | +
+ stop(+ |
+
| 254 | +1x | +
+ "Attempted to reorder factor levels in split that are not present in data:\n",+ |
+
| 255 | +1x | +
+ .print_setdiff_error(neworder, uni_vals)+ |
+
| 256 | ++ |
+ )+ |
+
| 257 | ++ |
+ }+ |
+
| 258 | ++ | + + | +
| 259 | ++ |
+ # Keeping all levels also from before if not dropped+ |
+
| 260 | +7x | +
+ diff_with_uni_vals <- setdiff(uni_vals, neworder)+ |
+
| 261 | +7x | +
+ if (!drlevels && length(diff_with_uni_vals) > 0) {
+ |
+
| 262 | +3x | +
+ if (length(newlabels) > length(neworder)) {
+ |
+
| 263 | +1x | +
+ stop(+ |
+
| 264 | +1x | +
+ "When keeping levels not in neworder (drlevels = FALSE), newlabels can ",+ |
+
| 265 | +1x | +
+ "affect only selected neworder, and not other levels.\n",+ |
+
| 266 | +1x | +
+ "Add labels for current neworder: ", paste0(neworder, collapse = ", ")+ |
+
| 267 | ++ |
+ )+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | +2x | +
+ neworder <- c(neworder, diff_with_uni_vals)+ |
+
| 270 | +2x | +
+ if (is.null(names(newlabels))) {
+ |
+
| 271 | +! | +
+ newlabels <- c(newlabels, diff_with_uni_vals)+ |
+
| 272 | ++ |
+ } else {
+ |
+
| 273 | +2x | +
+ newlabels <- c(newlabels, setNames(diff_with_uni_vals, diff_with_uni_vals))+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ | + + | +
| 277 | +6x | +
+ valvec <- factor(valvec, levels = neworder)+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ # Labels+ |
+
| 280 | +6x | +
+ if (!is.null(names(newlabels))) {
+ |
+
| 281 | +5x | +
+ if (any(!names(newlabels) %in% neworder)) {
+ |
+
| 282 | +2x | +
+ stop(+ |
+
| 283 | +2x | +
+ "Got labels' names for levels that are not present:\n",+ |
+
| 284 | +2x | +
+ setdiff(names(newlabels), neworder)+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ |
+ # To be safe: sorting by neworder+ |
+
| 288 | +3x | +
+ newlabels <- newlabels[sapply(names(newlabels), function(x) which(x == neworder))]+ |
+
| 289 | +1x | +
+ } else if (length(neworder) != length(newlabels)) {
+ |
+
| 290 | +1x | +
+ stop(+ |
+
| 291 | +1x | +
+ "Got unnamed newlabels with different length than neworder. ",+ |
+
| 292 | +1x | +
+ "Please provide names or make sure they are of the same length.\n",+ |
+
| 293 | +1x | +
+ "Current neworder: ", paste0(neworder, collapse = ", ")+ |
+
| 294 | ++ |
+ )+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ # Final values+ |
+
| 298 | +3x | +
+ spl_child_order(spl) <- neworder+ |
+
| 299 | +3x | +
+ df2[[spl_payload(spl)]] <- valvec+ |
+
| 300 | +3x | +
+ .apply_split_inner(spl, df2,+ |
+
| 301 | +3x | +
+ vals = neworder,+ |
+
| 302 | +3x | +
+ labels = newlabels,+ |
+
| 303 | +3x | +
+ trim = trim+ |
+
| 304 | ++ |
+ )+ |
+
| 305 | ++ |
+ }+ |
+
| 306 | ++ |
+ }+ |
+
| 307 | ++ | + + | +
| 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 | ++ |
+ #' consider using [trim_levels_to_map()].+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped)+ |
+
| 313 | ++ |
+ #' *separately within each grouping defined at this point in the structure*.+ |
+
| 314 | ++ |
+ #' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer"+ |
+
| 315 | ++ |
+ #' variable, not `innervar`) should be dropped. Defaults to `TRUE`.+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' @examples+ |
+
| 318 | ++ |
+ #' # trim_levels_in_group() trims levels within each group defined by the split variable+ |
+
| 319 | ++ |
+ #' dat <- data.frame(+ |
+
| 320 | ++ |
+ #' col1 = factor(c("A", "B", "C"), levels = c("A", "B", "C", "N")),
+ |
+
| 321 | ++ |
+ #' col2 = factor(c("a", "b", "c"), levels = c("a", "b", "c", "x"))
+ |
+
| 322 | ++ |
+ #' ) # N is removed if drop_outlevs = TRUE, x is removed always+ |
+
| 323 | ++ |
+ #'+ |
+
| 324 | ++ |
+ #' tbl <- basic_table() %>%+ |
+
| 325 | ++ |
+ #' split_rows_by("col1", split_fun = trim_levels_in_group("col2")) %>%
+ |
+
| 326 | ++ |
+ #' analyze("col2") %>%
+ |
+
| 327 | ++ |
+ #' build_table(dat)+ |
+
| 328 | ++ |
+ #' tbl+ |
+
| 329 | ++ |
+ #'+ |
+
| 330 | ++ |
+ #' @export+ |
+
| 331 | ++ |
+ 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 | +! | +
+ vals = vals,+ |
+
| 336 | +! | +
+ labels = labels, trim = trim+ |
+
| 337 | ++ |
+ )+ |
+
| 338 | ++ |
+ } else {
+ |
+
| 339 | +6x | +
+ ret <- drop_split_levels(+ |
+
| 340 | +6x | +
+ df = df, spl = spl, vals = vals,+ |
+
| 341 | +6x | +
+ labels = labels, trim = trim+ |
+
| 342 | ++ |
+ )+ |
+
| 343 | ++ |
+ }+ |
+
| 344 | ++ | + + | +
| 345 | +6x | +
+ ret$datasplit <- lapply(ret$datasplit, function(x) {
+ |
+
| 346 | +14x | +
+ coldat <- x[[innervar]]+ |
+
| 347 | +14x | +
+ if (is(coldat, "character")) {
+ |
+
| 348 | +! | +
+ if (!is.null(vals)) {
+ |
+
| 349 | +! | +
+ lvs <- vals+ |
+
| 350 | ++ |
+ } else {
+ |
+
| 351 | +! | +
+ lvs <- unique(coldat)+ |
+
| 352 | ++ |
+ }+ |
+
| 353 | +! | +
+ coldat <- factor(coldat, levels = lvs) ## otherwise+ |
+
| 354 | ++ |
+ } else {
+ |
+
| 355 | +14x | +
+ coldat <- droplevels(coldat)+ |
+
| 356 | ++ |
+ }+ |
+
| 357 | +14x | +
+ x[[innervar]] <- coldat+ |
+
| 358 | +14x | +
+ x+ |
+
| 359 | ++ |
+ })+ |
+
| 360 | +6x | +
+ ret$labels <- as.character(ret$labels) # TODO+ |
+
| 361 | +6x | +
+ ret+ |
+
| 362 | ++ |
+ }+ |
+
| 363 | +6x | +
+ myfun+ |
+
| 364 | ++ |
+ }+ |
+
| 365 | ++ | + + | +
| 366 | ++ |
+ # add_combo_levels -------------------------------------------------------------+ |
+
| 367 | ++ |
+ # Dedicated docs are attached to default split functions+ |
+
| 368 | ++ |
+ .add_combo_part_info <- function(part,+ |
+
| 369 | ++ |
+ df,+ |
+
| 370 | ++ |
+ valuename,+ |
+
| 371 | ++ |
+ levels,+ |
+
| 372 | ++ |
+ label,+ |
+
| 373 | ++ |
+ extras,+ |
+
| 374 | ++ |
+ first = TRUE) {
+ |
+
| 375 | +24x | +
+ value <- LevelComboSplitValue(valuename, extras,+ |
+
| 376 | +24x | +
+ combolevels = levels,+ |
+
| 377 | +24x | +
+ label = label+ |
+
| 378 | ++ |
+ )+ |
+
| 379 | +24x | +
+ newdat <- setNames(list(df), valuename)+ |
+
| 380 | +24x | +
+ newval <- setNames(list(value), valuename)+ |
+
| 381 | +24x | +
+ newextra <- setNames(list(extras), valuename)+ |
+
| 382 | +24x | +
+ if (first) {
+ |
+
| 383 | +6x | +
+ part$datasplit <- c(newdat, part$datasplit)+ |
+
| 384 | +6x | +
+ part$values <- c(newval, part$values)+ |
+
| 385 | +6x | +
+ part$labels <- c(setNames(label, valuename), part$labels)+ |
+
| 386 | +6x | +
+ part$extras <- c(newextra, part$extras)+ |
+
| 387 | ++ |
+ } else {
+ |
+
| 388 | +18x | +
+ part$datasplit <- c(part$datasplit, newdat)+ |
+
| 389 | +18x | +
+ 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 | ++ |
+ }+ |
+
| 393 | ++ |
+ ## not needed even in custom split function case.+ |
+
| 394 | ++ |
+ ## part = .fixupvals(part)+ |
+
| 395 | +24x | +
+ part+ |
+
| 396 | ++ |
+ }+ |
+
| 397 | ++ | + + | +
| 398 | ++ |
+ #' Add overall or combination levels to split groups+ |
+
| 399 | ++ |
+ #'+ |
+
| 400 | ++ |
+ #' @description+ |
+
| 401 | ++ |
+ #' `add_overall_level` is a split function that adds a global level to the current levels in the split. Similarly,+ |
+
| 402 | ++ |
+ #' `add_combo_df` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a+ |
+
| 403 | ++ |
+ #' single overall column, after all splits, please check [add_overall_col()]. Consider also defining+ |
+
| 404 | ++ |
+ #' your custom split function if you need more flexibility (see [custom_split_funs]).+ |
+
| 405 | ++ |
+ #'+ |
+
| 406 | ++ |
+ #' @inheritParams lyt_args+ |
+
| 407 | ++ |
+ #' @inheritParams sf_args+ |
+
| 408 | ++ |
+ #' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to+ |
+
| 409 | ++ |
+ #' `"Overall"`.+ |
+
| 410 | ++ |
+ #' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults+ |
+
| 411 | ++ |
+ #' to `TRUE`.+ |
+
| 412 | ++ |
+ #'+ |
+
| 413 | ++ |
+ #' @return A splitting function (`splfun`) that adds or changes the levels of a split.+ |
+
| 414 | ++ |
+ #'+ |
+
| 415 | ++ |
+ #' @seealso [custom_split_funs] and [split_funcs].+ |
+
| 416 | ++ |
+ #'+ |
+
| 417 | ++ |
+ #' @examples+ |
+
| 418 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 419 | ++ |
+ #' split_cols_by("ARM", split_fun = add_overall_level("All Patients",
+ |
+
| 420 | ++ |
+ #' first = FALSE+ |
+
| 421 | ++ |
+ #' )) %>%+ |
+
| 422 | ++ |
+ #' analyze("AGE")
+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 425 | ++ |
+ #' tbl+ |
+
| 426 | ++ |
+ #'+ |
+
| 427 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 428 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 429 | ++ |
+ #' split_rows_by("RACE",
+ |
+
| 430 | ++ |
+ #' split_fun = add_overall_level("All Ethnicities")
+ |
+
| 431 | ++ |
+ #' ) %>%+ |
+
| 432 | ++ |
+ #' summarize_row_groups(label_fstr = "%s (n)") %>%+ |
+
| 433 | ++ |
+ #' analyze("AGE")
+ |
+
| 434 | ++ |
+ #' lyt2+ |
+
| 435 | ++ |
+ #'+ |
+
| 436 | ++ |
+ #' tbl2 <- build_table(lyt2, DM)+ |
+
| 437 | ++ |
+ #' tbl2+ |
+
| 438 | ++ |
+ #'+ |
+
| 439 | ++ |
+ #' @export+ |
+
| 440 | ++ |
+ add_overall_level <- function(valname = "Overall",+ |
+
| 441 | ++ |
+ label = valname,+ |
+
| 442 | ++ |
+ extra_args = list(),+ |
+
| 443 | ++ |
+ first = TRUE,+ |
+
| 444 | ++ |
+ 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+ |
+
| 451 | ++ |
+ )+ |
+
| 452 | +6x | +
+ add_combo_levels(combodf,+ |
+
| 453 | +6x | +
+ trim = trim, first = first+ |
+
| 454 | ++ |
+ )+ |
+
| 455 | ++ |
+ }+ |
+
| 456 | ++ | + + | +
| 457 | ++ |
+ setClass("AllLevelsSentinel", contains = "character")
+ |
+
| 458 | ++ | + + | +
| 459 | ++ |
+ # nocov start+ |
+
| 460 | ++ |
+ #' @rdname add_overall_level+ |
+
| 461 | ++ |
+ #' @export+ |
+
| 462 | ++ |
+ select_all_levels <- new("AllLevelsSentinel")
+ |
+
| 463 | ++ |
+ # nocov end+ |
+
| 464 | ++ | + + | +
| 465 | ++ |
+ #' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and+ |
+
| 466 | ++ |
+ #' `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in+ |
+
| 467 | ++ |
+ #' `comblevels` column indicates that an overall/all-observations level should be created.+ |
+
| 468 | ++ |
+ #' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and+ |
+
| 469 | ++ |
+ #' individual levels.+ |
+
| 470 | ++ |
+ #'+ |
+
| 471 | ++ |
+ #' @inherit add_overall_level return+ |
+
| 472 | ++ |
+ #'+ |
+
| 473 | ++ |
+ #' @note+ |
+
| 474 | ++ |
+ #' Analysis or summary functions for which the order matters should never be used within the tabulation framework.+ |
+
| 475 | ++ |
+ #'+ |
+
| 476 | ++ |
+ #' @examplesIf require(tibble)+ |
+
| 477 | ++ |
+ #'+ |
+
| 478 | ++ |
+ #' library(tibble)+ |
+
| 479 | ++ |
+ #' combodf <- tribble(+ |
+
| 480 | ++ |
+ #' ~valname, ~label, ~levelcombo, ~exargs,+ |
+
| 481 | ++ |
+ #' "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
+ |
+
| 482 | ++ |
+ #' "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
+ |
+
| 483 | ++ |
+ #' )+ |
+
| 484 | ++ |
+ #'+ |
+
| 485 | ++ |
+ #' lyt <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 486 | ++ |
+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
+ |
+
| 487 | ++ |
+ #' analyze("AGE")
+ |
+
| 488 | ++ |
+ #'+ |
+
| 489 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 490 | ++ |
+ #' tbl+ |
+
| 491 | ++ |
+ #'+ |
+
| 492 | ++ |
+ #' lyt1 <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 493 | ++ |
+ #' split_cols_by("ARM",
+ |
+
| 494 | ++ |
+ #' split_fun = add_combo_levels(combodf,+ |
+
| 495 | ++ |
+ #' keep_levels = c(+ |
+
| 496 | ++ |
+ #' "A_B",+ |
+
| 497 | ++ |
+ #' "A_C"+ |
+
| 498 | ++ |
+ #' )+ |
+
| 499 | ++ |
+ #' )+ |
+
| 500 | ++ |
+ #' ) %>%+ |
+
| 501 | ++ |
+ #' analyze("AGE")
+ |
+
| 502 | ++ |
+ #'+ |
+
| 503 | ++ |
+ #' tbl1 <- build_table(lyt1, DM)+ |
+
| 504 | ++ |
+ #' tbl1+ |
+
| 505 | ++ |
+ #'+ |
+
| 506 | ++ |
+ #' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
+ |
+
| 507 | ++ |
+ #' grepl("^(A|B)", ARM)))
+ |
+
| 508 | ++ |
+ #' lyt2 <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 509 | ++ |
+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
+ |
+
| 510 | ++ |
+ #' split_cols_by("SEX",
+ |
+
| 511 | ++ |
+ #' split_fun = add_overall_level("SEX_ALL", "All Genders")
+ |
+
| 512 | ++ |
+ #' ) %>%+ |
+
| 513 | ++ |
+ #' analyze("AGE")
+ |
+
| 514 | ++ |
+ #'+ |
+
| 515 | ++ |
+ #' lyt3 <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 516 | ++ |
+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
+ |
+
| 517 | ++ |
+ #' split_rows_by("SEX",
+ |
+
| 518 | ++ |
+ #' split_fun = add_overall_level("SEX_ALL", "All Genders")
+ |
+
| 519 | ++ |
+ #' ) %>%+ |
+
| 520 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 521 | ++ |
+ #' analyze("AGE")
+ |
+
| 522 | ++ |
+ #'+ |
+
| 523 | ++ |
+ #' tbl3 <- build_table(lyt3, smallerDM)+ |
+
| 524 | ++ |
+ #' tbl3+ |
+
| 525 | ++ |
+ #'+ |
+
| 526 | ++ |
+ #' @rdname add_overall_level+ |
+
| 527 | ++ |
+ #' @export+ |
+
| 528 | ++ |
+ add_combo_levels <- function(combosdf,+ |
+
| 529 | ++ |
+ trim = FALSE,+ |
+
| 530 | ++ |
+ first = FALSE,+ |
+
| 531 | ++ |
+ 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+ |
+
| 536 | ++ |
+ )+ |
+
| 537 | +14x | +
+ } # nocov+ |
+
| 538 | +18x | +
+ ret <- .apply_split_inner(spl, df,+ |
+
| 539 | +18x | +
+ vals = vals,+ |
+
| 540 | +18x | +
+ labels = labels, trim = trim+ |
+
| 541 | ++ |
+ )+ |
+
| 542 | +18x | +
+ for (i in seq_len(nrow(combosdf))) {
+ |
+
| 543 | +24x | +
+ lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]]+ |
+
| 544 | +24x | +
+ spld <- spl_payload(spl)+ |
+
| 545 | +24x | +
+ if (is(lcombo, "AllLevelsSentinel")) {
+ |
+
| 546 | +6x | +
+ subdf <- df+ |
+
| 547 | +18x | +
+ } else if (is(spl, "VarLevelSplit")) {
+ |
+
| 548 | +18x | +
+ subdf <- df[df[[spld]] %in% lcombo, ]+ |
+
| 549 | +14x | +
+ } else { ## this covers non-var splits, e.g. Cut-based splits
+ |
+
| 550 | +! | +
+ stopifnot(all(lcombo %in% c(ret$labels, ret$vals)))+ |
+
| 551 | +! | +
+ subdf <- do.call(+ |
+
| 552 | +! | +
+ rbind,+ |
+
| 553 | +! | +
+ ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo]+ |
+
| 554 | ++ |
+ )+ |
+
| 555 | ++ |
+ }+ |
+
| 556 | +24x | +
+ ret <- .add_combo_part_info(+ |
+
| 557 | +24x | +
+ ret, subdf,+ |
+
| 558 | +24x | +
+ combosdf[i, "valname", drop = TRUE],+ |
+
| 559 | +24x | +
+ lcombo,+ |
+
| 560 | +24x | +
+ combosdf[i, "label", drop = TRUE],+ |
+
| 561 | +24x | +
+ combosdf[i, "exargs", drop = TRUE][[1]],+ |
+
| 562 | +24x | +
+ first+ |
+
| 563 | ++ |
+ )+ |
+
| 564 | ++ |
+ }+ |
+
| 565 | +18x | +
+ if (!is.null(keep_levels)) {
+ |
+
| 566 | +3x | +
+ keep_inds <- value_names(ret$values) %in% keep_levels+ |
+
| 567 | +3x | +
+ ret <- lapply(ret, function(x) x[keep_inds])+ |
+
| 568 | ++ |
+ }+ |
+
| 569 | ++ | + + | +
| 570 | +18x | +
+ ret+ |
+
| 571 | ++ |
+ }+ |
+
| 572 | +14x | +
+ myfun+ |
+
| 573 | ++ |
+ }+ |
+
| 574 | ++ | + + | +
| 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 | ++ |
+ #' variables. Any combination at the level of this split not present in the+ |
+
| 583 | ++ |
+ #' map will be removed from the data, both for the variable being split and+ |
+
| 584 | ++ |
+ #' those present in the data but not associated with this split or any parents+ |
+
| 585 | ++ |
+ #' of it.+ |
+
| 586 | ++ |
+ #'+ |
+
| 587 | ++ |
+ #' @details+ |
+
| 588 | ++ |
+ #' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the+ |
+
| 589 | ++ |
+ #' variable being split are then pruned to only those still present within this subset of the map representing the+ |
+
| 590 | ++ |
+ #' current hierarchical splitting context.+ |
+
| 591 | ++ |
+ #'+ |
+
| 592 | ++ |
+ #' Splitting is then performed via the [keep_split_levels()] split function.+ |
+
| 593 | ++ |
+ #'+ |
+
| 594 | ++ |
+ #' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables+ |
+
| 595 | ++ |
+ #' specified in the map to those values allowed under the combination of the previous and current split.+ |
+
| 596 | ++ |
+ #'+ |
+
| 597 | ++ |
+ #' @return A function that can be used as a split function.+ |
+
| 598 | ++ |
+ #'+ |
+
| 599 | ++ |
+ #' @seealso [trim_levels_in_group()].+ |
+
| 600 | ++ |
+ #'+ |
+
| 601 | ++ |
+ #' @examples+ |
+
| 602 | ++ |
+ #' map <- data.frame(+ |
+
| 603 | ++ |
+ #' LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
+ |
+
| 604 | ++ |
+ #' PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
+ |
+
| 605 | ++ |
+ #' ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
+ |
+
| 606 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 607 | ++ |
+ #' )+ |
+
| 608 | ++ |
+ #'+ |
+
| 609 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 610 | ++ |
+ #' split_rows_by("LBCAT") %>%
+ |
+
| 611 | ++ |
+ #' split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
+ |
+
| 612 | ++ |
+ #' analyze("ANRIND")
+ |
+
| 613 | ++ |
+ #' tbl <- build_table(lyt, ex_adlb)+ |
+
| 614 | ++ |
+ #'+ |
+
| 615 | ++ |
+ #' @export+ |
+
| 616 | ++ |
+ trim_levels_to_map <- function(map = NULL) {
+ |
+
| 617 | +7x | +
+ if (is.null(map) || any(sapply(map, class) != "character")) {
+ |
+
| 618 | +! | +
+ stop(+ |
+
| 619 | +! | +
+ "No map dataframe was provided or not all of the columns are of ",+ |
+
| 620 | +! | +
+ "type character."+ |
+
| 621 | ++ |
+ )+ |
+
| 622 | ++ |
+ }+ |
+
| 623 | ++ | + + | +
| 624 | +7x | +
+ myfun <- function(df,+ |
+
| 625 | +7x | +
+ spl,+ |
+
| 626 | +7x | +
+ vals = NULL,+ |
+
| 627 | +7x | +
+ labels = NULL,+ |
+
| 628 | +7x | +
+ trim = FALSE,+ |
+
| 629 | +7x | +
+ .spl_context) {
+ |
+
| 630 | +12x | +
+ allvars <- colnames(map)+ |
+
| 631 | +12x | +
+ splvar <- spl_payload(spl)+ |
+
| 632 | ++ | + + | +
| 633 | +12x | +
+ allvmatches <- match(.spl_context$split, allvars)+ |
+
| 634 | +12x | +
+ outvars <- allvars[na.omit(allvmatches)]+ |
+
| 635 | ++ |
+ ## invars are variables present in data, but not in+ |
+
| 636 | ++ |
+ ## previous or current splits+ |
+
| 637 | +12x | +
+ invars <- intersect(+ |
+
| 638 | +12x | +
+ setdiff(allvars, c(outvars, splvar)),+ |
+
| 639 | +12x | +
+ names(df)+ |
+
| 640 | ++ |
+ )+ |
+
| 641 | ++ |
+ ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits+ |
+
| 642 | ++ |
+ ## which(allvars == splvar), ## this split+ |
+
| 643 | ++ |
+ ## allvars[-1*na.omit(allvmatches)]) ## "outvars"+ |
+
| 644 | ++ | + + | +
| 645 | ++ |
+ ## allvars <- allvars[allvarord]+ |
+
| 646 | ++ |
+ ## outvars <- allvars[-(which(allvars == splvar):length(allvars))]+ |
+
| 647 | +12x | +
+ if (length(outvars) > 0) {
+ |
+
| 648 | +10x | +
+ indfilters <- vapply(outvars, function(ivar) {
+ |
+
| 649 | +12x | +
+ obsval <- .spl_context$value[match(ivar, .spl_context$split)]+ |
+
| 650 | +12x | +
+ sprintf("%s == '%s'", ivar, obsval)
+ |
+
| 651 | ++ |
+ }, "")+ |
+
| 652 | ++ | + + | +
| 653 | +10x | +
+ allfilters <- paste(indfilters, collapse = " & ")+ |
+
| 654 | +10x | +
+ map <- map[eval(parse(text = allfilters), envir = map), ]+ |
+
| 655 | ++ |
+ }+ |
+
| 656 | +12x | +
+ map_splvarpos <- which(names(map) == splvar)+ |
+
| 657 | +12x | +
+ nondup <- !duplicated(map[[splvar]])+ |
+
| 658 | +12x | +
+ ksl_fun <- keep_split_levels(+ |
+
| 659 | +12x | +
+ only = map[[splvar]][nondup],+ |
+
| 660 | +12x | +
+ reorder = TRUE+ |
+
| 661 | ++ |
+ )+ |
+
| 662 | +12x | +
+ ret <- ksl_fun(df, spl, vals, labels, trim = trim)+ |
+
| 663 | ++ | + + | +
| 664 | +12x | +
+ if (length(ret$datasplit) == 0) {
+ |
+
| 665 | +1x | +
+ msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
+ |
+
| 666 | +1x | +
+ collapse = "->"+ |
+
| 667 | ++ |
+ )+ |
+
| 668 | +1x | +
+ stop(+ |
+
| 669 | +1x | +
+ "map does not allow any values present in data for split ",+ |
+
| 670 | +1x | +
+ "variable ", splvar,+ |
+
| 671 | +1x | +
+ " under the following parent splits:\n\t", msg+ |
+
| 672 | ++ |
+ )+ |
+
| 673 | ++ |
+ }+ |
+
| 674 | ++ | + + | +
| 675 | ++ |
+ ## keep non-split (inner) variables levels+ |
+
| 676 | +11x | +
+ ret$datasplit <- lapply(ret$values, function(splvar_lev) {
+ |
+
| 677 | +19x | +
+ df3 <- ret$datasplit[[splvar_lev]]+ |
+
| 678 | +19x | +
+ curmap <- map[map[[map_splvarpos]] == splvar_lev, ]+ |
+
| 679 | ++ |
+ ## loop through inner variables+ |
+
| 680 | +19x | +
+ for (iv in invars) { ## setdiff(colnames(map), splvar)) {
+ |
+
| 681 | +19x | +
+ 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 | +! | +
+ stop(+ |
+
| 685 | +! | +
+ "Attempted to keep invalid factor level(s) in split ",+ |
+
| 686 | +! | +
+ setdiff(levkeep, levels(iv_lev))+ |
+
| 687 | ++ |
+ )+ |
+
| 688 | ++ |
+ }+ |
+
| 689 | ++ | + + | +
| 690 | +19x | +
+ df3 <- df3[iv_lev %in% levkeep, , drop = FALSE]+ |
+
| 691 | ++ | + + | +
| 692 | +19x | +
+ if (is.factor(iv_lev)) {
+ |
+
| 693 | +19x | +
+ df3[[iv]] <- factor(as.character(df3[[iv]]),+ |
+
| 694 | +19x | +
+ levels = levkeep+ |
+
| 695 | ++ |
+ )+ |
+
| 696 | ++ |
+ }+ |
+
| 697 | ++ |
+ }+ |
+
| 698 | ++ | + + | +
| 699 | +19x | +
+ df3+ |
+
| 700 | ++ |
+ })+ |
+
| 701 | +11x | +
+ names(ret$datasplit) <- ret$values+ |
+
| 702 | +11x | +
+ ret+ |
+
| 703 | ++ |
+ }+ |
+
| 704 | ++ | + + | +
| 705 | +7x | +
+ myfun+ |
+
| 706 | ++ |
+ }+ |
+
| 1 | ++ |
+ # paths summary ----+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' Get a list of table row/column paths+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param x (`VTableTree`)\cr an `rtable` object.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @return A list of paths to each row/column within `x`.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @examples+ |
+
| 12 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 13 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 14 | ++ |
+ #' analyze(c("SEX", "AGE"))
+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 17 | ++ |
+ #' tbl+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' row_paths(tbl)+ |
+
| 20 | ++ |
+ #' col_paths(tbl)+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @rdname make_col_row_df+ |
+
| 25 | ++ |
+ #' @export+ |
+
| 26 | ++ |
+ row_paths <- function(x) {
+ |
+
| 27 | +45x | +
+ stopifnot(is_rtable(x))+ |
+
| 28 | +45x | +
+ make_row_df(x, visible_only = TRUE)$path+ |
+
| 29 | ++ |
+ }+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ #' @rdname make_col_row_df+ |
+
| 32 | ++ |
+ #' @export+ |
+
| 33 | ++ |
+ col_paths <- function(x) {
+ |
+
| 34 | +2340x | +
+ if (!is(coltree(x), "LayoutColTree")) {
+ |
+
| 35 | +! | +
+ stop("I don't know how to extract the column paths from an object of class ", class(x))
+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | +2340x | +
+ make_col_df(x, visible_only = TRUE)$path+ |
+
| 38 | ++ |
+ }+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ #' Print row/column paths summary+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @param x (`VTableTree`)\cr an `rtable` object.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @return A data frame summarizing the row- or column-structure of `x`.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 47 | ++ |
+ #' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 50 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 51 | ++ |
+ #' split_cols_by("SEX", split_fun = drop_split_levels) %>%
+ |
+
| 52 | ++ |
+ #' analyze(c("AGE", "BMRKR2"))
+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl_MF)+ |
+
| 55 | ++ |
+ #' tbl+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' df <- row_paths_summary(tbl)+ |
+
| 58 | ++ |
+ #' df+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' col_paths_summary(tbl)+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' # manually constructed table+ |
+
| 63 | ++ |
+ #' tbl2 <- rtable(+ |
+
| 64 | ++ |
+ #' rheader(+ |
+
| 65 | ++ |
+ #' rrow(+ |
+
| 66 | ++ |
+ #' "row 1", rcell("a", colspan = 2),
+ |
+
| 67 | ++ |
+ #' rcell("b", colspan = 2)
+ |
+
| 68 | ++ |
+ #' ),+ |
+
| 69 | ++ |
+ #' rrow("h2", "a", "b", "c", "d")
+ |
+
| 70 | ++ |
+ #' ),+ |
+
| 71 | ++ |
+ #' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #' col_paths_summary(tbl2)+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ #' @export+ |
+
| 76 | ++ |
+ row_paths_summary <- function(x) {
+ |
+
| 77 | +1x | +
+ stopifnot(is_rtable(x))+ |
+
| 78 | ++ | + + | +
| 79 | +1x | +
+ if (nrow(x) == 0) {
+ |
+
| 80 | +! | +
+ return("rowname node_class path\n---------------------\n")
+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ | + + | +
| 83 | +1x | +
+ pagdf <- make_row_df(x, visible_only = TRUE)+ |
+
| 84 | +1x | +
+ row.names(pagdf) <- NULL+ |
+
| 85 | ++ | + + | +
| 86 | +1x | +
+ mat <- rbind(+ |
+
| 87 | +1x | +
+ c("rowname", "node_class", "path"),
+ |
+
| 88 | +1x | +
+ t(apply(pagdf, 1, function(xi) {
+ |
+
| 89 | +28x | +
+ c(+ |
+
| 90 | +28x | +
+ indent_string(xi$label, xi$indent),+ |
+
| 91 | +28x | +
+ xi$node_class,+ |
+
| 92 | +28x | +
+ paste(xi$path, collapse = ", ")+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ |
+ }))+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ | + + | +
| 97 | +1x | +
+ txt <- mat_as_string(mat)+ |
+
| 98 | +1x | +
+ cat(txt)+ |
+
| 99 | +1x | +
+ cat("\n")
+ |
+
| 100 | ++ | + + | +
| 101 | +1x | +
+ invisible(pagdf[, c("label", "indent", "node_class", "path")])
+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ #' @rdname row_paths_summary+ |
+
| 105 | ++ |
+ #' @export+ |
+
| 106 | ++ |
+ col_paths_summary <- function(x) {
+ |
+
| 107 | +1x | +
+ stopifnot(is_rtable(x))+ |
+
| 108 | ++ | + + | +
| 109 | +1x | +
+ pagdf <- make_col_df(x, visible_only = FALSE)+ |
+
| 110 | +1x | +
+ row.names(pagdf) <- NULL+ |
+
| 111 | ++ | + + | +
| 112 | +1x | +
+ mat <- rbind(+ |
+
| 113 | +1x | +
+ c("label", "path"),
+ |
+
| 114 | +1x | +
+ t(apply(pagdf, 1, function(xi) {
+ |
+
| 115 | +6x | +
+ c(+ |
+
| 116 | +6x | +
+ indent_string(xi$label, floor(length(xi$path) / 2 - 1)),+ |
+
| 117 | +6x | +
+ paste(xi$path, collapse = ", ")+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ |
+ }))+ |
+
| 120 | ++ |
+ )+ |
+
| 121 | ++ | + + | +
| 122 | +1x | +
+ txt <- mat_as_string(mat)+ |
+
| 123 | +1x | +
+ cat(txt)+ |
+
| 124 | +1x | +
+ cat("\n")
+ |
+
| 125 | ++ | + + | +
| 126 | +1x | +
+ invisible(pagdf[, c("label", "path")])
+ |
+
| 127 | ++ |
+ }+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ # Rows ----+ |
+
| 130 | ++ |
+ # . Summarize Rows ----+ |
+
| 131 | ++ | + + | +
| 132 | ++ |
+ # summarize_row_df <-+ |
+
| 133 | ++ |
+ # function(name,+ |
+
| 134 | ++ |
+ # label,+ |
+
| 135 | ++ |
+ # indent,+ |
+
| 136 | ++ |
+ # depth,+ |
+
| 137 | ++ |
+ # rowtype,+ |
+
| 138 | ++ |
+ # indent_mod,+ |
+
| 139 | ++ |
+ # level) {
+ |
+
| 140 | ++ |
+ # data.frame(+ |
+
| 141 | ++ |
+ # name = name,+ |
+
| 142 | ++ |
+ # label = label,+ |
+
| 143 | ++ |
+ # indent = indent,+ |
+
| 144 | ++ |
+ # depth = level,+ |
+
| 145 | ++ |
+ # rowtype = rowtype,+ |
+
| 146 | ++ |
+ # indent_mod = indent_mod,+ |
+
| 147 | ++ |
+ # level = level,+ |
+
| 148 | ++ |
+ # stringsAsFactors = FALSE+ |
+
| 149 | ++ |
+ # )+ |
+
| 150 | ++ |
+ # }+ |
+
| 151 | ++ | + + | +
| 152 | ++ |
+ #' Summarize rows+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' @inheritParams gen_args+ |
+
| 155 | ++ |
+ #' @param depth (`numeric(1)`)\cr depth.+ |
+
| 156 | ++ |
+ #' @param indent (`numeric(1)`)\cr indent.+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 159 | ++ |
+ #' library(dplyr)+ |
+
| 160 | ++ |
+ #'+ |
+
| 161 | ++ |
+ #' iris2 <- iris %>%+ |
+
| 162 | ++ |
+ #' group_by(Species) %>%+ |
+
| 163 | ++ |
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ |
+
| 164 | ++ |
+ #' ungroup()+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 167 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 168 | ++ |
+ #' split_cols_by("group") %>%
+ |
+
| 169 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"),
+ |
+
| 170 | ++ |
+ #' afun = list_wrap_x(summary),+ |
+
| 171 | ++ |
+ #' format = "xx.xx"+ |
+
| 172 | ++ |
+ #' )+ |
+
| 173 | ++ |
+ #'+ |
+
| 174 | ++ |
+ #' tbl <- build_table(lyt, iris2)+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' @rdname int_methods+ |
+
| 177 | ++ |
+ setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
+ |
+
| 178 | +! | +
+ standardGeneric("summarize_rows_inner")
+ |
+
| 179 | ++ |
+ })+ |
+
| 180 | ++ | + + | +
| 181 | ++ |
+ #' @rdname int_methods+ |
+
| 182 | ++ |
+ setMethod(+ |
+
| 183 | ++ |
+ "summarize_rows_inner", "TableTree",+ |
+
| 184 | ++ |
+ function(obj, depth = 0, indent = 0) {
+ |
+
| 185 | +! | +
+ indent <- max(0L, indent + indent_mod(obj))+ |
+
| 186 | ++ | + + | +
| 187 | +! | +
+ lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)+ |
+
| 188 | +! | +
+ if (!is.null(lr)) {
+ |
+
| 189 | +! | +
+ ret <- list(lr)+ |
+
| 190 | ++ |
+ } else {
+ |
+
| 191 | +! | +
+ ret <- list()+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | +! | +
+ indent <- indent + (!is.null(lr))+ |
+
| 195 | ++ | + + | +
| 196 | +! | +
+ ctab <- content_table(obj)+ |
+
| 197 | +! | +
+ if (NROW(ctab)) {
+ |
+
| 198 | +! | +
+ ct <- summarize_rows_inner(ctab,+ |
+
| 199 | +! | +
+ depth = depth,+ |
+
| 200 | +! | +
+ indent = indent + indent_mod(ctab)+ |
+
| 201 | ++ |
+ )+ |
+
| 202 | +! | +
+ ret <- c(ret, ct)+ |
+
| 203 | +! | +
+ indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))+ |
+
| 204 | ++ |
+ }+ |
+
| 205 | ++ | + + | +
| 206 | +! | +
+ kids <- tree_children(obj)+ |
+
| 207 | +! | +
+ els <- lapply(tree_children(obj), summarize_rows_inner,+ |
+
| 208 | +! | +
+ depth = depth + 1, indent = indent+ |
+
| 209 | ++ |
+ )+ |
+
| 210 | +! | +
+ if (!are(kids, "TableRow")) {
+ |
+
| 211 | +! | +
+ if (!are(kids, "VTableTree")) {
+ |
+
| 212 | ++ |
+ ## hatchet job of a hack, wrap em just so we can unlist em all at+ |
+
| 213 | ++ |
+ ## the same level+ |
+
| 214 | +! | +
+ rowinds <- vapply(kids, is, NA, class2 = "TableRow")+ |
+
| 215 | +! | +
+ els[rowinds] <- lapply(els[rowinds], function(x) list(x))+ |
+
| 216 | ++ |
+ }+ |
+
| 217 | +! | +
+ els <- unlist(els, recursive = FALSE)+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | +! | +
+ ret <- c(ret, els)+ |
+
| 220 | +! | +
+ ret+ |
+
| 221 | ++ |
+ ## df <- do.call(rbind, c(list(lr), list(ct), els))+ |
+
| 222 | ++ | + + | +
| 223 | ++ |
+ ## row.names(df) <- NULL+ |
+
| 224 | ++ |
+ ## df+ |
+
| 225 | ++ |
+ }+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ | + + | +
| 228 | ++ |
+ # Print Table Structure ----+ |
+
| 229 | ++ | + + | +
| 230 | ++ |
+ #' Summarize table+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @param x (`VTableTree`)\cr a table object.+ |
+
| 233 | ++ |
+ #' @param detail (`string`)\cr either `row` or `subtable`.+ |
+
| 234 | ++ |
+ #'+ |
+
| 235 | ++ |
+ #' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' @examplesIf require(dplyr)+ |
+
| 238 | ++ |
+ #' library(dplyr)+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' iris2 <- iris %>%+ |
+
| 241 | ++ |
+ #' group_by(Species) %>%+ |
+
| 242 | ++ |
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ |
+
| 243 | ++ |
+ #' ungroup()+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 246 | ++ |
+ #' split_cols_by("Species") %>%
+ |
+
| 247 | ++ |
+ #' split_cols_by("group") %>%
+ |
+
| 248 | ++ |
+ #' analyze(c("Sepal.Length", "Petal.Width"),
+ |
+
| 249 | ++ |
+ #' afun = list_wrap_x(summary),+ |
+
| 250 | ++ |
+ #' format = "xx.xx"+ |
+
| 251 | ++ |
+ #' )+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' tbl <- build_table(lyt, iris2)+ |
+
| 254 | ++ |
+ #' tbl+ |
+
| 255 | ++ |
+ #'+ |
+
| 256 | ++ |
+ #' row_paths(tbl)+ |
+
| 257 | ++ |
+ #'+ |
+
| 258 | ++ |
+ #' table_structure(tbl)+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' table_structure(tbl, detail = "row")+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' @export+ |
+
| 263 | ++ |
+ table_structure <- function(x, detail = c("subtable", "row")) {
+ |
+
| 264 | +2x | +
+ detail <- match.arg(detail)+ |
+
| 265 | ++ | + + | +
| 266 | +2x | +
+ switch(detail,+ |
+
| 267 | +1x | +
+ subtable = treestruct(x),+ |
+
| 268 | +1x | +
+ row = table_structure_inner(x),+ |
+
| 269 | +! | +
+ stop("unsupported level of detail ", detail)
+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | ++ | + + | +
| 273 | ++ |
+ #' @param obj (`VTableTree`)\cr a table object.+ |
+
| 274 | ++ |
+ #' @param depth (`numeric(1)`)\cr depth in tree.+ |
+
| 275 | ++ |
+ #' @param indent (`numeric(1)`)\cr indent.+ |
+
| 276 | ++ |
+ #' @param print_indent (`numeric(1)`)\cr indent for printing.+ |
+
| 277 | ++ |
+ #'+ |
+
| 278 | ++ |
+ #' @rdname int_methods+ |
+
| 279 | ++ |
+ setGeneric(+ |
+
| 280 | ++ |
+ "table_structure_inner",+ |
+
| 281 | ++ |
+ function(obj,+ |
+
| 282 | ++ |
+ depth = 0,+ |
+
| 283 | ++ |
+ indent = 0,+ |
+
| 284 | ++ |
+ print_indent = 0) {
+ |
+
| 285 | +70x | +
+ standardGeneric("table_structure_inner")
+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ |
+ )+ |
+
| 288 | ++ | + + | +
| 289 | ++ |
+ scat <- function(..., indent = 0, newline = TRUE) {
+ |
+
| 290 | +101x | +
+ txt <- paste(..., collapse = "", sep = "")+ |
+
| 291 | ++ | + + | +
| 292 | +101x | +
+ cat(indent_string(txt, indent))+ |
+
| 293 | ++ | + + | +
| 294 | +101x | +
+ if (newline) cat("\n")
+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ ## helper functions+ |
+
| 298 | ++ |
+ obj_visible <- function(x) {
+ |
+
| 299 | +50x | +
+ x@visible+ |
+
| 300 | ++ |
+ }+ |
+
| 301 | ++ | + + | +
| 302 | ++ |
+ is_empty_labelrow <- function(x) {
+ |
+
| 303 | +4x | +
+ obj_label(x) == "" && !labelrow_visible(x)+ |
+
| 304 | ++ |
+ }+ |
+
| 305 | ++ | + + | +
| 306 | ++ |
+ is_empty_ElementaryTable <- function(x) {
+ |
+
| 307 | +10x | +
+ length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ #' @param object (`VTableTree`)\cr a table object.+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' @rdname int_methods+ |
+
| 313 | ++ |
+ #' @export+ |
+
| 314 | ++ |
+ setGeneric("str", function(object, ...) {
+ |
+
| 315 | +! | +
+ standardGeneric("str")
+ |
+
| 316 | ++ |
+ })+ |
+
| 317 | ++ | + + | +
| 318 | ++ |
+ #' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike+ |
+
| 319 | ++ |
+ #' the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects.+ |
+
| 320 | ++ |
+ #'+ |
+
| 321 | ++ |
+ #' @rdname int_methods+ |
+
| 322 | ++ |
+ #' @export+ |
+
| 323 | ++ |
+ setMethod(+ |
+
| 324 | ++ |
+ "str", "VTableTree",+ |
+
| 325 | ++ |
+ function(object, max.level = 3L, ...) {
+ |
+
| 326 | +! | +
+ utils::str(object, max.level = max.level, ...)+ |
+
| 327 | +! | +
+ warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
+ |
+
| 328 | +! | +
+ "See table_structure(.) for a summary of table struture intended for end users.",+ |
+
| 329 | +! | +
+ call. = FALSE+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | +! | +
+ invisible(NULL)+ |
+
| 332 | ++ |
+ }+ |
+
| 333 | ++ |
+ )+ |
+
| 334 | ++ | + + | +
| 335 | ++ |
+ #' @inheritParams table_structure_inner+ |
+
| 336 | ++ |
+ #' @rdname int_methods+ |
+
| 337 | ++ |
+ setMethod(+ |
+
| 338 | ++ |
+ "table_structure_inner", "TableTree",+ |
+
| 339 | ++ |
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
+ |
+
| 340 | +10x | +
+ indent <- indent + indent_mod(obj)+ |
+
| 341 | ++ | + + | +
| 342 | +10x | +
+ scat("TableTree: ", "[", obj_name(obj), "] (",
+ |
+
| 343 | +10x | +
+ obj_label(obj), ")",+ |
+
| 344 | +10x | +
+ indent = print_indent+ |
+
| 345 | ++ |
+ )+ |
+
| 346 | ++ | + + | +
| 347 | +10x | +
+ table_structure_inner(+ |
+
| 348 | +10x | +
+ tt_labelrow(obj), depth, indent,+ |
+
| 349 | +10x | +
+ print_indent + 1+ |
+
| 350 | ++ |
+ )+ |
+
| 351 | ++ | + + | +
| 352 | +10x | +
+ ctab <- content_table(obj)+ |
+
| 353 | +10x | +
+ visible_content <- if (is_empty_ElementaryTable(ctab)) {
+ |
+
| 354 | ++ |
+ # scat("content: -", indent = print_indent + 1)
+ |
+
| 355 | +4x | +
+ FALSE+ |
+
| 356 | ++ |
+ } else {
+ |
+
| 357 | +6x | +
+ scat("content:", indent = print_indent + 1)
+ |
+
| 358 | +6x | +
+ table_structure_inner(ctab,+ |
+
| 359 | +6x | +
+ depth = depth,+ |
+
| 360 | +6x | +
+ indent = indent + indent_mod(ctab),+ |
+
| 361 | +6x | +
+ print_indent = print_indent + 2+ |
+
| 362 | ++ |
+ )+ |
+
| 363 | ++ |
+ }+ |
+
| 364 | ++ | + + | +
| 365 | +10x | +
+ if (length(tree_children(obj)) == 0) {
+ |
+
| 366 | +! | +
+ scat("children: - ", indent = print_indent + 1)
+ |
+
| 367 | ++ |
+ } else {
+ |
+
| 368 | +10x | +
+ scat("children: ", indent = print_indent + 1)
+ |
+
| 369 | +10x | +
+ lapply(tree_children(obj), table_structure_inner,+ |
+
| 370 | +10x | +
+ depth = depth + 1,+ |
+
| 371 | +10x | +
+ indent = indent + visible_content * (1 + indent_mod(ctab)),+ |
+
| 372 | +10x | +
+ print_indent = print_indent + 2+ |
+
| 373 | ++ |
+ )+ |
+
| 374 | ++ |
+ }+ |
+
| 375 | ++ | + + | +
| 376 | +10x | +
+ invisible(NULL)+ |
+
| 377 | ++ |
+ }+ |
+
| 378 | ++ |
+ )+ |
+
| 379 | ++ | + + | +
| 380 | ++ |
+ #' @rdname int_methods+ |
+
| 381 | ++ |
+ setMethod(+ |
+
| 382 | ++ |
+ "table_structure_inner", "ElementaryTable",+ |
+
| 383 | ++ |
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
+ |
+
| 384 | +15x | +
+ scat("ElementaryTable: ", "[", obj_name(obj),
+ |
+
| 385 | +15x | +
+ "] (", obj_label(obj), ")",
+ |
+
| 386 | +15x | +
+ indent = print_indent+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | ++ | + + | +
| 389 | +15x | +
+ indent <- indent + indent_mod(obj)+ |
+
| 390 | ++ | + + | +
| 391 | +15x | +
+ table_structure_inner(+ |
+
| 392 | +15x | +
+ tt_labelrow(obj), depth,+ |
+
| 393 | +15x | +
+ indent, print_indent + 1+ |
+
| 394 | ++ |
+ )+ |
+
| 395 | ++ | + + | +
| 396 | +15x | +
+ if (length(tree_children(obj)) == 0) {
+ |
+
| 397 | +! | +
+ scat("children: - ", indent = print_indent + 1)
+ |
+
| 398 | ++ |
+ } else {
+ |
+
| 399 | +15x | +
+ scat("children: ", indent = print_indent + 1)
+ |
+
| 400 | +15x | +
+ lapply(tree_children(obj), table_structure_inner,+ |
+
| 401 | +15x | +
+ depth = depth + 1, indent = indent,+ |
+
| 402 | +15x | +
+ print_indent = print_indent + 2+ |
+
| 403 | ++ |
+ )+ |
+
| 404 | ++ |
+ }+ |
+
| 405 | ++ | + + | +
| 406 | +15x | +
+ invisible(NULL)+ |
+
| 407 | ++ |
+ }+ |
+
| 408 | ++ |
+ )+ |
+
| 409 | ++ | + + | +
| 410 | ++ |
+ #' @rdname int_methods+ |
+
| 411 | ++ |
+ setMethod(+ |
+
| 412 | ++ |
+ "table_structure_inner", "TableRow",+ |
+
| 413 | ++ |
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
+ |
+
| 414 | +20x | +
+ scat(class(obj), ": ", "[", obj_name(obj), "] (",
+ |
+
| 415 | +20x | +
+ obj_label(obj), ")",+ |
+
| 416 | +20x | +
+ indent = print_indent+ |
+
| 417 | ++ |
+ )+ |
+
| 418 | ++ | + + | +
| 419 | +20x | +
+ indent <- indent + indent_mod(obj)+ |
+
| 420 | ++ | + + | +
| 421 | +20x | +
+ invisible(NULL)+ |
+
| 422 | ++ |
+ }+ |
+
| 423 | ++ |
+ )+ |
+
| 424 | ++ | + + | +
| 425 | ++ |
+ #' @rdname int_methods+ |
+
| 426 | ++ |
+ setMethod(+ |
+
| 427 | ++ |
+ "table_structure_inner", "LabelRow",+ |
+
| 428 | ++ |
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
+ |
+
| 429 | +25x | +
+ indent <- indent + indent_mod(obj)+ |
+
| 430 | ++ | + + | +
| 431 | +25x | +
+ txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""+ |
+
| 432 | ++ | + + | +
| 433 | +25x | +
+ scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
+ |
+
| 434 | +25x | +
+ txtvis,+ |
+
| 435 | +25x | +
+ indent = print_indent+ |
+
| 436 | ++ |
+ )+ |
+
| 437 | ++ | + + | +
| 438 | +25x | +
+ obj_visible(obj)+ |
+
| 439 | ++ |
+ }+ |
+
| 440 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Create an `ElementaryTable` from a `data.frame`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @param df (`data.frame`)\cr a data frame.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @details+ |
+
| 6 | ++ |
+ #' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column+ |
+
| 7 | ++ |
+ #' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior+ |
+
| 8 | ++ |
+ #' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @seealso [as_result_df()] for the inverse operation.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @examples+ |
+
| 13 | ++ |
+ #' df_to_tt(mtcars)+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ df_to_tt <- function(df) {
+ |
+
| 17 | +4x | +
+ colnms <- colnames(df)+ |
+
| 18 | +4x | +
+ cinfo <- manual_cols(colnms)+ |
+
| 19 | +4x | +
+ rnames <- rownames(df)+ |
+
| 20 | +4x | +
+ havern <- !is.null(rnames)+ |
+
| 21 | ++ | + + | +
| 22 | +4x | +
+ if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
+ |
+
| 23 | +1x | +
+ rnames <- df$label_name+ |
+
| 24 | +1x | +
+ df <- df[, -match("label_name", colnms)]
+ |
+
| 25 | +1x | +
+ colnms <- colnames(df)+ |
+
| 26 | +1x | +
+ cinfo <- manual_cols(colnms)+ |
+
| 27 | +1x | +
+ havern <- TRUE+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ | + + | +
| 30 | +4x | +
+ kids <- lapply(seq_len(nrow(df)), function(i) {
+ |
+
| 31 | +124x | +
+ rni <- if (havern) rnames[i] else ""+ |
+
| 32 | +124x | +
+ do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))+ |
+
| 33 | ++ |
+ })+ |
+
| 34 | ++ | + + | +
| 35 | +4x | +
+ ElementaryTable(kids = kids, cinfo = cinfo)+ |
+
| 36 | ++ |
+ }+ |
+
| 1 | ++ |
+ # Generics and how they are used directly -------------------------------------+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ ## check_validsplit - Check if the split is valid for the data, error if not+ |
+
| 4 | ++ | + + | +
| 5 | ++ |
+ ## .apply_spl_extras - Generate Extras+ |
+
| 6 | ++ | + + | +
| 7 | ++ |
+ ## .apply_spl_datapart - generate data partition+ |
+
| 8 | ++ | + + | +
| 9 | ++ |
+ ## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values+ |
+
| 10 | ++ | + + | +
| 11 | ++ |
+ setGeneric(+ |
+
| 12 | ++ |
+ ".applysplit_rawvals",+ |
+
| 13 | +981x | +
+ function(spl, df) standardGeneric(".applysplit_rawvals")
+ |
+
| 14 | ++ |
+ )+ |
+
| 15 | ++ | + + | +
| 16 | ++ |
+ setGeneric(+ |
+
| 17 | ++ |
+ ".applysplit_datapart",+ |
+
| 18 | +1054x | +
+ function(spl, df, vals) standardGeneric(".applysplit_datapart")
+ |
+
| 19 | ++ |
+ )+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ setGeneric(+ |
+
| 22 | ++ |
+ ".applysplit_extras",+ |
+
| 23 | +1054x | +
+ function(spl, df, vals) standardGeneric(".applysplit_extras")
+ |
+
| 24 | ++ |
+ )+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ setGeneric(+ |
+
| 27 | ++ |
+ ".applysplit_partlabels",+ |
+
| 28 | +1051x | +
+ function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
+ |
+
| 29 | ++ |
+ )+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ setGeneric(+ |
+
| 32 | ++ |
+ "check_validsplit",+ |
+
| 33 | +2184x | +
+ function(spl, df) standardGeneric("check_validsplit")
+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ setGeneric(+ |
+
| 37 | ++ |
+ ".applysplit_ref_vals",+ |
+
| 38 | +17x | +
+ function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
+ |
+
| 39 | ++ |
+ )+ |
+
| 40 | ++ |
+ # Custom split fncs ------------------------------------------------------------+ |
+
| 41 | ++ |
+ #' Custom split functions+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set+ |
+
| 44 | ++ |
+ #' of incoming data and a split object, and return "splits" of that data.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @section Custom Splitting Function Details:+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' User-defined custom split functions can perform any type of computation on the incoming data provided that they+ |
+
| 49 | ++ |
+ #' meet the requirements for generating "splits" of the incoming data based on the split object.+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' Split functions are functions that accept:+ |
+
| 52 | ++ |
+ #' \describe{
+ |
+
| 53 | ++ |
+ #' \item{df}{a `data.frame` of incoming data to be split.}
+ |
+
| 54 | ++ |
+ #' \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
+ |
+
| 55 | ++ |
+ #' but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting+ |
+
| 56 | ++ |
+ #' table.}+ |
+
| 57 | ++ |
+ #' \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
+ |
+
| 58 | ++ |
+ #' Should be `NULL` in most cases and can usually be ignored.}+ |
+
| 59 | ++ |
+ #' \item{labels}{any pre-calculated value labels. Same as above for `values`.}
+ |
+
| 60 | ++ |
+ #' \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
+ |
+
| 61 | ++ |
+ #' \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
+ |
+
| 62 | ++ |
+ #' arrived at `df`.}+ |
+
| 63 | ++ |
+ #' }+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' The function must then output a named `list` with the following elements:+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' \describe{
+ |
+
| 68 | ++ |
+ #' \item{values}{the vector of all values corresponding to the splits of `df`.}
+ |
+
| 69 | ++ |
+ #' \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
+ |
+
| 70 | ++ |
+ #' \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
+ |
+
| 71 | ++ |
+ #' \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
+ |
+
| 72 | ++ |
+ #' whenever they are executed on the corresponding element of `datasplit` or a subset thereof.}+ |
+
| 73 | ++ |
+ #' }+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ #' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming+ |
+
| 76 | ++ |
+ #' data before they are called or their outputs.+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of+ |
+
| 79 | ++ |
+ #' pre-defined split functions.+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @examples+ |
+
| 82 | ++ |
+ #' # Example of a picky split function. The number of values in the column variable+ |
+
| 83 | ++ |
+ #' # var decrees if we are going to print also the column with all observation+ |
+
| 84 | ++ |
+ #' # or not.+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' picky_splitter <- function(var) {
+ |
+
| 87 | ++ |
+ #' # Main layout function+ |
+
| 88 | ++ |
+ #' function(df, spl, vals, labels, trim) {
+ |
+
| 89 | ++ |
+ #' orig_vals <- vals+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' # Check for number of levels if all are selected+ |
+
| 92 | ++ |
+ #' if (is.null(vals)) {
+ |
+
| 93 | ++ |
+ #' vec <- df[[var]]+ |
+
| 94 | ++ |
+ #' vals <- unique(vec)+ |
+
| 95 | ++ |
+ #' }+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' # Do a split with or without All obs+ |
+
| 98 | ++ |
+ #' if (length(vals) == 1) {
+ |
+
| 99 | ++ |
+ #' do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim)+ |
+
| 100 | ++ |
+ #' } else {
+ |
+
| 101 | ++ |
+ #' fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
+ |
+
| 102 | ++ |
+ #' fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim)+ |
+
| 103 | ++ |
+ #' }+ |
+
| 104 | ++ |
+ #' }+ |
+
| 105 | ++ |
+ #' }+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' # Data sub-set+ |
+
| 108 | ++ |
+ #' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F"))+ |
+
| 109 | ++ |
+ #' d1 <- subset(d1, SEX %in% c("M", "F"))
+ |
+
| 110 | ++ |
+ #' d1$SEX <- factor(d1$SEX)+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' # This table uses the number of values in the SEX column to add the overall col or not+ |
+
| 113 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 114 | ++ |
+ #' split_cols_by("ARM", split_fun = drop_split_levels) %>%
+ |
+
| 115 | ++ |
+ #' split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
+ |
+
| 116 | ++ |
+ #' analyze("AGE", show_labels = "visible")
+ |
+
| 117 | ++ |
+ #' tbl <- build_table(lyt, d1)+ |
+
| 118 | ++ |
+ #' tbl+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @name custom_split_funs+ |
+
| 121 | ++ |
+ NULL+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ ## do various cleaning, and naming, plus+ |
+
| 124 | ++ |
+ ## ensure partinfo$values contains SplitValue objects only+ |
+
| 125 | ++ |
+ .fixupvals <- function(partinfo) {
+ |
+
| 126 | +1081x | +
+ if (is.factor(partinfo$labels)) {
+ |
+
| 127 | +! | +
+ partinfo$labels <- as.character(partinfo$labels)+ |
+
| 128 | ++ |
+ }+ |
+
| 129 | ++ | + + | +
| 130 | +1081x | +
+ vals <- partinfo$values+ |
+
| 131 | +1081x | +
+ if (is.factor(vals)) {
+ |
+
| 132 | +! | +
+ vals <- levels(vals)[vals]+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | +1081x | +
+ extr <- partinfo$extras+ |
+
| 135 | +1081x | +
+ dpart <- partinfo$datasplit+ |
+
| 136 | +1081x | +
+ labels <- partinfo$labels+ |
+
| 137 | +1081x | +
+ if (is.null(labels)) {
+ |
+
| 138 | +! | +
+ if (!is.null(names(vals))) {
+ |
+
| 139 | +! | +
+ labels <- names(vals)+ |
+
| 140 | +! | +
+ } else if (!is.null(names(dpart))) {
+ |
+
| 141 | +! | +
+ labels <- names(dpart)+ |
+
| 142 | +! | +
+ } else if (!is.null(names(extr))) {
+ |
+
| 143 | +! | +
+ labels <- names(extr)+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | ++ | + + | +
| 147 | +1081x | +
+ subsets <- partinfo$subset_exprs+ |
+
| 148 | +1081x | +
+ if (is.null(subsets)) {
+ |
+
| 149 | +1065x | +
+ subsets <- vector(mode = "list", length = length(vals))+ |
+
| 150 | ++ |
+ ## use labels here cause we already did all that work+ |
+
| 151 | ++ |
+ ## to get the names on the labels vector right+ |
+
| 152 | +1065x | +
+ names(subsets) <- names(labels)+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | ++ | + + | +
| 155 | +1081x | +
+ if (is.null(vals) && !is.null(extr)) {
+ |
+
| 156 | +! | +
+ vals <- seq_along(extr)+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | +1081x | +
+ if (length(vals) == 0) {
+ |
+
| 160 | +13x | +
+ stopifnot(length(extr) == 0)+ |
+
| 161 | +13x | +
+ return(partinfo)+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | ++ |
+ ## length(vals) > 0 from here down+ |
+
| 164 | ++ | + + | +
| 165 | +1068x | +
+ if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
+ |
+
| 166 | +22x | +
+ if (!is.null(extr)) {
+ |
+
| 167 | ++ |
+ ## in_ref_cols is in here for some reason even though its already in the SplitValue object.+ |
+
| 168 | ++ |
+ ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598+ |
+
| 169 | ++ |
+ ## the if is a bandaid.+ |
+
| 170 | ++ |
+ ## XXX FIXME RIGHT+ |
+
| 171 | +3x | +
+ sq <- seq_along(vals)+ |
+
| 172 | +3x | +
+ if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
+ |
+
| 173 | +! | +
+ warning(+ |
+
| 174 | +! | +
+ "Got a partinfo list with values that are ",+ |
+
| 175 | +! | +
+ "already SplitValue objects and non-null extras ",+ |
+
| 176 | +! | +
+ "element. This shouldn't happen"+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | ++ |
+ } else {
+ |
+
| 181 | +1046x | +
+ if (is.null(extr)) {
+ |
+
| 182 | +6x | +
+ extr <- rep(list(list()), length(vals))+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | +1046x | +
+ vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets)+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | ++ |
+ ## we're done with this so take it off+ |
+
| 187 | +1068x | +
+ partinfo$extras <- NULL+ |
+
| 188 | ++ | + + | +
| 189 | +1068x | +
+ vnames <- value_names(vals)+ |
+
| 190 | +1068x | +
+ names(vals) <- vnames+ |
+
| 191 | +1068x | +
+ partinfo$values <- vals+ |
+
| 192 | ++ | + + | +
| 193 | +1068x | +
+ if (!identical(names(dpart), vnames)) {
+ |
+
| 194 | +1068x | +
+ names(dpart) <- vnames+ |
+
| 195 | +1068x | +
+ partinfo$datasplit <- dpart+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ | + + | +
| 198 | +1068x | +
+ partinfo$labels <- labels+ |
+
| 199 | ++ | + + | +
| 200 | +1068x | +
+ stopifnot(length(unique(sapply(partinfo, NROW))) == 1)+ |
+
| 201 | +1068x | +
+ partinfo+ |
+
| 202 | ++ |
+ }+ |
+
| 203 | ++ | + + | +
| 204 | ++ |
+ .add_ref_extras <- function(spl, df, partinfo) {
+ |
+
| 205 | ++ |
+ ## this is only the .in_ref_col booleans+ |
+
| 206 | +17x | +
+ refvals <- .applysplit_ref_vals(spl, df, partinfo$values)+ |
+
| 207 | +17x | +
+ ref_ind <- which(unlist(refvals))+ |
+
| 208 | +17x | +
+ stopifnot(length(ref_ind) == 1)+ |
+
| 209 | ++ | + + | +
| 210 | +17x | +
+ vnames <- value_names(partinfo$values)+ |
+
| 211 | +17x | +
+ if (is.null(partinfo$extras)) {
+ |
+
| 212 | +3x | +
+ names(refvals) <- vnames+ |
+
| 213 | +3x | +
+ partinfo$extras <- refvals+ |
+
| 214 | ++ |
+ } else {
+ |
+
| 215 | +14x | +
+ 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+ |
+
| 220 | ++ |
+ ))+ |
+
| 221 | ++ |
+ },+ |
+
| 222 | +14x | +
+ old = partinfo$extras,+ |
+
| 223 | +14x | +
+ incol = unlist(refvals),+ |
+
| 224 | +14x | +
+ MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]),+ |
+
| 225 | +14x | +
+ SIMPLIFY = FALSE+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | +14x | +
+ names(newextras) <- vnames+ |
+
| 228 | +14x | +
+ partinfo$extras <- newextras+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | +17x | +
+ partinfo+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | ++ | + + | +
| 233 | ++ |
+ #' Apply basic split (for use in custom split functions)+ |
+
| 234 | ++ |
+ #'+ |
+
| 235 | ++ |
+ #' This function is intended for use inside custom split functions. It applies the current split *as if it had no+ |
+
| 236 | ++ |
+ #' custom splitting function* so that those default splits can be further manipulated.+ |
+
| 237 | ++ |
+ #'+ |
+
| 238 | ++ |
+ #' @inheritParams gen_args+ |
+
| 239 | ++ |
+ #' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`.+ |
+
| 240 | ++ |
+ #' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should+ |
+
| 241 | ++ |
+ #' almost always be the case.+ |
+
| 242 | ++ |
+ #' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to+ |
+
| 243 | ++ |
+ #' `FALSE`.+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs].+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @examples+ |
+
| 248 | ++ |
+ #' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ |
+
| 249 | ++ |
+ #' ret <- do_base_split(spl, df, vals, labels, trim)+ |
+
| 250 | ++ |
+ #' if (NROW(df) == 0) {
+ |
+
| 251 | ++ |
+ #' ret <- lapply(ret, function(x) x[1])+ |
+
| 252 | ++ |
+ #' }+ |
+
| 253 | ++ |
+ #' ret+ |
+
| 254 | ++ |
+ #' }+ |
+
| 255 | ++ |
+ #'+ |
+
| 256 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 257 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 258 | ++ |
+ #' split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
+ |
+
| 259 | ++ |
+ #' varlabels = c("N", "E", "BMR1"),
+ |
+
| 260 | ++ |
+ #' split_fun = uneven_splfun+ |
+
| 261 | ++ |
+ #' ) %>%+ |
+
| 262 | ++ |
+ #' analyze_colvars(list(+ |
+
| 263 | ++ |
+ #' USUBJID = function(x, ...) length(unique(x)),+ |
+
| 264 | ++ |
+ #' AESEQ = max,+ |
+
| 265 | ++ |
+ #' BMRKR1 = mean+ |
+
| 266 | ++ |
+ #' ))+ |
+
| 267 | ++ |
+ #'+ |
+
| 268 | ++ |
+ #' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2))+ |
+
| 269 | ++ |
+ #' tbl+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @export+ |
+
| 272 | ++ |
+ do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
+ |
+
| 273 | +13x | +
+ spl2 <- spl+ |
+
| 274 | +13x | +
+ split_fun(spl2) <- NULL+ |
+
| 275 | +13x | +
+ do_split(spl2,+ |
+
| 276 | +13x | +
+ df = df, vals = vals, labels = labels, trim = trim,+ |
+
| 277 | +13x | +
+ spl_context = NULL+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ }+ |
+
| 280 | ++ | + + | +
| 281 | ++ |
+ ### NB This is called at EACH level of recursive splitting+ |
+
| 282 | ++ |
+ do_split <- function(spl,+ |
+
| 283 | ++ |
+ df,+ |
+
| 284 | ++ |
+ vals = NULL,+ |
+
| 285 | ++ |
+ labels = NULL,+ |
+
| 286 | ++ |
+ trim = FALSE,+ |
+
| 287 | ++ |
+ spl_context) {
+ |
+
| 288 | ++ |
+ ## this will error if, e.g., df doesn't have columns+ |
+
| 289 | ++ |
+ ## required by spl, or generally any time the spl+ |
+
| 290 | ++ |
+ ## can't be applied to df+ |
+
| 291 | +1081x | +
+ check_validsplit(spl, df)+ |
+
| 292 | ++ |
+ ## note the <- here!!!+ |
+
| 293 | +1080x | +
+ if (!is.null(splfun <- split_fun(spl))) {
+ |
+
| 294 | ++ |
+ ## Currently the contract is that split_functions take df, vals, labels and+ |
+
| 295 | ++ |
+ ## return list(values=., datasplit=., labels = .), optionally with+ |
+
| 296 | ++ |
+ ## an additional extras element+ |
+
| 297 | +353x | +
+ if (func_takes(splfun, ".spl_context")) {
+ |
+
| 298 | +23x | +
+ ret <- tryCatch(+ |
+
| 299 | +23x | +
+ splfun(df, spl, vals, labels,+ |
+
| 300 | +23x | +
+ trim = trim,+ |
+
| 301 | +23x | +
+ .spl_context = spl_context+ |
+
| 302 | ++ |
+ ),+ |
+
| 303 | +23x | +
+ error = function(e) e+ |
+
| 304 | +23x | +
+ ) ## rawvalues(spl_context ))+ |
+
| 305 | ++ |
+ } else {
+ |
+
| 306 | +330x | +
+ ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim),+ |
+
| 307 | +330x | +
+ error = function(e) e+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | +353x | +
+ if (is(ret, "error")) {
+ |
+
| 311 | +12x | +
+ stop(+ |
+
| 312 | +12x | +
+ "Error applying custom split function: ", ret$message, "\n\tsplit: ",+ |
+
| 313 | +12x | +
+ class(spl), " (", payloadmsg(spl), ")\n",
+ |
+
| 314 | +12x | +
+ "\toccured at path: ",+ |
+
| 315 | +12x | +
+ spl_context_to_disp_path(spl_context), "\n"+ |
+
| 316 | ++ |
+ )+ |
+
| 317 | ++ |
+ }+ |
+
| 318 | ++ |
+ } else {
+ |
+
| 319 | +727x | +
+ ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim)+ |
+
| 320 | ++ |
+ }+ |
+
| 321 | ++ | + + | +
| 322 | ++ |
+ ## this adds .ref_full and .in_ref_col+ |
+
| 323 | +1068x | +
+ if (is(spl, "VarLevWBaselineSplit")) {
+ |
+
| 324 | +17x | +
+ ret <- .add_ref_extras(spl, df, ret)+ |
+
| 325 | ++ |
+ }+ |
+
| 326 | ++ | + + | +
| 327 | ++ |
+ ## this:+ |
+
| 328 | ++ |
+ ## - guarantees that ret$values contains SplitValue objects+ |
+
| 329 | ++ |
+ ## - removes the extras element since its redundant after the above+ |
+
| 330 | ++ |
+ ## - Ensures datasplit and values lists are named according to labels+ |
+
| 331 | ++ |
+ ## - ensures labels are character not factor+ |
+
| 332 | +1068x | +
+ ret <- .fixupvals(ret)+ |
+
| 333 | ++ |
+ ## we didn't put this in .fixupvals because that get called withint he split functions+ |
+
| 334 | ++ |
+ ## created by make_split_fun and its not clear this check should be happening then.+ |
+
| 335 | +1068x | +
+ if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
+ |
+
| 336 | +3x | +
+ stop(+ |
+
| 337 | +3x | +
+ "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ",+ |
+
| 338 | +3x | +
+ class(spl), " (", payloadmsg(spl), ")\n",
+ |
+
| 339 | +3x | +
+ "\toccured at path: ",+ |
+
| 340 | +3x | +
+ spl_context_to_disp_path(spl_context), "\n"+ |
+
| 341 | ++ |
+ )+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | +1065x | +
+ ret+ |
+
| 344 | ++ |
+ }+ |
+
| 345 | ++ | + + | +
| 346 | ++ |
+ .apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
+ |
+
| 347 | +1054x | +
+ if (is.null(vals)) {
+ |
+
| 348 | +981x | +
+ vals <- .applysplit_rawvals(spl, df)+ |
+
| 349 | ++ |
+ }+ |
+
| 350 | +1054x | +
+ extr <- .applysplit_extras(spl, df, vals)+ |
+
| 351 | ++ | + + | +
| 352 | +1054x | +
+ if (is.null(vals)) {
+ |
+
| 353 | +! | +
+ return(list(+ |
+
| 354 | +! | +
+ values = list(),+ |
+
| 355 | +! | +
+ datasplit = list(),+ |
+
| 356 | +! | +
+ labels = list(),+ |
+
| 357 | +! | +
+ extras = list()+ |
+
| 358 | ++ |
+ ))+ |
+
| 359 | ++ |
+ }+ |
+
| 360 | ++ | + + | +
| 361 | +1054x | +
+ dpart <- .applysplit_datapart(spl, df, vals)+ |
+
| 362 | ++ | + + | +
| 363 | +1054x | +
+ if (is.null(labels)) {
+ |
+
| 364 | +1051x | +
+ labels <- .applysplit_partlabels(spl, df, vals, labels)+ |
+
| 365 | ++ |
+ } else {
+ |
+
| 366 | +3x | +
+ stopifnot(names(labels) == names(vals))+ |
+
| 367 | ++ |
+ }+ |
+
| 368 | ++ |
+ ## get rid of columns that would not have any+ |
+
| 369 | ++ |
+ ## observations.+ |
+
| 370 | ++ |
+ ##+ |
+
| 371 | ++ |
+ ## But only if there were any rows to start with+ |
+
| 372 | ++ |
+ ## if not we're in a manually constructed table+ |
+
| 373 | ++ |
+ ## column tree+ |
+
| 374 | +1054x | +
+ if (trim) {
+ |
+
| 375 | +! | +
+ hasdata <- sapply(dpart, function(x) nrow(x) > 0)+ |
+
| 376 | +! | +
+ if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
+ |
+
| 377 | +! | +
+ dpart <- dpart[hasdata]+ |
+
| 378 | +! | +
+ vals <- vals[hasdata]+ |
+
| 379 | +! | +
+ extr <- extr[hasdata]+ |
+
| 380 | +! | +
+ labels <- labels[hasdata]+ |
+
| 381 | ++ |
+ }+ |
+
| 382 | ++ |
+ }+ |
+
| 383 | ++ | + + | +
| 384 | +1054x | +
+ if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
+ |
+
| 385 | +162x | +
+ vord <- seq_along(vals)+ |
+
| 386 | ++ |
+ } else {
+ |
+
| 387 | +892x | +
+ vord <- match(+ |
+
| 388 | +892x | +
+ spl_child_order(spl),+ |
+
| 389 | +892x | +
+ vals+ |
+
| 390 | ++ |
+ )+ |
+
| 391 | +892x | +
+ vord <- vord[!is.na(vord)]+ |
+
| 392 | ++ |
+ }+ |
+
| 393 | ++ | + + | +
| 394 | ++ |
+ ## FIXME: should be an S4 object, not a list+ |
+
| 395 | +1054x | +
+ ret <- list(+ |
+
| 396 | +1054x | +
+ values = vals[vord],+ |
+
| 397 | +1054x | +
+ datasplit = dpart[vord],+ |
+
| 398 | +1054x | +
+ labels = labels[vord],+ |
+
| 399 | +1054x | +
+ extras = extr[vord]+ |
+
| 400 | ++ |
+ )+ |
+
| 401 | +1054x | +
+ ret+ |
+
| 402 | ++ |
+ }+ |
+
| 403 | ++ | + + | +
| 404 | ++ |
+ .checkvarsok <- function(spl, df) {
+ |
+
| 405 | +1948x | +
+ vars <- spl_payload(spl)+ |
+
| 406 | ++ |
+ ## could be multiple vars in the future?+ |
+
| 407 | ++ |
+ ## no reason not to make that work here now.+ |
+
| 408 | +1948x | +
+ if (!all(vars %in% names(df))) {
+ |
+
| 409 | +2x | +
+ stop(+ |
+
| 410 | +2x | +
+ " variable(s) [",+ |
+
| 411 | +2x | +
+ paste(setdiff(vars, names(df)),+ |
+
| 412 | +2x | +
+ collapse = ", "+ |
+
| 413 | ++ |
+ ),+ |
+
| 414 | +2x | +
+ "] not present in data. (",
+ |
+
| 415 | +2x | +
+ class(spl), ")"+ |
+
| 416 | ++ |
+ )+ |
+
| 417 | ++ |
+ }+ |
+
| 418 | +1946x | +
+ invisible(NULL)+ |
+
| 419 | ++ |
+ }+ |
+
| 420 | ++ | + + | +
| 421 | ++ |
+ ### Methods to verify a split appears to be valid, applicable+ |
+
| 422 | ++ |
+ ### to the ***current subset*** of the df.+ |
+
| 423 | ++ |
+ ###+ |
+
| 424 | ++ |
+ ### This is called at each level of recursive splitting so+ |
+
| 425 | ++ |
+ ### do NOT make it check, e.g., if the ref_group level of+ |
+
| 426 | ++ |
+ ### a factor is present in the data, because it may not be.+ |
+
| 427 | ++ | + + | +
| 428 | ++ |
+ setMethod(+ |
+
| 429 | ++ |
+ "check_validsplit", "VarLevelSplit",+ |
+
| 430 | ++ |
+ function(spl, df) {
+ |
+
| 431 | +843x | +
+ .checkvarsok(spl, df)+ |
+
| 432 | ++ |
+ }+ |
+
| 433 | ++ |
+ )+ |
+
| 434 | ++ | + + | +
| 435 | ++ |
+ setMethod(+ |
+
| 436 | ++ |
+ "check_validsplit", "MultiVarSplit",+ |
+
| 437 | ++ |
+ function(spl, df) {
+ |
+
| 438 | +56x | +
+ .checkvarsok(spl, df)+ |
+
| 439 | ++ |
+ }+ |
+
| 440 | ++ |
+ )+ |
+
| 441 | ++ | + + | +
| 442 | ++ |
+ setMethod(+ |
+
| 443 | ++ |
+ "check_validsplit", "VAnalyzeSplit",+ |
+
| 444 | ++ |
+ function(spl, df) {
+ |
+
| 445 | +1103x | +
+ if (!is.na(spl_payload(spl))) {
+ |
+
| 446 | +1049x | +
+ .checkvarsok(spl, df)+ |
+
| 447 | ++ |
+ } else {
+ |
+
| 448 | +54x | +
+ TRUE+ |
+
| 449 | ++ |
+ }+ |
+
| 450 | ++ |
+ }+ |
+
| 451 | ++ |
+ )+ |
+
| 452 | ++ | + + | +
| 453 | ++ |
+ setMethod(+ |
+
| 454 | ++ |
+ "check_validsplit", "CompoundSplit",+ |
+
| 455 | ++ |
+ function(spl, df) {
+ |
+
| 456 | +! | +
+ all(sapply(spl_payload(spl), df))+ |
+
| 457 | ++ |
+ }+ |
+
| 458 | ++ |
+ )+ |
+
| 459 | ++ | + + | +
| 460 | ++ |
+ ## default does nothing, add methods as they become+ |
+
| 461 | ++ |
+ ## required+ |
+
| 462 | ++ |
+ setMethod(+ |
+
| 463 | ++ |
+ "check_validsplit", "Split",+ |
+
| 464 | +131x | +
+ function(spl, df) invisible(NULL)+ |
+
| 465 | ++ |
+ )+ |
+
| 466 | ++ | + + | +
| 467 | ++ |
+ setMethod(+ |
+
| 468 | ++ |
+ ".applysplit_rawvals", "VarLevelSplit",+ |
+
| 469 | ++ |
+ function(spl, df) {
+ |
+
| 470 | +751x | +
+ varvec <- df[[spl_payload(spl)]]+ |
+
| 471 | +751x | +
+ if (is.factor(varvec)) {
+ |
+
| 472 | +554x | +
+ levels(varvec)+ |
+
| 473 | ++ |
+ } else {
+ |
+
| 474 | +197x | +
+ unique(varvec)+ |
+
| 475 | ++ |
+ }+ |
+
| 476 | ++ |
+ }+ |
+
| 477 | ++ |
+ )+ |
+
| 478 | ++ | + + | +
| 479 | ++ |
+ setMethod(+ |
+
| 480 | ++ |
+ ".applysplit_rawvals", "MultiVarSplit",+ |
+
| 481 | ++ |
+ function(spl, df) {
+ |
+
| 482 | ++ |
+ ## spl_payload(spl)+ |
+
| 483 | +48x | +
+ spl_varnames(spl)+ |
+
| 484 | ++ |
+ }+ |
+
| 485 | ++ |
+ )+ |
+
| 486 | ++ | + + | +
| 487 | ++ |
+ setMethod(+ |
+
| 488 | ++ |
+ ".applysplit_rawvals", "AllSplit",+ |
+
| 489 | +109x | +
+ function(spl, df) obj_name(spl)+ |
+
| 490 | ++ |
+ ) # "all obs")+ |
+
| 491 | ++ | + + | +
| 492 | ++ |
+ setMethod(+ |
+
| 493 | ++ |
+ ".applysplit_rawvals", "ManualSplit",+ |
+
| 494 | +51x | +
+ function(spl, df) spl@levels+ |
+
| 495 | ++ |
+ )+ |
+
| 496 | ++ | + + | +
| 497 | ++ |
+ ## setMethod(".applysplit_rawvals", "NULLSplit",
+ |
+
| 498 | ++ |
+ ## function(spl, df) "")+ |
+
| 499 | ++ | + + | +
| 500 | ++ |
+ setMethod(+ |
+
| 501 | ++ |
+ ".applysplit_rawvals", "VAnalyzeSplit",+ |
+
| 502 | +! | +
+ function(spl, df) spl_payload(spl)+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | ++ | + + | +
| 505 | ++ |
+ ## formfactor here is gross we're gonna have ot do this+ |
+
| 506 | ++ |
+ ## all again in tthe data split part :-/+ |
+
| 507 | ++ |
+ setMethod(+ |
+
| 508 | ++ |
+ ".applysplit_rawvals", "VarStaticCutSplit",+ |
+
| 509 | ++ |
+ function(spl, df) {
+ |
+
| 510 | +22x | +
+ spl_cutlabels(spl)+ |
+
| 511 | ++ |
+ }+ |
+
| 512 | ++ |
+ )+ |
+
| 513 | ++ | + + | +
| 514 | ++ |
+ setMethod(+ |
+
| 515 | ++ |
+ ".applysplit_datapart", "VarLevelSplit",+ |
+
| 516 | ++ |
+ function(spl, df, vals) {
+ |
+
| 517 | +824x | +
+ if (!(spl_payload(spl) %in% names(df))) {
+ |
+
| 518 | +! | +
+ stop(+ |
+
| 519 | +! | +
+ "Attempted to split on values of column (", spl_payload(spl),
+ |
+
| 520 | +! | +
+ ") not present in the data"+ |
+
| 521 | ++ |
+ )+ |
+
| 522 | ++ |
+ }+ |
+
| 523 | +824x | +
+ ret <- lapply(seq_along(vals), function(i) {
+ |
+
| 524 | +2251x | +
+ spl_col <- df[[spl_payload(spl)]]+ |
+
| 525 | +2251x | +
+ df[!is.na(spl_col) & spl_col == vals[[i]], ]+ |
+
| 526 | ++ |
+ })+ |
+
| 527 | +824x | +
+ names(ret) <- as.character(vals)+ |
+
| 528 | +824x | +
+ ret+ |
+
| 529 | ++ |
+ }+ |
+
| 530 | ++ |
+ )+ |
+
| 531 | ++ | + + | +
| 532 | ++ |
+ setMethod(+ |
+
| 533 | ++ |
+ ".applysplit_datapart", "MultiVarSplit",+ |
+
| 534 | ++ |
+ function(spl, df, vals) {
+ |
+
| 535 | +48x | +
+ allvnms <- spl_varnames(spl)+ |
+
| 536 | +48x | +
+ if (!is.null(vals) && !identical(allvnms, vals)) {
+ |
+
| 537 | +! | +
+ incl <- match(vals, allvnms)+ |
+
| 538 | ++ |
+ } else {
+ |
+
| 539 | +48x | +
+ incl <- seq_along(allvnms)+ |
+
| 540 | ++ |
+ }+ |
+
| 541 | +48x | +
+ vars <- spl_payload(spl)[incl]+ |
+
| 542 | ++ |
+ ## don't remove nas+ |
+
| 543 | ++ |
+ ## ret = lapply(vars, function(cl) {
+ |
+
| 544 | ++ |
+ ## df[!is.na(df[[cl]]),]+ |
+
| 545 | ++ |
+ ## })+ |
+
| 546 | +48x | +
+ ret <- rep(list(df), length(vars))+ |
+
| 547 | +48x | +
+ names(ret) <- vals+ |
+
| 548 | +48x | +
+ ret+ |
+
| 549 | ++ |
+ }+ |
+
| 550 | ++ |
+ )+ |
+
| 551 | ++ | + + | +
| 552 | ++ |
+ setMethod(+ |
+
| 553 | ++ |
+ ".applysplit_datapart", "AllSplit",+ |
+
| 554 | +109x | +
+ function(spl, df, vals) list(df)+ |
+
| 555 | ++ |
+ )+ |
+
| 556 | ++ | + + | +
| 557 | ++ |
+ ## ## not sure I need this+ |
+
| 558 | ++ |
+ setMethod(+ |
+
| 559 | ++ |
+ ".applysplit_datapart", "ManualSplit",+ |
+
| 560 | +51x | +
+ function(spl, df, vals) rep(list(df), times = length(vals))+ |
+
| 561 | ++ |
+ )+ |
+
| 562 | ++ | + + | +
| 563 | ++ |
+ ## setMethod(".applysplit_datapart", "NULLSplit",
+ |
+
| 564 | ++ |
+ ## function(spl, df, vals) list(df[FALSE,]))+ |
+
| 565 | ++ | + + | +
| 566 | ++ |
+ setMethod(+ |
+
| 567 | ++ |
+ ".applysplit_datapart", "VarStaticCutSplit",+ |
+
| 568 | ++ |
+ function(spl, df, vals) {
+ |
+
| 569 | ++ |
+ # lbs = spl_cutlabels(spl)+ |
+
| 570 | +14x | +
+ var <- spl_payload(spl)+ |
+
| 571 | +14x | +
+ varvec <- df[[var]]+ |
+
| 572 | +14x | +
+ cts <- spl_cuts(spl)+ |
+
| 573 | +14x | +
+ cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ |
+
| 574 | +14x | +
+ split(df, cfct, drop = FALSE)+ |
+
| 575 | ++ |
+ }+ |
+
| 576 | ++ |
+ )+ |
+
| 577 | ++ | + + | +
| 578 | ++ |
+ setMethod(+ |
+
| 579 | ++ |
+ ".applysplit_datapart", "CumulativeCutSplit",+ |
+
| 580 | ++ |
+ function(spl, df, vals) {
+ |
+
| 581 | ++ |
+ # lbs = spl_cutlabels(spl)+ |
+
| 582 | +8x | +
+ var <- spl_payload(spl)+ |
+
| 583 | +8x | +
+ varvec <- df[[var]]+ |
+
| 584 | +8x | +
+ cts <- spl_cuts(spl)+ |
+
| 585 | +8x | +
+ cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ |
+
| 586 | +8x | +
+ ret <- lapply(+ |
+
| 587 | +8x | +
+ seq_len(length(levels(cfct))),+ |
+
| 588 | +8x | +
+ function(i) df[as.integer(cfct) <= i, ]+ |
+
| 589 | ++ |
+ )+ |
+
| 590 | +8x | +
+ names(ret) <- levels(cfct)+ |
+
| 591 | +8x | +
+ ret+ |
+
| 592 | ++ |
+ }+ |
+
| 593 | ++ |
+ )+ |
+
| 594 | ++ | + + | +
| 595 | ++ |
+ ## XXX TODO *CutSplit Methods+ |
+
| 596 | ++ | + + | +
| 597 | ++ |
+ setClass("NullSentinel", contains = "NULL")
+ |
+
| 598 | ++ |
+ nullsentinel <- new("NullSentinel")
+ |
+
| 599 | +! | +
+ noarg <- function() nullsentinel+ |
+
| 600 | ++ | + + | +
| 601 | ++ |
+ ## Extras generation methods+ |
+
| 602 | ++ |
+ setMethod(+ |
+
| 603 | ++ |
+ ".applysplit_extras", "Split",+ |
+
| 604 | ++ |
+ function(spl, df, vals) {
+ |
+
| 605 | +1003x | +
+ splex <- split_exargs(spl)+ |
+
| 606 | +1003x | +
+ nvals <- length(vals)+ |
+
| 607 | +1003x | +
+ lapply(seq_len(nvals), function(vpos) {
+ |
+
| 608 | +2552x | +
+ one_ex <- lapply(splex, function(arg) {
+ |
+
| 609 | +! | +
+ if (length(arg) >= vpos) {
+ |
+
| 610 | +! | +
+ arg[[vpos]]+ |
+
| 611 | ++ |
+ } else {
+ |
+
| 612 | +! | +
+ noarg()+ |
+
| 613 | ++ |
+ }+ |
+
| 614 | ++ |
+ })+ |
+
| 615 | +2552x | +
+ names(one_ex) <- names(splex)+ |
+
| 616 | +2552x | +
+ one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")]+ |
+
| 617 | +2552x | +
+ one_ex+ |
+
| 618 | ++ |
+ })+ |
+
| 619 | ++ |
+ }+ |
+
| 620 | ++ |
+ )+ |
+
| 621 | ++ | + + | +
| 622 | ++ |
+ setMethod(+ |
+
| 623 | ++ |
+ ".applysplit_ref_vals", "Split",+ |
+
| 624 | +! | +
+ function(spl, df, vals) rep(list(NULL), length(vals))+ |
+
| 625 | ++ |
+ )+ |
+
| 626 | ++ | + + | +
| 627 | ++ |
+ setMethod(+ |
+
| 628 | ++ |
+ ".applysplit_ref_vals", "VarLevWBaselineSplit",+ |
+
| 629 | ++ |
+ function(spl, df, vals) {
+ |
+
| 630 | +17x | +
+ bl_level <- spl@ref_group_value # XXX XXX+ |
+
| 631 | +17x | +
+ vnames <- value_names(vals)+ |
+
| 632 | +17x | +
+ ret <- lapply(vnames, function(vl) {
+ |
+
| 633 | +46x | +
+ list(.in_ref_col = vl == bl_level)+ |
+
| 634 | ++ |
+ })+ |
+
| 635 | +17x | +
+ names(ret) <- vnames+ |
+
| 636 | +17x | +
+ ret+ |
+
| 637 | ++ |
+ }+ |
+
| 638 | ++ |
+ )+ |
+
| 639 | ++ | + + | +
| 640 | ++ |
+ ## XXX TODO FIXME+ |
+
| 641 | ++ |
+ setMethod(+ |
+
| 642 | ++ |
+ ".applysplit_partlabels", "Split",+ |
+
| 643 | +131x | +
+ function(spl, df, vals, labels) as.character(vals)+ |
+
| 644 | ++ |
+ )+ |
+
| 645 | ++ | + + | +
| 646 | ++ |
+ setMethod(+ |
+
| 647 | ++ |
+ ".applysplit_partlabels", "VarLevelSplit",+ |
+
| 648 | ++ |
+ function(spl, df, vals, labels) {
+ |
+
| 649 | +821x | +
+ varname <- spl_payload(spl)+ |
+
| 650 | +821x | +
+ vlabelname <- spl_labelvar(spl)+ |
+
| 651 | +821x | +
+ varvec <- df[[varname]]+ |
+
| 652 | ++ |
+ ## we used to check if vals was NULL but+ |
+
| 653 | ++ |
+ ## this is called after a short-circuit return in .apply_split_inner in that+ |
+
| 654 | ++ |
+ ## case+ |
+
| 655 | ++ |
+ ## so vals is guaranteed to be non-null here+ |
+
| 656 | +821x | +
+ if (is.null(labels)) {
+ |
+
| 657 | +821x | +
+ if (varname == vlabelname) {
+ |
+
| 658 | +691x | +
+ labels <- vals+ |
+
| 659 | ++ |
+ } else {
+ |
+
| 660 | +130x | +
+ labfact <- is.factor(df[[vlabelname]])+ |
+
| 661 | +130x | +
+ lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL+ |
+
| 662 | +130x | +
+ labels <- sapply(vals, function(v) {
+ |
+
| 663 | +262x | +
+ vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE])+ |
+
| 664 | ++ |
+ ## TODO remove this once 1-to-1 value-label map is enforced+ |
+
| 665 | ++ |
+ ## elsewhere.+ |
+
| 666 | +262x | +
+ stopifnot(length(vlabel) < 2)+ |
+
| 667 | +262x | +
+ if (length(vlabel) == 0) {
+ |
+
| 668 | +! | +
+ vlabel <- ""+ |
+
| 669 | +262x | +
+ } else if (labfact) {
+ |
+
| 670 | +6x | +
+ vlabel <- lablevs[vlabel]+ |
+
| 671 | ++ |
+ }+ |
+
| 672 | +262x | +
+ vlabel+ |
+
| 673 | ++ |
+ })+ |
+
| 674 | ++ |
+ }+ |
+
| 675 | ++ |
+ }+ |
+
| 676 | +821x | +
+ names(labels) <- as.character(vals)+ |
+
| 677 | +821x | +
+ labels+ |
+
| 678 | ++ |
+ }+ |
+
| 679 | ++ |
+ )+ |
+
| 680 | ++ | + + | +
| 681 | ++ |
+ setMethod(+ |
+
| 682 | ++ |
+ ".applysplit_partlabels", "MultiVarSplit",+ |
+
| 683 | +48x | +
+ function(spl, df, vals, labels) value_labels(spl)+ |
+
| 684 | ++ |
+ )+ |
+
| 685 | ++ | + + | +
| 686 | ++ |
+ make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals,+ |
+
| 687 | ++ |
+ subset_exprs) {
+ |
+
| 688 | +2789x | +
+ if (length(vals) == 0) {
+ |
+
| 689 | +376x | +
+ return(vals)+ |
+
| 690 | ++ |
+ }+ |
+
| 691 | ++ | + + | +
| 692 | +2413x | +
+ if (is(extrs, "AsIs")) {
+ |
+
| 693 | +! | +
+ extrs <- unclass(extrs)+ |
+
| 694 | ++ |
+ }+ |
+
| 695 | ++ |
+ ## if(are(vals, "SplitValue")) {
+ |
+
| 696 | ++ | + + | +
| 697 | ++ |
+ ## return(vals)+ |
+
| 698 | ++ |
+ ## }+ |
+
| 699 | ++ | + + | +
| 700 | +2413x | +
+ mapply(SplitValue,+ |
+
| 701 | +2413x | +
+ val = vals, extr = extrs,+ |
+
| 702 | +2413x | +
+ label = labels,+ |
+
| 703 | +2413x | +
+ sub_expr = subset_exprs,+ |
+
| 704 | +2413x | +
+ SIMPLIFY = FALSE+ |
+
| 705 | ++ |
+ )+ |
+
| 706 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Find degenerate (sub)structures within a table+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if+ |
+
| 6 | ++ |
+ #' they have associated content rows).+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param tt (`TableTree`)\cr a `TableTree` object.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @examples+ |
+
| 13 | ++ |
+ #' find_degen_struct(rtable("hi"))
+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @family table structure validation functions+ |
+
| 16 | ++ |
+ #' @export+ |
+
| 17 | ++ |
+ find_degen_struct <- function(tt) {
+ |
+
| 18 | +7x | +
+ degen <- list()+ |
+
| 19 | ++ | + + | +
| 20 | +7x | +
+ recurse_check <- function(tti, path) {
+ |
+
| 21 | +103x | +
+ if (is(tti, "VTableTree")) {
+ |
+
| 22 | +103x | +
+ kids <- tree_children(tti)+ |
+
| 23 | +103x | +
+ if (length(kids) == 0) {
+ |
+
| 24 | +69x | +
+ degen <<- c(degen, list(path))+ |
+
| 25 | ++ |
+ } else {
+ |
+
| 26 | +34x | +
+ for (i in seq_along(kids)) {
+ |
+
| 27 | +96x | +
+ recurse_check(kids[[i]], path = c(path, names(kids)[i]))+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ |
+ }+ |
+
| 30 | ++ |
+ }+ |
+
| 31 | ++ |
+ }+ |
+
| 32 | +7x | +
+ recurse_check(tt, obj_name(tt) %||% "root")+ |
+
| 33 | +7x | +
+ degen+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ #' Validate and assert valid table structure+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' A `TableTree` (`rtables`-built table) is considered degenerate if:+ |
+
| 41 | ++ |
+ #' \enumerate{
+ |
+
| 42 | ++ |
+ #' \item{It contains no subtables or data rows (content rows do not count).}
+ |
+
| 43 | ++ |
+ #' \item{It contains a subtable which is degenerate by the criterion above.}
+ |
+
| 44 | ++ |
+ #' }+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or+ |
+
| 49 | ++ |
+ #' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more+ |
+
| 50 | ++ |
+ #' invalid substructures.+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @param tt (`TableTree`)\cr a `TableTree` object.+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' @return+ |
+
| 55 | ++ |
+ #' * `validate_table_struct` returns a logical value indicating valid structure.+ |
+
| 56 | ++ |
+ #' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @examples+ |
+
| 61 | ++ |
+ #' validate_table_struct(rtable("hahaha"))
+ |
+
| 62 | ++ |
+ #' \dontrun{
+ |
+
| 63 | ++ |
+ #' assert_valid_table(rtable("oops"))
+ |
+
| 64 | ++ |
+ #' }+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @family table structure validation functions+ |
+
| 67 | ++ |
+ #' @export+ |
+
| 68 | ++ |
+ validate_table_struct <- function(tt) {
+ |
+
| 69 | +1x | +
+ degen_pths <- find_degen_struct(tt)+ |
+
| 70 | +1x | +
+ length(degen_pths) == 0+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ | + + | +
| 73 | ++ |
+ ## XXX this doesn't handle content paths correctly+ |
+
| 74 | ++ |
+ .path_to_disp <- function(pth) {
+ |
+
| 75 | +4x | +
+ if (length(pth) == 1) {
+ |
+
| 76 | +1x | +
+ return(pth)+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | +3x | +
+ has_cont <- any(pth == "@content")+ |
+
| 79 | +3x | +
+ if (has_cont) {
+ |
+
| 80 | +! | +
+ contpos <- which(pth == "@content")+ |
+
| 81 | +! | +
+ cont_disp <- paste(tail(pth, length(pth) - contpos + 1),+ |
+
| 82 | +! | +
+ collapse = "->"+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | +! | +
+ pth <- head(pth, contpos)+ |
+
| 85 | ++ |
+ } else {
+ |
+
| 86 | +3x | +
+ cont_disp <- character()+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ | + + | +
| 89 | +3x | +
+ topaste <- character(0)+ |
+
| 90 | +3x | +
+ fullpth <- pth+ |
+
| 91 | +3x | +
+ while (length(pth) > 0) {
+ |
+
| 92 | +6x | +
+ if (length(pth) <= 1) {
+ |
+
| 93 | +! | +
+ topaste <- c(topaste, pth)+ |
+
| 94 | +! | +
+ pth <- character()+ |
+
| 95 | ++ |
+ } else {
+ |
+
| 96 | +6x | +
+ topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
+ |
+
| 97 | +6x | +
+ pth <- tail(pth, -2)+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | +3x | +
+ topaste <- c(topaste, cont_disp)+ |
+
| 101 | +3x | +
+ paste(topaste, collapse = "->")+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ no_analyze_guess <- paste0(+ |
+
| 105 | ++ |
+ "Was this table created using ",+ |
+
| 106 | ++ |
+ "summarize_row_groups but no calls ",+ |
+
| 107 | ++ |
+ "to analyze?\n"+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ make_degen_message <- function(degen_pths, tt) {
+ |
+
| 113 | +2x | +
+ msg <- sprintf(+ |
+
| 114 | +2x | +
+ paste0(+ |
+
| 115 | +2x | +
+ "Invalid table - found %d (sub)structures which contain no data rows.",+ |
+
| 116 | +2x | +
+ "\n\tThe first occured at path: %s"+ |
+
| 117 | ++ |
+ ),+ |
+
| 118 | +2x | +
+ length(degen_pths), .path_to_disp(degen_pths[[1]])+ |
+
| 119 | ++ |
+ )+ |
+
| 120 | +2x | +
+ if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
+ |
+
| 121 | +1x | +
+ msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values",+ |
+
| 122 | +1x | +
+ sep = "\n"+ |
+
| 123 | ++ |
+ )+ |
+
| 124 | +1x | +
+ } else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
+ |
+
| 125 | +1x | +
+ msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())",+ |
+
| 126 | +1x | +
+ sep = "\n"+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | ++ |
+ }+ |
+
| 129 | +2x | +
+ msg <- paste(msg, use_sanitize_msg, sep = "\n")+ |
+
| 130 | +2x | +
+ msg+ |
+
| 131 | ++ |
+ }+ |
+
| 132 | ++ | + + | +
| 133 | ++ |
+ #' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @rdname validate_table_struct+ |
+
| 136 | ++ |
+ #' @export+ |
+
| 137 | ++ |
+ assert_valid_table <- function(tt, warn_only = FALSE) {
+ |
+
| 138 | +2x | +
+ degen_pths <- find_degen_struct(tt)+ |
+
| 139 | +2x | +
+ if (length(degen_pths) == 0) {
+ |
+
| 140 | +! | +
+ return(TRUE)+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | ++ |
+ ## we failed, now we build an informative error/warning message+ |
+
| 144 | +2x | +
+ msg <- make_degen_message(degen_pths, tt)+ |
+
| 145 | ++ | + + | +
| 146 | +2x | +
+ if (!warn_only) {
+ |
+
| 147 | +2x | +
+ stop(msg)+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | +! | +
+ warning(msg)+ |
+
| 150 | +! | +
+ return(FALSE)+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ |
+ #' Sanitize degenerate table structures+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @param tt (`TableTree`)\cr a `TableTree` object.+ |
+
| 160 | ++ |
+ #' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @details+ |
+
| 163 | ++ |
+ #' This function locates degenerate portions of the table (including the table overall in the case of a table with no+ |
+
| 164 | ++ |
+ #' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table+ |
+
| 165 | ++ |
+ #' guaranteed to be non-degenerate.+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate+ |
+
| 168 | ++ |
+ #' version of the table is returned.+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @examples+ |
+
| 171 | ++ |
+ #' sanitize_table_struct(rtable("cool beans"))
+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 174 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 175 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 176 | ++ |
+ #' summarize_row_groups()+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' ## Degenerate because it doesn't have any analyze calls -> no data rows+ |
+
| 179 | ++ |
+ #' badtab <- build_table(lyt, DM)+ |
+
| 180 | ++ |
+ #' sanitize_table_struct(badtab)+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' @family table structure validation functions+ |
+
| 183 | ++ |
+ #' @export+ |
+
| 184 | ++ |
+ sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
+ |
+
| 185 | +4x | +
+ rdf <- make_row_df(tt)+ |
+
| 186 | ++ | + + | +
| 187 | +4x | +
+ emptyrow <- DataRow(+ |
+
| 188 | +4x | +
+ vals = list(empty_msg),+ |
+
| 189 | +4x | +
+ name = "empty_section",+ |
+
| 190 | +4x | +
+ label = "",+ |
+
| 191 | +4x | +
+ cspan = ncol(tt),+ |
+
| 192 | +4x | +
+ cinfo = col_info(tt),+ |
+
| 193 | +4x | +
+ format = "xx",+ |
+
| 194 | +4x | +
+ table_inset = table_inset(tt)+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | +4x | +
+ degen_pths <- find_degen_struct(tt)+ |
+
| 197 | ++ | + + | +
| 198 | +4x | +
+ if (identical(degen_pths, list("root"))) {
+ |
+
| 199 | +2x | +
+ tree_children(tt) <- list(empty_row = emptyrow)+ |
+
| 200 | +2x | +
+ return(tt)+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | +2x | +
+ for (pth in degen_pths) {
+ |
+
| 204 | ++ |
+ ## FIXME this shouldn't be necessary. why is it?+ |
+
| 205 | +33x | +
+ tti <- tt_at_path(tt, path = pth)+ |
+
| 206 | +33x | +
+ tree_children(tti) <- list(empty_section = emptyrow)+ |
+
| 207 | +33x | +
+ tt_at_path(tt, path = pth) <- tti+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | +2x | +
+ tt+ |
+
| 210 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Variable associated with a split+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This function is intended for use when writing custom splitting logic. In cases where the split is associated with+ |
+
| 4 | ++ |
+ #' a single variable, the name of that variable will be returned. At time of writing this includes splits generated+ |
+
| 5 | ++ |
+ #' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],+ |
+
| 6 | ++ |
+ #' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param spl (`VarLevelSplit`)\cr the split object.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @export+ |
+
| 13 | ++ |
+ #' @seealso \code{\link{make_split_fun}}
+ |
+
| 14 | +2x | +
+ setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
+ |
+
| 15 | ++ | + + | +
| 16 | ++ |
+ #' @rdname spl_variable+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | +1x | +
+ setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ #' @rdname spl_variable+ |
+
| 21 | ++ |
+ #' @export+ |
+
| 22 | +! | +
+ setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
+ |
+
| 23 | ++ | + + | +
| 24 | ++ |
+ #' @rdname spl_variable+ |
+
| 25 | ++ |
+ #' @export+ |
+
| 26 | +! | +
+ setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ #' @rdname spl_variable+ |
+
| 29 | ++ |
+ #' @export+ |
+
| 30 | ++ |
+ setMethod(+ |
+
| 31 | ++ |
+ "spl_variable", "Split",+ |
+
| 32 | +1x | +
+ function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
+ |
+
| 33 | ++ |
+ )+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ in_col_split <- function(spl_ctx) {
+ |
+
| 36 | +! | +
+ identical(+ |
+
| 37 | +! | +
+ names(spl_ctx),+ |
+
| 38 | +! | +
+ names(context_df_row(cinfo = NULL))+ |
+
| 39 | ++ |
+ )+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
+ |
+
| 43 | +45x | +
+ msg_2_append <- ""+ |
+
| 44 | +45x | +
+ if (!is.null(component)) {
+ |
+
| 45 | +33x | +
+ msg_2_append <- paste0(+ |
+
| 46 | +33x | +
+ "Invalid split function constructed by upstream call to ",+ |
+
| 47 | +33x | +
+ "make_split_fun. Problem source: ",+ |
+
| 48 | +33x | +
+ component, " argument."+ |
+
| 49 | ++ |
+ )+ |
+
| 50 | ++ |
+ }+ |
+
| 51 | +45x | +
+ if (!(nm %in% names(pinfo))) {
+ |
+
| 52 | +! | +
+ stop(+ |
+
| 53 | +! | +
+ "Split result does not have required element: ", nm, ".",+ |
+
| 54 | +! | +
+ msg_2_append+ |
+
| 55 | ++ |
+ )+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | +45x | +
+ if (!is.null(len) && length(pinfo[[nm]]) != len) {
+ |
+
| 58 | +! | +
+ stop(+ |
+
| 59 | +! | +
+ "Split result element ", nm, " does not have required length ", len, ".",+ |
+
| 60 | +! | +
+ msg_2_append+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | +45x | +
+ TRUE+ |
+
| 64 | ++ |
+ }+ |
+
| 65 | ++ | + + | +
| 66 | ++ |
+ validate_split_result <- function(pinfo, component = NULL) {
+ |
+
| 67 | +15x | +
+ assert_splres_element(pinfo, "datasplit", component = component)+ |
+
| 68 | +15x | +
+ len <- length(pinfo$datasplit)+ |
+
| 69 | +15x | +
+ assert_splres_element(pinfo, "values", len, component = component)+ |
+
| 70 | +15x | +
+ assert_splres_element(pinfo, "labels", len, component = component)+ |
+
| 71 | +15x | +
+ TRUE+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ #' Construct split result object+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' These functions can be used to create or add to a split result in functions which implement core splitting or+ |
+
| 77 | ++ |
+ #' post-processing within a custom split function.+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.+ |
+
| 80 | ++ |
+ #' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.+ |
+
| 81 | ++ |
+ #' @param labels (`character`)\cr the labels associated with each facet.+ |
+
| 82 | ++ |
+ #' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to+ |
+
| 83 | ++ |
+ #' analysis functions applied within the facet.+ |
+
| 84 | ++ |
+ #' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,+ |
+
| 85 | ++ |
+ #' created with `quote()`) to be used during column subsetting.+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and+ |
+
| 88 | ++ |
+ #' `labels`, which are the same length and correspond to each other element-wise.+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @details+ |
+
| 91 | ++ |
+ #' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables+ |
+
| 92 | ++ |
+ #' internals expect it, most of which are not relevant to end users.+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @examples+ |
+
| 95 | ++ |
+ #' splres <- make_split_result(+ |
+
| 96 | ++ |
+ #' values = c("hi", "lo"),
+ |
+
| 97 | ++ |
+ #' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),+ |
+
| 98 | ++ |
+ #' labels = c("more data", "less data"),
+ |
+
| 99 | ++ |
+ #' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' splres2 <- add_to_split_result(splres,+ |
+
| 103 | ++ |
+ #' values = "med",+ |
+
| 104 | ++ |
+ #' datasplit = list(med = mtcars[1:20, ]),+ |
+
| 105 | ++ |
+ #' labels = "kinda some data",+ |
+
| 106 | ++ |
+ #' subset_exprs = quote(seq_along(wt) <= 20)+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @family make_custom_split+ |
+
| 110 | ++ |
+ #' @rdname make_split_result+ |
+
| 111 | ++ |
+ #' @export+ |
+
| 112 | ++ |
+ #' @family make_custom_split+ |
+
| 113 | ++ |
+ 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 | +! | +
+ datasplit <- list(datasplit)+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | +9x | +
+ ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)+ |
+
| 118 | +9x | +
+ if (!is.null(extras)) {
+ |
+
| 119 | +! | +
+ ret$extras <- extras+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | +9x | +
+ .fixupvals(ret)+ |
+
| 122 | ++ |
+ }+ |
+
| 123 | ++ | + + | +
| 124 | ++ |
+ #' @param splres (`list`)\cr a list representing the result of splitting.+ |
+
| 125 | ++ |
+ #'+ |
+
| 126 | ++ |
+ #' @rdname make_split_result+ |
+
| 127 | ++ |
+ #' @export+ |
+
| 128 | ++ |
+ add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
+ |
+
| 129 | +4x | +
+ validate_split_result(splres)+ |
+
| 130 | +4x | +
+ newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))+ |
+
| 131 | +4x | +
+ ret <- lapply(+ |
+
| 132 | +4x | +
+ names(splres),+ |
+
| 133 | +4x | +
+ function(nm) c(splres[[nm]], newstuff[[nm]])+ |
+
| 134 | ++ |
+ )+ |
+
| 135 | +4x | +
+ names(ret) <- names(splres)+ |
+
| 136 | +4x | +
+ .fixupvals(ret)+ |
+
| 137 | ++ |
+ }+ |
+
| 138 | ++ | + + | +
| 139 | ++ | + + | +
| 140 | +13x | +
+ .can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
+ |
+
| 141 | ++ | + + | +
| 142 | ++ |
+ #' Create a custom splitting function+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that+ |
+
| 145 | ++ |
+ #' should split via `core_split`. They will be called on the data in the order they appear in the list.+ |
+
| 146 | ++ |
+ #' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that+ |
+
| 147 | ++ |
+ #' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior+ |
+
| 148 | ++ |
+ #' 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 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' @details+ |
+
| 152 | ++ |
+ #' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' 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 | ++ |
+ #' 3. Post-processing operations on the set of facets (groups) generated by the split.+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' This function provides an interface to create custom split functions by implementing and specifying sets of+ |
+
| 159 | ++ |
+ #' 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 | ++ |
+ #' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.+ |
+
| 163 | ++ |
+ #' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if+ |
+
| 164 | ++ |
+ #' 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 | ++ |
+ #' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones+ |
+
| 168 | ++ |
+ #' or to reorder levels based on observed counts, etc.+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' Core splitting functions override the fundamental+ |
+
| 171 | ++ |
+ #' splitting procedure, and are only necessary in rare cases. These+ |
+
| 172 | ++ |
+ #' must accept `spl`, `df`, `vals`, `labels`, and can optionally+ |
+
| 173 | ++ |
+ #' 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+ |
+
| 178 | ++ |
+ #' `quote()` or `bquote` must be provided, while they are+ |
+
| 179 | ++ |
+ #' optional (and largely ignored, currently) in row space.+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' Post-processing functions (3) must accept the result of the core split as their first argument (which can be+ |
+
| 183 | ++ |
+ #' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a+ |
+
| 184 | ++ |
+ #' modified version of the same structure specified above for core splitting.+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied+ |
+
| 187 | ++ |
+ #' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).+ |
+
| 188 | ++ |
+ #'+ |
+
| 189 | ++ |
+ #' @return A custom function that can be used as a split function.+ |
+
| 190 | ++ |
+ #'+ |
+
| 191 | ++ |
+ #' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.+ |
+
| 192 | ++ |
+ #'+ |
+
| 193 | ++ |
+ #' @examples+ |
+
| 194 | ++ |
+ #' mysplitfun <- make_split_fun(+ |
+
| 195 | ++ |
+ #' pre = list(drop_facet_levels),+ |
+
| 196 | ++ |
+ #' post = list(add_overall_facet("ALL", "All Arms"))
+ |
+
| 197 | ++ |
+ #' )+ |
+
| 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 | ++ |
+ #' )+ |
+
| 213 | ++ |
+ #' }+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' mysplitfun2 <- make_split_fun(+ |
+
| 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 | ++ |
+ #'+ |
+
| 227 | ++ |
+ #' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
+ |
+
| 228 | ++ |
+ #' make_split_result(c("stupid", "silly"),
+ |
+
| 229 | ++ |
+ #' datasplit = list(df[1:10, ], df[11:30, ]),+ |
+
| 230 | ++ |
+ #' labels = c("first 10", "second 20")
+ |
+
| 231 | ++ |
+ #' )+ |
+
| 232 | ++ |
+ #' }+ |
+
| 233 | ++ |
+ #'+ |
+
| 234 | ++ |
+ #' dumb_30_facet <- add_combo_facet("dumb",
+ |
+
| 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 | ++ |
+ #'+ |
+
| 243 | ++ |
+ #' ## recall core split overriding is not supported in column space+ |
+
| 244 | ++ |
+ #' ## currently, but we can see it in action in row space+ |
+
| 245 | ++ |
+ #'+ |
+
| 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 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' @family make_custom_split+ |
+
| 254 | ++ |
+ #' @export+ |
+
| 255 | ++ |
+ 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(+ |
+
| 271 | +! | +
+ "Error in custom split function, pre-split step did not return a data.frame. ",+ |
+
| 272 | +! | +
+ "See upstream call to make_split_fun for original source of error."+ |
+
| 273 | ++ |
+ )+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ | + + | +
| 277 | +9x | +
+ if (!all(orig_columns %in% names(df))) {
+ |
+
| 278 | +! | +
+ stop(+ |
+
| 279 | +! | +
+ "Preprocessing functions(s) in custom split function removed a column from the incoming data.",+ |
+
| 280 | +! | +
+ " This is not supported. See upstread make_split_fun call (pre argument) for original source of error."+ |
+
| 281 | ++ |
+ )+ |
+
| 282 | ++ |
+ }+ |
+
| 283 | ++ | + + | +
| 284 | +9x | +
+ if (is.null(core_split)) {
+ |
+
| 285 | +7x | +
+ ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)+ |
+
| 286 | ++ |
+ } else {
+ |
+
| 287 | +2x | +
+ ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)+ |
+
| 288 | +2x | +
+ validate_split_result(ret, component = "core_split")+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ | + + | +
| 291 | +9x | +
+ for (post_fn in post) {
+ |
+
| 292 | +8x | +
+ if (.can_take_spl_context(post_fn)) {
+ |
+
| 293 | +8x | +
+ ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)+ |
+
| 294 | ++ |
+ } else {
+ |
+
| 295 | +! | +
+ ret <- post_fn(ret, spl = spl, fulldf = df)+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ |
+ }+ |
+
| 298 | +9x | +
+ validate_split_result(ret, "post")+ |
+
| 299 | +9x | +
+ ret+ |
+
| 300 | ++ |
+ }+ |
+
| 301 | ++ |
+ }+ |
+
| 302 | ++ | + + | +
| 303 | ++ |
+ #' Add a combination facet in post-processing+ |
+
| 304 | ++ |
+ #'+ |
+
| 305 | ++ |
+ #' Add a combination facet during the post-processing stage in a custom split fun.+ |
+
| 306 | ++ |
+ #'+ |
+
| 307 | ++ |
+ #' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).+ |
+
| 308 | ++ |
+ #' @param label (`string`)\cr label for the resulting facet.+ |
+
| 309 | ++ |
+ #' @param levels (`character`)\cr vector of levels to combine within the resulting facet.+ |
+
| 310 | ++ |
+ #' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' @details+ |
+
| 313 | ++ |
+ #' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for+ |
+
| 314 | ++ |
+ #' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data+ |
+
| 315 | ++ |
+ #' that appears in both will be duplicated.+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' @return A function which can be used within the `post` argument in [make_split_fun()].+ |
+
| 318 | ++ |
+ #'+ |
+
| 319 | ++ |
+ #' @seealso [make_split_fun()]+ |
+
| 320 | ++ |
+ #'+ |
+
| 321 | ++ |
+ #' @examples+ |
+
| 322 | ++ |
+ #' mysplfun <- make_split_fun(post = list(+ |
+
| 323 | ++ |
+ #' add_combo_facet("A_B",
+ |
+
| 324 | ++ |
+ #' label = "Arms A+B",+ |
+
| 325 | ++ |
+ #' levels = c("A: Drug X", "B: Placebo")
+ |
+
| 326 | ++ |
+ #' ),+ |
+
| 327 | ++ |
+ #' add_overall_facet("ALL", label = "All Arms")
+ |
+
| 328 | ++ |
+ #' ))+ |
+
| 329 | ++ |
+ #'+ |
+
| 330 | ++ |
+ #' lyt <- basic_table(show_colcounts = TRUE) %>%+ |
+
| 331 | ++ |
+ #' split_cols_by("ARM", split_fun = mysplfun) %>%
+ |
+
| 332 | ++ |
+ #' analyze("AGE")
+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' tbl <- build_table(lyt, DM)+ |
+
| 335 | ++ |
+ #'+ |
+
| 336 | ++ |
+ #' @family make_custom_split+ |
+
| 337 | ++ |
+ #' @export+ |
+
| 338 | ++ |
+ add_combo_facet <- function(name, label = name, levels, extra = list()) {
+ |
+
| 339 | +3x | +
+ function(ret, spl, .spl_context, fulldf) {
+ |
+
| 340 | +4x | +
+ if (is(levels, "AllLevelsSentinel")) {
+ |
+
| 341 | +1x | +
+ subexpr <- expression(TRUE)+ |
+
| 342 | +1x | +
+ datpart <- list(fulldf)+ |
+
| 343 | ++ |
+ } else {
+ |
+
| 344 | +3x | +
+ subexpr <- .combine_value_exprs(ret$values[levels])+ |
+
| 345 | +3x | +
+ datpart <- list(do.call(rbind, ret$datasplit[levels]))+ |
+
| 346 | ++ |
+ }+ |
+
| 347 | ++ | + + | +
| 348 | ++ | + + | +
| 349 | +4x | +
+ val <- LevelComboSplitValue(+ |
+
| 350 | +4x | +
+ val = name, extr = extra, combolevels = levels, label = label,+ |
+
| 351 | +4x | +
+ sub_expr = subexpr+ |
+
| 352 | ++ |
+ )+ |
+
| 353 | +4x | +
+ add_to_split_result(ret,+ |
+
| 354 | +4x | +
+ values = list(val), labels = label,+ |
+
| 355 | +4x | +
+ datasplit = datpart+ |
+
| 356 | ++ |
+ )+ |
+
| 357 | ++ |
+ }+ |
+
| 358 | ++ |
+ }+ |
+
| 359 | ++ | + + | +
| 360 | ++ |
+ .combine_value_exprs <- function(val_lst, spl) {
+ |
+
| 361 | +3x | +
+ exprs <- lapply(val_lst, value_expr)+ |
+
| 362 | +3x | +
+ nulls <- vapply(exprs, is.null, TRUE)+ |
+
| 363 | +3x | +
+ if (all(nulls)) {
+ |
+
| 364 | +1x | +
+ return(NULL) # default behavior all the way down the line, no need to do anything.+ |
+
| 365 | +2x | +
+ } else if (any(nulls)) {
+ |
+
| 366 | +! | +
+ exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))+ |
+
| 367 | ++ |
+ }+ |
+
| 368 | +2x | +
+ Reduce(.or_combine_exprs, exprs)+ |
+
| 369 | ++ |
+ }+ |
+
| 370 | ++ | + + | +
| 371 | ++ |
+ ## no NULLS coming in here, everything has been populated+ |
+
| 372 | ++ |
+ ## by either custom subsetting expressions or the result of make_subset_expr(spl, val)+ |
+
| 373 | ++ |
+ .or_combine_exprs <- function(ex1, ex2) {
+ |
+
| 374 | +2x | +
+ if (identical(ex1, expression(FALSE))) {
+ |
+
| 375 | +! | +
+ return(ex2)+ |
+
| 376 | +2x | +
+ } else if (identical(ex2, expression(FALSE))) {
+ |
+
| 377 | +! | +
+ return(ex1)+ |
+
| 378 | +2x | +
+ } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
+ |
+
| 379 | +! | +
+ return(TRUE)+ |
+
| 380 | ++ |
+ }+ |
+
| 381 | +2x | +
+ as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]])))+ |
+
| 382 | ++ |
+ }+ |
+
| 383 | ++ | + + | +
| 384 | ++ |
+ #' @rdname add_combo_facet+ |
+
| 385 | ++ |
+ #' @export+ |
+
| 386 | ++ |
+ add_overall_facet <- function(name, label, extra = list()) {
+ |
+
| 387 | +1x | +
+ add_combo_facet(+ |
+
| 388 | +1x | +
+ name = name, label = label, levels = select_all_levels,+ |
+
| 389 | +1x | +
+ extra = extra+ |
+
| 390 | ++ |
+ )+ |
+
| 391 | ++ |
+ }+ |
+
| 392 | ++ | + + | +
| 393 | ++ |
+ #' Trim levels of another variable from each facet (post-processing split step)+ |
+
| 394 | ++ |
+ #'+ |
+
| 395 | ++ |
+ #' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.+ |
+
| 396 | ++ |
+ #'+ |
+
| 397 | ++ |
+ #' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.+ |
+
| 398 | ++ |
+ #'+ |
+
| 399 | ++ |
+ #' @seealso [make_split_fun()]+ |
+
| 400 | ++ |
+ #'+ |
+
| 401 | ++ |
+ #' @family make_custom_split+ |
+
| 402 | ++ |
+ #' @export+ |
+
| 403 | ++ |
+ trim_levels_in_facets <- function(innervar) {
+ |
+
| 404 | +1x | +
+ function(ret, ...) {
+ |
+
| 405 | +1x | +
+ for (var in innervar) {
+ |
+
| 406 | +1x | +
+ ret$datasplit <- lapply(ret$datasplit, function(df) {
+ |
+
| 407 | +2x | +
+ df[[var]] <- factor(df[[var]])+ |
+
| 408 | +2x | +
+ df+ |
+
| 409 | ++ |
+ })+ |
+
| 410 | ++ |
+ }+ |
+
| 411 | +1x | +
+ ret+ |
+
| 412 | ++ |
+ }+ |
+
| 413 | ++ |
+ }+ |
+
| 414 | ++ | + + | +
| 415 | ++ |
+ #' Pre-processing function for use in `make_split_fun`+ |
+
| 416 | ++ |
+ #'+ |
+
| 417 | ++ |
+ #' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called+ |
+
| 418 | ++ |
+ #' directly by end users.+ |
+
| 419 | ++ |
+ #'+ |
+
| 420 | ++ |
+ #' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.+ |
+
| 421 | ++ |
+ #' @param spl (`VarLevelSplit`)\cr the split.+ |
+
| 422 | ++ |
+ #' @param ... additional parameters passed internally.+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' @seealso [make_split_fun()]+ |
+
| 425 | ++ |
+ #'+ |
+
| 426 | ++ |
+ #' @family make_custom_split+ |
+
| 427 | ++ |
+ #' @export+ |
+
| 428 | ++ |
+ drop_facet_levels <- function(df, spl, ...) {
+ |
+
| 429 | +2x | +
+ if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) {
+ |
+
| 430 | +! | +
+ stop("Unable to determine faceting variable in drop_facet_levels application.")
+ |
+
| 431 | ++ |
+ }+ |
+
| 432 | +2x | +
+ var <- spl_payload(spl)+ |
+
| 433 | +2x | +
+ df[[var]] <- factor(df[[var]])+ |
+
| 434 | +2x | +
+ df+ |
+
| 435 | ++ |
+ }+ |
+
| 1 | ++ |
+ .reindex_one_pos <- function(refs, cur_idx_fun) {
+ |
+
| 2 | +2223x | +
+ if (length(refs) == 0) {
+ |
+
| 3 | +2157x | +
+ return(refs)+ |
+
| 4 | ++ |
+ }+ |
+
| 5 | ++ | + + | +
| 6 | +66x | +
+ lapply(refs, function(refi) {
+ |
+
| 7 | ++ |
+ ## these can be symbols, e.g. ^, †now, those are+ |
+
| 8 | ++ |
+ ## special and don't get reindexed cause they're not numbered+ |
+
| 9 | ++ |
+ ## to begin with+ |
+
| 10 | +71x | +
+ idx <- ref_index(refi)+ |
+
| 11 | +71x | +
+ if (is.na(idx) || !is.na(as.integer(idx))) {
+ |
+
| 12 | +71x | +
+ ref_index(refi) <- cur_idx_fun(refi)+ |
+
| 13 | ++ |
+ }+ |
+
| 14 | +71x | +
+ refi+ |
+
| 15 | ++ |
+ })+ |
+
| 16 | ++ |
+ }+ |
+
| 17 | ++ | + + | +
| 18 | +56x | +
+ setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))
+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ setMethod(+ |
+
| 21 | ++ |
+ ".idx_helper", "TableRow",+ |
+
| 22 | ++ |
+ function(tr, cur_idx_fun) {
+ |
+
| 23 | +54x | +
+ row_footnotes(tr) <- .reindex_one_pos(+ |
+
| 24 | +54x | +
+ row_footnotes(tr),+ |
+
| 25 | +54x | +
+ cur_idx_fun+ |
+
| 26 | ++ |
+ )+ |
+
| 27 | ++ | + + | +
| 28 | +54x | +
+ cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs,+ |
+
| 29 | +54x | +
+ .reindex_one_pos,+ |
+
| 30 | +54x | +
+ cur_idx_fun = cur_idx_fun+ |
+
| 31 | ++ |
+ )+ |
+
| 32 | +54x | +
+ tr+ |
+
| 33 | ++ |
+ }+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ setMethod(+ |
+
| 37 | ++ |
+ ".idx_helper", "VTableTree",+ |
+
| 38 | ++ |
+ function(tr, cur_idx_fun) {
+ |
+
| 39 | +2x | +
+ if (!labelrow_visible(tr)) {
+ |
+
| 40 | ++ |
+ stop("got a row footnote on a non-visible label row. this should never happen") # nocov
+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | +2x | +
+ lr <- tt_labelrow(tr)+ |
+
| 43 | ++ | + + | +
| 44 | +2x | +
+ row_footnotes(lr) <- .reindex_one_pos(+ |
+
| 45 | +2x | +
+ row_footnotes(lr),+ |
+
| 46 | +2x | +
+ cur_idx_fun+ |
+
| 47 | ++ |
+ )+ |
+
| 48 | ++ | + + | +
| 49 | +2x | +
+ tt_labelrow(tr) <- lr+ |
+
| 50 | ++ | + + | +
| 51 | +2x | +
+ tr+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ |
+ )+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ index_col_refs <- function(tt, cur_idx_fun) {
+ |
+
| 56 | +419x | +
+ ctree <- coltree(tt)+ |
+
| 57 | +419x | +
+ ctree <- .index_col_refs_inner(ctree, cur_idx_fun)+ |
+
| 58 | +419x | +
+ coltree(tt) <- ctree+ |
+
| 59 | +419x | +
+ tt+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ .index_col_refs_inner <- function(ctree, cur_idx_fun) {
+ |
+
| 63 | +1998x | +
+ col_footnotes(ctree) <- .reindex_one_pos(+ |
+
| 64 | +1998x | +
+ col_footnotes(ctree),+ |
+
| 65 | +1998x | +
+ cur_idx_fun+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | ++ | + + | +
| 68 | +1998x | +
+ if (is(ctree, "LayoutColTree")) {
+ |
+
| 69 | +747x | +
+ tree_children(ctree) <- lapply(tree_children(ctree),+ |
+
| 70 | +747x | +
+ .index_col_refs_inner,+ |
+
| 71 | +747x | +
+ cur_idx_fun = cur_idx_fun+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | +1998x | +
+ ctree+ |
+
| 75 | ++ |
+ ## cfs <- col_footnotes(ctree)+ |
+
| 76 | ++ |
+ ## if(length(unlist(cfs)) > 0) {
+ |
+
| 77 | ++ |
+ ## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,+ |
+
| 78 | ++ |
+ ## function(refs) lapply(refs, function(refi) {
+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ #' Update footnote indices on a built table+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' Re-indexes footnotes within a built table.+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @inheritParams gen_args+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @details+ |
+
| 88 | ++ |
+ #' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes+ |
+
| 89 | ++ |
+ #' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based+ |
+
| 90 | ++ |
+ #' on the full table.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @note In the future this should not generally need to be called manually.+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @export+ |
+
| 95 | ++ |
+ update_ref_indexing <- function(tt) {
+ |
+
| 96 | +419x | +
+ col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))+ |
+
| 97 | +419x | +
+ row_fnotes <- row_footnotes(tt)+ |
+
| 98 | +419x | +
+ cell_fnotes <- cell_footnotes(tt)+ |
+
| 99 | +419x | +
+ all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))+ |
+
| 100 | +419x | +
+ all_fns <- unlist(t(all_fns))+ |
+
| 101 | +419x | +
+ unique_fnotes <- unique(sapply(all_fns, ref_msg))+ |
+
| 102 | ++ | + + | +
| 103 | +419x | +
+ cur_index <- function(ref_fn) {
+ |
+
| 104 | +71x | +
+ match(ref_msg(ref_fn), unique_fnotes)+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | +419x | +
+ if (ncol(tt) > 0) {
+ |
+
| 108 | +419x | +
+ tt <- index_col_refs(tt, cur_index)+ |
+
| 109 | ++ |
+ } ## col_info(tt) <- index_col_refs(col_info(tt), cur_index)+ |
+
| 110 | ++ |
+ ## TODO when column refs are a thing we will+ |
+
| 111 | ++ |
+ ## still need to do those here before returning!!!+ |
+
| 112 | +419x | +
+ if (nrow(tt) == 0) {
+ |
+
| 113 | +16x | +
+ return(tt)+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ | + + | +
| 116 | +403x | +
+ rdf <- make_row_df(tt)+ |
+
| 117 | ++ | + + | +
| 118 | +403x | +
+ rdf <- rdf[rdf$nreflines > 0, ]+ |
+
| 119 | +403x | +
+ if (nrow(rdf) == 0) {
+ |
+
| 120 | +371x | +
+ return(tt)+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | +32x | +
+ for (i in seq_len(nrow(rdf))) {
+ |
+
| 124 | +56x | +
+ path <- unname(rdf$path[[i]])+ |
+
| 125 | +56x | +
+ tt_at_path(tt, path) <-+ |
+
| 126 | +56x | +
+ .idx_helper(+ |
+
| 127 | +56x | +
+ tt_at_path(tt, path),+ |
+
| 128 | +56x | +
+ cur_index+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | +32x | +
+ tt+ |
+
| 132 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Score functions for sorting `TableTrees`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @inheritParams gen_args+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @export+ |
+
| 8 | ++ |
+ #' @rdname score_funs+ |
+
| 9 | ++ |
+ cont_n_allcols <- function(tt) {
+ |
+
| 10 | +6x | +
+ ctab <- content_table(tt)+ |
+
| 11 | +6x | +
+ if (NROW(ctab) == 0) {
+ |
+
| 12 | +2x | +
+ stop(+ |
+
| 13 | +2x | +
+ "cont_n_allcols score function used at subtable [",+ |
+
| 14 | +2x | +
+ obj_name(tt), "] that has no content table."+ |
+
| 15 | ++ |
+ )+ |
+
| 16 | ++ |
+ }+ |
+
| 17 | +4x | +
+ sum(sapply(+ |
+
| 18 | +4x | +
+ row_values(tree_children(ctab)[[1]]),+ |
+
| 19 | +4x | +
+ function(cv) cv[1]+ |
+
| 20 | ++ |
+ ))+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ #' @param j (`numeric(1)`)\cr index of column used for scoring.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @seealso For examples and details, please read the documentation for [sort_at_path()] and the+ |
+
| 26 | ++ |
+ #' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)+ |
+
| 27 | ++ |
+ #' vignette.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @export+ |
+
| 30 | ++ |
+ #' @rdname score_funs+ |
+
| 31 | ++ |
+ cont_n_onecol <- function(j) {
+ |
+
| 32 | +2x | +
+ function(tt) {
+ |
+
| 33 | +6x | +
+ ctab <- content_table(tt)+ |
+
| 34 | +6x | +
+ if (NROW(ctab) == 0) {
+ |
+
| 35 | +2x | +
+ stop(+ |
+
| 36 | +2x | +
+ "cont_n_allcols score function used at subtable [",+ |
+
| 37 | +2x | +
+ obj_name(tt), "] that has no content table."+ |
+
| 38 | ++ |
+ )+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | +4x | +
+ row_values(tree_children(ctab)[[1]])[[j]][1]+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' Sorting a table at a specific path+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @inheritParams gen_args+ |
+
| 49 | ++ |
+ #' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position+ |
+
| 50 | ++ |
+ #' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value+ |
+
| 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+ |
+
| 54 | ++ |
+ #' characters.+ |
+
| 55 | ++ |
+ #' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to+ |
+
| 56 | ++ |
+ #' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores+ |
+
| 57 | ++ |
+ #' should be placed in the order.+ |
+
| 58 | ++ |
+ #' @param .prev_path (`character`)\cr internal detail, do not set manually.+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done+ |
+
| 61 | ++ |
+ #' at `path`.+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' @details+ |
+
| 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+ |
+
| 66 | ++ |
+ #' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting+ |
+
| 67 | ++ |
+ #' operations.+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus+ |
+
| 70 | ++ |
+ #' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper+ |
+
| 71 | ++ |
+ #' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare+ |
+
| 72 | ++ |
+ #' it, which we encourage users to avoid.+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means+ |
+
| 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.+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by+ |
+
| 79 | ++ |
+ #' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the+ |
+
| 80 | ++ |
+ #' summary given by [table_structure()].+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related+ |
+
| 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+ |
+
| 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+ |
+
| 88 | ++ |
+ #' 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()) {
+ |
+
| 158 | +35x | +
+ if (NROW(tt) == 0) {
+ |
+
| 159 | +1x | +
+ return(tt)+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ | + + | +
| 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+ |
+
| 164 | +34x | +
+ if (path[1] == "root") {
+ |
+
| 165 | ++ |
+ ## always remove first root element but only add it to+ |
+
| 166 | ++ |
+ ## .prev_path (used for error reporting) if it actually matched the name+ |
+
| 167 | +1x | +
+ if (obj_name(tt) == "root") {
+ |
+
| 168 | +1x | +
+ .prev_path <- c(.prev_path, path[1])+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | +1x | +
+ path <- path[-1]+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | +34x | +
+ if (identical(obj_name(tt), path[1])) {
+ |
+
| 173 | +1x | +
+ .prev_path <- c(.prev_path, path[1])+ |
+
| 174 | +1x | +
+ path <- path[-1]+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ | + + | +
| 177 | +34x | +
+ curpath <- path+ |
+
| 178 | +34x | +
+ subtree <- tt+ |
+
| 179 | +34x | +
+ backpath <- c()+ |
+
| 180 | +34x | +
+ count <- 0+ |
+
| 181 | +34x | +
+ while (length(curpath) > 0) {
+ |
+
| 182 | +40x | +
+ curname <- curpath[1]+ |
+
| 183 | +40x | +
+ oldkids <- tree_children(subtree)+ |
+
| 184 | ++ |
+ ## we sort each child separately based on the score function+ |
+
| 185 | ++ |
+ ## and the remaining path+ |
+
| 186 | +40x | +
+ if (curname == "*") {
+ |
+
| 187 | +7x | +
+ oldnames <- vapply(oldkids, obj_name, "")+ |
+
| 188 | +7x | +
+ newkids <- lapply(+ |
+
| 189 | +7x | +
+ seq_along(oldkids),+ |
+
| 190 | +7x | +
+ function(i) {
+ |
+
| 191 | +27x | +
+ sort_at_path(oldkids[[i]],+ |
+
| 192 | +27x | +
+ path = curpath[-1],+ |
+
| 193 | +27x | +
+ scorefun = scorefun,+ |
+
| 194 | +27x | +
+ decreasing = decreasing,+ |
+
| 195 | +27x | +
+ na.pos = na.pos,+ |
+
| 196 | ++ |
+ ## its ok to modify the "path" here because its only ever used for+ |
+
| 197 | ++ |
+ ## informative error reporting.+ |
+
| 198 | +27x | +
+ .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | ++ |
+ )+ |
+
| 202 | +4x | +
+ names(newkids) <- oldnames+ |
+
| 203 | +4x | +
+ newtab <- subtree+ |
+
| 204 | +4x | +
+ tree_children(newtab) <- newkids+ |
+
| 205 | +4x | +
+ if (length(backpath) > 0) {
+ |
+
| 206 | +3x | +
+ ret <- recursive_replace(tt, backpath, value = newtab)+ |
+
| 207 | ++ |
+ } else {
+ |
+
| 208 | +1x | +
+ ret <- newtab+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | +4x | +
+ return(ret)+ |
+
| 211 | +33x | +
+ } else if (!(curname %in% names(oldkids))) {
+ |
+
| 212 | +1x | +
+ stop(+ |
+
| 213 | +1x | +
+ "Unable to find child(ren) '",+ |
+
| 214 | +1x | +
+ curname, "'\n\t occurred at path: ",+ |
+
| 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",+ |
+
| 217 | +1x | +
+ "'table_structure(obj)' to explore valid paths."+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ |
+ }+ |
+
| 220 | +32x | +
+ subtree <- tree_children(subtree)[[curname]]+ |
+
| 221 | +32x | +
+ backpath <- c(backpath, curpath[1])+ |
+
| 222 | +32x | +
+ curpath <- curpath[-1]+ |
+
| 223 | +32x | +
+ count <- count + 1+ |
+
| 224 | ++ |
+ }+ |
+
| 225 | +26x | +
+ real_backpath <- path[seq_len(count)]+ |
+
| 226 | ++ | + + | +
| 227 | +26x | +
+ na.pos <- match.arg(na.pos)+ |
+
| 228 | ++ |
+ ## subtree <- tt_at_path(tt, path)+ |
+
| 229 | +26x | +
+ kids <- tree_children(subtree)+ |
+
| 230 | ++ |
+ ## relax this to allow character "scores"+ |
+
| 231 | ++ |
+ ## scores <- vapply(kids, scorefun, NA_real_)+ |
+
| 232 | +26x | +
+ scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e))+ |
+
| 233 | +26x | +
+ errs <- which(vapply(scores, is, class2 = "error", TRUE))+ |
+
| 234 | +26x | +
+ if (length(errs) > 0) {
+ |
+
| 235 | +2x | +
+ stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
+ |
+
| 236 | +2x | +
+ "First error: ", scores[[errs[1]]]$message,+ |
+
| 237 | +2x | +
+ "\n\toccurred at path: ",+ |
+
| 238 | +2x | +
+ paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),+ |
+
| 239 | +2x | +
+ call. = FALSE+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | ++ |
+ } else {
+ |
+
| 242 | +24x | +
+ scores <- unlist(scores)+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | +24x | +
+ if (!is.null(dim(scores)) || length(scores) != length(kids)) {
+ |
+
| 245 | +! | +
+ stop(+ |
+
| 246 | +! | +
+ "Score function does not appear to have return exactly one ",+ |
+
| 247 | +! | +
+ "scalar value per child"+ |
+
| 248 | ++ |
+ )+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | +24x | +
+ if (is.na(decreasing)) {
+ |
+
| 251 | +8x | +
+ decreasing <- if (is.character(scores)) FALSE else TRUE+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | +24x | +
+ ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)+ |
+
| 254 | +24x | +
+ newkids <- kids[ord]+ |
+
| 255 | +24x | +
+ if (anyNA(scores) && na.pos == "omit") { # we did na last here
+ |
+
| 256 | +! | +
+ newkids <- head(newkids, -1 * sum(is.na(scores)))+ |
+
| 257 | ++ |
+ }+ |
+
| 258 | ++ | + + | +
| 259 | +24x | +
+ newtree <- subtree+ |
+
| 260 | +24x | +
+ tree_children(newtree) <- newkids+ |
+
| 261 | +24x | +
+ tt_at_path(tt, path) <- newtree+ |
+
| 262 | +24x | +
+ tt+ |
+
| 263 | ++ |
+ }+ |
+
| 1 | ++ |
+ ## NB handling the case where there are no values is done during tabulation+ |
+
| 2 | ++ |
+ ## which is the only reason expression(TRUE) is ok, because otherwise+ |
+
| 3 | ++ |
+ ## we (sometimes) run into+ |
+
| 4 | ++ |
+ ## factor()[TRUE] giving <NA> (i.e. length 1)+ |
+
| 5 | +4289x | +
+ 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+ |
+
| 12 | +3194x | +
+ if (length(value_expr(val)) > 0) {
+ |
+
| 13 | +12x | +
+ return(value_expr(val))+ |
+
| 14 | ++ |
+ }+ |
+
| 15 | ++ | + + | +
| 16 | +3182x | +
+ v <- unlist(rawvalues(val))+ |
+
| 17 | ++ |
+ ## XXX if we're including all levels should even missing be included?+ |
+
| 18 | +3182x | +
+ if (is(v, "AllLevelsSentinel")) {
+ |
+
| 19 | +9x | +
+ as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))+ |
+
| 20 | ++ |
+ } else {
+ |
+
| 21 | +3173x | +
+ as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(+ |
+
| 22 | +3173x | +
+ a = as.name(spl_payload(spl)),+ |
+
| 23 | +3173x | +
+ b = v+ |
+
| 24 | ++ |
+ )))+ |
+
| 25 | ++ |
+ }+ |
+
| 26 | ++ |
+ }+ |
+
| 27 | ++ |
+ )+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ setMethod(+ |
+
| 30 | ++ |
+ "make_subset_expr", "MultiVarSplit",+ |
+
| 31 | ++ |
+ function(spl, val) {
+ |
+
| 32 | ++ |
+ ## this is how custom split functions will communicate the correct expression+ |
+
| 33 | ++ |
+ ## to the column modeling code+ |
+
| 34 | +300x | +
+ if (length(value_expr(val)) > 0) {
+ |
+
| 35 | +! | +
+ return(value_expr(val))+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ ## v = rawvalues(val)+ |
+
| 39 | ++ |
+ ## as.expression(bquote(!is.na(.(a)), list(a = v)))+ |
+
| 40 | +300x | +
+ expression(TRUE)+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | ++ |
+ )+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ setMethod(+ |
+
| 45 | ++ |
+ "make_subset_expr", "AnalyzeVarSplit",+ |
+
| 46 | ++ |
+ function(spl, val) {
+ |
+
| 47 | +! | +
+ if (avar_inclNAs(spl)) {
+ |
+
| 48 | +! | +
+ expression(TRUE)+ |
+
| 49 | ++ |
+ } else {
+ |
+
| 50 | +! | +
+ as.expression(bquote(+ |
+
| 51 | +! | +
+ !is.na(.(a)),+ |
+
| 52 | +! | +
+ list(a = as.name(spl_payload(spl)))+ |
+
| 53 | ++ |
+ ))+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ |
+ }+ |
+
| 56 | ++ |
+ )+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ setMethod(+ |
+
| 59 | ++ |
+ "make_subset_expr", "AnalyzeColVarSplit",+ |
+
| 60 | ++ |
+ function(spl, val) {
+ |
+
| 61 | +! | +
+ expression(TRUE)+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ |
+ )+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ ## XXX these are going to be ridiculously slow+ |
+
| 66 | ++ |
+ ## FIXME+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ setMethod(+ |
+
| 69 | ++ |
+ "make_subset_expr", "VarStaticCutSplit",+ |
+
| 70 | ++ |
+ function(spl, val) {
+ |
+
| 71 | +135x | +
+ v <- rawvalues(val)+ |
+
| 72 | ++ |
+ ## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),+ |
+
| 73 | +135x | +
+ as.expression(bquote(+ |
+
| 74 | +135x | +
+ cut(.(a),+ |
+
| 75 | +135x | +
+ breaks = .(brk), labels = .(labels),+ |
+
| 76 | +135x | +
+ include.lowest = TRUE+ |
+
| 77 | +135x | +
+ ) == .(b),+ |
+
| 78 | +135x | +
+ list(+ |
+
| 79 | +135x | +
+ a = as.name(spl_payload(spl)),+ |
+
| 80 | +135x | +
+ b = v,+ |
+
| 81 | +135x | +
+ brk = spl_cuts(spl),+ |
+
| 82 | +135x | +
+ labels = spl_cutlabels(spl)+ |
+
| 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)+ |
+
| 93 | ++ |
+ ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),+ |
+
| 94 | +63x | +
+ as.expression(bquote(+ |
+
| 95 | +63x | +
+ as.integer(cut(.(a),+ |
+
| 96 | +63x | +
+ breaks = .(brk),+ |
+
| 97 | +63x | +
+ labels = .(labels),+ |
+
| 98 | +63x | +
+ include.lowest = TRUE+ |
+
| 99 | ++ |
+ )) <=+ |
+
| 100 | +63x | +
+ as.integer(factor(.(b), levels = .(labels))),+ |
+
| 101 | +63x | +
+ list(+ |
+
| 102 | +63x | +
+ a = as.name(spl_payload(spl)),+ |
+
| 103 | +63x | +
+ b = v,+ |
+
| 104 | +63x | +
+ brk = spl_cuts(spl),+ |
+
| 105 | +63x | +
+ labels = spl_cutlabels(spl)+ |
+
| 106 | ++ |
+ )+ |
+
| 107 | ++ |
+ ))+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ | + + | +
| 111 | ++ |
+ ## I think this one is unnecessary,+ |
+
| 112 | ++ |
+ ## build_table collapses DynCutSplits into+ |
+
| 113 | ++ |
+ ## static ones.+ |
+
| 114 | ++ |
+ ##+ |
+
| 115 | ++ |
+ ## XXX TODO fixme+ |
+
| 116 | ++ |
+ ## setMethod("make_subset_expr", "VarDynCutSplit",
+ |
+
| 117 | ++ |
+ ## function(spl, val) {
+ |
+
| 118 | ++ |
+ ## v = rawvalues(val)+ |
+
| 119 | ++ |
+ ## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)),+ |
+
| 120 | ++ |
+ ## as.expression(bquote(.(fun)(.(a)) == .(b)),+ |
+
| 121 | ++ |
+ ## list(a = as.name(spl_payload(spl)),+ |
+
| 122 | ++ |
+ ## b = v,+ |
+
| 123 | ++ |
+ ## fun = spl@cut_fun))+ |
+
| 124 | ++ |
+ ## })+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ setMethod(+ |
+
| 127 | ++ |
+ "make_subset_expr", "AllSplit",+ |
+
| 128 | +327x | +
+ function(spl, val) expression(TRUE)+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ ## probably don't need this+ |
+
| 132 | ++ | + + | +
| 133 | ++ |
+ setMethod(+ |
+
| 134 | ++ |
+ "make_subset_expr", "expression",+ |
+
| 135 | +! | +
+ function(spl, val) spl+ |
+
| 136 | ++ |
+ )+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ setMethod(+ |
+
| 139 | ++ |
+ "make_subset_expr", "character",+ |
+
| 140 | ++ |
+ function(spl, val) {
+ |
+
| 141 | +! | +
+ newspl <- VarLevelSplit(spl, spl)+ |
+
| 142 | +! | +
+ make_subset_expr(newspl, val)+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | ++ | + + | +
| 146 | ++ |
+ .combine_subset_exprs <- function(ex1, ex2) {
+ |
+
| 147 | +2922x | +
+ if (is.null(ex1) || identical(ex1, expression(TRUE))) {
+ |
+
| 148 | +1852x | +
+ if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
+ |
+
| 149 | +1419x | +
+ return(ex2)+ |
+
| 150 | ++ |
+ } else {
+ |
+
| 151 | +433x | +
+ return(expression(TRUE))+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ ## if(is.null(ex2))+ |
+
| 156 | ++ |
+ ## ex2 <- expression(TRUE)+ |
+
| 157 | +1070x | +
+ stopifnot(is.expression(ex1), is.expression(ex2))+ |
+
| 158 | +1070x | +
+ as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))+ |
+
| 159 | ++ |
+ }+ |
+
| 160 | ++ | + + | +
| 161 | ++ |
+ make_pos_subset <- function(spls = pos_splits(pos),+ |
+
| 162 | ++ |
+ svals = pos_splvals(pos),+ |
+
| 163 | ++ |
+ pos) {
+ |
+
| 164 | +1003x | +
+ expr <- NULL+ |
+
| 165 | +1003x | +
+ for (i in seq_along(spls)) {
+ |
+
| 166 | +1555x | +
+ newexpr <- make_subset_expr(spls[[i]], svals[[i]])+ |
+
| 167 | +1555x | +
+ expr <- .combine_subset_exprs(expr, newexpr)+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | +1003x | +
+ expr+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ get_pos_extra <- function(svals = pos_splvals(pos),+ |
+
| 173 | ++ |
+ pos) {
+ |
+
| 174 | +1009x | +
+ ret <- list()+ |
+
| 175 | +1009x | +
+ for (i in seq_along(svals)) {
+ |
+
| 176 | +1567x | +
+ extrs <- splv_extra(svals[[i]])+ |
+
| 177 | +1567x | +
+ if (any(names(ret) %in% names(extrs))) {
+ |
+
| 178 | +! | +
+ stop("same extra argument specified at multiple levels of nesting. Not currently supported")
+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | +1567x | +
+ ret <- c(ret, extrs)+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | +1009x | +
+ ret+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ get_col_extras <- function(ctree) {
+ |
+
| 186 | +320x | +
+ leaves <- collect_leaves(ctree)+ |
+
| 187 | +320x | +
+ lapply(+ |
+
| 188 | +320x | +
+ leaves,+ |
+
| 189 | +320x | +
+ function(x) get_pos_extra(pos = tree_pos(x))+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ setGeneric(+ |
+
| 194 | ++ |
+ "make_col_subsets",+ |
+
| 195 | +1322x | +
+ function(lyt, df) standardGeneric("make_col_subsets")
+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | ++ | + + | +
| 198 | ++ |
+ setMethod(+ |
+
| 199 | ++ |
+ "make_col_subsets", "LayoutColTree",+ |
+
| 200 | ++ |
+ function(lyt, df) {
+ |
+
| 201 | +319x | +
+ leaves <- collect_leaves(lyt)+ |
+
| 202 | +319x | +
+ lapply(leaves, make_col_subsets)+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ | + + | +
| 206 | ++ |
+ setMethod(+ |
+
| 207 | ++ |
+ "make_col_subsets", "LayoutColLeaf",+ |
+
| 208 | ++ |
+ function(lyt, df) {
+ |
+
| 209 | +1003x | +
+ make_pos_subset(pos = tree_pos(lyt))+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | ++ |
+ )+ |
+
| 212 | ++ | + + | +
| 213 | ++ |
+ create_colinfo <- function(lyt, df, rtpos = TreePos(),+ |
+
| 214 | ++ |
+ counts = NULL,+ |
+
| 215 | ++ |
+ alt_counts_df = NULL,+ |
+
| 216 | ++ |
+ total = NULL,+ |
+
| 217 | ++ |
+ topleft = NULL) {
+ |
+
| 218 | ++ |
+ ## this will work whether clayout is pre or post+ |
+
| 219 | ++ |
+ ## data+ |
+
| 220 | +325x | +
+ clayout <- clayout(lyt)+ |
+
| 221 | +325x | +
+ if (is.null(topleft)) {
+ |
+
| 222 | +325x | +
+ topleft <- top_left(lyt)+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | +325x | +
+ cc_format <- colcount_format(lyt) %||% "(N=xx)"+ |
+
| 225 | ++ | + + | +
| 226 | ++ |
+ ## do it this way for full backwards compatibility+ |
+
| 227 | +325x | +
+ if (is.null(alt_counts_df)) {
+ |
+
| 228 | +306x | +
+ alt_counts_df <- df+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | +325x | +
+ ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format)+ |
+
| 231 | +318x | +
+ if (!is.na(disp_ccounts(lyt))) {
+ |
+
| 232 | +81x | +
+ leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path+ |
+
| 233 | +81x | +
+ for (path in leaf_pths) {
+ |
+
| 234 | +323x | +
+ colcount_visible(ctree, path) <- disp_ccounts(lyt)+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | ++ | + + | +
| 238 | +318x | +
+ cexprs <- make_col_subsets(ctree, df)+ |
+
| 239 | +318x | +
+ colextras <- col_extra_args(ctree)+ |
+
| 240 | ++ | + + | +
| 241 | ++ |
+ ## calculate the counts based on the df+ |
+
| 242 | ++ |
+ ## This presumes that it is called on the WHOLE dataset,+ |
+
| 243 | ++ |
+ ## NOT after any splitting has occurred. Otherwise+ |
+
| 244 | ++ |
+ ## the counts will obviously be wrong.+ |
+
| 245 | +318x | +
+ if (is.null(counts)) {
+ |
+
| 246 | +314x | +
+ counts <- rep(NA_integer_, length(cexprs))+ |
+
| 247 | +4x | +
+ } else if (length(counts) != length(cexprs)) {
+ |
+
| 248 | +1x | +
+ stop(+ |
+
| 249 | +1x | +
+ "Length of overriding counts must equal number of columns. Got ",+ |
+
| 250 | +1x | +
+ length(counts), " values for ", length(cexprs), " columns. ",+ |
+
| 251 | +1x | +
+ "Use NAs to specify that the default counting machinery should be ",+ |
+
| 252 | +1x | +
+ "used for that position."+ |
+
| 253 | ++ |
+ )+ |
+
| 254 | ++ |
+ }+ |
+
| 255 | ++ | + + | +
| 256 | +317x | +
+ counts_df_name <- "alt_counts_df"+ |
+
| 257 | +317x | +
+ if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
+ |
+
| 258 | +302x | +
+ alt_counts_df <- df+ |
+
| 259 | +302x | +
+ counts_df_name <- "df"+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | +317x | +
+ calcpos <- is.na(counts)+ |
+
| 262 | ++ | + + | +
| 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 | ++ |
+ } else {
+ |
+
| 269 | +845x | +
+ vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)+ |
+
| 270 | +845x | +
+ if (is(vec, "numeric")) {
+ |
+
| 271 | +! | +
+ length(vec)+ |
+
| 272 | +845x | +
+ } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
+ |
+
| 273 | +845x | +
+ sum(vec, na.rm = TRUE)+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ |
+ })+ |
+
| 277 | +317x | +
+ counts[calcpos] <- calccounts[calcpos]+ |
+
| 278 | +317x | +
+ counts <- as.integer(counts)+ |
+
| 279 | +317x | +
+ if (is.null(total)) {
+ |
+
| 280 | +! | +
+ total <- sum(counts)+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | ++ | + + | +
| 283 | +317x | +
+ cpths <- col_paths(ctree)+ |
+
| 284 | +317x | +
+ for (i in seq_along(cpths)) {
+ |
+
| 285 | +994x | +
+ facet_colcount(ctree, cpths[[i]]) <- counts[i]+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | +317x | +
+ InstantiatedColumnInfo(+ |
+
| 288 | +317x | +
+ treelyt = ctree,+ |
+
| 289 | +317x | +
+ csubs = cexprs,+ |
+
| 290 | +317x | +
+ extras = colextras,+ |
+
| 291 | +317x | +
+ cnts = counts,+ |
+
| 292 | +317x | +
+ dispcounts = disp_ccounts(lyt),+ |
+
| 293 | +317x | +
+ countformat = cc_format,+ |
+
| 294 | +317x | +
+ total_cnt = total,+ |
+
| 295 | +317x | +
+ topleft = topleft+ |
+
| 296 | ++ |
+ )+ |
+
| 297 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Trimming and pruning criteria+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Criteria functions (and constructors thereof) for trimming and pruning tables.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams gen_args+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [prune_table()], [trim_rows()]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`*+ |
+
| 12 | ++ |
+ #' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' adsl <- ex_adsl+ |
+
| 16 | ++ |
+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ |
+
| 17 | ++ |
+ #' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0+ |
+
| 18 | ++ |
+ #' adsl$BMRKR1 <- 0+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' tbl_to_prune <- basic_table() %>%+ |
+
| 21 | ++ |
+ #' analyze("BMRKR1") %>%
+ |
+
| 22 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 23 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 24 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 25 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+
| 26 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 27 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 28 | ++ |
+ #' build_table(adsl)+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' tbl_to_prune %>% prune_table(all_zero_or_na)+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @rdname trim_prune_funs+ |
+
| 33 | ++ |
+ #' @export+ |
+
| 34 | ++ |
+ all_zero_or_na <- function(tr) {
+ |
+
| 35 | +347x | +
+ if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ |
+
| 36 | +93x | +
+ return(FALSE)+ |
+
| 37 | ++ |
+ }+ |
+
| 38 | +254x | +
+ rvs <- unlist(unname(row_values(tr)))+ |
+
| 39 | +254x | +
+ all(is.na(rvs) | rvs == 0 | !is.finite(rvs))+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ #' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @examples+ |
+
| 45 | ++ |
+ #' tbl_to_prune %>% prune_table(all_zero)+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @rdname trim_prune_funs+ |
+
| 48 | ++ |
+ #' @export+ |
+
| 49 | ++ |
+ all_zero <- function(tr) {
+ |
+
| 50 | +8x | +
+ if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ |
+
| 51 | +! | +
+ return(FALSE)+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | +8x | +
+ rvs <- unlist(unname(row_values(tr)))+ |
+
| 54 | +8x | +
+ isTRUE(all(rvs == 0))+ |
+
| 55 | ++ |
+ }+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ #' Trim rows from a populated table without regard for table structure+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' @inheritParams gen_args+ |
+
| 60 | ++ |
+ #' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row+ |
+
| 61 | ++ |
+ #' should be removed. Defaults to [all_zero_or_na()].+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' @return The table with rows that have only `NA` or 0 cell values removed.+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' @note+ |
+
| 66 | ++ |
+ #' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or+ |
+
| 67 | ++ |
+ #' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on+ |
+
| 68 | ++ |
+ #' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @details+ |
+
| 71 | ++ |
+ #' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]+ |
+
| 72 | ++ |
+ #' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure+ |
+
| 73 | ++ |
+ #' into account.+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ #' @seealso [prune_table()]+ |
+
| 76 | ++ |
+ #'+ |
+
| 77 | ++ |
+ #' @examples+ |
+
| 78 | ++ |
+ #' adsl <- ex_adsl+ |
+
| 79 | ++ |
+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' tbl_to_trim <- basic_table() %>%+ |
+
| 82 | ++ |
+ #' analyze("BMRKR1") %>%
+ |
+
| 83 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 84 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 85 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 86 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+
| 87 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 88 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 89 | ++ |
+ #' build_table(adsl)+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' tbl_to_trim %>% trim_rows()+ |
+
| 92 | ++ |
+ #'+ |
+
| 93 | ++ |
+ #' tbl_to_trim %>% trim_rows(all_zero)+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' @export+ |
+
| 96 | ++ |
+ trim_rows <- function(tt, criteria = all_zero_or_na) {
+ |
+
| 97 | +3x | +
+ rows <- collect_leaves(tt, TRUE, TRUE)+ |
+
| 98 | +3x | +
+ torm <- vapply(rows, criteria,+ |
+
| 99 | +3x | +
+ NA,+ |
+
| 100 | +3x | +
+ USE.NAMES = FALSE+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | +3x | +
+ tt[!torm, ,+ |
+
| 103 | +3x | +
+ keep_topleft = TRUE,+ |
+
| 104 | +3x | +
+ keep_titles = TRUE,+ |
+
| 105 | +3x | +
+ keep_footers = TRUE,+ |
+
| 106 | +3x | +
+ reindex_refs = TRUE+ |
+
| 107 | ++ |
+ ]+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ #' @inheritParams trim_rows+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @details+ |
+
| 113 | ++ |
+ #' `content_all_zeros_nas` prunes a subtable if both of the following are true:+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' * It has a content table with exactly one row in it.+ |
+
| 116 | ++ |
+ #' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content+ |
+
| 117 | ++ |
+ #' function is used, this represents pruning any subtable which corresponds to an empty set of the input data+ |
+
| 118 | ++ |
+ #' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @examples+ |
+
| 121 | ++ |
+ #' tbl_to_prune %>% prune_table(content_all_zeros_nas)+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @rdname trim_prune_funs+ |
+
| 124 | ++ |
+ #' @export+ |
+
| 125 | ++ |
+ content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
+ |
+
| 126 | ++ |
+ ## this will be NULL if+ |
+
| 127 | ++ |
+ ## tt is something that doesn't have a content table+ |
+
| 128 | +254x | +
+ ct <- content_table(tt)+ |
+
| 129 | ++ |
+ ## NROW returns 0 for NULL.+ |
+
| 130 | +254x | +
+ if (NROW(ct) == 0 || nrow(ct) > 1) {
+ |
+
| 131 | +242x | +
+ return(FALSE)+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | +12x | +
+ cr <- tree_children(ct)[[1]]+ |
+
| 135 | +12x | +
+ criteria(cr)+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' @details+ |
+
| 139 | ++ |
+ #' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on+ |
+
| 140 | ++ |
+ #' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no+ |
+
| 141 | ++ |
+ #' children.+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' @examples+ |
+
| 144 | ++ |
+ #' tbl_to_prune %>% prune_table(prune_empty_level)+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @rdname trim_prune_funs+ |
+
| 147 | ++ |
+ #' @export+ |
+
| 148 | ++ |
+ prune_empty_level <- function(tt) {
+ |
+
| 149 | +389x | +
+ if (is(tt, "TableRow")) {
+ |
+
| 150 | +151x | +
+ return(all_zero_or_na(tt))+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | +238x | +
+ if (content_all_zeros_nas(tt)) {
+ |
+
| 154 | +2x | +
+ return(TRUE)+ |
+
| 155 | ++ |
+ }+ |
+
| 156 | +236x | +
+ kids <- tree_children(tt)+ |
+
| 157 | +236x | +
+ length(kids) == 0+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | ++ |
+ #' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes+ |
+
| 161 | ++ |
+ #' only in the case of all non-missing zero values.+ |
+
| 162 | ++ |
+ #'+ |
+
| 163 | ++ |
+ #' @examples+ |
+
| 164 | ++ |
+ #' tbl_to_prune %>% prune_table(prune_zeros_only)+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' @rdname trim_prune_funs+ |
+
| 167 | ++ |
+ #' @export+ |
+
| 168 | ++ |
+ prune_zeros_only <- function(tt) {
+ |
+
| 169 | +16x | +
+ if (is(tt, "TableRow")) {
+ |
+
| 170 | +8x | +
+ return(all_zero(tt))+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | ++ | + + | +
| 173 | +8x | +
+ if (content_all_zeros_nas(tt, criteria = all_zero)) {
+ |
+
| 174 | +! | +
+ return(TRUE)+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | +8x | +
+ kids <- tree_children(tt)+ |
+
| 177 | +8x | +
+ length(kids) == 0+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | ++ | + + | +
| 180 | ++ |
+ #' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.+ |
+
| 181 | ++ |
+ #' Subtables whose combined/average count are below this threshold will be pruned.+ |
+
| 182 | ++ |
+ #' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.+ |
+
| 183 | ++ |
+ #'+ |
+
| 184 | ++ |
+ #' @details+ |
+
| 185 | ++ |
+ #' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which+ |
+
| 186 | ++ |
+ #' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell+ |
+
| 187 | ++ |
+ #' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.+ |
+
| 188 | ++ |
+ #'+ |
+
| 189 | ++ |
+ #' @examples+ |
+
| 190 | ++ |
+ #' min_prune <- low_obs_pruner(70, "sum")+ |
+
| 191 | ++ |
+ #' tbl_to_prune %>% prune_table(min_prune)+ |
+
| 192 | ++ |
+ #'+ |
+
| 193 | ++ |
+ #' @rdname trim_prune_funs+ |
+
| 194 | ++ |
+ #' @export+ |
+
| 195 | ++ |
+ low_obs_pruner <- function(min, type = c("sum", "mean")) {
+ |
+
| 196 | +3x | +
+ type <- match.arg(type)+ |
+
| 197 | +3x | +
+ function(tt) {
+ |
+
| 198 | +21x | +
+ if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
+ |
+
| 199 | +9x | +
+ return(FALSE) ## only trimming on count content rows+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | +12x | +
+ ctr <- tree_children(ctab)[[1]]+ |
+
| 202 | +12x | +
+ vals <- sapply(row_values(ctr), function(v) v[[1]])+ |
+
| 203 | +12x | +
+ sumvals <- sum(vals)+ |
+
| 204 | +12x | +
+ if (type == "mean") {
+ |
+
| 205 | +8x | +
+ sumvals <- sumvals / length(vals)+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | +12x | +
+ sumvals < min+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ #' Recursively prune a `TableTree`+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @inheritParams gen_args+ |
+
| 214 | ++ |
+ #' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the+ |
+
| 215 | ++ |
+ #' entire subtree should be removed.+ |
+
| 216 | ++ |
+ #' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.+ |
+
| 217 | ++ |
+ #' Defaults to `NA` which indicates pruning should happen at all levels.+ |
+
| 218 | ++ |
+ #' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @return A `TableTree` pruned via recursive application of `prune_func`.+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included+ |
+
| 223 | ++ |
+ #' in the `rtables` package.+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' @examples+ |
+
| 226 | ++ |
+ #' adsl <- ex_adsl+ |
+
| 227 | ++ |
+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ |
+
| 228 | ++ |
+ #'+ |
+
| 229 | ++ |
+ #' tbl_to_prune <- basic_table() %>%+ |
+
| 230 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 231 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 232 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 233 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+
| 234 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 235 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 236 | ++ |
+ #' build_table(adsl)+ |
+
| 237 | ++ |
+ #'+ |
+
| 238 | ++ |
+ #' tbl_to_prune %>% prune_table()+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @export+ |
+
| 241 | ++ |
+ prune_table <- function(tt,+ |
+
| 242 | ++ |
+ prune_func = prune_empty_level,+ |
+
| 243 | ++ |
+ stop_depth = NA_real_,+ |
+
| 244 | ++ |
+ depth = 0) {
+ |
+
| 245 | +323x | +
+ if (!is.na(stop_depth) && depth > stop_depth) {
+ |
+
| 246 | +! | +
+ return(tt)+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | +323x | +
+ if (is(tt, "TableRow")) {
+ |
+
| 249 | +54x | +
+ if (prune_func(tt)) {
+ |
+
| 250 | +! | +
+ tt <- NULL+ |
+
| 251 | ++ |
+ }+ |
+
| 252 | +54x | +
+ return(tt)+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ | + + | +
| 255 | +269x | +
+ kids <- tree_children(tt)+ |
+
| 256 | ++ | + + | +
| 257 | +269x | +
+ torm <- vapply(kids, function(tb) {
+ |
+
| 258 | +386x | +
+ !is.null(tb) && prune_func(tb)+ |
+
| 259 | +269x | +
+ }, NA)+ |
+
| 260 | ++ | + + | +
| 261 | +269x | +
+ keepkids <- kids[!torm]+ |
+
| 262 | +269x | +
+ keepkids <- lapply(keepkids, prune_table,+ |
+
| 263 | +269x | +
+ prune_func = prune_func,+ |
+
| 264 | +269x | +
+ stop_depth = stop_depth,+ |
+
| 265 | +269x | +
+ depth = depth + 1+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ | + + | +
| 268 | +269x | +
+ keepkids <- keepkids[!vapply(keepkids, is.null, NA)]+ |
+
| 269 | +269x | +
+ if (length(keepkids) > 0) {
+ |
+
| 270 | +135x | +
+ tree_children(tt) <- keepkids+ |
+
| 271 | ++ |
+ } else {
+ |
+
| 272 | +134x | +
+ tt <- NULL+ |
+
| 273 | ++ |
+ }+ |
+
| 274 | +269x | +
+ tt+ |
+
| 275 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Compare two rtables+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Prints a matrix where `.` means cell matches, `X` means cell does+ |
+
| 4 | ++ |
+ #' not match, `+` cell (row) is missing, and `-` cell (row)+ |
+
| 5 | ++ |
+ #' should not be there. If `structure` is set to `TRUE`, `C` indicates+ |
+
| 6 | ++ |
+ #' column-structure mismatch, `R` indicates row-structure mismatch, and+ |
+
| 7 | ++ |
+ #' `S` indicates mismatch in both row and column structure.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @param object (`VTableTree`)\cr `rtable` to test.+ |
+
| 10 | ++ |
+ #' @param expected (`VTableTree`)\cr expected `rtable`.+ |
+
| 11 | ++ |
+ #' @param tol (`numeric(1)`)\cr tolerance.+ |
+
| 12 | ++ |
+ #' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are+ |
+
| 13 | ++ |
+ #' silently ignored.+ |
+
| 14 | ++ |
+ #' @param structure (`flag`)\cr whether structures (in the form of column and row+ |
+
| 15 | ++ |
+ #' paths to cells) should be compared. Currently defaults to `FALSE`, but this is+ |
+
| 16 | ++ |
+ #' subject to change in future versions.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @note In its current form, `compare_rtables` does not take structure into+ |
+
| 19 | ++ |
+ #' account, only row and cell position.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @return A matrix of class `rtables_diff` representing the differences+ |
+
| 22 | ++ |
+ #' between `object` and `expected` as described above.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
+ |
+
| 26 | ++ |
+ #' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' compare_rtables(object = t1, expected = t2)+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' if (interactive()) {
+ |
+
| 31 | ++ |
+ #' Viewer(t1, t2)+ |
+
| 32 | ++ |
+ #' }+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' expected <- rtable(+ |
+
| 35 | ++ |
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ |
+
| 36 | ++ |
+ #' format = "xx",+ |
+
| 37 | ++ |
+ #' rrow("row 1", 10, 15),
+ |
+
| 38 | ++ |
+ #' rrow(),+ |
+
| 39 | ++ |
+ #' rrow("section title"),
+ |
+
| 40 | ++ |
+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' expected+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' object <- rtable(+ |
+
| 46 | ++ |
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ |
+
| 47 | ++ |
+ #' format = "xx",+ |
+
| 48 | ++ |
+ #' rrow("row 1", 10, 15),
+ |
+
| 49 | ++ |
+ #' rrow("section title"),
+ |
+
| 50 | ++ |
+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' compare_rtables(object, expected, comp.attr = FALSE)+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' object <- rtable(+ |
+
| 56 | ++ |
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ |
+
| 57 | ++ |
+ #' format = "xx",+ |
+
| 58 | ++ |
+ #' rrow("row 1", 10, 15),
+ |
+
| 59 | ++ |
+ #' rrow(),+ |
+
| 60 | ++ |
+ #' rrow("section title")
+ |
+
| 61 | ++ |
+ #' )+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' compare_rtables(object, expected)+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' object <- rtable(+ |
+
| 66 | ++ |
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ |
+
| 67 | ++ |
+ #' format = "xx",+ |
+
| 68 | ++ |
+ #' rrow("row 1", 14, 15.03),
+ |
+
| 69 | ++ |
+ #' rrow(),+ |
+
| 70 | ++ |
+ #' rrow("section title"),
+ |
+
| 71 | ++ |
+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' compare_rtables(object, expected)+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' object <- rtable(+ |
+
| 77 | ++ |
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ |
+
| 78 | ++ |
+ #' format = "xx",+ |
+
| 79 | ++ |
+ #' rrow("row 1", 10, 15),
+ |
+
| 80 | ++ |
+ #' rrow(),+ |
+
| 81 | ++ |
+ #' rrow("section title"),
+ |
+
| 82 | ++ |
+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
+ |
+
| 83 | ++ |
+ #' )+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' compare_rtables(object, expected)+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @export+ |
+
| 88 | ++ |
+ compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,+ |
+
| 89 | ++ |
+ structure = FALSE) {
+ |
+
| 90 | ++ |
+ # if (identical(object, expected)) return(invisible(TRUE))+ |
+
| 91 | ++ | + + | +
| 92 | +12x | +
+ if (!is(object, "VTableTree")) {
+ |
+
| 93 | +! | +
+ stop(+ |
+
| 94 | +! | +
+ "argument object is expected to be of class TableTree or ",+ |
+
| 95 | +! | +
+ "ElementaryTable"+ |
+
| 96 | ++ |
+ )+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | +12x | +
+ if (!is(expected, "VTableTree")) {
+ |
+
| 99 | +! | +
+ stop(+ |
+
| 100 | +! | +
+ "argument expected is expected to be of class TableTree or ",+ |
+
| 101 | +! | +
+ "ElementaryTable"+ |
+
| 102 | ++ |
+ )+ |
+
| 103 | ++ |
+ }+ |
+
| 104 | +12x | +
+ dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)+ |
+
| 105 | ++ | + + | +
| 106 | +12x | +
+ X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
+ |
+
| 107 | +12x | +
+ row.names(X) <- as.character(1:dim_out[1])+ |
+
| 108 | +12x | +
+ colnames(X) <- as.character(1:dim_out[2])+ |
+
| 109 | ++ | + + | +
| 110 | +12x | +
+ if (!identical(names(object), names(expected))) {
+ |
+
| 111 | +7x | +
+ attr(X, "info") <- "column names are not the same"+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ | + + | +
| 114 | +12x | +
+ if (!comp.attr) {
+ |
+
| 115 | +! | +
+ attr(X, "info") <- c(+ |
+
| 116 | +! | +
+ attr(X, "info"),+ |
+
| 117 | +! | +
+ "cell attributes have not been compared"+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | +12x | +
+ if (!identical(row.names(object), row.names(expected))) {
+ |
+
| 121 | +2x | +
+ attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")+ |
+
| 122 | ++ |
+ }+ |
+
| 123 | ++ | + + | +
| 124 | +12x | +
+ nro <- nrow(object)+ |
+
| 125 | +12x | +
+ nre <- nrow(expected)+ |
+
| 126 | +12x | +
+ nco <- ncol(object)+ |
+
| 127 | +12x | +
+ nce <- ncol(expected)+ |
+
| 128 | ++ | + + | +
| 129 | +12x | +
+ if (nco < nce) {
+ |
+
| 130 | +2x | +
+ X[, seq(nco + 1, nce)] <- "-"+ |
+
| 131 | +10x | +
+ } else if (nce < nco) {
+ |
+
| 132 | +3x | +
+ X[, seq(nce + 1, nco)] <- "+"+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | +12x | +
+ if (nro < nre) {
+ |
+
| 135 | +1x | +
+ X[seq(nro + 1, nre), ] <- "-"+ |
+
| 136 | +11x | +
+ } else if (nre < nro) {
+ |
+
| 137 | +! | +
+ X[seq(nre + 1, nro), ] <- "+"+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ | + + | +
| 140 | +12x | +
+ orig_object <- object # nolint+ |
+
| 141 | +12x | +
+ orig_expected <- expected # nolint+ |
+
| 142 | +12x | +
+ if (nro != nre || nco != nce) {
+ |
+
| 143 | +5x | +
+ object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]+ |
+
| 144 | +5x | +
+ expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]+ |
+
| 145 | +5x | +
+ inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)+ |
+
| 146 | +5x | +
+ X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner+ |
+
| 147 | +5x | +
+ class(X) <- c("rtables_diff", class(X))
+ |
+
| 148 | +5x | +
+ return(X)+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ ## from here dimensions match!+ |
+
| 152 | ++ | + + | +
| 153 | +7x | +
+ orows <- cell_values(object, omit_labrows = FALSE)+ |
+
| 154 | +7x | +
+ erows <- cell_values(expected, omit_labrows = FALSE)+ |
+
| 155 | +7x | +
+ if (nrow(object) == 1) {
+ |
+
| 156 | +! | +
+ orows <- list(orows)+ |
+
| 157 | +! | +
+ erows <- list(erows)+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | +7x | +
+ res <- mapply(compare_rrows,+ |
+
| 160 | +7x | +
+ row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),+ |
+
| 161 | +7x | +
+ USE.NAMES = FALSE, SIMPLIFY = FALSE+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | +7x | +
+ X <- do.call(rbind, res)+ |
+
| 164 | +7x | +
+ rpo <- row_paths(object)+ |
+
| 165 | +7x | +
+ rpe <- row_paths(expected)+ |
+
| 166 | ++ | + + | +
| 167 | +7x | +
+ if (comp.attr) {
+ |
+
| 168 | +7x | +
+ ofmts <- value_formats(object)+ |
+
| 169 | +7x | +
+ efmts <- value_formats(expected)+ |
+
| 170 | ++ |
+ ## dim(ofmts) <- NULL+ |
+
| 171 | ++ |
+ ## dim(efmts) <- NULL+ |
+
| 172 | ++ | + + | +
| 173 | +7x | +
+ fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim+ |
+
| 174 | ++ | + + | +
| 175 | ++ | + + | +
| 176 | ++ |
+ ## note the single index here!!!, no comma!!!!+ |
+
| 177 | +7x | +
+ X[fmt_mismatch] <- "X"+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | ++ | + + | +
| 180 | ++ | + + | +
| 181 | +7x | +
+ if (structure) {
+ |
+
| 182 | +1x | +
+ rp_mismatches <- !mapply(identical, x = rpo, y = rpe)+ |
+
| 183 | +1x | +
+ cpo <- col_paths(object)+ |
+
| 184 | +1x | +
+ cpe <- col_paths(expected)+ |
+
| 185 | +1x | +
+ cp_mismatches <- !mapply(identical, x = cpo, y = cpe)+ |
+
| 186 | ++ | + + | +
| 187 | +1x | +
+ if (any(rp_mismatches)) { # P for (row or column) path do not match
+ |
+
| 188 | +! | +
+ X[rp_mismatches, ] <- "R"+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | +1x | +
+ if (any(cp_mismatches)) {
+ |
+
| 191 | +1x | +
+ crep <- rep("C", nrow(X))
+ |
+
| 192 | +1x | +
+ if (any(rp_mismatches)) {
+ |
+
| 193 | +! | +
+ crep[rp_mismatches] <- "P"+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | +1x | +
+ X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | +7x | +
+ class(X) <- c("rtables_diff", class(X))
+ |
+
| 199 | +7x | +
+ X+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | ++ | + + | +
| 202 | ++ |
+ ## for (i in 1:dim(X)[1]) {
+ |
+
| 203 | ++ |
+ ## for (j in 1:dim(X)[2]) {
+ |
+
| 204 | ++ | + + | +
| 205 | ++ |
+ ## is_equivalent <- TRUE+ |
+
| 206 | ++ |
+ ## if (i <= nro && i <= nre && j <= nco && j <= nce) {
+ |
+
| 207 | ++ |
+ ## x <- object[i,j, drop = TRUE]+ |
+
| 208 | ++ |
+ ## y <- expected[i,j, drop = TRUE]+ |
+
| 209 | ++ | + + | +
| 210 | ++ |
+ ## attr_x <- attributes(x)+ |
+
| 211 | ++ |
+ ## attr_y <- attributes(y)+ |
+
| 212 | ++ | + + | +
| 213 | ++ |
+ ## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]+ |
+
| 214 | ++ |
+ ## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]+ |
+
| 215 | ++ | + + | +
| 216 | ++ |
+ ## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
+ |
+
| 217 | ++ |
+ ## is_equivalent <- FALSE+ |
+
| 218 | ++ |
+ ## } else if (is.numeric(x) && is.numeric(y)) {
+ |
+
| 219 | ++ |
+ ## if (any(abs(na.omit(x - y)) > tol)) {
+ |
+
| 220 | ++ |
+ ## is_equivalent <- FALSE+ |
+
| 221 | ++ |
+ ## }+ |
+
| 222 | ++ |
+ ## } else {
+ |
+
| 223 | ++ |
+ ## if (!identical(x, y)) {
+ |
+
| 224 | ++ |
+ ## is_equivalent <- FALSE+ |
+
| 225 | ++ |
+ ## }+ |
+
| 226 | ++ |
+ ## }+ |
+
| 227 | ++ | + + | +
| 228 | ++ |
+ ## if (!is_equivalent) {
+ |
+
| 229 | ++ |
+ ## X[i,j] <- "X"+ |
+
| 230 | ++ |
+ ## }+ |
+
| 231 | ++ |
+ ## } else if (i > nro || j > nco) {
+ |
+
| 232 | ++ |
+ ## ## missing in object+ |
+
| 233 | ++ |
+ ## X[i, j] <- "+"+ |
+
| 234 | ++ |
+ ## } else {
+ |
+
| 235 | ++ |
+ ## ## too many elements+ |
+
| 236 | ++ |
+ ## X[i, j] <- "-"+ |
+
| 237 | ++ |
+ ## }+ |
+
| 238 | ++ |
+ ## }+ |
+
| 239 | ++ |
+ ## }+ |
+
| 240 | ++ |
+ ## class(X) <- c("rtable_diff", class(X))
+ |
+
| 241 | ++ |
+ ## X+ |
+
| 242 | ++ |
+ ## }+ |
+
| 243 | ++ | + + | +
| 244 | ++ |
+ compare_value <- function(x, y, tol) {
+ |
+
| 245 | +359x | +
+ if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
+ |
+
| 246 | ++ |
+ "."+ |
+
| 247 | ++ |
+ } else {
+ |
+
| 248 | +72x | +
+ "X"+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | ++ | + + | +
| 252 | ++ |
+ compare_rrows <- function(row1, row2, tol, ncol) {
+ |
+
| 253 | +173x | +
+ if (length(row1) == ncol && length(row2) == ncol) {
+ |
+
| 254 | +115x | +
+ mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)+ |
+
| 255 | +58x | +
+ } else if (length(row1) == 0 && length(row2) == 0) {
+ |
+
| 256 | +44x | +
+ rep(".", ncol)
+ |
+
| 257 | ++ |
+ } else {
+ |
+
| 258 | +14x | +
+ rep("X", ncol)
+ |
+
| 259 | ++ |
+ }+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | ++ |
+ ## #' @export+ |
+
| 263 | ++ |
+ ## print.rtable_diff <- function(x, ...) {
+ |
+
| 264 | ++ |
+ ## print.default(unclass(x), quote = FALSE, ...)+ |
+
| 265 | ++ |
+ ## }+ |
+
| 1 | ++ |
+ #' Default tabulation+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This function is used when [analyze()] is invoked.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param x (`vector`)\cr the *already split* data being tabulated for a particular cell/set of cells.+ |
+
| 6 | ++ |
+ #' @param ... additional parameters to pass on.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @details This function has the following behavior given particular types of inputs:+ |
+
| 9 | ++ |
+ #' \describe{
+ |
+
| 10 | ++ |
+ #' \item{numeric}{calls [mean()] on `x`.}
+ |
+
| 11 | ++ |
+ #' \item{logical}{calls [sum()] on `x`.}
+ |
+
| 12 | ++ |
+ #' \item{factor}{calls [length()] on `x`.}
+ |
+
| 13 | ++ |
+ #' }+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @inherit in_rows return+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @author Gabriel Becker and Adrian Waddell+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' simple_analysis(1:3)+ |
+
| 23 | ++ |
+ #' simple_analysis(iris$Species)+ |
+
| 24 | ++ |
+ #' simple_analysis(iris$Species == "setosa")+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @rdname rtinner+ |
+
| 27 | ++ |
+ #' @export+ |
+
| 28 | +1304x | +
+ setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))
+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ #' @rdname rtinner+ |
+
| 31 | ++ |
+ #' @exportMethod simple_analysis+ |
+
| 32 | ++ |
+ setMethod(+ |
+
| 33 | ++ |
+ "simple_analysis", "numeric",+ |
+
| 34 | +966x | +
+ function(x, ...) in_rows("Mean" = rcell(mean(x, ...), format = "xx.xx"))
+ |
+
| 35 | ++ |
+ )+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ #' @rdname rtinner+ |
+
| 38 | ++ |
+ #' @exportMethod simple_analysis+ |
+
| 39 | ++ |
+ setMethod(+ |
+
| 40 | ++ |
+ "simple_analysis", "logical",+ |
+
| 41 | +4x | +
+ function(x, ...) in_rows("Count" = rcell(sum(x, ...), format = "xx"))
+ |
+
| 42 | ++ |
+ )+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' @rdname rtinner+ |
+
| 45 | ++ |
+ #' @exportMethod simple_analysis+ |
+
| 46 | ++ |
+ setMethod(+ |
+
| 47 | ++ |
+ "simple_analysis", "factor",+ |
+
| 48 | +334x | +
+ function(x, ...) in_rows(.list = as.list(table(x)))+ |
+
| 49 | ++ |
+ )+ |
+
| 50 | ++ | + + | +
| 51 | ++ |
+ #' @rdname rtinner+ |
+
| 52 | ++ |
+ #' @exportMethod simple_analysis+ |
+
| 53 | ++ |
+ setMethod(+ |
+
| 54 | ++ |
+ "simple_analysis", "ANY",+ |
+
| 55 | ++ |
+ function(x, ...) {
+ |
+
| 56 | +! | +
+ stop("No default simple_analysis behavior for class ", class(x), " please specify FUN explicitly.")
+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ #' Check if an object is a valid `rtable`+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @param x (`ANY`)\cr an object.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @examples+ |
+
| 67 | ++ |
+ #' is_rtable(build_table(basic_table(), iris))+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' @export+ |
+
| 70 | ++ |
+ is_rtable <- function(x) {
+ |
+
| 71 | +47x | +
+ is(x, "VTableTree")+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ # nocov start+ |
+
| 75 | ++ |
+ ## is each object in a collection from a class+ |
+
| 76 | ++ |
+ are <- function(object_collection, class2) {
+ |
+
| 77 | ++ |
+ all(vapply(object_collection, is, logical(1), class2))+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
+ |
+
| 81 | ++ |
+ stopifnot(is.numeric(x))+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ if (length(x) == 1) {
+ |
+
| 84 | ++ |
+ return(TRUE)+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ y <- range(x) / mean(x)+ |
+
| 88 | ++ |
+ isTRUE(all.equal(y[1], y[2], tolerance = tol))+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ # copied over from utils.nest which is not open-source+ |
+
| 92 | ++ |
+ all_true <- function(lst, fcn, ...) {
+ |
+
| 93 | ++ |
+ all(vapply(lst, fcn, logical(1), ...))+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ | + + | +
| 96 | ++ |
+ is_logical_single <- function(x) {
+ |
+
| 97 | ++ |
+ !is.null(x) &&+ |
+
| 98 | ++ |
+ is.logical(x) &&+ |
+
| 99 | ++ |
+ length(x) == 1 &&+ |
+
| 100 | ++ |
+ !is.na(x)+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ is_logical_vector_modif <- function(x, min_length = 1) {
+ |
+
| 104 | ++ |
+ !is.null(x) &&+ |
+
| 105 | ++ |
+ is.logical(x) &&+ |
+
| 106 | ++ |
+ is.atomic(x) &&+ |
+
| 107 | ++ |
+ !anyNA(x) &&+ |
+
| 108 | ++ |
+ ifelse(min_length > 0, length(x) >= min_length, TRUE)+ |
+
| 109 | ++ |
+ }+ |
+
| 110 | ++ |
+ # nocov end+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ # Shorthand for functions that take df as first parameter+ |
+
| 113 | ++ |
+ .takes_df <- function(f) {
+ |
+
| 114 | +1585x | +
+ func_takes(f, "df", is_first = TRUE)+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ # Checking if function takes parameters+ |
+
| 118 | ++ |
+ func_takes <- function(func, params, is_first = FALSE) {
+ |
+
| 119 | +10852x | +
+ if (is.list(func)) {
+ |
+
| 120 | +2256x | +
+ return(lapply(func, func_takes, params = params, is_first = is_first))+ |
+
| 121 | ++ |
+ }+ |
+
| 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))+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | +6844x | +
+ f_params <- formals(func)+ |
+
| 127 | +6844x | +
+ if (!is_first) {
+ |
+
| 128 | +2265x | +
+ return(setNames(params %in% names(f_params), params))+ |
+
| 129 | ++ |
+ } else {
+ |
+
| 130 | +4579x | +
+ if (length(params) > 1L) {
+ |
+
| 131 | +1x | +
+ stop("is_first works only with one parameters.")
+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | +4578x | +
+ return(!is.null(f_params) && names(f_params)[1] == params)+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ | + + | +
| 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 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @return A character string containing a description of the row path corresponding to `ctx`.+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' @export+ |
+
| 144 | ++ |
+ spl_context_to_disp_path <- function(ctx) {
+ |
+
| 145 | ++ |
+ ## this can happen in the first split in column space, but+ |
+
| 146 | ++ |
+ ## should never happen in row space+ |
+
| 147 | +20x | +
+ if (length(ctx$split) == 0) {
+ |
+
| 148 | +2x | +
+ return("root")
+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | +18x | +
+ if (ctx$split[1] == "root" && ctx$value[1] == "root") {
+ |
+
| 151 | +17x | +
+ ctx <- ctx[-1, ]+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | +18x | +
+ ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
+ |
+
| 154 | +18x | +
+ collapse = "->"+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | +18x | +
+ if (length(ret) == 0 || nchar(ret) == 0) {
+ |
+
| 157 | +11x | +
+ ret <- "root"+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | +18x | +
+ ret+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ # Utility function to paste vector of values in a nice way+ |
+
| 163 | ++ |
+ paste_vec <- function(vec) {
+ |
+
| 164 | +7x | +
+ paste0('c("', paste(vec, collapse = '", "'), '")')
+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ # Utility for checking if a package is installed+ |
+
| 168 | ++ |
+ check_required_packages <- function(pkgs) {
+ |
+
| 169 | +! | +
+ for (pkgi in pkgs) {
+ |
+
| 170 | +! | +
+ if (!requireNamespace(pkgi, quietly = TRUE)) {
+ |
+
| 171 | +! | +
+ stop(+ |
+
| 172 | +! | +
+ "This function requires the ", pkgi, " package. ",+ |
+
| 173 | +! | +
+ "Please install it if you wish to use it"+ |
+
| 174 | ++ |
+ )+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @importFrom utils browseURL+ |
+
| 2 | ++ |
+ NULL+ |
+
| 3 | ++ | + + | +
| 4 | ++ |
+ #' Display an `rtable` object in the Viewer pane in RStudio or in a browser+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' The table will be displayed using bootstrap styling.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).+ |
+
| 9 | ++ |
+ #' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.+ |
+
| 10 | ++ |
+ #' @param ... arguments passed to [as_html()].+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' if (interactive()) {
+ |
+
| 16 | ++ |
+ #' sl5 <- factor(iris$Sepal.Length > 5,+ |
+
| 17 | ++ |
+ #' levels = c(TRUE, FALSE),+ |
+
| 18 | ++ |
+ #' labels = c("S.L > 5", "S.L <= 5")
+ |
+
| 19 | ++ |
+ #' )+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' df <- cbind(iris, sl5 = sl5)+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 24 | ++ |
+ #' split_cols_by("sl5") %>%
+ |
+
| 25 | ++ |
+ #' analyze("Sepal.Length")
+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' tbl <- build_table(lyt, df)+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' Viewer(tbl)+ |
+
| 30 | ++ |
+ #' Viewer(tbl, tbl)+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' tbl2 <- htmltools::tags$div(+ |
+
| 34 | ++ |
+ #' class = "table-responsive",+ |
+
| 35 | ++ |
+ #' as_html(tbl, class_table = "table")+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' Viewer(tbl, tbl2)+ |
+
| 39 | ++ |
+ #' }+ |
+
| 40 | ++ |
+ #' @export+ |
+
| 41 | ++ |
+ Viewer <- function(x, y = NULL, ...) {
+ |
+
| 42 | +3x | +
+ check_convert <- function(x, name, accept_NULL = FALSE) {
+ |
+
| 43 | +6x | +
+ if (accept_NULL && is.null(x)) {
+ |
+
| 44 | +3x | +
+ NULL+ |
+
| 45 | +3x | +
+ } else if (is(x, "shiny.tag")) {
+ |
+
| 46 | +! | +
+ x+ |
+
| 47 | +3x | +
+ } else if (is(x, "VTableTree")) {
+ |
+
| 48 | +3x | +
+ as_html(x, ...)+ |
+
| 49 | ++ |
+ } else {
+ |
+
| 50 | +! | +
+ stop("object of class rtable or shiny tag excepted for ", name)
+ |
+
| 51 | ++ |
+ }+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | +3x | +
+ x_tag <- check_convert(x, "x", FALSE)+ |
+
| 55 | +3x | +
+ y_tag <- check_convert(y, "y", TRUE)+ |
+
| 56 | ++ | + + | +
| 57 | +3x | +
+ html_output <- if (is.null(y)) {
+ |
+
| 58 | +3x | +
+ x_tag+ |
+
| 59 | ++ |
+ } else {
+ |
+
| 60 | +! | +
+ tags$div(class = "container-fluid", htmltools::tags$div(+ |
+
| 61 | +! | +
+ class = "row",+ |
+
| 62 | +! | +
+ tags$div(class = "col-xs-6", x_tag),+ |
+
| 63 | +! | +
+ tags$div(class = "col-xs-6", y_tag)+ |
+
| 64 | ++ |
+ ))+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | +3x | +
+ sandbox_folder <- file.path(tempdir(), "rtable")+ |
+
| 68 | ++ | + + | +
| 69 | +3x | +
+ if (!dir.exists(sandbox_folder)) {
+ |
+
| 70 | +1x | +
+ dir.create(sandbox_folder, recursive = TRUE)+ |
+
| 71 | +1x | +
+ pbs <- file.path(path.package(package = "rtables"), "bootstrap/")+ |
+
| 72 | +1x | +
+ file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)+ |
+
| 73 | ++ |
+ # list.files(sandbox_folder)+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ # get html name+ |
+
| 77 | +3x | +
+ n_try <- 10000+ |
+
| 78 | +3x | +
+ for (i in seq_len(n_try)) {
+ |
+
| 79 | +6x | +
+ htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
+ |
+
| 80 | ++ | + + | +
| 81 | +6x | +
+ if (!file.exists(htmlFile)) {
+ |
+
| 82 | +3x | +
+ break+ |
+
| 83 | +3x | +
+ } else if (i == n_try) {
+ |
+
| 84 | +! | +
+ stop("too many html rtables created, restart your session")
+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ | + + | +
| 88 | +3x | +
+ html_bs <- tags$html(+ |
+
| 89 | +3x | +
+ lang = "en",+ |
+
| 90 | +3x | +
+ tags$head(+ |
+
| 91 | +3x | +
+ tags$meta(charset = "utf-8"),+ |
+
| 92 | +3x | +
+ tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
+ |
+
| 93 | +3x | +
+ tags$meta(+ |
+
| 94 | +3x | +
+ name = "viewport",+ |
+
| 95 | +3x | +
+ content = "width=device-width, initial-scale=1"+ |
+
| 96 | ++ |
+ ),+ |
+
| 97 | +3x | +
+ tags$title("rtable"),
+ |
+
| 98 | +3x | +
+ tags$link(+ |
+
| 99 | +3x | +
+ href = "css/bootstrap.min.css",+ |
+
| 100 | +3x | +
+ rel = "stylesheet"+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ |
+ ),+ |
+
| 103 | +3x | +
+ tags$body(+ |
+
| 104 | +3x | +
+ html_output+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ |
+ )+ |
+
| 107 | ++ | + + | +
| 108 | +3x | +
+ cat(+ |
+
| 109 | +3x | +
+ paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
+ |
+
| 110 | +3x | +
+ file = htmlFile, append = FALSE+ |
+
| 111 | ++ |
+ )+ |
+
| 112 | ++ | + + | +
| 113 | +3x | +
+ viewer <- getOption("viewer")
+ |
+
| 114 | ++ | + + | +
| 115 | +3x | +
+ if (!is.null(viewer)) {
+ |
+
| 116 | +3x | +
+ viewer(htmlFile)+ |
+
| 117 | ++ |
+ } else {
+ |
+
| 118 | +! | +
+ browseURL(htmlFile)+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @importFrom tools file_ext+ |
+
| 2 | ++ |
+ NULL+ |
+
| 3 | ++ | + + | +
| 4 | ++ |
+ #' Create enriched flat value table with paths+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then+ |
+
| 7 | ++ |
+ #' writes that data frame out as a `tsv` file.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are+ |
+
| 10 | ++ |
+ #' collapsed to character vectors by collapsing the list element with `"|"`.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @note+ |
+
| 13 | ++ |
+ #' There is currently no round-trip capability for this type of export. You can read values exported this way back in+ |
+
| 14 | ++ |
+ #' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @inheritParams gen_args+ |
+
| 17 | ++ |
+ #' @inheritParams data.frame_export+ |
+
| 18 | ++ |
+ #' @param file (`string`)\cr the path of the file to written to or read from.+ |
+
| 19 | ++ |
+ #' @param sep (`string`)\cr defaults to `\t`. See [utils::write.table()] for more details.+ |
+
| 20 | ++ |
+ #' @param ... (`any`)\cr additional arguments to be passed to [utils::write.table()].+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @return+ |
+
| 23 | ++ |
+ #' * `export_as_tsv` returns `NULL` silently.+ |
+
| 24 | ++ |
+ #' * `import_from_tsv` returns a `data.frame` with re-constituted list values.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @seealso [path_enriched_df()] for the underlying function that does the work.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @importFrom utils write.table read.table+ |
+
| 29 | ++ |
+ #' @rdname tsv_io+ |
+
| 30 | ++ |
+ #' @export+ |
+
| 31 | ++ |
+ export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,+ |
+
| 32 | ++ |
+ value_fun = collapse_values, sep = "\t", ...) {
+ |
+
| 33 | +1x | +
+ df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)+ |
+
| 34 | +1x | +
+ write.table(df, file, sep = sep, ...)+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ #' @rdname tsv_io+ |
+
| 38 | ++ |
+ #' @export+ |
+
| 39 | ++ |
+ import_from_tsv <- function(file) {
+ |
+
| 40 | +1x | +
+ rawdf <- read.table(file, header = TRUE, sep = "\t")+ |
+
| 41 | +1x | +
+ as.data.frame(lapply(+ |
+
| 42 | +1x | +
+ rawdf,+ |
+
| 43 | +1x | +
+ function(col) {
+ |
+
| 44 | +7x | +
+ if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
+ |
+
| 45 | +! | +
+ col+ |
+
| 46 | ++ |
+ } else {
+ |
+
| 47 | +7x | +
+ I(strsplit(col, split = .collapse_char_esc))+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | ++ |
+ ))+ |
+
| 51 | ++ |
+ }+ |
+
| 52 | ++ |
+ # txt (formatters) --------------------------------------------------------------------+ |
+
| 53 | ++ |
+ #' @importFrom formatters export_as_txt+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @examples+ |
+
| 56 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 57 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 58 | ++ |
+ #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8))+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' \dontrun{
+ |
+
| 65 | ++ |
+ #' tf <- tempfile(fileext = ".txt")+ |
+
| 66 | ++ |
+ #' export_as_txt(tbl, file = tf)+ |
+
| 67 | ++ |
+ #' system2("cat", tf)
+ |
+
| 68 | ++ |
+ #' }+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @export+ |
+
| 71 | ++ |
+ formatters::export_as_txt+ |
+
| 72 | ++ | + + | +
| 73 | ++ |
+ # pdf (formatters) ----------------------------------------------------------+ |
+
| 74 | ++ |
+ #' @importFrom formatters export_as_pdf+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @examples+ |
+
| 77 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 78 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 79 | ++ |
+ #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' tbl <- build_table(lyt, ex_adsl)+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' \dontrun{
+ |
+
| 84 | ++ |
+ #' tf <- tempfile(fileext = ".pdf")+ |
+
| 85 | ++ |
+ #' export_as_pdf(tbl, file = tf, pg_height = 4)+ |
+
| 86 | ++ |
+ #' tf <- tempfile(fileext = ".pdf")+ |
+
| 87 | ++ |
+ #' export_as_pdf(tbl, file = tf, lpp = 8)+ |
+
| 88 | ++ |
+ #' }+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @export+ |
+
| 91 | ++ |
+ formatters::export_as_pdf+ |
+