standardGeneric("subset_cols")
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
cinfo <- col_info(tt)
newcinfo <- subset_cols(cinfo, j,
keep_topleft = keep_topleft,
keep_titles = keep_titles,
keep_footers = keep_footers, ...
kids <- tree_children(tt)
newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
tt2 <- tt
col_info(tt2) <- newcinfo
tree_children(tt2) <- newkids
tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)
tt2 <- .h_copy_titles_footers_topleft(
tt2, tt,
keep_titles,
keep_footers,
keep_topleft
tt2
j <- seq_len(n)[j]
j
ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE)
ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE)
ret
paste(vapply(path, function(x) {
if (identical(x, "*")) {
escape_name_padding(x)
}, ""), collapse = path_collapse_sep)
path <- path[!grepl("^(|root)$", path)]
if (cols) {
rowdf <- make_col_df(tt)
if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
return(seq(1, nrow(rowdf)))
paths <- rowdf$path
pathregex <- path_to_regex(path)
pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep)
allmatchs <- grep(pathregex, pathstrs)
if (length(allmatchs) == 0) {
idxdiffs <- diff(allmatchs)
if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
allmatchs
cspans <- row_cspans(rw)
nc <- sum(cspans)
j <- .j_to_posj(j, nc)
start <- cumsum(c(1, head(cspans, -1)))
ends <- c(tail(start, -1) - 1, nc)
res <- mapply(function(st, en) {
sum(j >= st & j <= en)
}, st = start, en = ends)
res <- res[res > 0]
stopifnot(sum(res) == length(j))
res
if (length(j) != length(unique(j))) {
spans <- vapply(
cells, function(x) cell_cspan(x),
integer(1)
inds <- rep(seq_along(cells), times = spans)
selinds <- inds[j]
retcells <- cells[selinds[!duplicated(selinds)]]
newspans <- vapply(
split(selinds, selinds),
length,
integer(1)
mapply(function(cl, sp) {
cell_cspan(cl) <- sp
cl
}, cl = retcells, sp = newspans, SIMPLIFY = FALSE)
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
tt2 <- tt
row_cells(tt2) <- select_cells_j(row_cells(tt2), j)
if (length(row_cspans(tt2)) > 0) {
row_cspans(tt2) <- .fix_rowcspans(tt2, j)
col_info(tt2) <- newcinfo
tt2
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
col_info(tt) <- newcinfo
tt
if (!is.null(newcinfo)) {
j <- .j_to_posj(j, length(col_exprs(tt)))
newctree <- subset_cols(coltree(tt), j, NULL)
newcextra <- col_extra_args(tt)[j]
newcsubs <- col_exprs(tt)[j]
newcounts <- col_counts(tt)[j]
tl <- if (keep_topleft) top_left(tt) else character()
InstantiatedColumnInfo(
treelyt = newctree,
csubs = newcsubs,
extras = newcextra,
cnts = newcounts,
dispcounts = disp_ccounts(tt),
countformat = colcount_format(tt),
topleft = tl
lst <- collect_leaves(tt)
j <- .j_to_posj(j, length(lst))
counter <- 0
prune_children <- function(x, j) {
kids <- tree_children(x)
newkids <- kids
for (i in seq_along(newkids)) {
if (is(newkids[[i]], "LayoutColLeaf")) {
counter <<- counter + 1
if (!(counter %in% j)) {
newkids[[i]] <- list()
} ## NULL removes the position entirely
newkids[[i]] <- prune_children(newkids[[i]], j)
newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)]
if (length(newkids) > 0) {
tree_children(x) <- newkids
x
list()
prune_children(tt, j)
i <- seq_len(nrow(x))
x[i = i, j = j, ..., drop = drop]
## j <- .colpath_to_j(j, coltree(x))
j <- .path_to_pos(path = j, tt = x, cols = TRUE)
x[i = i, j = j, ..., drop = drop]
i <- seq_len(nrow(x))
x[i, j, ..., drop = drop]
keep_topleft <- list(...)[["keep_topleft"]] %||% NA
keep_titles <- list(...)[["keep_titles"]] %||% FALSE
keep_footers <- list(...)[["keep_footers"]] %||% keep_titles
reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE
nr <- nrow(x)
nc <- ncol(x)
i <- .j_to_posj(i, nr)
j <- .j_to_posj(j, nc)
if (length(i) < nr) { ## already populated by .j_to_posj
} else if (is.na(keep_topleft)) {
keep_topleft <- TRUE
if (length(j) < nc) {
x <- subset_cols(x, j,
keep_topleft = keep_topleft,
keep_titles = keep_titles,
keep_footers = keep_footers
if (drop) {
if (!drop) {
if (!keep_topleft) {
if (reindex_refs) {
x <- update_ref_indexing(x)
x
if (isTRUE(keep_titles)) {
main_title(new) <- main_title(empt_tbl)
subtitles(new) <- subtitles(empt_tbl)
if (isTRUE(keep_footers)) {
main_footer(new) <- main_footer(empt_tbl)
prov_footer(new) <- prov_footer(empt_tbl)
if (isTRUE(keep_topleft)) {
top_left(new) <- top_left(old)
if (reindex_refs) {
new
| 1 |
- ## XXX Do we want add.labrows here or no?+ #' @importFrom tools file_ext |
||
| 2 |
- ## we have to choose one and stick to it.+ NULL |
||
| 4 |
- #' Internal generics and methods+ #' Create enriched flat value table with paths |
||
| 6 |
- #' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no+ #' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then |
||
| 7 |
- #' attention to this documentation.+ #' writes that data frame out as a `tsv` file. |
||
| 9 |
- #' @param x (`ANY`)\cr the object.+ #' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are |
||
| 10 |
- #' @param obj (`ANY`)\cr the object.+ #' collapsed to character vectors by collapsing the list element with `"|"`. |
||
| 12 |
- #' @name internal_methods+ #' @note |
||
| 13 |
- #' @rdname int_methods+ #' There is currently no round-trip capability for this type of export. You can read values exported this way back in |
||
| 14 |
- #' @aliases int_methods+ #' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`. |
||
| 15 |
- NULL+ #' |
||
| 16 |
-
+ #' @inheritParams gen_args |
||
| 17 |
- #' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object.+ #' @inheritParams data.frame_export |
||
| 18 |
- #'+ #' @param file (`string`)\cr the path of the file to written to or read from. |
||
| 19 |
- #' @rdname dimensions+ #' |
||
| 20 |
- #' @exportMethod nrow+ #' @return |
||
| 21 |
- setMethod(+ #' * `export_as_tsv` returns `NULL` silently. |
||
| 22 |
- "nrow", "VTableTree",+ #' * `import_from_tsv` returns a `data.frame` with re-constituted list values. |
||
| 23 | -2361x | +
- function(x) length(collect_leaves(x, TRUE, TRUE))+ #' |
|
| 24 |
- )+ #' @seealso [path_enriched_df()] for the underlying function that does the work. |
||
| 25 |
-
+ #' |
||
| 26 |
- #' @rdname int_methods+ #' @importFrom utils write.table read.table |
||
| 27 |
- #' @exportMethod nrow+ #' @rdname tsv_io |
||
| 28 |
- setMethod(+ #' @export |
||
| 29 |
- "nrow", "TableRow",+ export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path, |
||
| 30 | -979x | +
- function(x) 1L+ value_fun = collapse_values) {
|
|
| 31 | -+ | 1x |
- )+ df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun) |
| 32 | -+ | 1x |
-
+ write.table(df, file, sep = "\t") |
| 33 |
- #' Table dimensions+ } |
||
| 34 |
- #'+ |
||
| 35 |
- #' @param x (`TableTree` or `ElementaryTable`)\cr a table object.+ #' @rdname tsv_io |
||
| 36 |
- #'+ #' @export |
||
| 37 |
- #' @examples+ import_from_tsv <- function(file) {
|
||
| 38 | -+ | 1x |
- #' lyt <- basic_table() %>%+ rawdf <- read.table(file, header = TRUE, sep = "\t") |
| 39 | -+ | 1x |
- #' split_cols_by("ARM") %>%
+ as.data.frame(lapply( |
| 40 | -+ | 1x |
- #' analyze(c("SEX", "AGE"))
+ rawdf, |
| 41 | -+ | 1x |
- #'+ function(col) {
|
| 42 | -+ | 7x |
- #' tbl <- build_table(lyt, ex_adsl)+ if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
|
| 43 | -+ | ! |
- #'+ col |
| 44 |
- #' dim(tbl)+ } else {
|
||
| 45 | -+ | 7x |
- #' nrow(tbl)+ I(strsplit(col, split = .collapse_char_esc)) |
| 46 |
- #' ncol(tbl)+ } |
||
| 47 |
- #'+ } |
||
| 48 |
- #' NROW(tbl)+ )) |
||
| 49 |
- #' NCOL(tbl)+ } |
||
| 50 |
- #'+ |
||
| 51 |
- #' @rdname dimensions+ ### Migrated to formatters ---- |
||
| 52 |
- #' @exportMethod ncol+ |
||
| 53 |
- setMethod(+ #' @importFrom formatters export_as_txt |
||
| 54 |
- "ncol", "VTableNodeInfo",+ #' |
||
| 55 |
- function(x) {
+ #' @examples |
||
| 56 | -23078x | +
- ncol(col_info(x))+ #' lyt <- basic_table() %>% |
|
| 57 |
- }+ #' split_cols_by("ARM") %>%
|
||
| 58 |
- )+ #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
|
||
| 59 |
-
+ #' |
||
| 60 |
- #' @rdname int_methods+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 61 |
- #' @exportMethod ncol+ #' |
||
| 62 |
- setMethod(+ #' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8)) |
||
| 63 |
- "ncol", "TableRow",+ #' |
||
| 64 |
- function(x) {
+ #' \dontrun{
|
||
| 65 | -69534x | +
- if (!no_colinfo(x)) {
+ #' tf <- tempfile(fileext = ".txt") |
|
| 66 | -69092x | +
- ncol(col_info(x))+ #' export_as_txt(tbl, file = tf) |
|
| 67 |
- } else {
+ #' system2("cat", tf)
|
||
| 68 | -442x | +
- length(spanned_values(x))+ #' } |
|
| 69 |
- }+ #' |
||
| 70 |
- }+ #' @export |
||
| 71 |
- )+ formatters::export_as_txt |
||
| 73 |
- #' @rdname int_methods+ # data.frame output ------------------------------------------------------------ |
||
| 74 |
- #' @exportMethod ncol+ |
||
| 75 |
- setMethod(+ #' Generate a result data frame |
||
| 76 |
- "ncol", "LabelRow",+ #' |
||
| 77 |
- function(x) {
+ #' Collection of utilities to extract `data.frame` objects from `TableTree` objects. |
||
| 78 | -23386x | +
- ncol(col_info(x))+ #' |
|
| 79 |
- }+ #' @inheritParams gen_args |
||
| 80 |
- )+ #' @param spec (`string`)\cr the specification to use to extract the result data frame. See Details below. |
||
| 81 |
-
+ #' @param simplify (`flag`)\cr whether the result data frame should only have labels and result columns visible. |
||
| 82 |
- #' @rdname int_methods+ #' @param ... additional arguments passed to spec-specific result data frame conversion function. Currently it can be |
||
| 83 |
- #' @exportMethod ncol+ #' one or more of the following parameters (valid only for `v0_experimental` spec. for now): |
||
| 84 |
- setMethod(+ #' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual |
||
| 85 |
- "ncol", "InstantiatedColumnInfo",+ #' output. This is useful when the result data frame is used for further processing. |
||
| 86 |
- function(x) {
+ #' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns. |
||
| 87 | -117580x | +
- length(col_exprs(x))+ #' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear |
|
| 88 |
- }+ #' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for |
||
| 89 |
- )+ #' column counts if `expand_colnames = TRUE`. |
||
| 90 |
-
+ #' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, |
||
| 91 |
- #' @rdname dimensions+ #' i.e. with the same precision and numbers, but in easy-to-use numeric form. |
||
| 92 |
- #' @exportMethod dim+ #' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the |
||
| 93 |
- setMethod(+ #' final table. |
||
| 94 |
- "dim", "VTableNodeInfo",+ #' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table, |
||
| 95 | -19139x | +
- function(x) c(nrow(x), ncol(x))+ #' but without information about the row structure. Row labels will be assigned to rows so to work well |
|
| 96 |
- )+ #' with [df_to_tt()]. |
||
| 97 |
-
+ #' |
||
| 98 |
- #' Retrieve or set the direct children of a tree-style object+ #' @details `as_result_df()`: Result data frame specifications may differ in the exact information |
||
| 99 |
- #'+ #' they include and the form in which they represent it. Specifications whose names end in "_experimental" |
||
| 100 |
- #' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure.+ #' are subject to change without notice, but specifications without the "_experimental" |
||
| 101 |
- #' @param value (`list`)\cr new list of children.+ #' suffix will remain available *including any bugs in their construction* indefinitely. |
||
| 103 |
- #' @return A list of direct children of `x`.+ #' @return |
||
| 104 |
- #'+ #' * `as_result_df` returns a result `data.frame`. |
||
| 105 |
- #' @export+ #' |
||
| 106 |
- #' @rdname tree_children+ #' @seealso [df_to_tt()] when using `as_is = TRUE` and [make_row_df()] to have a comprehensive view of the |
||
| 107 | -235328x | +
- setGeneric("tree_children", function(x) standardGeneric("tree_children"))
+ #' hierarchical structure of the rows. |
|
| 108 |
-
+ #' |
||
| 109 |
- #' @exportMethod tree_children+ #' @examples |
||
| 110 |
- #' @rdname int_methods+ #' lyt <- basic_table() %>% |
||
| 111 |
- setMethod(+ #' split_cols_by("ARM") %>%
|
||
| 112 |
- "tree_children", c(x = "VTree"),+ #' split_rows_by("STRATA1") %>%
|
||
| 113 | -! | +
- function(x) x@children+ #' analyze(c("AGE", "BMRKR2"))
|
|
| 114 |
- )+ #' |
||
| 115 |
-
+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 116 |
- #' @exportMethod tree_children+ #' as_result_df(tbl) |
||
| 117 |
- #' @rdname int_methods+ #' |
||
| 118 |
- setMethod(+ #' @name data.frame_export |
||
| 119 |
- "tree_children", c(x = "VTableTree"),+ #' @export |
||
| 120 | -66899x | +
- function(x) x@children+ as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) {
|
|
| 121 | -+ | 24x |
- )+ checkmate::assert_class(tt, "VTableTree") |
| 122 | -+ | 24x |
-
+ checkmate::assert_string(spec) |
| 123 | -+ | 24x |
- ## this includes VLeaf but also allows for general methods+ checkmate::assert_flag(simplify) |
| 124 |
- ## needed for table_inset being carried around by rows and+ |
||
| 125 | -+ | 24x |
- ## such.+ if (nrow(tt) == 0) {
|
| 126 | -+ | 2x |
- #' @exportMethod tree_children+ return(sanitize_table_struct(tt)) |
| 127 |
- #' @rdname int_methods+ } |
||
| 128 |
- setMethod(+ |
||
| 129 | -+ | 22x |
- "tree_children", c(x = "ANY"), ## "VLeaf"),+ result_df_fun <- lookup_result_df_specfun(spec) |
| 130 | -10933x | +22x |
- function(x) list()+ out <- result_df_fun(tt, ...) |
| 131 |
- )+ |
||
| 132 | -+ | 22x |
-
+ if (simplify) {
|
| 133 | -+ | 4x |
- #' @export+ out <- .simplify_result_df(out) |
| 134 |
- #' @rdname tree_children+ } |
||
| 135 | -53367x | +
- setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))
+
|
|
| 136 | -+ | 22x |
-
+ out |
| 137 |
- #' @exportMethod tree_children<-+ } |
||
| 138 |
- #' @rdname int_methods+ |
||
| 139 |
- setMethod(+ # Function that selects specific outputs from the result data frame |
||
| 140 |
- "tree_children<-", c(x = "VTree"),+ .simplify_result_df <- function(df) {
|
||
| 141 | -+ | 4x |
- function(x, value) {
+ col_df <- colnames(df) |
| 142 | -1157x | +4x |
- x@children <- value+ row_names_col <- which(col_df == "row_name") |
| 143 | -1157x | +4x |
- x+ result_cols <- seq(which(col_df == "node_class") + 1, length(col_df)) |
| 144 |
- }+ |
||
| 145 | -+ | 4x |
- )+ df[, c(row_names_col, result_cols)] |
| 146 |
-
+ } |
||
| 147 |
- #' @exportMethod tree_children<-+ |
||
| 148 |
- #' @rdname int_methods+ # Not used in rtables |
||
| 149 |
- setMethod(+ # .split_colwidths <- function(ptabs, nctot, colwidths) {
|
||
| 150 |
- "tree_children<-", c(x = "VTableTree"),+ # ret <- list() |
||
| 151 |
- function(x, value) {
+ # i <- 1L |
||
| 152 | -52210x | +
- x@children <- value+ # |
|
| 153 | -52210x | +
- x+ # rlw <- colwidths[1] |
|
| 154 |
- }+ # colwidths <- colwidths[-1] |
||
| 155 |
- )+ # donenc <- 0 |
||
| 156 |
-
+ # while (donenc < nctot) {
|
||
| 157 |
- #' Retrieve or set content table from a `TableTree`+ # curnc <- NCOL(ptabs[[i]]) |
||
| 158 |
- #'+ # ret[[i]] <- c(rlw, colwidths[seq_len(curnc)]) |
||
| 159 |
- #' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise.+ # colwidths <- colwidths[-1 * seq_len(curnc)] |
||
| 160 |
- #'+ # donenc <- donenc + curnc |
||
| 161 |
- #' @param obj (`TableTree`)\cr the table object.+ # i <- i + 1 |
||
| 162 |
- #'+ # } |
||
| 163 |
- #' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not+ # ret |
||
| 164 |
- #' a formal table object).+ # } |
||
| 165 |
- #'+ |
||
| 166 |
- #' @export+ #' @describeIn data.frame_export A list of functions that extract result data frames from `TableTree`s. |
||
| 167 |
- #' @rdname content_table+ #' |
||
| 168 | -92800x | +
- setGeneric("content_table", function(obj) standardGeneric("content_table"))
+ #' @return |
|
| 169 |
-
+ #' * `result_df_specs()` returns a named list of result data frame extraction functions by "specification". |
||
| 170 |
- #' @exportMethod content_table+ #' |
||
| 171 |
- #' @rdname int_methods+ #' @examples |
||
| 172 |
- setMethod(+ #' result_df_specs() |
||
| 173 |
- "content_table", "TableTree",+ #' |
||
| 174 | -61286x | +
- function(obj) obj@content+ #' @export |
|
| 175 |
- )+ result_df_specs <- function() {
|
||
| 176 | -+ | 44x |
-
+ list(v0_experimental = result_df_v0_experimental) |
| 177 |
- #' @exportMethod content_table+ } |
||
| 178 |
- #' @rdname int_methods+ |
||
| 179 |
- setMethod(+ lookup_result_df_specfun <- function(spec) {
|
||
| 180 | -+ | 22x |
- "content_table", "ANY",+ if (!(spec %in% names(result_df_specs()))) {
|
| 181 | -10885x | +! |
- function(obj) NULL+ stop( |
| 182 | -+ | ! |
- )+ "unrecognized result data frame specification: ", |
| 183 | -+ | ! |
-
+ spec, |
| 184 | -+ | ! |
- #' @param value (`ElementaryTable`)\cr the new content table for `obj`.+ "If that specification is correct you may need to update your version of rtables" |
| 185 |
- #'+ ) |
||
| 186 |
- #' @export+ } |
||
| 187 | -+ | 22x |
- #' @rdname content_table+ result_df_specs()[[spec]] |
| 188 | -6330x | +
- setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))
+ } |
|
| 190 |
- #' @exportMethod "content_table<-"+ result_df_v0_experimental <- function(tt, |
||
| 191 |
- #' @rdname int_methods+ as_viewer = FALSE, |
||
| 192 |
- setMethod(+ as_strings = FALSE, |
||
| 193 |
- "content_table<-", c("TableTree", "ElementaryTable"),
+ expand_colnames = FALSE, |
||
| 194 |
- function(obj, value) {
+ keep_label_rows = FALSE, |
||
| 195 | -6330x | +
- obj@content <- value+ as_is = FALSE) {
|
|
| 196 | -6330x | +22x |
- obj+ checkmate::assert_flag(as_viewer) |
| 197 | -+ | 22x |
- }+ checkmate::assert_flag(as_strings) |
| 198 | -+ | 22x |
- )+ checkmate::assert_flag(expand_colnames) |
| 199 | -+ | 22x |
-
+ checkmate::assert_flag(keep_label_rows) |
| 200 | -+ | 22x |
- #' @param for_analyze (`flag`) whether split is an analyze split.+ checkmate::assert_flag(as_is) |
| 201 |
- #' @rdname int_methods+ |
||
| 202 | -1085x | +22x |
- setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))
+ if (as_is) {
|
| 203 | -+ | 2x |
-
+ keep_label_rows <- TRUE |
| 204 | -+ | 2x |
- #' @rdname int_methods+ expand_colnames <- FALSE |
| 205 |
- setMethod(+ } |
||
| 206 |
- "next_rpos", "PreDataTableLayouts",+ |
||
| 207 | -+ | 22x |
- function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze)+ raw_cvals <- cell_values(tt) |
| 208 |
- )+ ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values |
||
| 209 |
-
+ ## rather than a list of length 1 representing the single row. This is bad but may not be changeable |
||
| 210 |
- .check_if_nest <- function(obj, nested, for_analyze) {
+ ## at this point. |
||
| 211 | -258x | +22x |
- if (!nested) {
+ if (nrow(tt) == 1 && length(raw_cvals) > 1) {
|
| 212 | -17x | +2x |
- FALSE+ raw_cvals <- list(raw_cvals) |
| 213 |
- } else {
+ } |
||
| 214 |
- ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?)+ |
||
| 215 | -241x | +
- for_analyze ||+ # Flatten the list of lists (rows) of cell values into a data frame |
|
| 216 | -+ | 22x |
- ## If its not an analyze split it can't go under an analyze split+ cellvals <- as.data.frame(do.call(rbind, raw_cvals)) |
| 217 | -241x | +22x |
- !(is(last_rowsplit(obj), "VAnalyzeSplit") ||+ row.names(cellvals) <- NULL |
| 218 | -241x | +
- is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint+ |
|
| 219 | -+ | 22x |
- }+ if (nrow(tt) == 1 && ncol(tt) == 1) {
|
| 220 | -+ | 5x |
- }+ colnames(cellvals) <- names(raw_cvals) |
| 221 |
-
+ } |
||
| 222 |
- #' @rdname int_methods+ |
||
| 223 | -+ | 22x |
- setMethod(+ if (as_viewer || as_strings) {
|
| 224 |
- "next_rpos", "PreDataRowLayout",+ # we keep previous calculations to check the format of the data |
||
| 225 | -+ | 9x |
- function(obj, nested, for_analyze) {
+ mf_tt <- matrix_form(tt) |
| 226 | -542x | +9x |
- l <- length(obj)+ mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1] |
| 227 | -542x | +9x |
- if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
+ mf_result_chars <- .remove_empty_elements(mf_result_chars) |
| 228 | -26x | +9x |
- l <- l + 1L+ mf_result_numeric <- as.data.frame( |
| 229 | -+ | 9x |
- }+ .make_numeric_char_mf(mf_result_chars) |
| 230 | -542x | +
- l+ ) |
|
| 231 | -+ | 9x |
- }+ mf_result_chars <- as.data.frame(mf_result_chars) |
| 232 | -+ | 9x |
- )+ if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
|
| 233 | -+ | ! |
-
+ stop( |
| 234 | -+ | ! |
- #' @rdname int_methods+ "The extracted numeric data.frame does not have the same dimension of the", |
| 235 | -1x | +! |
- setMethod("next_rpos", "ANY", function(obj, nested) 1L)
+ " cell values extracted with cell_values(). This is a bug. Please report it." |
| 236 | -+ | ! |
-
+ ) # nocov |
| 237 |
- #' @rdname int_methods+ } |
||
| 238 | -579x | +9x |
- setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))
+ if (as_strings) {
|
| 239 | -+ | 5x |
-
+ colnames(mf_result_chars) <- colnames(cellvals) |
| 240 | -+ | 5x |
- #' @rdname int_methods+ cellvals <- mf_result_chars |
| 241 |
- setMethod(+ } else {
|
||
| 242 | -+ | 4x |
- "next_cpos", "PreDataTableLayouts",+ colnames(mf_result_numeric) <- colnames(cellvals) |
| 243 | -+ | 4x |
- function(obj, nested) next_cpos(clayout(obj), nested)+ cellvals <- mf_result_numeric |
| 244 |
- )+ } |
||
| 245 |
-
+ } |
||
| 246 |
- #' @rdname int_methods+ |
||
| 247 | -+ | 22x |
- setMethod(+ rdf <- make_row_df(tt) |
| 248 |
- "next_cpos", "PreDataColLayout",+ |
||
| 249 | -+ | 22x |
- function(obj, nested) {
+ df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
|
| 250 | -289x | +
- if (nested || length(obj[[length(obj)]]) == 0) {
+ # Removing initial root elements from path (out of the loop -> right maxlen) |
|
| 251 | -284x | +22x |
- length(obj)+ df$path <- lapply(df$path, .remove_root_elems_from_path, |
| 252 | -+ | 22x |
- } else {
+ which_root_name = c("root", "rbind_root"),
|
| 253 | -5x | +22x |
- length(obj) + 1L+ all = TRUE |
| 254 |
- }+ ) |
||
| 255 | -+ | 22x |
- }+ maxlen <- max(lengths(df$path)) |
| 256 |
- )+ |
||
| 257 |
-
+ # Loop for metadata (path and details from make_row_df) |
||
| 258 | -+ | 22x |
- #' @rdname int_methods+ metadf <- do.call( |
| 259 | -+ | 22x |
- setMethod("next_cpos", "ANY", function(obj, nested) 1L)
+ rbind.data.frame, |
| 260 | -+ | 22x |
-
+ lapply( |
| 261 | -+ | 22x |
- #' @rdname int_methods+ seq_len(NROW(df)), |
| 262 | -2572x | +22x |
- setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))
+ function(ii) {
|
| 263 | -+ | 433x |
-
+ handle_rdf_row(df[ii, ], maxlen = maxlen) |
| 264 |
- #' @rdname int_methods+ } |
||
| 265 |
- setMethod(+ ) |
||
| 266 |
- "last_rowsplit", "NULL",+ ) |
||
| 267 | -! | +
- function(obj) NULL+ |
|
| 268 |
- )+ # Should we keep label rows with NAs instead of values? |
||
| 269 | -+ | 22x |
-
+ if (keep_label_rows) {
|
| 270 | -+ | 7x |
- #' @rdname int_methods+ cellvals_mat_struct <- as.data.frame( |
| 271 | -+ | 7x |
- setMethod(+ matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals)) |
| 272 |
- "last_rowsplit", "SplitVector",+ ) |
||
| 273 | -+ | 7x |
- function(obj) {
+ colnames(cellvals_mat_struct) <- colnames(cellvals) |
| 274 | -1012x | +7x |
- if (length(obj) == 0) {
+ cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals |
| 275 | -204x | +7x |
- NULL+ ret <- cbind(metadf, cellvals_mat_struct) |
| 276 |
- } else {
+ } else {
|
||
| 277 | -808x | +15x |
- obj[[length(obj)]]+ ret <- cbind( |
| 278 | -+ | 15x |
- }+ metadf[metadf$node_class != "LabelRow", ], |
| 279 | -+ | 15x |
- }+ cellvals |
| 280 |
- )+ ) |
||
| 281 |
-
+ } |
||
| 282 |
- #' @rdname int_methods+ |
||
| 283 |
- setMethod(+ # If we want to expand colnames |
||
| 284 | -+ | 22x |
- "last_rowsplit", "PreDataRowLayout",+ if (expand_colnames) {
|
| 285 | -+ | 6x |
- function(obj) {
+ col_name_structure <- .get_formatted_colnames(clayout(tt)) |
| 286 | -1012x | +6x |
- if (length(obj) == 0) {
+ number_of_non_data_cols <- which(colnames(ret) == "node_class") |
| 287 | -! | +6x |
- NULL+ if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
|
| 288 | -+ | ! |
- } else {
+ stop( |
| 289 | -1012x | +! |
- last_rowsplit(obj[[length(obj)]])+ "When expanding colnames structure, we were not able to find the same", |
| 290 | -+ | ! |
- }+ " number of columns as in the result data frame. This is a bug. Please report it." |
| 291 | -+ | ! |
- }+ ) # nocov |
| 292 |
- )+ } |
||
| 294 | -+ | 6x |
- #' @rdname int_methods+ buffer_rows_for_colnames <- matrix( |
| 295 | -+ | 6x |
- setMethod(+ rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
|
| 296 | -+ | 6x |
- "last_rowsplit", "PreDataTableLayouts",+ nrow = NROW(col_name_structure) |
| 297 | -546x | +
- function(obj) last_rowsplit(rlayout(obj))+ ) |
|
| 298 |
- )+ |
||
| 299 | -+ | 6x |
-
+ header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure)) |
| 300 | -+ | 6x |
- # rlayout ----+ colnames(header_colnames_matrix) <- colnames(ret) |
| 301 |
- ## TODO maybe export these?+ |
||
| 302 | -+ | 6x |
-
+ count_row <- NULL |
| 303 | -+ | 6x |
- #' @rdname int_methods+ if (disp_ccounts(tt)) {
|
| 304 | -3666x | +3x |
- setGeneric("rlayout", function(obj) standardGeneric("rlayout"))
+ ccounts <- col_counts(tt) |
| 305 | -+ | 3x |
-
+ if (as_strings) {
|
| 306 | -+ | 2x |
- #' @rdname int_methods+ ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ] |
| 307 | -+ | 2x |
- setMethod(+ ccounts <- .remove_empty_elements(ccounts) |
| 308 |
- "rlayout", "PreDataTableLayouts",+ } |
||
| 309 | -3666x | +3x |
- function(obj) obj@row_layout+ count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
|
| 310 | -+ | 3x |
- )+ header_colnames_matrix <- rbind(header_colnames_matrix, count_row) |
| 311 |
-
+ } |
||
| 312 | -+ | 6x |
- #' @rdname int_methods+ ret <- rbind(header_colnames_matrix, ret) |
| 313 | -! | +
- setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())
+ } |
|
| 315 |
- #' @rdname int_methods+ # Using only labels for row names and losing information about paths |
||
| 316 | -1630x | +22x |
- setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))
+ if (as_is) {
|
| 317 | -+ | 2x |
-
+ tmp_rownames <- ret$label_name |
| 318 | -+ | 2x |
- #' @rdname int_methods+ ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))] |
| 319 | -+ | 2x |
- setMethod(+ if (length(unique(tmp_rownames)) == length(tmp_rownames)) {
|
| 320 | -+ | 1x |
- "rlayout<-", "PreDataTableLayouts",+ rownames(ret) <- tmp_rownames |
| 321 |
- function(object, value) {
+ } else {
|
||
| 322 | -1630x | +1x |
- object@row_layout <- value+ ret <- cbind("label_name" = tmp_rownames, ret)
|
| 323 | -1630x | +1x |
- object+ rownames(ret) <- NULL |
| 324 |
- }+ } |
||
| 325 |
- )+ } else {
|
||
| 326 | -+ | 20x |
-
+ rownames(ret) <- NULL |
| 327 |
- #' @rdname int_methods+ } |
||
| 328 | -20587x | +
- setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))
+
|
|
| 329 | -+ | 22x |
-
+ ret |
| 330 |
- ## setMethod("tree_pos", "VNodeInfo",
+ } |
||
| 331 |
- ## function(obj) obj@pos_in_tree)+ |
||
| 332 |
-
+ .remove_empty_elements <- function(char_df) {
|
||
| 333 | -+ | 11x |
- #' @rdname int_methods+ if (is.null(dim(char_df))) {
|
| 334 | -+ | 5x |
- setMethod(+ return(char_df[nzchar(char_df, keepNA = TRUE)]) |
| 335 |
- "tree_pos", "VLayoutNode",+ } |
||
| 336 | -20587x | +
- function(obj) obj@pos_in_tree+ |
|
| 337 | -+ | 6x |
- )+ apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)]) |
| 338 |
-
+ } |
||
| 339 |
- #' @rdname int_methods+ |
||
| 340 | -1237x | +
- setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))
+ # Helper function to make the character matrix numeric |
|
| 341 |
-
+ .make_numeric_char_mf <- function(char_df) {
|
||
| 342 | -+ | 9x |
- #' @rdname int_methods+ if (is.null(dim(char_df))) {
|
| 343 | -+ | 3x |
- setMethod(+ return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+"))) |
| 344 |
- "pos_subset", "TreePos",+ } |
||
| 345 | -1237x | +
- function(obj) obj@subset+ |
|
| 346 | -+ | 6x |
- )+ ret <- apply(char_df, 2, function(col_i) {
|
| 347 | -+ | 27x |
-
+ lapply( |
| 348 | -+ | 27x |
- ## setMethod("pos_subset", "VNodeInfo",
+ stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"), |
| 349 | -+ | 27x |
- ## function(obj) pos_subset(tree_pos(obj)))+ as.numeric |
| 350 |
-
+ ) |
||
| 351 |
- #' @rdname int_methods+ }) |
||
| 352 |
- setMethod(+ |
||
| 353 | -+ | 6x |
- "pos_subset", "VLayoutNode",+ do.call(cbind, ret) |
| 354 | -! | +
- function(obj) pos_subset(tree_pos(obj))+ } |
|
| 355 |
- )+ |
||
| 356 |
-
+ make_result_df_md_colnames <- function(maxlen) {
|
||
| 357 | -+ | 433x |
- #' @rdname int_methods+ spllen <- floor((maxlen - 2) / 2) |
| 358 | -20903x | +433x |
- setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))
+ ret <- character() |
| 359 | -+ | 433x |
-
+ if (spllen > 0) {
|
| 360 | -+ | 387x |
- #' @rdname int_methods+ ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_")
|
| 361 |
- setMethod(+ } |
||
| 362 | -+ | 433x |
- "pos_splits", "TreePos",+ ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
|
| 363 | -20903x | +
- function(obj) obj@splits+ } |
|
| 364 |
- )+ |
||
| 365 |
-
+ do_label_row <- function(rdfrow, maxlen) {
|
||
| 366 | -+ | 143x |
- ## setMethod("pos_splits", "VNodeInfo",
+ pth <- rdfrow$path[[1]] |
| 367 |
- ## function(obj) pos_splits(tree_pos(obj)))+ # Adjusting for the fact that we have two columns for each split |
||
| 368 | -+ | 143x |
-
+ extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2 |
| 369 |
- #' @rdname int_methods+ |
||
| 370 |
- setMethod(+ # Special cases with hidden labels |
||
| 371 | -+ | 143x |
- "pos_splits", "VLayoutNode",+ if (length(pth) %% 2 == 1) {
|
| 372 | -! | +108x |
- function(obj) pos_splits(tree_pos(obj))+ extra_nas_from_splits <- extra_nas_from_splits + 1 |
| 373 |
- )+ } |
||
| 375 | -+ | 143x |
- #' @rdname int_methods+ c( |
| 376 | -23319x | +143x |
- setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))
+ as.list(pth[seq_len(length(pth) - 1)]), |
| 377 | -+ | 143x |
-
+ as.list(replicate(extra_nas_from_splits, list(NA_character_))), |
| 378 | -+ | 143x |
- #' @rdname int_methods+ as.list(tail(pth, 1)), |
| 379 | -+ | 143x |
- setMethod(+ list( |
| 380 | -+ | 143x |
- "pos_splvals", "TreePos",+ label_name = rdfrow$label, |
| 381 | -23319x | +143x |
- function(obj) obj@s_values+ row_num = rdfrow$abs_rownumber, |
| 382 | -+ | 143x |
- )+ content = FALSE, |
| 383 | -+ | 143x |
-
+ node_class = rdfrow$node_class |
| 384 |
- ## setMethod("pos_splvals", "VNodeInfo",
+ ) |
||
| 385 |
- ## function(obj) pos_splvals(tree_pos(obj)))+ ) |
||
| 386 |
-
+ } |
||
| 387 |
- #' @rdname int_methods+ |
||
| 388 |
- setMethod(+ do_content_row <- function(rdfrow, maxlen) {
|
||
| 389 | -+ | 36x |
- "pos_splvals", "VLayoutNode",+ pth <- rdfrow$path[[1]] |
| 390 | -! | +36x |
- function(obj) pos_splvals(tree_pos(obj))+ contpos <- which(pth == "@content") |
| 391 |
- )+ |
||
| 392 | -+ | 36x |
-
+ seq_before <- seq_len(contpos - 1) |
| 393 |
- #' @rdname int_methods+ |
||
| 394 | -1237x | +36x |
- setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))
+ c( |
| 395 | -+ | 36x |
-
+ as.list(pth[seq_before]), |
| 396 | -+ | 36x |
- #' @rdname int_methods+ as.list(replicate(maxlen - contpos, list(NA_character_))), |
| 397 | -+ | 36x |
- setMethod(+ list(tail(pth, 1)), |
| 398 | -+ | 36x |
- "pos_splval_labels", "TreePos",+ list( |
| 399 | -1237x | +36x |
- function(obj) obj@sval_labels+ label_name = rdfrow$label, |
| 400 | -+ | 36x |
- )+ row_num = rdfrow$abs_rownumber, |
| 401 | -+ | 36x |
- ## no longer used+ content = TRUE, |
| 402 | -+ | 36x |
-
+ node_class = rdfrow$node_class |
| 403 |
- ## setMethod("pos_splval_labels", "VNodeInfo",
+ ) |
||
| 404 |
- ## function(obj) pos_splval_labels(tree_pos(obj)))+ ) |
||
| 405 |
- ## #' @rdname int_methods+ } |
||
| 406 |
- ## setMethod("pos_splval_labels", "VLayoutNode",
+
|
||
| 407 |
- ## function(obj) pos_splval_labels(tree_pos(obj)))+ do_data_row <- function(rdfrow, maxlen) {
|
||
| 408 | -+ | 254x |
-
+ pth <- rdfrow$path[[1]] |
| 409 | -+ | 254x |
- #' @rdname int_methods+ pthlen <- length(pth) |
| 410 | -13129x | +
- setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))
+ ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame |
|
| 411 | -+ | 254x |
-
+ if (pthlen %% 2 == 1) {
|
| 412 | -+ | 38x |
- #' @rdname int_methods+ pth <- pth[-1 * (pthlen - 2)] |
| 413 | -13129x | +
- setMethod("spl_payload", "Split", function(obj) obj@payload)
+ } |
|
| 414 | -+ | 254x |
-
+ pthlen_new <- length(pth) |
| 415 | -+ | 33x |
- #' @rdname int_methods+ if (maxlen == 1) pthlen_new <- 3 |
| 416 | -3x | +254x |
- setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))
+ c( |
| 417 | -+ | 254x |
-
+ as.list(pth[seq_len(pthlen_new - 2)]), |
| 418 | -+ | 254x |
- #' @rdname int_methods+ replicate(maxlen - pthlen, list(NA_character_)), |
| 419 | -+ | 254x |
- setMethod("spl_payload<-", "Split", function(obj, value) {
+ as.list(tail(pth, 2)), |
| 420 | -3x | +254x |
- obj@payload <- value+ list( |
| 421 | -3x | +254x |
- obj+ label_name = rdfrow$label, |
| 422 | -+ | 254x |
- })+ row_num = rdfrow$abs_rownumber, |
| 423 | -+ | 254x |
-
+ content = FALSE, |
| 424 | -+ | 254x |
- #' @rdname int_methods+ node_class = rdfrow$node_class |
| 425 | -690x | +
- setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))
+ ) |
|
| 426 |
-
+ ) |
||
| 427 |
- #' @rdname int_methods+ } |
||
| 428 | -687x | +
- setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)
+
|
|
| 429 |
-
+ .remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
|
||
| 430 | -+ | 434x |
- ## TODO revisit. do we want to do this? used in vars_in_layout, but only+ any_root_paths <- path[1] %in% which_root_name |
| 431 | -+ | 434x |
- ## for convenience.+ if (any_root_paths) {
|
| 432 | -+ | 274x |
- #' @rdname int_methods+ if (isTRUE(all)) {
|
| 433 | -3x | +
- setMethod("spl_label_var", "Split", function(obj) NULL)
+ # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later) |
|
| 434 | -+ | 274x |
-
+ root_indices <- which(path %in% which_root_name) |
| 435 | -+ | 274x |
- ### name related things+ if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
|
| 436 | -+ | ! |
- # #' @inherit formatters::formatter_methods+ end_point_root_headers <- which(diff(root_indices) > 1)[1] |
| 437 |
- #' Methods for generics in the `formatters` package+ } else {
|
||
| 438 | -+ | 274x |
- #'+ end_point_root_headers <- length(root_indices) |
| 439 |
- #' See the `formatters` documentation for descriptions of these generics.+ } |
||
| 440 | -+ | 274x |
- #'+ root_path_to_remove <- seq_len(end_point_root_headers) |
| 441 |
- #' @inheritParams gen_args+ } else {
|
||
| 442 | -+ | ! |
- #'+ root_path_to_remove <- 1 |
| 443 |
- #' @return+ } |
||
| 444 | -+ | 274x |
- #' * Accessor functions return the current value of the component being accessed of `obj`+ path <- path[-root_path_to_remove] |
| 445 |
- #' * Setter functions return a modified copy of `obj` with the new value.+ } |
||
| 446 |
- #'+ |
||
| 447 |
- #' @rdname formatters_methods+ # Fix for very edge case where we have only root elements |
||
| 448 | -+ | 434x |
- #' @aliases formatters_methods+ if (length(path) == 0) {
|
| 449 | -+ | 1x |
- #' @exportMethod obj_name+ path <- which_root_name[1] |
| 450 |
- setMethod(+ } |
||
| 451 |
- "obj_name", "VNodeInfo",+ |
||
| 452 | -64231x | +434x |
- function(obj) obj@name+ path |
| 453 |
- )+ } |
||
| 455 |
- #' @rdname formatters_methods+ handle_rdf_row <- function(rdfrow, maxlen) {
|
||
| 456 | -+ | 433x |
- #' @exportMethod obj_name+ nclass <- rdfrow$node_class |
| 457 |
- setMethod(+ |
||
| 458 | -+ | 433x |
- "obj_name", "Split",+ ret <- switch(nclass, |
| 459 | -30849x | +433x |
- function(obj) obj@name+ LabelRow = do_label_row(rdfrow, maxlen), |
| 460 | -+ | 433x |
- )+ ContentRow = do_content_row(rdfrow, maxlen), |
| 461 | -+ | 433x |
-
+ DataRow = do_data_row(rdfrow, maxlen), |
| 462 | -+ | 433x |
- #' @rdname formatters_methods+ stop("Unrecognized node type in row dataframe, unable to generate result data frame")
|
| 463 |
- #' @exportMethod obj_name<-+ ) |
||
| 464 | -+ | 433x |
- setMethod(+ setNames(ret, make_result_df_md_colnames(maxlen)) |
| 465 |
- "obj_name<-", "VNodeInfo",+ } |
||
| 466 |
- function(obj, value) {
+
|
||
| 467 | -2x | +
- obj@name <- value+ # Helper recurrent function to get the column names for the result data frame from the VTableTree |
|
| 468 | -2x | +
- obj+ .get_formatted_colnames <- function(clyt) {
|
|
| 469 | -+ | 41x |
- }+ ret <- obj_label(clyt) |
| 470 | -+ | 41x |
- )+ if (!nzchar(ret)) {
|
| 471 | -+ | 6x |
-
+ ret <- NULL |
| 472 |
- #' @rdname formatters_methods+ } |
||
| 473 | -+ | 41x |
- #' @exportMethod obj_name<-+ if (is.null(tree_children(clyt))) {
|
| 474 | -+ | ! |
- setMethod(+ return(ret) |
| 475 |
- "obj_name<-", "Split",+ } else {
|
||
| 476 | -+ | 41x |
- function(obj, value) {
+ ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames))) |
| 477 | -3x | +41x |
- obj@name <- value+ colnames(ret) <- NULL |
| 478 | -3x | +41x |
- obj+ rownames(ret) <- NULL |
| 479 | -+ | 41x |
- }+ return(ret) |
| 480 |
- )+ } |
||
| 481 |
-
+ } |
||
| 482 |
- ### Label related things+ |
||
| 483 |
- #' @rdname formatters_methods+ #' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`. |
||
| 484 |
- #' @exportMethod obj_label+ #' |
||
| 485 | -2097x | +
- setMethod("obj_label", "Split", function(obj) obj@split_label)
+ #' @param path_fun (`function`)\cr function to transform paths into single-string row/column names. |
|
| 486 |
-
+ #' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to |
||
| 487 |
- #' @rdname formatters_methods+ #' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`. |
||
| 488 |
- #' @exportMethod obj_label+ #' |
||
| 489 | -42456x | +
- setMethod("obj_label", "TableRow", function(obj) obj@label)
+ #' @return |
|
| 490 |
-
+ #' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by |
||
| 491 |
- ## XXX Do we want a convenience for VTableTree that+ #' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed |
||
| 492 |
- ## grabs the label from the LabelRow or will+ #' by `path_fun`). |
||
| 493 |
- ## that just muddy the waters?+ #' |
||
| 494 |
- #' @rdname formatters_methods+ #' @examples |
||
| 495 |
- #' @exportMethod obj_label+ #' lyt <- basic_table() %>% |
||
| 496 |
- setMethod(+ #' split_cols_by("ARM") %>%
|
||
| 497 |
- "obj_label", "VTableTree",+ #' analyze(c("AGE", "BMRKR2"))
|
||
| 498 | -270x | +
- function(obj) obj_label(tt_labelrow(obj))+ #' |
|
| 499 |
- )+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 500 |
-
+ #' path_enriched_df(tbl) |
||
| 501 |
- #' @rdname formatters_methods+ #' |
||
| 502 |
- #' @exportMethod obj_label+ #' @export |
||
| 503 | -! | +
- setMethod("obj_label", "ValueWrapper", function(obj) obj@label)
+ path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
|
|
| 504 | -+ | 3x |
-
+ rdf <- make_row_df(tt) |
| 505 | -+ | 3x |
- #' @rdname formatters_methods+ cdf <- make_col_df(tt) |
| 506 | -+ | 3x |
- #' @exportMethod obj_label<-+ cvs <- as.data.frame(do.call(rbind, cell_values(tt))) |
| 507 | -+ | 3x |
- setMethod(+ cvs <- as.data.frame(lapply(cvs, value_fun)) |
| 508 | -+ | 3x |
- "obj_label<-", "Split",+ row.names(cvs) <- NULL |
| 509 | -+ | 3x |
- function(obj, value) {
+ colnames(cvs) <- path_fun(cdf$path) |
| 510 | -1x | +3x |
- obj@split_label <- value+ preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) |
| 511 | -1x | +3x |
- obj+ cbind.data.frame(row_path = preppaths, cvs) |
| 512 |
- }+ } |
||
| 513 |
- )+ |
||
| 514 |
-
+ .collapse_char <- "|" |
||
| 515 |
- #' @rdname formatters_methods+ .collapse_char_esc <- "\\|" |
||
| 516 |
- #' @exportMethod obj_label<-+ |
||
| 517 |
- setMethod(+ collapse_path <- function(paths) {
|
||
| 518 | -+ | 196x |
- "obj_label<-", "TableRow",+ if (is.list(paths)) {
|
| 519 | -+ | 6x |
- function(obj, value) {
+ return(vapply(paths, collapse_path, "")) |
| 520 | -32x | +
- obj@label <- value+ } |
|
| 521 | -32x | +190x |
- obj+ paste(paths, collapse = .collapse_char) |
| 522 |
- }+ } |
||
| 523 |
- )+ |
||
| 524 |
-
+ collapse_values <- function(colvals) {
|
||
| 525 | -+ | 13x |
- #' @rdname formatters_methods+ if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
|
| 526 | -+ | ! |
- #' @exportMethod obj_label<-+ return(colvals) |
| 527 | -+ | 13x |
- setMethod(+ } else if (all(vapply(colvals, length, 1L) == 1)) {
|
| 528 | -+ | 1x |
- "obj_label<-", "ValueWrapper",+ return(unlist(colvals)) |
| 529 |
- function(obj, value) {
+ } |
||
| 530 | -! | +12x |
- obj@label <- value+ vapply(colvals, paste, "", collapse = .collapse_char) |
| 531 | -! | +
- obj+ } |
|
| 532 |
- }+ |
||
| 533 |
- )+ # pdf output ------------------------------------------------------------------- |
||
| 535 |
- #' @rdname formatters_methods+ ### Export as PDF - migrated to formatters |
||
| 536 |
- #' @exportMethod obj_label<-+ |
||
| 537 |
- setMethod(+ #' @importFrom formatters export_as_pdf |
||
| 538 |
- "obj_label<-", "VTableTree",+ #' |
||
| 539 |
- function(obj, value) {
+ #' @examples |
||
| 540 | -11x | +
- lr <- tt_labelrow(obj)+ #' lyt <- basic_table() %>% |
|
| 541 | -11x | +
- obj_label(lr) <- value+ #' split_cols_by("ARM") %>%
|
|
| 542 | -11x | +
- if (!is.na(value) && nzchar(value)) {
+ #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
|
|
| 543 | -10x | +
- labelrow_visible(lr) <- TRUE+ #' |
|
| 544 | -1x | +
- } else if (is.na(value)) {
+ #' tbl <- build_table(lyt, ex_adsl) |
|
| 545 | -1x | +
- labelrow_visible(lr) <- FALSE+ #' |
|
| 546 |
- }+ #' \dontrun{
|
||
| 547 | -11x | +
- tt_labelrow(obj) <- lr+ #' tf <- tempfile(fileext = ".pdf") |
|
| 548 | -11x | +
- obj+ #' export_as_pdf(tbl, file = tf, pg_height = 4) |
|
| 549 |
- }+ #' tf <- tempfile(fileext = ".pdf") |
||
| 550 |
- )+ #' export_as_pdf(tbl, file = tf, lpp = 8) |
||
| 551 |
-
+ #' } |
||
| 552 |
- ### Label rows.+ #' |
||
| 553 |
- #' @rdname int_methods+ #' @export |
||
| 554 | -139031x | +
- setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))
+ formatters::export_as_pdf |
|
| 556 |
- #' @rdname int_methods+ # only used in pagination |
||
| 557 |
- setMethod(+ .tab_to_colpath_set <- function(tt) {
|
||
| 558 | -+ | 4x |
- "tt_labelrow", "VTableTree",+ vapply( |
| 559 | -51273x | +4x |
- function(obj) obj@labelrow+ collect_leaves(coltree(tt)), |
| 560 | -+ | 4x |
- )+ function(y) paste(pos_to_path(tree_pos(y)), collapse = " "), |
| 561 |
-
+ "" |
||
| 562 |
- #' @rdname int_methods+ ) |
||
| 563 | -4066x | +
- setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))
+ } |
|
| 564 |
-
+ .figure_out_colinds <- function(subtab, fulltab) {
|
||
| 565 | -+ | 2x |
- #' @rdname int_methods+ match( |
| 566 | -+ | 2x |
- setMethod(+ .tab_to_colpath_set(subtab), |
| 567 | -+ | 2x |
- "tt_labelrow<-", c("VTableTree", "LabelRow"),
+ .tab_to_colpath_set(fulltab) |
| 568 |
- function(obj, value) {
+ ) |
||
| 569 | -4066x | +
- if (no_colinfo(value)) {
+ } |
|
| 570 | -1x | +
- col_info(value) <- col_info(obj)+ |
|
| 571 |
- }+ # Flextable and docx ----------------------------------------------------------- |
||
| 572 | -4066x | +
- obj@labelrow <- value+ |
|
| 573 | -4066x | +
- obj+ #' Export as word document |
|
| 574 |
- }+ #' |
||
| 575 |
- )+ #' From a table, produce a self-contained word document or attach it to a template word |
||
| 576 |
-
+ #' file (`template_file`). This function is based on the [tt_to_flextable()] transformer and |
||
| 577 |
- #' @rdname int_methods+ #' the `officer` package. |
||
| 578 | -209987x | +
- setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))
+ #' |
|
| 579 |
-
+ #' @inheritParams gen_args |
||
| 580 |
- #' @rdname int_methods+ #' @param file (`string`)\cr string that indicates the final file output. Must have `.docx` extension. |
||
| 581 |
- setMethod(+ #' @param doc_metadata (`list` of `string`s)\cr any value that can be used as metadata by |
||
| 582 |
- "labelrow_visible", "VTableTree",+ #' `?officer::set_doc_properties`. Important text values are `title`, `subject`, `creator`, and `description`, |
||
| 583 |
- function(obj) {
+ #' while `created` is a date object. |
||
| 584 | -31235x | +
- labelrow_visible(tt_labelrow(obj))+ #' @inheritParams tt_to_flextable |
|
| 585 |
- }+ #' @param template_file (`string`)\cr template file that `officer` will use as a starting point for the final |
||
| 586 |
- )+ #' document. Document attaches the table and uses the defaults defined in the template file. |
||
| 587 |
-
+ #' @param section_properties (`officer::prop_section`)\cr an [officer::prop_section()] object which sets margins and |
||
| 588 |
- #' @rdname int_methods+ #' page size. |
||
| 589 |
- setMethod(+ #' |
||
| 590 |
- "labelrow_visible", "LabelRow",+ #' @note `export_as_docx()` has few customization options available. If you require specific formats and details, |
||
| 591 | -115095x | +
- function(obj) obj@visible+ #' we suggest that you use [tt_to_flextable()] prior to `export_as_docx`. Only the `title_as_header` and |
|
| 592 |
- )+ #' `footer_as_text` parameters must be re-specified if the table is changed first using [tt_to_flextable()]. |
||
| 593 |
-
+ #' |
||
| 594 |
- #' @rdname int_methods+ #' @seealso [tt_to_flextable()] |
||
| 595 |
- setMethod(+ #' |
||
| 596 |
- "labelrow_visible", "VAnalyzeSplit",+ #' @examples |
||
| 597 | -1391x | +
- function(obj) .labelkids_helper(obj@var_label_position)+ #' lyt <- basic_table() %>% |
|
| 598 |
- )+ #' split_cols_by("ARM") %>%
|
||
| 599 |
-
+ #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
|
||
| 600 |
- #' @rdname int_methods+ #' |
||
| 601 | -2909x | +
- setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))
+ #' tbl <- build_table(lyt, ex_adsl) |
|
| 602 |
-
+ #' |
||
| 603 |
- #' @rdname int_methods+ #' # See how section_properties_portrait function is built for custom |
||
| 604 |
- setMethod(+ #' \dontrun{
|
||
| 605 |
- "labelrow_visible<-", "VTableTree",+ #' tf <- tempfile(fileext = ".docx") |
||
| 606 |
- function(obj, value) {
+ #' export_as_docx(tbl, file = tf, section_properties = section_properties_portrait()) |
||
| 607 | -1318x | +
- lr <- tt_labelrow(obj)+ #' } |
|
| 608 | -1318x | +
- labelrow_visible(lr) <- value+ #' |
|
| 609 | -1318x | +
- tt_labelrow(obj) <- lr+ #' @export |
|
| 610 | -1318x | +
- obj+ export_as_docx <- function(tt, |
|
| 611 |
- }+ file, |
||
| 612 |
- )+ doc_metadata = NULL, |
||
| 613 |
-
+ titles_as_header = FALSE, |
||
| 614 |
- #' @rdname int_methods+ footers_as_text = TRUE, |
||
| 615 |
- setMethod(+ template_file = NULL, |
||
| 616 |
- "labelrow_visible<-", "LabelRow",+ section_properties = NULL) {
|
||
| 617 |
- function(obj, value) {
+ # Checks |
||
| 618 | -1329x | +3x |
- obj@visible <- value+ check_required_packages(c("flextable", "officer"))
|
| 619 | -1329x | +3x |
- obj+ if (inherits(tt, "VTableTree")) {
|
| 620 | -+ | 2x |
- }+ flex_tbl <- tt_to_flextable(tt, |
| 621 | -+ | 2x |
- )+ titles_as_header = titles_as_header, |
| 622 | -+ | 2x |
-
+ footers_as_text = footers_as_text |
| 623 |
- #' @rdname int_methods+ ) |
||
| 624 | -+ | 2x |
- setMethod(+ if (isFALSE(titles_as_header) || isTRUE(footers_as_text)) {
|
| 625 |
- "labelrow_visible<-", "VAnalyzeSplit",+ # Ugly but I could not find a getter for font.size |
||
| 626 | -+ | 2x |
- function(obj, value) {
+ font_sz <- flex_tbl$header$styles$text$font.size$data[1, 1] |
| 627 | -262x | +2x |
- obj@var_label_position <- value+ font_sz_footer <- flex_tbl$header$styles$text$font.size$data[1, 1] - 1 |
| 628 | -262x | +2x |
- obj+ font_fam <- flex_tbl$header$styles$text$font.family$data[1, 1] |
| 629 |
- }+ |
||
| 630 |
- )+ # Set the test as the tt |
||
| 631 | -+ | 2x |
-
+ fpt <- officer::fp_text(font.family = font_fam, font.size = font_sz) |
| 632 | -+ | 2x |
- ## TRUE is always, FALSE is never, NA is only when no+ fpt_footer <- officer::fp_text(font.family = font_fam, font.size = font_sz_footer) |
| 633 |
- ## content function (or rows in an instantiated table) is present+ } |
||
| 634 |
- #' @rdname int_methods+ } else {
|
||
| 635 | -1515x | +1x |
- setGeneric("label_kids", function(spl) standardGeneric("label_kids"))
+ flex_tbl <- tt |
| 636 |
-
+ } |
||
| 637 | -+ | 3x |
- #' @rdname int_methods+ if (!is.null(template_file) && !file.exists(template_file)) {
|
| 638 | -1515x | +1x |
- setMethod("label_kids", "Split", function(spl) spl@label_children)
+ template_file <- NULL |
| 639 |
-
+ } |
||
| 640 |
- #' @rdname int_methods+ |
||
| 641 | -3x | +
- setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))
+ # Create a new empty Word document |
|
| 642 | -+ | 3x |
-
+ if (!is.null(template_file)) {
|
| 643 | -+ | 2x |
- #' @rdname int_methods+ doc <- officer::read_docx(template_file) |
| 644 |
- setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
+ } else {
|
||
| 645 | 1x |
- label_kids(spl) <- .labelkids_helper(value)+ doc <- officer::read_docx() |
|
| 646 | -1x | +
- spl+ } |
|
| 647 |
- })+ |
||
| 648 | -+ | 3x |
-
+ if (!is.null(section_properties)) {
|
| 649 | -+ | 3x |
- #' @rdname int_methods+ doc <- officer::body_set_default_section(doc, section_properties) |
| 650 |
- setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
+ } |
||
| 651 | -2x | +
- spl@label_children <- value+ |
|
| 652 | -2x | +
- spl+ # Extract title |
|
| 653 | -+ | 3x |
- })+ if (isFALSE(titles_as_header) && inherits(tt, "VTableTree")) {
|
| 654 | -+ | 2x |
-
+ ts_tbl <- all_titles(tt) |
| 655 | -+ | 2x |
- #' @rdname int_methods+ if (length(ts_tbl) > 0) {
|
| 656 | -406x | +2x |
- setGeneric("vis_label", function(spl) standardGeneric("vis_label"))
+ doc <- add_text_par(doc, ts_tbl, fpt) |
| 657 |
-
+ } |
||
| 658 |
- #' @rdname int_methods+ } |
||
| 659 |
- setMethod("vis_label", "Split", function(spl) {
+
|
||
| 660 | -406x | +
- .labelkids_helper(label_position(spl))+ # Add the table to the document |
|
| 661 | -+ | 3x |
- })+ doc <- flextable::body_add_flextable(doc, flex_tbl, align = "left") |
| 663 |
- ## #' @rdname int_methods+ # add footers as paragraphs |
||
| 664 | -+ | 3x |
- ## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
+ if (isTRUE(footers_as_text) && inherits(tt, "VTableTree")) {
|
| 665 |
- ## #' @rdname int_methods+ # Adding referantial footer line separator if present |
||
| 666 |
- ## setMethod("vis_label<-", "Split", function(spl, value) {
+ # (this is usually done differently, i.e. inside footnotes) |
||
| 667 | -+ | 2x |
- ## stop("defunct")
+ matform <- matrix_form(tt, indent_rownames = TRUE) |
| 668 | -+ | 2x |
- ## if(is.na(value))+ if (length(matform$ref_footnotes) > 0) {
|
| 669 | -+ | 2x |
- ## stop("split label visibility must be TRUE or FALSE, got NA")
+ doc <- add_text_par(doc, matform$ref_footnotes, fpt_footer) |
| 670 |
- ## # spl@split_label_visible <- value+ } |
||
| 671 |
- ## spl+ # Footer lines |
||
| 672 | -+ | 2x |
- ## })+ if (length(all_footers(tt)) > 0) {
|
| 673 | -+ | 2x |
-
+ doc <- add_text_par(doc, all_footers(tt), fpt_footer) |
| 674 |
- #' @rdname int_methods+ } |
||
| 675 | -1027x | +
- setGeneric("label_position", function(spl) standardGeneric("label_position"))
+ } |
|
| 677 | -+ | 3x |
- #' @rdname int_methods+ if (!is.null(doc_metadata)) {
|
| 678 | -706x | +
- setMethod("label_position", "Split", function(spl) spl@split_label_position)
+ # Checks for values rely on officer function |
|
| 679 | -+ | 3x |
-
+ doc <- do.call(officer::set_doc_properties, c(list("x" = doc), doc_metadata))
|
| 680 |
- #' @rdname int_methods+ } |
||
| 681 | -321x | +
- setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)
+
|
|
| 682 |
-
+ # Save the Word document to a file |
||
| 683 | -+ | 3x |
- #' @rdname int_methods+ print(doc, target = file) |
| 684 | -50x | +
- setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))
+ } |
|
| 686 |
- #' @rdname int_methods+ # Shorthand to add text paragraph |
||
| 687 |
- setMethod("label_position<-", "Split", function(spl, value) {
+ add_text_par <- function(doc, chr_v, text_format) {
|
||
| 688 | -50x | +6x |
- value <- match.arg(value, valid_lbl_pos)+ for (ii in seq_along(chr_v)) {
|
| 689 | -50x | +16x |
- spl@split_label_position <- value+ cur_fp <- officer::fpar(officer::ftext(chr_v[ii], prop = text_format)) |
| 690 | -50x | +16x |
- spl+ doc <- officer::body_add_fpar(doc, cur_fp) |
| 691 |
- })+ } |
||
| 692 | -+ | 6x |
-
+ doc |
| 693 |
- ### Function accessors (summary, tabulation and split) ----+ } |
||
| 695 |
- #' @rdname int_methods+ #' @describeIn export_as_docx Helper function that defines standard portrait properties for tables. |
||
| 696 | -3212x | +
- setGeneric("content_fun", function(obj) standardGeneric("content_fun"))
+ #' @export |
|
| 697 |
-
+ section_properties_portrait <- function() {
|
||
| 698 | -+ | 2x |
- #' @rdname int_methods+ officer::prop_section( |
| 699 | -3161x | +2x |
- setMethod("content_fun", "Split", function(obj) obj@content_fun)
+ page_size = officer::page_size( |
| 700 | -+ | 2x |
-
+ orient = "portrait", |
| 701 | -+ | 2x |
- #' @rdname int_methods+ width = 8.5, height = 11 |
| 702 | -105x | +
- setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))
+ ), |
|
| 703 | -+ | 2x |
-
+ type = "continuous", |
| 704 | -+ | 2x |
- #' @rdname int_methods+ page_margins = margins_potrait() |
| 705 |
- setMethod("content_fun<-", "Split", function(object, value) {
+ ) |
||
| 706 | -105x | +
- object@content_fun <- value+ } |
|
| 707 | -105x | +
- object+ |
|
| 708 |
- })+ #' @describeIn export_as_docx Helper function that defines standard landscape properties for tables. |
||
| 709 |
-
+ #' @export |
||
| 710 |
- #' @rdname int_methods+ section_properties_landscape <- function() {
|
||
| 711 | -1720x | +1x |
- setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))
+ officer::prop_section( |
| 712 | -+ | 1x |
-
+ page_size = officer::page_size( |
| 713 | -+ | 1x |
- #' @rdname int_methods+ orient = "landscape", |
| 714 | -1625x | +1x |
- setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)
+ width = 8.5, height = 11 |
| 715 |
-
+ ), |
||
| 716 | -+ | 1x |
- #' @rdname int_methods+ type = "continuous", |
| 717 | -95x | +1x |
- setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)
+ page_margins = margins_landscape() |
| 718 |
-
+ ) |
||
| 719 |
- ## not used and probably not needed+ } |
||
| 720 |
- ## #' @rdname int_methods+ |
||
| 721 |
- ## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))
+ #' @describeIn export_as_docx Helper function that defines standard portrait margins for tables. |
||
| 722 |
-
+ #' @export |
||
| 723 |
- ## #' @rdname int_methods+ margins_potrait <- function() {
|
||
| 724 | -+ | 2x |
- ## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
+ officer::page_mar(bottom = 0.98, top = 0.95, left = 1.5, right = 1, gutter = 0) |
| 725 |
- ## object@analysis_fun <- value+ } |
||
| 726 |
- ## object+ #' @describeIn export_as_docx Helper function that defines standard landscape margins for tables. |
||
| 727 |
- ## })+ #' @export |
||
| 728 |
- ## #' @rdname int_methods+ margins_landscape <- function() {
|
||
| 729 | -+ | 1x |
- ## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
+ officer::page_mar(bottom = 1, top = 1.5, left = 0.98, right = 0.95, gutter = 0) |
| 730 |
- ## if(is(value, "function"))+ } |
||
| 731 |
- ## value <- list(value)+ |
||
| 732 |
- ## object@analysis_fun <- value+ #' Create a `flextable` from an `rtables` table |
||
| 733 |
- ## object+ #' |
||
| 734 |
- ## })+ #' Principally used for export ([export_as_docx()]), this function produces a `flextable` |
||
| 735 |
-
+ #' from an `rtables` table. If `theme = NULL`, `rtables`-like style will be used. Otherwise, |
||
| 736 |
- #' @rdname int_methods+ #' [theme_docx_default()] will produce a `.docx`-friendly table. |
||
| 737 | -1033x | +
- setGeneric("split_fun", function(obj) standardGeneric("split_fun"))
+ #' |
|
| 738 |
-
+ #' @inheritParams gen_args |
||
| 739 |
- #' @rdname int_methods+ #' @inheritParams paginate_table |
||
| 740 | -863x | +
- setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)
+ #' @param theme (`function` or `NULL`)\cr A theme function that is designed internally as a function of a `flextable` |
|
| 741 |
-
+ #' object to change its layout and style. If `NULL`, it will produce a table similar to `rtables` default. Defaults |
||
| 742 |
- ## Only that type of split currently has the slot+ #' to `theme_docx_default(tt)`. |
||
| 743 |
- ## this should probably change? for now define+ #' @param border (`officer` border object)\cr defaults to `officer::fp_border(width = 0.5)`. |
||
| 744 |
- ## an accessor that just returns NULL+ #' @param indent_size (`integer(1)`)\cr if `NULL`, the default indent size of the table (see [matrix_form()] |
||
| 745 |
- #' @rdname int_methods+ #' `indent_size`) is used. To work with `docx`, any size is multiplied by 2 mm (5.67 pt) by default. |
||
| 746 | -119x | +
- setMethod("split_fun", "Split", function(obj) NULL)
+ #' @param titles_as_header (`flag`)\cr defaults to `TRUE` for [tt_to_flextable()], so the table is self-contained |
|
| 747 |
-
+ #' as it makes additional header rows for [main_title()] string and [subtitles()] character vector (one per element). |
||
| 748 |
- #' @rdname int_methods+ #' `FALSE` is suggested for [export_as_docx()]. This adds titles and subtitles as a text paragraph above the table. |
||
| 749 | -13x | +
- setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))
+ #' The same style is applied. |
|
| 750 |
-
+ #' @param footers_as_text (`flag`)\cr defaults to `FALSE` for [tt_to_flextable()], so the table is self-contained with |
||
| 751 |
- #' @rdname int_methods+ #' the `flextable` definition of footnotes. `TRUE` is used for [export_as_docx()] to add the footers as a new |
||
| 752 |
- setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
+ #' paragraph after the table. The same style is applied, but with a smaller font. |
||
| 753 | -13x | +
- obj@split_fun <- value+ #' @param counts_in_newline (`flag`)\cr defaults to `FALSE`. In `rtables` text printing ([formatters::toString()]), |
|
| 754 | -13x | +
- obj+ #' the column counts, i.e. `(N=xx)`, are always on a new line. For `docx` exports it could be necessary to print it |
|
| 755 |
- })+ #' on the same line. |
||
| 756 |
-
+ #' @param paginate (`flag`)\cr when exporting `.docx` documents using `export_as_docx`, we suggest relying on the |
||
| 757 |
- # nocov start+ #' Microsoft Word pagination system. If `TRUE`, this option splits `tt` into different "pages" as multiple |
||
| 758 |
- ## Only that type of split currently has the slot+ #' `flextables`. Cooperation between the two mechanisms is not guaranteed. Defaults to `FALSE`. |
||
| 759 |
- ## this should probably change? for now define+ #' @param total_width (`numeric(1)`)\cr total width (in inches) for the resulting flextable(s). Defaults to 10. |
||
| 760 |
- ## an accessor that just returns NULL+ #' |
||
| 761 |
- #' @rdname int_methods+ #' @return A `flextable` object. |
||
| 762 |
- setMethod(+ #' |
||
| 763 |
- "split_fun<-", "Split",+ #' @seealso [export_as_docx()] |
||
| 764 |
- function(obj, value) {
+ #' |
||
| 765 |
- stop(+ #' @examples |
||
| 766 |
- "Attempted to set a custom split function on a non-customizable split.",+ #' analysisfun <- function(x, ...) {
|
||
| 767 |
- "This should not happen, please contact the maintainers."+ #' in_rows( |
||
| 768 |
- )+ #' row1 = 5, |
||
| 769 |
- }+ #' row2 = c(1, 2), |
||
| 770 |
- )+ #' .row_footnotes = list(row1 = "row 1 - row footnote"), |
||
| 771 |
- # nocov end+ #' .cell_footnotes = list(row2 = "row 2 - cell footnote") |
||
| 772 |
-
+ #' ) |
||
| 773 |
- ## Content specification related accessors ----+ #' } |
||
| 774 |
-
+ #' |
||
| 775 |
- #' @rdname int_methods+ #' lyt <- basic_table( |
||
| 776 | -459x | +
- setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))
+ #' title = "Title says Whaaaat", subtitles = "Oh, ok.", |
|
| 777 |
-
+ #' main_footer = "ha HA! Footer!" |
||
| 778 |
- #' @rdname int_methods+ #' ) %>% |
||
| 779 | -459x | +
- setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)
+ #' split_cols_by("ARM") %>%
|
|
| 780 |
-
+ #' analyze("AGE", afun = analysisfun)
|
||
| 781 |
- #' @rdname int_methods+ #' |
||
| 782 | -105x | +
- setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))
+ #' tbl <- build_table(lyt, ex_adsl) |
|
| 783 |
-
+ #' # rtables style |
||
| 784 |
- #' @rdname int_methods+ #' tt_to_flextable(tbl, theme = NULL) |
||
| 785 |
- setMethod("content_extra_args<-", "Split", function(object, value) {
+ #' |
||
| 786 | -105x | +
- object@content_extra_args <- value+ #' tt_to_flextable(tbl, theme = theme_docx_default(tbl, font_size = 7)) |
|
| 787 | -105x | +
- object+ #' |
|
| 788 |
- })+ #' @export |
||
| 789 |
-
+ tt_to_flextable <- function(tt, |
||
| 790 |
- #' @rdname int_methods+ theme = theme_docx_default(tt), |
||
| 791 | -1820x | +
- setGeneric("content_var", function(obj) standardGeneric("content_var"))
+ border = flextable::fp_border_default(width = 0.5), |
|
| 792 |
-
+ indent_size = NULL, |
||
| 793 |
- #' @rdname int_methods+ titles_as_header = TRUE, |
||
| 794 | -1820x | +
- setMethod("content_var", "Split", function(obj) obj@content_var)
+ footers_as_text = FALSE, |
|
| 795 |
-
+ counts_in_newline = FALSE, |
||
| 796 |
- #' @rdname int_methods+ paginate = FALSE, |
||
| 797 | -105x | +
- setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))
+ lpp = NULL, |
|
| 798 |
-
+ cpp = NULL, |
||
| 799 |
- #' @rdname int_methods+ ..., |
||
| 800 |
- setMethod("content_var<-", "Split", function(object, value) {
+ colwidths = propose_column_widths(matrix_form(tt, indent_rownames = TRUE)), |
||
| 801 | -105x | +
- object@content_var <- value+ tf_wrap = !is.null(cpp), |
|
| 802 | -105x | +
- object+ max_width = cpp, |
|
| 803 |
- })+ total_width = 10) {
|
||
| 804 | -+ | 13x |
-
+ check_required_packages("flextable")
|
| 805 | -+ | 13x |
- ### Miscellaneous accessors ----+ if (!inherits(tt, "VTableTree")) {
|
| 806 | -+ | ! |
-
+ stop("Input table is not an rtables' object.")
|
| 807 |
- #' @rdname int_methods+ } |
||
| 808 | -1122x | +13x |
- setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))
+ checkmate::assert_flag(titles_as_header) |
| 809 | -+ | 13x |
-
+ checkmate::assert_flag(footers_as_text) |
| 810 | -+ | 13x |
- #' @rdname int_methods+ checkmate::assert_flag(counts_in_newline) |
| 811 |
- setMethod(+ |
||
| 812 |
- "avar_inclNAs", "VAnalyzeSplit",+ ## if we're paginating, just call -> pagination happens also afterwards if needed |
||
| 813 | -1122x | +13x |
- function(obj) obj@include_NAs+ if (paginate) {
|
| 814 | -+ | 1x |
- )+ if (is.null(lpp)) {
|
| 815 | -+ | ! |
-
+ stop("lpp must be specified when calling tt_to_flextable with paginate=TRUE")
|
| 816 |
- #' @rdname int_methods+ } |
||
| 817 | -! | +1x |
- setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))
+ tabs <- paginate_table(tt, lpp = lpp, cpp = cpp, tf_wrap = tf_wrap, max_width = max_width, ...) |
| 818 | -+ | 1x |
-
+ cinds <- lapply(tabs, function(tb) c(1, .figure_out_colinds(tb, tt) + 1L)) |
| 819 | -+ | 1x |
- #' @rdname int_methods+ return(mapply(tt_to_flextable, |
| 820 | -+ | 1x |
- setMethod(+ tt = tabs, colwidths = cinds, |
| 821 | -+ | 1x |
- "avar_inclNAs<-", "VAnalyzeSplit",+ MoreArgs = list(paginate = FALSE, total_width = total_width), |
| 822 | -+ | 1x |
- function(obj, value) {
+ SIMPLIFY = FALSE |
| 823 | -! | +
- obj@include_NAs <- value+ )) |
|
| 825 |
- )+ |
||
| 826 |
-
+ # Calculate the needed colwidths |
||
| 827 | -+ | 12x |
- #' @rdname int_methods+ final_cwidths <- total_width * colwidths / sum(colwidths) # xxx to fix |
| 828 | -784x | +
- setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))
+ # xxx FIXME missing transformer from character based widths to mm or pt |
|
| 830 |
- #' @rdname int_methods+ # Extract relevant information |
||
| 831 | -784x | +12x |
- setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)
+ matform <- matrix_form(tt, indent_rownames = TRUE) |
| 832 | -+ | 12x |
-
+ body <- mf_strings(matform) # Contains header |
| 833 | -+ | 12x |
- #' @rdname int_methods+ spans <- mf_spans(matform) # Contains header |
| 834 | -2649x | +12x |
- setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))
+ mpf_aligns <- mf_aligns(matform) # Contains header |
| 835 | -+ | 12x |
-
+ hnum <- mf_nlheader(matform) # Number of lines for the header |
| 836 | -+ | 12x |
- #' @rdname int_methods+ rdf <- make_row_df(tt) # Row-wise info |
| 837 | -2361x | +
- setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)
+
|
|
| 838 |
-
+ # decimal alignment pre-proc |
||
| 839 | -+ | 12x |
- #' @rdname int_methods+ if (any(grepl("dec", mpf_aligns))) {
|
| 840 | -+ | ! |
- setGeneric(+ body <- decimal_align(body, mpf_aligns) |
| 841 |
- "spl_child_order<-",+ # Coercion for flextable |
||
| 842 | -606x | +! |
- function(obj, value) standardGeneric("spl_child_order<-")
+ mpf_aligns[mpf_aligns == "decimal"] <- "center" |
| 843 | -+ | ! |
- )+ mpf_aligns[mpf_aligns == "dec_left"] <- "left" |
| 844 | -+ | ! |
-
+ mpf_aligns[mpf_aligns == "dec_right"] <- "right" |
| 845 |
- #' @rdname int_methods+ } |
||
| 846 |
- setMethod(+ |
||
| 847 |
- "spl_child_order<-", "VarLevelSplit",+ # Fundamental content of the table |
||
| 848 | -+ | 12x |
- function(obj, value) {
+ content <- as.data.frame(body[-seq_len(hnum), , drop = FALSE]) |
| 849 | -606x | +12x |
- obj@value_order <- value+ flx <- flextable::qflextable(content) %>% |
| 850 | -606x | +
- obj+ # Default rtables if no footnotes |
|
| 851 | -+ | 12x |
- }+ remove_hborder(part = "body", w = "bottom") |
| 852 |
- )+ |
||
| 853 |
-
+ # Header addition -> NB: here we have a problem with (N=xx) |
||
| 854 | -+ | 12x |
- #' @rdname int_methods+ hdr <- body[seq_len(hnum), , drop = FALSE] |
| 855 |
- setMethod(+ |
||
| 856 |
- "spl_child_order",+ # XXX NOT NECESSARY change of (N=xx) which is by default on a new line but we do not |
||
| 857 |
- "ManualSplit",+ # want this in docx, and it depends on the size of the table, it is not another |
||
| 858 | -51x | +
- function(obj) obj@levels+ # row with different columns -> All of this should be fixed at source (in matrix_form) |
|
| 859 |
- )+ # See .tbl_header_mat for this change |
||
| 860 | -+ | 12x |
-
+ if (hnum > 1) { # otherwise nothing to do
|
| 861 | -+ | 12x |
- #' @rdname int_methods+ det_nclab <- apply(hdr, 2, grepl, pattern = "\\(N=[0-9]+\\)$") |
| 862 | -+ | 12x |
- setMethod(+ has_nclab <- apply(det_nclab, 1, any) |
| 863 | -+ | 12x |
- "spl_child_order",+ whsnc <- which(has_nclab) # which rows have it -> more than one is not supported |
| 864 | -+ | 12x |
- "MultiVarSplit",+ if (isFALSE(counts_in_newline) && any(has_nclab) && length(whsnc) == 1L) {
|
| 865 | -96x | +5x |
- function(obj) spl_varnames(obj)+ what_is_nclab <- det_nclab[whsnc, ] |
| 866 |
- )+ |
||
| 867 |
-
+ # condition for popping the interested row by merging the upper one |
||
| 868 | -+ | 5x |
- #' @rdname int_methods+ hdr[whsnc, what_is_nclab] <- paste(hdr[whsnc - 1, what_is_nclab], |
| 869 | -+ | 5x |
- setMethod(+ hdr[whsnc, what_is_nclab], |
| 870 | -+ | 5x |
- "spl_child_order",+ sep = " " |
| 871 |
- "AllSplit",+ ) |
||
| 872 | -97x | +5x |
- function(obj) character()+ hdr[whsnc - 1, what_is_nclab] <- "" |
| 873 |
- )+ |
||
| 874 |
-
+ # We can remove the row if they are all "" |
||
| 875 | -+ | 5x |
- #' @rdname int_methods+ row_to_pop <- whsnc - 1 |
| 876 | -+ | 5x |
- setMethod(+ if (all(!nzchar(hdr[row_to_pop, ]))) {
|
| 877 | -+ | 4x |
- "spl_child_order",+ hdr <- hdr[-row_to_pop, , drop = FALSE] |
| 878 | -+ | 4x |
- "VarStaticCutSplit",+ spans <- spans[-row_to_pop, , drop = FALSE] |
| 879 | -44x | +4x |
- function(obj) spl_cutlabels(obj)+ body <- body[-row_to_pop, , drop = FALSE] |
| 880 | -+ | 4x |
- )+ mpf_aligns <- mpf_aligns[-row_to_pop, , drop = FALSE] |
| 881 | -+ | 4x |
-
+ hnum <- hnum - 1 |
| 882 |
- #' @rdname int_methods+ } |
||
| 883 | -938x | +
- setGeneric("root_spl", function(obj) standardGeneric("root_spl"))
+ } |
|
| 884 |
-
+ } |
||
| 885 |
- #' @rdname int_methods+ |
||
| 886 | -+ | 12x |
- setMethod(+ flx <- flx %>% |
| 887 | -+ | 12x |
- "root_spl", "PreDataAxisLayout",+ flextable::set_header_labels( # Needed bc headers must be unique |
| 888 | -938x | +12x |
- function(obj) obj@root_split+ values = setNames( |
| 889 | -+ | 12x |
- )+ as.vector(hdr[hnum, , drop = TRUE]), |
| 890 | -+ | 12x |
-
+ names(content) |
| 891 |
- #' @rdname int_methods+ ) |
||
| 892 | -9x | +
- setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))
+ ) |
|
| 893 |
-
+ # If there are more rows |
||
| 894 | -+ | 12x |
- #' @rdname int_methods+ if (hnum > 1) {
|
| 895 | -+ | 11x |
- setMethod(+ for (i in seq(hnum - 1, 1)) {
|
| 896 | -+ | 11x |
- "root_spl<-", "PreDataAxisLayout",+ sel <- spans_to_viscell(spans[i, ]) |
| 897 | -+ | 11x |
- function(obj, value) {
+ flx <- flextable::add_header_row( |
| 898 | -9x | +11x |
- obj@root_split <- value+ flx, |
| 899 | -9x | +11x |
- obj+ top = TRUE, |
| 900 | -+ | 11x |
- }+ values = as.vector(hdr[i, sel]), |
| 901 | -+ | 11x |
- )+ colwidths = as.integer(spans[i, sel]) # xxx to fix |
| 902 |
-
+ ) |
||
| 903 |
- #' Row attribute accessors+ } |
||
| 904 |
- #'+ } |
||
| 905 |
- #' @inheritParams gen_args+ |
||
| 906 |
- #'+ # Polish the inner horizontal borders from the header |
||
| 907 | -+ | 12x |
- #' @return Various return values depending on the accessor called.+ flx <- flx %>% |
| 908 | -+ | 12x |
- #'+ remove_hborder(part = "header", w = "all") %>% |
| 909 | -+ | 12x |
- #' @export+ add_hborder("header", ii = c(0, hnum), border = border)
|
| 910 |
- #' @rdname row_accessors+ |
||
| 911 | -76x | +
- setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))
+ # ALIGNS |
|
| 912 | -+ | 12x |
-
+ flx <- flx %>% |
| 913 | -+ | 12x |
- #' @rdname row_accessors+ apply_alignments(mpf_aligns[seq_len(hnum), , drop = FALSE], "header") %>% |
| 914 | -+ | 12x |
- #' @exportMethod obj_avar+ apply_alignments(mpf_aligns[-seq_len(hnum), , drop = FALSE], "body") |
| 915 | -58x | +
- setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)
+
|
|
| 916 |
-
+ # Rownames indentation |
||
| 917 | -+ | 12x |
- #' @rdname row_accessors+ checkmate::check_int(indent_size, null.ok = TRUE) |
| 918 | -+ | 12x |
- #' @exportMethod obj_avar+ if (is.null(indent_size)) {
|
| 919 | -18x | +12x |
- setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)
+ indent_size <- matform$indent_size * word_mm_to_pt(2) # default is 2mm (5.7pt) |
| 920 |
-
+ } |
||
| 921 | -+ | 12x |
- #' @export+ for (i in seq_len(NROW(tt))) {
|
| 922 | -+ | 229x |
- #' @rdname row_accessors+ flx <- flextable::padding(flx, |
| 923 | -70544x | +229x |
- setGeneric("row_cells", function(obj) standardGeneric("row_cells"))
+ i = i, j = 1, |
| 924 | -+ | 229x |
-
+ padding.left = indent_size * rdf$indent[[i]] + word_mm_to_pt(0.1), # 0.1 mmm in pt |
| 925 | -+ | 229x |
- #' @rdname row_accessors+ padding.right = word_mm_to_pt(0.1) # 0.1 mmm in pt (so not to touch the border) |
| 926 |
- #' @exportMethod row_cells+ ) |
||
| 927 | -8335x | +
- setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)
+ } |
|
| 929 |
- #' @rdname row_accessors+ # Adding referantial footer line separator if present |
||
| 930 | -4045x | +12x |
- setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))
+ if (length(matform$ref_footnotes) > 0 && isFALSE(footers_as_text)) {
|
| 931 | -+ | 7x |
-
+ flx <- flextable::add_footer_lines(flx, values = matform$ref_footnotes) %>% |
| 932 | -+ | 7x |
- #' @rdname row_accessors+ add_hborder(part = "body", ii = nrow(tt), border = border) |
| 933 |
- #' @exportMethod row_cells+ } |
||
| 934 |
- setMethod("row_cells<-", "TableRow", function(obj, value) {
+
|
||
| 935 | -4045x | +
- obj@leaf_value <- value+ # Footer lines |
|
| 936 | -4045x | +12x |
- obj+ if (length(all_footers(tt)) > 0 && isFALSE(footers_as_text)) {
|
| 937 | -+ | 1x |
- })+ flx <- flextable::add_footer_lines(flx, values = all_footers(tt)) |
| 938 |
-
+ } |
||
| 939 |
- #' @export+ |
||
| 940 | -+ | 12x |
- #' @rdname row_accessors+ flx <- flextable::width(flx, width = final_cwidths) # xxx to fix |
| 941 | -2745x | +
- setGeneric("row_values", function(obj) standardGeneric("row_values"))
+
|
|
| 942 | -+ | 12x |
-
+ if (!is.null(theme)) {
|
| 943 | -+ | 11x |
- #' @rdname row_accessors+ flx <- theme(flx) |
| 944 |
- #' @exportMethod row_values+ } |
||
| 945 | -529x | +
- setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))
+
|
|
| 946 |
-
+ # Title lines (after theme for problems with lines) |
||
| 947 | -+ | 11x |
-
+ if (titles_as_header && length(all_titles(tt)) > 0 && any(nzchar(all_titles(tt)))) {
|
| 948 | -+ | 1x |
- #' @rdname row_accessors+ real_titles <- all_titles(tt) |
| 949 | -+ | 1x |
- #' @exportMethod row_values<-+ real_titles <- real_titles[nzchar(real_titles)] |
| 950 | -1234x | +1x |
- setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))
+ flx <- flextable::add_header_lines(flx, values = real_titles, top = TRUE) %>% |
| 951 |
-
+ # Remove the added borders |
||
| 952 | -+ | 1x |
- #' @rdname row_accessors+ remove_hborder(part = "header", w = c("inner", "top")) %>%
|
| 953 |
- #' @exportMethod row_values<-+ # Re-add the separator between titles and real headers |
||
| 954 | -+ | 1x |
- setMethod(+ add_hborder( |
| 955 | -+ | 1x |
- "row_values<-", "TableRow",+ part = "header", ii = length(real_titles), |
| 956 | -+ | 1x |
- function(obj, value) {
+ border = border |
| 957 | -1234x | +
- obj@leaf_value <- lapply(value, rcell)+ ) %>% |
|
| 958 | -1234x | +
- obj+ # Remove vertical borders added by theme eventually |
|
| 959 | -+ | 1x |
- }+ remove_vborder(part = "header", ii = seq_along(real_titles)) |
| 960 |
- )+ } |
||
| 962 |
- #' @rdname row_accessors+ # These final formatting need to work with colwidths |
||
| 963 | -+ | 11x |
- #' @exportMethod row_values<-+ flx <- flextable::set_table_properties(flx, layout = "autofit", align = "left") # xxx to fix |
| 964 |
- setMethod(+ # NB: autofit or fixed may be switched if widths are correctly staying in the page |
||
| 965 | -+ | 11x |
- "row_values<-", "LabelRow",+ flx <- flextable::fix_border_issues(flx) # Fixes some rendering gaps in borders |
| 966 |
- function(obj, value) {
+
|
||
| 967 | -! | +11x |
- stop("LabelRows cannot have row values.")
+ flx |
| 968 |
- }+ } |
||
| 969 |
- )+ |
||
| 970 |
-
+ #' @describeIn tt_to_flextable Main theme function for [export_as_docx()] |
||
| 971 |
- #' @rdname int_methods+ #' |
||
| 972 | -443x | +
- setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))
+ #' @inheritParams export_as_docx |
|
| 973 |
-
+ #' @param font (`string`)\cr defaults to `"Arial"`. If the font is not available, `flextable` default is used. |
||
| 974 |
- #' @rdname int_methods+ #' @param font_size (`integer(1)`)\cr font size. Defaults to 9. |
||
| 975 |
- setMethod(+ #' @param bold (`character`)\cr parts of the table text that should be in bold. Can be any combination of |
||
| 976 |
- "spanned_values", "TableRow",+ #' `c("header", "content_rows", "label_rows")`. The first one renders all column names bold (not `topleft` content).
|
||
| 977 |
- function(obj) {
+ #' The second and third option use [rtables::make_row_df()] to render content or/and label rows as bold. |
||
| 978 | -443x | +
- rawvalues(spanned_cells(obj))+ #' @param bold_manual (named `list` or `NULL`)\cr list of index lists. See example for needed structure. Accepted |
|
| 979 |
- }+ #' groupings/names are `c("header", "body")`.
|
||
| 980 |
- )+ #' |
||
| 981 |
-
+ #' @seealso [export_as_docx()] |
||
| 982 |
- #' @rdname int_methods+ #' |
||
| 983 |
- setMethod(+ #' @examples |
||
| 984 |
- "spanned_values", "LabelRow",+ #' # Custom theme |
||
| 985 |
- function(obj) {
+ #' special_bold <- list( |
||
| 986 | -! | +
- rep(list(NULL), ncol(obj))+ #' "header" = list("i" = 1, "j" = c(1, 3)),
|
|
| 987 |
- }+ #' "body" = list("i" = c(1, 2), "j" = 1)
|
||
| 988 |
- )+ #' ) |
||
| 989 |
-
+ #' custom_theme <- theme_docx_default(tbl, |
||
| 990 |
- #' @rdname int_methods+ #' font_size = 10, |
||
| 991 | -443x | +
- setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))
+ #' font = "Brush Script MT", |
|
| 992 |
-
+ #' border = flextable::fp_border_default(color = "pink", width = 2), |
||
| 993 |
- #' @rdname int_methods+ #' bold = NULL, |
||
| 994 |
- setMethod(+ #' bold_manual = special_bold |
||
| 995 |
- "spanned_cells", "TableRow",+ #' ) |
||
| 996 |
- function(obj) {
+ #' tt_to_flextable(tbl, |
||
| 997 | -443x | +
- sp <- row_cspans(obj)+ #' border = flextable::fp_border_default(color = "pink", width = 2), |
|
| 998 | -443x | +
- rvals <- row_cells(obj)+ #' theme = custom_theme |
|
| 999 | -443x | +
- unlist(+ #' ) |
|
| 1000 | -443x | +
- mapply(function(v, s) rep(list(v), times = s),+ #' |
|
| 1001 | -443x | +
- v = rvals, s = sp+ #' @export |
|
| 1002 |
- ),+ theme_docx_default <- function(tt = NULL, # Option for more complicated stuff |
||
| 1003 | -443x | +
- recursive = FALSE+ font = "Arial", |
|
| 1004 |
- )+ font_size = 9, |
||
| 1005 |
- }+ bold = c("header", "content_rows", "label_rows"),
|
||
| 1006 |
- )+ bold_manual = NULL, |
||
| 1007 |
-
+ border = flextable::fp_border_default(width = 0.5)) {
|
||
| 1008 | -+ | 11x |
- #' @rdname int_methods+ function(flx) {
|
| 1009 | -+ | 11x |
- setMethod(+ check_required_packages("flextable")
|
| 1010 | -+ | 11x |
- "spanned_cells", "LabelRow",+ if (!inherits(flx, "flextable")) {
|
| 1011 | -+ | ! |
- function(obj) {
+ stop(sprintf( |
| 1012 | ! |
- rep(list(NULL), ncol(obj))+ "Function `%s` supports only flextable objects.", |
|
| 1013 | -+ | ! |
- }+ "theme_box()" |
| 1014 |
- )+ )) |
||
| 1015 |
-
+ } |
||
| 1016 | -+ | 11x |
- #' @rdname int_methods+ if (!is.null(tt) && !inherits(tt, "VTableTree")) {
|
| 1017 | -3x | +! |
- setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))
+ stop("Input table is not an rtables' object.")
|
| 1018 |
-
+ } |
||
| 1019 | -+ | 11x |
- #' @rdname int_methods+ checkmate::assert_int(font_size, lower = 1) |
| 1020 | -+ | 11x |
- setMethod(+ checkmate::assert_string(font) |
| 1021 | -+ | 11x |
- "spanned_values<-", "TableRow",+ checkmate::assert_subset(bold, |
| 1022 | -+ | 11x |
- function(obj, value) {
+ eval(formals(theme_docx_default)$bold), |
| 1023 | -2x | +11x |
- sp <- row_cspans(obj)+ empty.ok = TRUE |
| 1024 |
- ## this is 3 times too clever!!!+ ) |
||
| 1025 | -2x | +
- valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1))))+ |
|
| 1026 |
-
+ # Font setting |
||
| 1027 | -2x | +11x |
- splvec <- cumsum(valindices)+ flx <- flextable::fontsize(flx, size = font_size, part = "all") %>% |
| 1028 | -2x | +11x |
- lapply(+ flextable::fontsize(size = font_size - 1, part = "footer") %>% |
| 1029 | -2x | +11x |
- split(value, splvec),+ flextable::font(fontname = font, part = "all") |
| 1030 | -2x | +
- function(v) {
+
|
|
| 1031 | -3x | +
- if (length(unique(v)) > 1) {
+ # Vertical borders |
|
| 1032 | -1x | +11x |
- stop(+ flx <- flx %>% |
| 1033 | -1x | +11x |
- "Got more than one unique value within a span, ",+ flextable::border_outer(part = "body", border = border) %>% |
| 1034 | -1x | +11x |
- "new spanned values do not appear to match the ",+ flextable::border_outer(part = "header", border = border) |
| 1035 | -1x | +
- "existing spanning pattern of the row (",
+
|
|
| 1036 | -1x | +
- paste(sp, collapse = " "), ")"+ # Vertical alignment -> all top for now, we will set it for the future |
|
| 1037 | -+ | 11x |
- )+ flx <- flx %>% |
| 1038 | -+ | 11x |
- }+ flextable::valign(j = 2:(NCOL(tt) + 1), valign = "top", part = "body") %>% |
| 1039 | -+ | 11x |
- }+ flextable::valign(j = 1, valign = "top", part = "body") %>% |
| 1040 | -+ | 11x |
- )+ flextable::valign(j = 2:(NCOL(tt) + 1), valign = "top", part = "header") |
| 1041 | -1x | +
- rvals <- value[valindices]+ |
|
| 1042 |
-
+ # Bold settings |
||
| 1043 | -+ | 11x |
- ## rvals = lapply(split(value, splvec),+ if (any(bold == "header")) {
|
| 1044 | -+ | 9x |
- ## function(v) {
+ flx <- flextable::bold(flx, j = 2:(NCOL(tt) + 1), part = "header") # Done with theme |
| 1045 |
- ## if(length(v) == 1)+ } |
||
| 1046 |
- ## return(v)+ # Content rows are effectively our labels in row names |
||
| 1047 | -+ | 11x |
- ## stopifnot(length(unique(v)) == 1L)+ if (any(bold == "content_rows")) {
|
| 1048 | -+ | ! |
- ## rcell(unique(v), colspan<- length(v))+ if (is.null(tt)) stop('bold = "content_rows" needs the original rtables object (tt).')
|
| 1049 | -+ | 9x |
- ## })+ rdf <- make_row_df(tt) |
| 1050 | -+ | 9x |
- ## if(any(splvec > 1))+ which_body <- which(rdf$node_class == "ContentRow") |
| 1051 | -+ | 9x |
- ## rvals <- lapply(rvals, function(x) x[[1]])+ flx <- flextable::bold(flx, j = 1, i = which_body, part = "body") |
| 1052 | -1x | +
- row_values(obj) <- rvals+ } |
|
| 1053 | -1x | +11x |
- obj+ if (any(bold == "label_rows")) {
|
| 1054 | -+ | ! |
- }+ if (is.null(tt)) stop('bold = "content_rows" needs the original rtables object (tt).')
|
| 1055 | -+ | 9x |
- )+ rdf <- make_row_df(tt) |
| 1056 | -+ | 9x |
-
+ which_body <- which(rdf$node_class == "LabelRow") |
| 1057 | -+ | 9x |
- #' @rdname int_methods+ flx <- flextable::bold(flx, j = 1, i = which_body, part = "body") |
| 1058 |
- setMethod(+ } |
||
| 1059 |
- "spanned_values<-", "LabelRow",+ # If you want specific cells to be bold |
||
| 1060 | -+ | 11x |
- function(obj, value) {
+ if (!is.null(bold_manual)) {
|
| 1061 | -1x | +2x |
- if (!is.null(value)) {
+ checkmate::assert_list(bold_manual) |
| 1062 | -1x | +2x |
- stop("Label rows can't have non-null cell values, got", value)
+ valid_sections <- c("header", "body") # Only valid values
|
| 1063 | -+ | 2x |
- }+ checkmate::assert_subset(names(bold_manual), valid_sections) |
| 1064 | -! | +2x |
- obj+ for (bi in seq_along(bold_manual)) {
|
| 1065 | -+ | 3x |
- }+ bld_tmp <- bold_manual[[bi]] |
| 1066 | -+ | 3x |
- )+ checkmate::assert_list(bld_tmp) |
| 1067 | -+ | 3x |
-
+ if (!all(c("i", "j") %in% names(bld_tmp)) || !all(vapply(bld_tmp, checkmate::test_integerish, logical(1)))) {
|
| 1068 | -+ | 1x |
- ### Format manipulation+ stop( |
| 1069 | -+ | 1x |
- ### obj_format<- is not recursive+ "Found an allowed section for manual bold (", names(bold_manual)[bi],
|
| 1070 | -+ | 1x |
- ## TODO export these?+ ") that was not a named list with i (row) and j (col) integer vectors." |
| 1071 |
- #' @rdname formatters_methods+ ) |
||
| 1072 |
- #' @export+ } |
||
| 1073 | -7010x | +2x |
- setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)
+ flx <- flextable::bold(flx, |
| 1074 | -+ | 2x |
-
+ i = bld_tmp$i, j = bld_tmp$j, |
| 1075 | -+ | 2x |
- #' @rdname formatters_methods+ part = names(bold_manual)[bi] |
| 1076 |
- #' @export+ ) |
||
| 1077 | -110801x | +
- setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))
+ } |
|
| 1078 |
-
+ } |
||
| 1079 |
- #' @rdname formatters_methods+ |
||
| 1080 |
- #' @export+ # vertical padding is manual atm and respect doc std |
||
| 1081 | -2285x | +10x |
- setMethod("obj_format", "Split", function(obj) obj@split_format)
+ flx <- flx %>% |
| 1082 |
-
+ # flextable::padding(j = 2:(NCOL(tt) + 1), padding.top = , part = "body") %>% # not specified |
||
| 1083 | -+ | 10x |
- #' @rdname formatters_methods+ flextable::padding(j = 1, padding.top = 1, padding.bottom = 1, part = "body") %>% |
| 1084 | -+ | 10x |
- #' @export+ flextable::padding(j = 2:(NCOL(tt) + 1), padding.top = 0, padding.bottom = 3, part = "header") |
| 1085 |
- setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
+
|
||
| 1086 | -1640x | +
- obj@format <- value+ # single line spacing (for safety) -> space = 1 |
|
| 1087 | -1640x | +10x |
- obj+ flx <- flextable::line_spacing(flx, space = 1, part = "all") |
| 1088 |
- })+ |
||
| 1089 | -+ | 10x |
-
+ flx |
| 1090 |
- #' @rdname formatters_methods+ } |
||
| 1091 |
- #' @export+ } |
||
| 1092 |
- setMethod("obj_format<-", "Split", function(obj, value) {
+
|
||
| 1093 | -1x | +
- obj@split_format <- value+ # Padding helper functions to transform mm to pt and viceversa |
|
| 1094 | -1x | +
- obj+ # # General note for word: 1pt -> 0.3527777778mm -> 0.013888888888889" |
|
| 1095 |
- })+ word_inch_to_pt <- function(inch) { # nocov
|
||
| 1096 |
-
+ inch / 0.013888888888889 # nocov |
||
| 1097 |
- #' @rdname formatters_methods+ } |
||
| 1098 |
- #' @export+ |
||
| 1099 |
- setMethod("obj_format<-", "CellValue", function(obj, value) {
+ word_mm_to_pt <- function(mm) {
|
||
| 1100 | -1221x | +470x |
- attr(obj, "format") <- value+ mm / 0.3527777778 |
| 1101 | -1221x | +
- obj+ } |
|
| 1102 |
- })+ |
||
| 1103 |
-
+ # Polish horizontal borders |
||
| 1104 |
- #' @rdname int_methods+ remove_hborder <- function(flx, part, w = c("top", "bottom", "inner")) {
|
||
| 1105 |
- #' @export+ # If you need to remove all of them |
||
| 1106 | -+ | 25x |
- setMethod("obj_na_str<-", "CellValue", function(obj, value) {
+ if (length(w) == 1 && w == "all") {
|
| 1107 | -4235x | +12x |
- attr(obj, "format_na_str") <- value+ w <- eval(formals(remove_hborder)$w) |
| 1108 | -4235x | +
- obj+ } |
|
| 1109 |
- })+ |
||
| 1110 | -+ | 25x |
-
+ if (any(w == "top")) {
|
| 1111 | -+ | 13x |
- #' @rdname int_methods+ flx <- flextable::hline_top(flx, |
| 1112 | -+ | 13x |
- #' @export+ border = flextable::fp_border_default(width = 0), |
| 1113 | -+ | 13x |
- setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
+ part = part |
| 1114 | -26x | +
- obj@na_str <- value+ ) |
|
| 1115 | -26x | +
- obj+ } |
|
| 1116 | -+ | 25x |
- })+ if (any(w == "bottom")) {
|
| 1117 | -+ | 24x |
-
+ flx <- flextable::hline_bottom(flx, |
| 1118 | -+ | 24x |
- #' @rdname int_methods+ border = flextable::fp_border_default(width = 0), |
| 1119 | -+ | 24x |
- #' @export+ part = part |
| 1120 |
- setMethod("obj_na_str<-", "Split", function(obj, value) {
+ ) |
||
| 1121 | -! | +
- obj@split_na_str <- value+ } |
|
| 1122 | -! | +
- obj+ # Inner horizontal lines removal |
|
| 1123 | -+ | 25x |
- })+ if (any(w == "inner")) {
|
| 1124 | -+ | 13x |
-
+ flx <- flextable::border_inner_h( |
| 1125 | -+ | 13x |
- #' @rdname int_methods+ flx, |
| 1126 | -+ | 13x |
- #' @export+ border = flextable::fp_border_default(width = 0), |
| 1127 | -28867x | +13x |
- setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)
+ part = part |
| 1128 |
-
+ ) |
||
| 1129 |
- #' @rdname formatters_methods+ } |
||
| 1130 | -+ | 25x |
- #' @export+ flx |
| 1131 | -1164x | +
- setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)
+ } |
|
| 1133 |
- .no_na_str <- function(x) {
+ # Remove vertical borders from both sides (for titles) |
||
| 1134 | -15087x | +
- if (!is.character(x)) {
+ remove_vborder <- function(flx, part, ii) {
|
|
| 1135 | -6192x | +1x |
- x <- obj_na_str(x)+ flx <- flextable::border(flx, |
| 1136 | -+ | 1x |
- }+ i = ii, part = part, |
| 1137 | -15087x | +1x |
- length(x) == 0 || all(is.na(x))+ border.left = flextable::fp_border_default(width = 0), |
| 1138 | -+ | 1x |
- }+ border.right = flextable::fp_border_default(width = 0) |
| 1139 |
-
+ ) |
||
| 1140 |
- #' @rdname int_methods+ } |
||
| 1141 |
- setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
+
|
||
| 1142 | -8888x | +
- standardGeneric("set_format_recursive")
+ # Add horizontal border |
|
| 1143 |
- })+ add_hborder <- function(flx, part, ii, border) {
|
||
| 1144 | -+ | 20x |
-
+ if (any(ii == 0)) {
|
| 1145 | -+ | 12x |
- #' @param override (`flag`)\cr whether to override attribute.+ flx <- flextable::border(flx, i = 1, border.top = border, part = part) |
| 1146 | -+ | 12x |
- #'+ ii <- ii[!(ii == 0)] |
| 1147 |
- #' @rdname int_methods+ } |
||
| 1148 | -+ | 20x |
- setMethod(+ if (length(ii) > 0) {
|
| 1149 | -+ | 20x |
- "set_format_recursive", "TableRow",+ flx <- flextable::border(flx, i = ii, border.bottom = border, part = part) |
| 1150 |
- function(obj, format, na_str, override = FALSE) {
+ } |
||
| 1151 | -1030x | +20x |
- if (is.null(format) && .no_na_str(na_str)) {
+ flx |
| 1152 | -514x | +
- return(obj)+ } |
|
| 1153 |
- }+ |
||
| 1154 |
-
+ apply_alignments <- function(flx, aligns_df, part) {
|
||
| 1155 | -516x | +
- if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
+ # List of characters you want to search for |
|
| 1156 | -515x | +24x |
- obj_format(obj) <- format+ search_chars <- unique(c(aligns_df)) |
| 1157 |
- }+ |
||
| 1158 | -516x | +
- if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
+ # Loop through each character and find its indexes |
|
| 1159 | -! | +24x |
- obj_na_str(obj) <- na_str+ for (char in search_chars) {
|
| 1160 | -+ | 48x |
- }+ indexes <- which(aligns_df == char, arr.ind = TRUE) |
| 1161 | -516x | +48x |
- lcells <- row_cells(obj)+ tmp_inds <- as.data.frame(indexes) |
| 1162 | -516x | +48x |
- lvals <- lapply(lcells, function(x) {
+ flx <- flx %>% |
| 1163 | -1920x | +48x |
- if (!is.null(x) && (override || is.null(obj_format(x)))) {
+ flextable::align( |
| 1164 | -53x | +48x |
- obj_format(x) <- obj_format(obj)+ i = tmp_inds[["row"]], |
| 1165 | -+ | 48x |
- }+ j = tmp_inds[["col"]], |
| 1166 | -1920x | +48x |
- if (!is.null(x) && (override || .no_na_str(x))) {
+ align = char, |
| 1167 | -1920x | +48x |
- obj_na_str(x) <- obj_na_str(obj)+ part = part |
| 1168 |
- }+ ) |
||
| 1169 | -1920x | +
- x+ } |
|
| 1170 |
- })+ |
||
| 1171 | -516x | -
- row_values(obj) <- lvals- |
- |
| 1172 | -516x | +24x |
- obj+ flx |
| 1173 | +1172 |
- }+ } |
| 1174 | +1 |
- )+ # paths summary ---- |
||
| 1175 | +2 | |||
| 1176 | +3 |
- #' @rdname int_methods+ #' Get a list of table row/column paths |
||
| 1177 | +4 |
- setMethod(+ #' |
||
| 1178 | +5 |
- "set_format_recursive", "LabelRow",- |
- ||
| 1179 | -11x | -
- function(obj, format, override = FALSE) obj+ #' @param x (`VTableTree`)\cr an `rtable` object. |
||
| 1180 | +6 |
- )+ #' |
||
| 1181 | +7 |
-
+ #' @return A list of paths to each row/column within `x`. |
||
| 1182 | +8 |
- setMethod(+ #' |
||
| 1183 | +9 |
- "set_format_recursive", "VTableTree",+ #' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()] |
||
| 1184 | +10 |
- function(obj, format, na_str, override = FALSE) {
- |
- ||
| 1185 | -1696x | -
- force(format)- |
- ||
| 1186 | -1696x | -
- if (is.null(format) && .no_na_str(na_str)) {
- |
- ||
| 1187 | -1689x | -
- return(obj)+ #' |
||
| 1188 | +11 |
- }+ #' @examples |
||
| 1189 | +12 | - - | -||
| 1190 | -7x | -
- if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
+ #' lyt <- basic_table() %>% |
||
| 1191 | -7x | +|||
| 13 | +
- obj_format(obj) <- format+ #' split_cols_by("ARM") %>%
|
|||
| 1192 | +14 |
- }+ #' analyze(c("SEX", "AGE"))
|
||
| 1193 | -7x | +|||
| 15 | +
- if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
+ #' |
|||
| 1194 | -! | +|||
| 16 | +
- obj_na_str(obj) <- na_str+ #' tbl <- build_table(lyt, ex_adsl) |
|||
| 1195 | +17 |
- }+ #' tbl |
||
| 1196 | +18 |
-
+ #' |
||
| 1197 | -7x | +|||
| 19 | +
- kids <- tree_children(obj)+ #' row_paths(tbl) |
|||
| 1198 | -7x | +|||
| 20 | +
- kids <- lapply(kids, function(x, format2, na_str2, oride) {
+ #' col_paths(tbl) |
|||
| 1199 | -33x | +|||
| 21 | +
- set_format_recursive(x,+ #' |
|||
| 1200 | -33x | +|||
| 22 | +
- format = format2, na_str = na_str2, override = oride+ #' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
|
|||
| 1201 | +23 |
- )+ #' |
||
| 1202 | +24 |
- },+ #' @rdname make_col_row_df |
||
| 1203 | -7x | +|||
| 25 | +
- format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override+ #' @export |
|||
| 1204 | +26 |
- )+ row_paths <- function(x) {
|
||
| 1205 | -7x | +27 | +45x |
- tree_children(obj) <- kids+ stopifnot(is_rtable(x)) |
| 1206 | -7x | -
- obj- |
- ||
| 1207 | -+ | 28 | +45x |
- }+ make_row_df(x, visible_only = TRUE)$path |
| 1208 | +29 |
- )+ } |
||
| 1209 | +30 | |||
| 1210 | +31 |
- #' @rdname int_methods- |
- ||
| 1211 | -1812x | -
- setGeneric("content_format", function(obj) standardGeneric("content_format"))
+ #' @rdname make_col_row_df |
||
| 1212 | +32 |
-
+ #' @export |
||
| 1213 | +33 |
- #' @rdname int_methods+ col_paths <- function(x) {
|
||
| 1214 | -1812x | +34 | +2357x |
- setMethod("content_format", "Split", function(obj) obj@content_format)
+ if (!is(coltree(x), "LayoutColTree")) {
|
| 1215 | -+ | |||
| 35 | +! |
-
+ stop("I don't know how to extract the column paths from an object of class ", class(x))
|
||
| 1216 | +36 |
- #' @rdname int_methods+ } |
||
| 1217 | -105x | +37 | +2357x |
- setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))
+ make_col_df(x, visible_only = TRUE)$path |
| 1218 | +38 |
-
+ } |
||
| 1219 | +39 |
- #' @rdname int_methods+ |
||
| 1220 | +40 |
- setMethod("content_format<-", "Split", function(obj, value) {
- |
- ||
| 1221 | -105x | -
- obj@content_format <- value- |
- ||
| 1222 | -105x | -
- obj+ #' Print row/column paths summary |
||
| 1223 | +41 |
- })+ #' |
||
| 1224 | +42 |
-
+ #' @param x (`VTableTree`)\cr an `rtable` object. |
||
| 1225 | +43 |
- #' @rdname int_methods- |
- ||
| 1226 | -1812x | -
- setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))
+ #' |
||
| 1227 | +44 |
-
+ #' @return A data frame summarizing the row- or column-structure of `x`. |
||
| 1228 | +45 |
- #' @rdname int_methods- |
- ||
| 1229 | -1812x | -
- setMethod("content_na_str", "Split", function(obj) obj@content_na_str)
+ #' |
||
| 1230 | +46 |
-
+ #' @examples |
||
| 1231 | +47 |
- #' @rdname int_methods- |
- ||
| 1232 | -! | -
- setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-"))
+ #' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
|
||
| 1233 | +48 |
-
+ #' |
||
| 1234 | +49 |
- #' @rdname int_methods+ #' lyt <- basic_table() %>% |
||
| 1235 | +50 |
- setMethod("content_na_str<-", "Split", function(obj, value) {
- |
- ||
| 1236 | -! | -
- obj@content_na_str <- value- |
- ||
| 1237 | -! | -
- obj+ #' split_cols_by("ARM") %>%
|
||
| 1238 | +51 |
- })+ #' split_cols_by("SEX", split_fun = drop_split_levels) %>%
|
||
| 1239 | +52 |
-
+ #' analyze(c("AGE", "BMRKR2"))
|
||
| 1240 | +53 |
- #' Value formats+ #' |
||
| 1241 | +54 |
- #'+ #' tbl <- build_table(lyt, ex_adsl_MF) |
||
| 1242 | +55 |
- #' Returns a matrix of formats for the cells in a table.+ #' tbl |
||
| 1243 | +56 |
#' |
||
| 1244 | +57 |
- #' @param obj (`VTableTree` or `TableRow`)\cr a table or row object.+ #' df <- row_paths_summary(tbl) |
||
| 1245 | +58 |
- #' @param default (`string`, `function`, or `list`)\cr default format.+ #' df |
||
| 1246 | +59 |
#' |
||
| 1247 | +60 |
- #' @return Matrix (storage mode list) containing the effective format for each cell position in the table+ #' col_paths_summary(tbl) |
||
| 1248 | +61 |
- #' (including 'virtual' cells implied by label rows, whose formats are always `NULL`).+ #' |
||
| 1249 | +62 |
- #'+ #' # manually constructed table |
||
| 1250 | +63 |
- #' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure.+ #' tbl2 <- rtable( |
||
| 1251 | +64 |
- #'+ #' rheader( |
||
| 1252 | +65 |
- #' @examples+ #' rrow( |
||
| 1253 | +66 |
- #' lyt <- basic_table() %>%+ #' "row 1", rcell("a", colspan = 2),
|
||
| 1254 | +67 |
- #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
+ #' rcell("b", colspan = 2)
|
||
| 1255 | +68 |
- #' analyze("AGE")
+ #' ), |
||
| 1256 | +69 |
- #'+ #' rrow("h2", "a", "b", "c", "d")
|
||
| 1257 | +70 |
- #' tbl <- build_table(lyt, DM)+ #' ), |
||
| 1258 | +71 |
- #' value_formats(tbl)+ #' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
|
||
| 1259 | +72 |
- #'+ #' ) |
||
| 1260 | +73 |
- #' @export- |
- ||
| 1261 | -1123x | -
- setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))
+ #' col_paths_summary(tbl2) |
||
| 1262 | +74 |
-
+ #' |
||
| 1263 | +75 |
- #' @rdname value_formats+ #' @export |
||
| 1264 | +76 |
- setMethod(+ row_paths_summary <- function(x) {
|
||
| 1265 | -+ | |||
| 77 | +1x |
- "value_formats", "ANY",+ stopifnot(is_rtable(x)) |
||
| 1266 | +78 |
- function(obj, default) {
+
|
||
| 1267 | -762x | +79 | +1x |
- obj_format(obj) %||% default+ if (nrow(x) == 0) {
|
| 1268 | -+ | |||
| 80 | +! |
- }+ return("rowname node_class path\n---------------------\n")
|
||
| 1269 | +81 |
- )+ } |
||
| 1270 | +82 | |||
| 1271 | -+ | |||
| 83 | +1x |
- #' @rdname value_formats+ pagdf <- make_row_df(x, visible_only = TRUE) |
||
| 1272 | -+ | |||
| 84 | +1x |
- setMethod(+ row.names(pagdf) <- NULL |
||
| 1273 | +85 |
- "value_formats", "TableRow",+ |
||
| 1274 | -+ | |||
| 86 | +1x |
- function(obj, default) {
+ mat <- rbind( |
||
| 1275 | -245x | +87 | +1x |
- if (!is.null(obj_format(obj))) {
+ c("rowname", "node_class", "path"),
|
| 1276 | -215x | +88 | +1x |
- default <- obj_format(obj)+ t(apply(pagdf, 1, function(xi) {
|
| 1277 | -+ | |||
| 89 | +28x |
- }+ c( |
||
| 1278 | -245x | +90 | +28x |
- formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default)+ indent_string(xi$label, xi$indent), |
| 1279 | -245x | +91 | +28x |
- formats+ xi$node_class, |
| 1280 | -+ | |||
| 92 | +28x |
- }+ paste(xi$path, collapse = ", ") |
||
| 1281 | +93 |
- )+ ) |
||
| 1282 | +94 |
-
+ })) |
||
| 1283 | +95 |
- #' @rdname value_formats+ ) |
||
| 1284 | +96 |
- setMethod(+ |
||
| 1285 | -+ | |||
| 97 | +1x |
- "value_formats", "LabelRow",+ txt <- mat_as_string(mat) |
||
| 1286 | -+ | |||
| 98 | +1x |
- function(obj, default) {
+ cat(txt) |
||
| 1287 | -102x | +99 | +1x |
- rep(list(NULL), ncol(obj))+ cat("\n")
|
| 1288 | +100 |
- }+ + |
+ ||
| 101 | +1x | +
+ invisible(pagdf[, c("label", "indent", "node_class", "path")])
|
||
| 1289 | +102 |
- )+ } |
||
| 1290 | +103 | |||
| 1291 | +104 |
- #' @rdname value_formats+ #' @rdname row_paths_summary |
||
| 1292 | +105 |
- setMethod(+ #' @export |
||
| 1293 | +106 |
- "value_formats", "VTableTree",+ col_paths_summary <- function(x) {
+ |
+ ||
| 107 | +1x | +
+ stopifnot(is_rtable(x)) |
||
| 1294 | +108 |
- function(obj, default) {
+
|
||
| 1295 | -14x | +109 | +1x |
- if (!is.null(obj_format(obj))) {
+ pagdf <- make_col_df(x, visible_only = FALSE) |
| 1296 | -! | +|||
| 110 | +1x |
- default <- obj_format(obj)+ row.names(pagdf) <- NULL |
||
| 1297 | +111 |
- }+ |
||
| 1298 | -14x | +112 | +1x |
- rws <- collect_leaves(obj, TRUE, TRUE)+ mat <- rbind( |
| 1299 | -14x | +113 | +1x |
- formatrws <- lapply(rws, value_formats, default = default)+ c("label", "path"),
|
| 1300 | -14x | +114 | +1x |
- mat <- do.call(rbind, formatrws)+ t(apply(pagdf, 1, function(xi) {
|
| 1301 | -14x | +115 | +6x |
- row.names(mat) <- row.names(obj)+ c( |
| 1302 | -14x | +116 | +6x |
- mat+ indent_string(xi$label, floor(length(xi$path) / 2 - 1)), |
| 1303 | -+ | |||
| 117 | +6x |
- }+ paste(xi$path, collapse = ", ") |
||
| 1304 | +118 |
- )+ ) |
||
| 1305 | +119 |
-
+ })) |
||
| 1306 | +120 |
- ### Collect all leaves of a current tree+ ) |
||
| 1307 | +121 |
- ### This is a workhorse function in various+ |
||
| 1308 | -+ | |||
| 122 | +1x |
- ### places+ txt <- mat_as_string(mat) |
||
| 1309 | -+ | |||
| 123 | +1x |
- ### NB this is written generally enought o+ cat(txt)+ |
+ ||
| 124 | +1x | +
+ cat("\n")
|
||
| 1310 | +125 |
- ### be used on all tree-based structures in the+ + |
+ ||
| 126 | +1x | +
+ invisible(pagdf[, c("label", "path")])
|
||
| 1311 | +127 |
- ### framework.+ } |
||
| 1312 | +128 | |||
| 1313 | +129 |
- #' Collect leaves of a `TableTree`+ # Rows ---- |
||
| 1314 | +130 |
- #'+ # . Summarize Rows ---- |
||
| 1315 | +131 |
- #' @inheritParams gen_args+ |
||
| 1316 | +132 |
- #' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`.+ # summarize_row_df <- |
||
| 1317 | +133 |
- #' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`.+ # function(name, |
||
| 1318 | +134 |
- #'+ # label, |
||
| 1319 | +135 |
- #' @return A list of `TableRow` objects for all rows in the table.+ # indent, |
||
| 1320 | +136 |
- #'+ # depth, |
||
| 1321 | +137 |
- #' @export+ # rowtype, |
||
| 1322 | +138 |
- setGeneric("collect_leaves",
+ # indent_mod, |
||
| 1323 | +139 |
- function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ # level) {
|
||
| 1324 | -99746x | +|||
| 140 | +
- standardGeneric("collect_leaves")
+ # data.frame( |
|||
| 1325 | +141 |
- },+ # name = name, |
||
| 1326 | +142 |
- signature = "tt"+ # label = label, |
||
| 1327 | +143 |
- )+ # indent = indent, |
||
| 1328 | +144 |
-
+ # depth = level, |
||
| 1329 | +145 |
- #' @inheritParams collect_leaves+ # rowtype = rowtype, |
||
| 1330 | +146 |
- #'+ # indent_mod = indent_mod, |
||
| 1331 | +147 |
- #' @rdname int_methods+ # level = level, |
||
| 1332 | +148 |
- #' @exportMethod collect_leaves+ # stringsAsFactors = FALSE |
||
| 1333 | +149 |
- setMethod(+ # ) |
||
| 1334 | +150 |
- "collect_leaves", "TableTree",+ # } |
||
| 1335 | +151 |
- function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+
|
||
| 1336 | -25990x | +|||
| 152 | +
- ret <- c(+ #' Summarize rows |
|||
| 1337 | -25990x | +|||
| 153 | +
- if (add.labrows && labelrow_visible(tt)) {
+ #' |
|||
| 1338 | -10626x | +|||
| 154 | +
- tt_labelrow(tt)+ #' @inheritParams gen_args |
|||
| 1339 | +155 |
- },+ #' @param depth (`numeric(1)`)\cr depth. |
||
| 1340 | -25990x | +|||
| 156 | +
- if (incl.cont) {
+ #' @param indent (`numeric(1)`)\cr indent. |
|||
| 1341 | -25990x | +|||
| 157 | +
- tree_children(content_table(tt))+ #' |
|||
| 1342 | +158 |
- },+ #' @examples |
||
| 1343 | -25990x | +|||
| 159 | +
- lapply(tree_children(tt),+ #' library(dplyr) |
|||
| 1344 | -25990x | +|||
| 160 | +
- collect_leaves,+ #' |
|||
| 1345 | -25990x | +|||
| 161 | +
- incl.cont = incl.cont, add.labrows = add.labrows+ #' iris2 <- iris %>% |
|||
| 1346 | +162 |
- )+ #' group_by(Species) %>% |
||
| 1347 | +163 |
- )+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 1348 | -25990x | +|||
| 164 | +
- unlist(ret, recursive = TRUE)+ #' ungroup() |
|||
| 1349 | +165 |
- }+ #' |
||
| 1350 | +166 |
- )+ #' lyt <- basic_table() %>% |
||
| 1351 | +167 |
-
+ #' split_cols_by("Species") %>%
|
||
| 1352 | +168 |
- #' @rdname int_methods+ #' split_cols_by("group") %>%
|
||
| 1353 | +169 |
- #' @exportMethod collect_leaves+ #' analyze(c("Sepal.Length", "Petal.Width"),
|
||
| 1354 | +170 |
- setMethod(+ #' afun = list_wrap_x(summary), |
||
| 1355 | +171 |
- "collect_leaves", "ElementaryTable",+ #' format = "xx.xx" |
||
| 1356 | +172 |
- function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ #' ) |
||
| 1357 | -56615x | +|||
| 173 | +
- ret <- tree_children(tt)+ #' |
|||
| 1358 | -56615x | +|||
| 174 | +
- if (add.labrows && labelrow_visible(tt)) {
+ #' tbl <- build_table(lyt, iris2) |
|||
| 1359 | -11080x | +|||
| 175 | +
- ret <- c(tt_labelrow(tt), ret)+ #' |
|||
| 1360 | +176 |
- }+ #' @rdname int_methods |
||
| 1361 | -56615x | +|||
| 177 | +
- ret+ setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
|
|||
| 1362 | -+ | |||
| 178 | +! |
- }+ standardGeneric("summarize_rows_inner")
|
||
| 1363 | +179 |
- )+ }) |
||
| 1364 | +180 | |||
| 1365 | +181 |
#' @rdname int_methods |
||
| 1366 | +182 |
- #' @exportMethod collect_leaves+ setMethod( |
||
| 1367 | +183 |
- setMethod(+ "summarize_rows_inner", "TableTree", |
||
| 1368 | +184 |
- "collect_leaves", "VTree",+ function(obj, depth = 0, indent = 0) {
+ |
+ ||
| 185 | +! | +
+ indent <- max(0L, indent + indent_mod(obj)) |
||
| 1369 | +186 |
- function(tt, incl.cont, add.labrows) {
+
|
||
| 1370 | +187 | ! |
- ret <- lapply(+ lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent) |
|
| 1371 | +188 | ! |
- tree_children(tt),+ if (!is.null(lr)) {
|
|
| 1372 | +189 | ! |
- collect_leaves+ ret <- list(lr) |
|
| 1373 | +190 |
- )+ } else {
|
||
| 1374 | +191 | ! |
- unlist(ret, recursive = TRUE)+ ret <- list() |
|
| 1375 | +192 |
- }+ } |
||
| 1376 | +193 |
- )+ |
||
| 1377 | -+ | |||
| 194 | +! |
-
+ indent <- indent + (!is.null(lr)) |
||
| 1378 | +195 |
- #' @rdname int_methods+ |
||
| 1379 | -+ | |||
| 196 | +! |
- #' @exportMethod collect_leaves+ ctab <- content_table(obj) |
||
| 1380 | -+ | |||
| 197 | +! |
- setMethod(+ if (NROW(ctab)) {
|
||
| 1381 | -+ | |||
| 198 | +! |
- "collect_leaves", "VLeaf",+ ct <- summarize_rows_inner(ctab, |
||
| 1382 | -+ | |||
| 199 | +! |
- function(tt, incl.cont, add.labrows) {
+ depth = depth, |
||
| 1383 | -686x | +|||
| 200 | +! |
- list(tt)+ indent = indent + indent_mod(ctab) |
||
| 1384 | +201 |
- }+ ) |
||
| 1385 | -+ | |||
| 202 | +! |
- )+ ret <- c(ret, ct) |
||
| 1386 | -+ | |||
| 203 | +! |
-
+ indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab)) |
||
| 1387 | +204 |
- #' @rdname int_methods+ } |
||
| 1388 | +205 |
- #' @exportMethod collect_leaves+ |
||
| 1389 | -+ | |||
| 206 | +! |
- setMethod(+ kids <- tree_children(obj) |
||
| 1390 | -+ | |||
| 207 | +! |
- "collect_leaves", "NULL",+ els <- lapply(tree_children(obj), summarize_rows_inner,+ |
+ ||
| 208 | +! | +
+ depth = depth + 1, indent = indent |
||
| 1391 | +209 |
- function(tt, incl.cont, add.labrows) {
+ ) |
||
| 1392 | +210 | ! |
- list()+ if (!are(kids, "TableRow")) {
|
|
| 1393 | -+ | |||
| 211 | +! |
- }+ if (!are(kids, "VTableTree")) {
|
||
| 1394 | +212 |
- )+ ## hatchet job of a hack, wrap em just so we can unlist em all at |
||
| 1395 | +213 |
-
+ ## the same level |
||
| 1396 | -+ | |||
| 214 | +! |
- #' @rdname int_methods+ rowinds <- vapply(kids, is, NA, class2 = "TableRow") |
||
| 1397 | -+ | |||
| 215 | +! |
- #' @exportMethod collect_leaves+ els[rowinds] <- lapply(els[rowinds], function(x) list(x)) |
||
| 1398 | +216 |
- setMethod(+ } |
||
| 1399 | -+ | |||
| 217 | +! |
- "collect_leaves", "ANY",+ els <- unlist(els, recursive = FALSE) |
||
| 1400 | +218 |
- function(tt, incl.cont, add.labrows) {
+ } |
||
| 1401 | +219 | ! |
- stop("class ", class(tt), " does not inherit from VTree or VLeaf")
+ ret <- c(ret, els) |
|
| 1402 | -+ | |||
| 220 | +! |
- }+ ret |
||
| 1403 | +221 |
- )+ ## df <- do.call(rbind, c(list(lr), list(ct), els)) |
||
| 1404 | +222 | |||
| 1405 | +223 |
- n_leaves <- function(tt, ...) {
- |
- ||
| 1406 | -130x | -
- length(collect_leaves(tt, ...))+ ## row.names(df) <- NULL |
||
| 1407 | +224 |
- }+ ## df |
||
| 1408 | +225 |
-
+ } |
||
| 1409 | +226 |
- ### Spanning information ----+ ) |
||
| 1410 | +227 | |||
| 1411 | +228 |
- #' @rdname int_methods- |
- ||
| 1412 | -55087x | -
- setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))
+ # Print Table Structure ---- |
||
| 1413 | +229 | |||
| 1414 | +230 |
- #' @rdname int_methods- |
- ||
| 1415 | -5194x | -
- setMethod("row_cspans", "TableRow", function(obj) obj@colspans)
+ #' Summarize table |
||
| 1416 | +231 |
-
+ #' |
||
| 1417 | +232 |
- #' @rdname int_methods+ #' @param x (`VTableTree`)\cr a table object. |
||
| 1418 | +233 |
- setMethod(+ #' @param detail (`string`)\cr either `row` or `subtable`. |
||
| 1419 | +234 |
- "row_cspans", "LabelRow",- |
- ||
| 1420 | -1655x | -
- function(obj) rep(1L, ncol(obj))+ #' |
||
| 1421 | +235 |
- )+ #' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`. |
||
| 1422 | +236 |
-
+ #' |
||
| 1423 | +237 |
- #' @rdname int_methods- |
- ||
| 1424 | -3968x | -
- setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))
+ #' @examples |
||
| 1425 | +238 |
-
+ #' library(dplyr) |
||
| 1426 | +239 |
- #' @rdname int_methods+ #' |
||
| 1427 | +240 |
- setMethod("row_cspans<-", "TableRow", function(obj, value) {
- |
- ||
| 1428 | -3968x | -
- obj@colspans <- value- |
- ||
| 1429 | -3968x | -
- obj+ #' iris2 <- iris %>% |
||
| 1430 | +241 |
- })+ #' group_by(Species) %>% |
||
| 1431 | +242 |
-
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 1432 | +243 |
- #' @rdname int_methods+ #' ungroup() |
||
| 1433 | +244 |
- setMethod("row_cspans<-", "LabelRow", function(obj, value) {
+ #' |
||
| 1434 | +245 |
- stop("attempted to set colspans for LabelRow") # nocov
+ #' lyt <- basic_table() %>% |
||
| 1435 | +246 |
- })+ #' split_cols_by("Species") %>%
|
||
| 1436 | +247 |
-
+ #' split_cols_by("group") %>%
|
||
| 1437 | +248 |
- ## XXX TODO colapse with above?+ #' analyze(c("Sepal.Length", "Petal.Width"),
|
||
| 1438 | +249 |
- #' @rdname int_methods- |
- ||
| 1439 | -45462x | -
- setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))
+ #' afun = list_wrap_x(summary), |
||
| 1440 | +250 |
-
+ #' format = "xx.xx" |
||
| 1441 | +251 |
- #' @rdname int_methods+ #' ) |
||
| 1442 | +252 |
- setMethod(+ #' |
||
| 1443 | +253 |
- "cell_cspan", "CellValue",+ #' tbl <- build_table(lyt, iris2) |
||
| 1444 | -45462x | +|||
| 254 | +
- function(obj) attr(obj, "colspan", exact = TRUE)+ #' tbl |
|||
| 1445 | +255 |
- ) ## obj@colspan)+ #' |
||
| 1446 | +256 |
-
+ #' row_paths(tbl) |
||
| 1447 | +257 |
- #' @rdname int_methods+ #' |
||
| 1448 | +258 |
- setGeneric(+ #' table_structure(tbl) |
||
| 1449 | +259 |
- "cell_cspan<-",+ #' |
||
| 1450 | -6886x | +|||
| 260 | +
- function(obj, value) standardGeneric("cell_cspan<-")
+ #' table_structure(tbl, detail = "row") |
|||
| 1451 | +261 |
- )+ #' |
||
| 1452 | +262 |
-
+ #' @export |
||
| 1453 | +263 |
- #' @rdname int_methods+ table_structure <- function(x, detail = c("subtable", "row")) {
|
||
| 1454 | -+ | |||
| 264 | +2x |
- setMethod("cell_cspan<-", "CellValue", function(obj, value) {
+ detail <- match.arg(detail) |
||
| 1455 | +265 |
- ## obj@colspan <- value+ |
||
| 1456 | -6886x | +266 | +2x |
- attr(obj, "colspan") <- value+ switch(detail, |
| 1457 | -6886x | +267 | +1x |
- obj+ subtable = treestruct(x), |
| 1458 | -+ | |||
| 268 | +1x |
- })+ row = table_structure_inner(x), |
||
| 1459 | -+ | |||
| 269 | +! |
-
+ stop("unsupported level of detail ", detail)
|
||
| 1460 | +270 |
- #' @rdname int_methods+ ) |
||
| 1461 | -28165x | +|||
| 271 | +
- setGeneric("cell_align", function(obj) standardGeneric("cell_align"))
+ } |
|||
| 1462 | +272 | |||
| 1463 | +273 |
- #' @rdname int_methods+ #' @param obj (`VTableTree`)\cr a table object. |
||
| 1464 | +274 |
- setMethod(+ #' @param depth (`numeric(1)`)\cr depth in tree. |
||
| 1465 | +275 |
- "cell_align", "CellValue",- |
- ||
| 1466 | -28165x | -
- function(obj) attr(obj, "align", exact = TRUE) %||% "center"+ #' @param indent (`numeric(1)`)\cr indent. |
||
| 1467 | +276 |
- ) ## obj@colspan)+ #' @param print_indent (`numeric(1)`)\cr indent for printing. |
||
| 1468 | +277 |
-
+ #' |
||
| 1469 | +278 |
#' @rdname int_methods |
||
| 1470 | +279 |
setGeneric( |
||
| 1471 | +280 |
- "cell_align<-",+ "table_structure_inner", |
||
| 1472 | -56x | +|||
| 281 | +
- function(obj, value) standardGeneric("cell_align<-")
+ function(obj, |
|||
| 1473 | +282 |
- )+ depth = 0, |
||
| 1474 | +283 |
-
+ indent = 0, |
||
| 1475 | +284 |
- #' @rdname int_methods+ print_indent = 0) {
|
||
| 1476 | -+ | |||
| 285 | +70x |
- setMethod("cell_align<-", "CellValue", function(obj, value) {
+ standardGeneric("table_structure_inner")
|
||
| 1477 | +286 |
- ## obj@colspan <- value+ } |
||
| 1478 | -56x | +|||
| 287 | +
- if (is.null(value)) {
+ ) |
|||
| 1479 | -! | +|||
| 288 | +
- value <- "center"+ |
|||
| 1480 | +289 |
- } else {
+ scat <- function(..., indent = 0, newline = TRUE) {
|
||
| 1481 | -56x | +290 | +101x |
- value <- tolower(value)+ txt <- paste(..., collapse = "", sep = "") |
| 1482 | +291 |
- }+ |
||
| 1483 | -56x | +292 | +101x |
- check_aligns(value)+ cat(indent_string(txt, indent)) |
| 1484 | -56x | +|||
| 293 | +
- attr(obj, "align") <- value+ |
|||
| 1485 | -56x | +294 | +101x |
- obj+ if (newline) cat("\n")
|
| 1486 | +295 |
- })+ } |
||
| 1487 | +296 | |||
| 1488 | +297 |
- ### Level (indent) in tree structure ----+ ## helper functions |
||
| 1489 | +298 | - - | -||
| 1490 | -- |
- #' @rdname int_methods+ obj_visible <- function(x) {
|
||
| 1491 | -213x | +299 | +50x |
- setGeneric("tt_level", function(obj) standardGeneric("tt_level"))
+ x@visible |
| 1492 | +300 |
-
+ } |
||
| 1493 | +301 |
- ## this will hit everything via inheritence+ |
||
| 1494 | +302 |
- #' @rdname int_methods+ is_empty_labelrow <- function(x) {
|
||
| 1495 | -213x | +303 | +4x |
- setMethod("tt_level", "VNodeInfo", function(obj) obj@level)
+ obj_label(x) == "" && !labelrow_visible(x) |
| 1496 | +304 | ++ |
+ }+ |
+ |
| 305 | ||||
| 1497 | +306 |
- #' @rdname int_methods+ is_empty_ElementaryTable <- function(x) {
|
||
| 1498 | -2x | +307 | +10x |
- setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))
+ length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x)) |
| 1499 | +308 | ++ |
+ }+ |
+ |
| 309 | ||||
| 1500 | +310 |
- ## this will hit everyhing via inheritence+ #' @param object (`VTableTree`)\cr a table object. |
||
| 1501 | +311 | ++ |
+ #'+ |
+ |
| 312 |
#' @rdname int_methods |
|||
| 1502 | +313 |
- setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
+ #' @export |
||
| 1503 | -1x | +|||
| 314 | +
- obj@level <- as.integer(value)+ setGeneric("str", function(object, ...) {
|
|||
| 1504 | -1x | +|||
| 315 | +! |
- obj+ standardGeneric("str")
|
||
| 1505 | +316 |
}) |
||
| 1506 | +317 | |||
| 1507 | +318 |
- #' @rdname int_methods+ #' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike |
||
| 1508 | +319 |
- setMethod(+ #' the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects. |
||
| 1509 | +320 |
- "tt_level<-", "VTableTree",+ #' |
||
| 1510 | +321 |
- function(obj, value) {
+ #' @rdname int_methods |
||
| 1511 | -1x | +|||
| 322 | +
- obj@level <- as.integer(value)+ #' @export |
|||
| 1512 | -1x | +|||
| 323 | +
- tree_children(obj) <- lapply(tree_children(obj),+ setMethod( |
|||
| 1513 | -1x | +|||
| 324 | +
- `tt_level<-`,+ "str", "VTableTree", |
|||
| 1514 | -1x | +|||
| 325 | +
- value = as.integer(value) + 1L+ function(object, max.level = 3L, ...) {
|
|||
| 1515 | -+ | |||
| 326 | +! |
- )+ utils::str(object, max.level = max.level, ...) |
||
| 1516 | -1x | +|||
| 327 | +! |
- obj+ warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
|
||
| 1517 | -+ | |||
| 328 | +! |
- }+ "See table_structure(.) for a summary of table struture intended for end users.", |
||
| 1518 | -+ | |||
| 329 | +! |
- )+ call. = FALSE |
||
| 1519 | +330 |
-
+ ) |
||
| 1520 | -+ | |||
| 331 | +! |
- #' @rdname int_methods+ invisible(NULL) |
||
| 1521 | +332 |
- #' @export+ } |
||
| 1522 | -55325x | +|||
| 333 | +
- setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))
+ ) |
|||
| 1523 | +334 | |||
| 1524 | +335 |
- #' @rdname int_methods+ #' @inheritParams table_structure_inner |
||
| 1525 | +336 |
- setMethod(+ #' @rdname int_methods |
||
| 1526 | +337 |
- "indent_mod", "Split",- |
- ||
| 1527 | -2915x | -
- function(obj) obj@indent_modifier+ setMethod( |
||
| 1528 | +338 |
- )+ "table_structure_inner", "TableTree", |
||
| 1529 | +339 |
-
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
||
| 1530 | -+ | |||
| 340 | +10x |
- #' @rdname int_methods+ indent <- indent + indent_mod(obj) |
||
| 1531 | +341 |
- setMethod(+ |
||
| 1532 | -+ | |||
| 342 | +10x |
- "indent_mod", "VTableNodeInfo",+ scat("TableTree: ", "[", obj_name(obj), "] (",
|
||
| 1533 | -26675x | +343 | +10x |
- function(obj) obj@indent_modifier+ obj_label(obj), ")", |
| 1534 | -+ | |||
| 344 | +10x |
- )+ indent = print_indent |
||
| 1535 | +345 |
-
+ ) |
||
| 1536 | +346 |
- #' @rdname int_methods+ |
||
| 1537 | -+ | |||
| 347 | +10x |
- setMethod(+ table_structure_inner( |
||
| 1538 | -+ | |||
| 348 | +10x |
- "indent_mod", "ANY",+ tt_labelrow(obj), depth, indent, |
||
| 1539 | -22518x | +349 | +10x |
- function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L+ print_indent + 1 |
| 1540 | +350 |
- )+ ) |
||
| 1541 | +351 | |||
| 1542 | -+ | |||
| 352 | +10x |
- #' @rdname int_methods+ ctab <- content_table(obj) |
||
| 1543 | -+ | |||
| 353 | +10x |
- setMethod(+ visible_content <- if (is_empty_ElementaryTable(ctab)) {
|
||
| 1544 | +354 |
- "indent_mod", "RowsVerticalSection",+ # scat("content: -", indent = print_indent + 1)
|
||
| 1545 | -+ | |||
| 355 | +4x |
- ## function(obj) setNames(obj@indent_mods,names(obj)))+ FALSE |
||
| 1546 | +356 |
- function(obj) {
+ } else {
|
||
| 1547 | -1602x | +357 | +6x |
- val <- attr(obj, "indent_mods", exact = TRUE) %||%+ scat("content:", indent = print_indent + 1)
|
| 1548 | -1602x | +358 | +6x |
- vapply(obj, indent_mod, 1L) ## rep(0L, length(obj))+ table_structure_inner(ctab, |
| 1549 | -1602x | +359 | +6x |
- setNames(val, names(obj))+ depth = depth, |
| 1550 | -+ | |||
| 360 | +6x |
- }+ indent = indent + indent_mod(ctab), |
||
| 1551 | -+ | |||
| 361 | +6x |
- )+ print_indent = print_indent + 2 |
||
| 1552 | +362 |
-
+ ) |
||
| 1553 | +363 |
- #' @examples+ } |
||
| 1554 | +364 |
- #' indent_mod(tbl)+ |
||
| 1555 | -+ | |||
| 365 | +10x |
- #' indent_mod(tbl) <- 1L+ if (length(tree_children(obj)) == 0) {
|
||
| 1556 | -+ | |||
| 366 | +! |
- #' tbl+ scat("children: - ", indent = print_indent + 1)
|
||
| 1557 | +367 |
- #'+ } else {
|
||
| 1558 | -+ | |||
| 368 | +10x |
- #' @rdname int_methods+ scat("children: ", indent = print_indent + 1)
|
||
| 1559 | -+ | |||
| 369 | +10x |
- #' @export+ lapply(tree_children(obj), table_structure_inner, |
||
| 1560 | -1434x | +370 | +10x |
- setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))
+ depth = depth + 1, |
| 1561 | -+ | |||
| 371 | +10x |
-
+ indent = indent + visible_content * (1 + indent_mod(ctab)), |
||
| 1562 | -+ | |||
| 372 | +10x |
- #' @rdname int_methods+ print_indent = print_indent + 2 |
||
| 1563 | +373 |
- setMethod(+ ) |
||
| 1564 | +374 |
- "indent_mod<-", "Split",+ } |
||
| 1565 | +375 |
- function(obj, value) {
- |
- ||
| 1566 | -1x | -
- obj@indent_modifier <- as.integer(value)+ |
||
| 1567 | -1x | +376 | +10x |
- obj+ invisible(NULL) |
| 1568 | +377 |
} |
||
| 1569 | +378 |
) |
||
| 1570 | +379 | |||
| 1571 | +380 |
#' @rdname int_methods |
||
| 1572 | +381 |
setMethod( |
||
| 1573 | +382 |
- "indent_mod<-", "VTableNodeInfo",+ "table_structure_inner", "ElementaryTable", |
||
| 1574 | +383 |
- function(obj, value) {
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
||
| 1575 | -1430x | +384 | +15x |
- obj@indent_modifier <- as.integer(value)+ scat("ElementaryTable: ", "[", obj_name(obj),
|
| 1576 | -1430x | +385 | +15x |
- obj+ "] (", obj_label(obj), ")",
|
| 1577 | -+ | |||
| 386 | +15x |
- }+ indent = print_indent |
||
| 1578 | +387 |
- )+ ) |
||
| 1579 | +388 | |||
| 1580 | -- |
- #' @rdname int_methods- |
- ||
| 1581 | -- |
- setMethod(- |
- ||
| 1582 | -+ | |||
| 389 | +15x |
- "indent_mod<-", "CellValue",+ indent <- indent + indent_mod(obj) |
||
| 1583 | +390 |
- function(obj, value) {
+
|
||
| 1584 | -2x | +391 | +15x |
- attr(obj, "indent_mod") <- as.integer(value)+ table_structure_inner( |
| 1585 | -2x | +392 | +15x |
- obj+ tt_labelrow(obj), depth, |
| 1586 | -+ | |||
| 393 | +15x |
- }+ indent, print_indent + 1 |
||
| 1587 | +394 |
- )+ ) |
||
| 1588 | +395 | |||
| 1589 | -- |
- #' @rdname int_methods- |
- ||
| 1590 | -+ | |||
| 396 | +15x |
- setMethod(+ if (length(tree_children(obj)) == 0) {
|
||
| 1591 | -+ | |||
| 397 | +! |
- "indent_mod<-", "RowsVerticalSection",+ scat("children: - ", indent = print_indent + 1)
|
||
| 1592 | +398 |
- function(obj, value) {
+ } else {
|
||
| 1593 | -1x | +399 | +15x |
- if (length(value) != 1 && length(value) != length(obj)) {
+ scat("children: ", indent = print_indent + 1)
|
| 1594 | -! | +|||
| 400 | +15x |
- stop(+ lapply(tree_children(obj), table_structure_inner, |
||
| 1595 | -! | +|||
| 401 | +15x |
- "When setting indent mods on a RowsVerticalSection the value ",+ depth = depth + 1, indent = indent, |
||
| 1596 | -! | +|||
| 402 | +15x |
- "must have length 1 or the number of rows"+ print_indent = print_indent + 2 |
||
| 1597 | +403 |
) |
||
| 1598 | +404 |
} |
||
| 1599 | -1x | +|||
| 405 | +
- attr(obj, "indent_mods") <- as.integer(value)+ |
|||
| 1600 | -1x | +406 | +15x |
- obj+ invisible(NULL) |
| 1601 | +407 |
-
+ } |
||
| 1602 | +408 |
- ## obj@indent_mods <- value+ ) |
||
| 1603 | +409 |
- ## obj+ |
||
| 1604 | +410 |
- }+ #' @rdname int_methods |
||
| 1605 | +411 |
- )+ setMethod( |
||
| 1606 | +412 |
-
+ "table_structure_inner", "TableRow", |
||
| 1607 | +413 |
- #' @rdname int_methods+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
||
| 1608 | -+ | |||
| 414 | +20x |
- setGeneric(+ scat(class(obj), ": ", "[", obj_name(obj), "] (",
|
||
| 1609 | -+ | |||
| 415 | +20x |
- "content_indent_mod",+ obj_label(obj), ")", |
||
| 1610 | -1202x | +416 | +20x |
- function(obj) standardGeneric("content_indent_mod")
+ indent = print_indent |
| 1611 | +417 |
- )+ ) |
||
| 1612 | +418 | |||
| 1613 | -+ | |||
| 419 | +20x |
- #' @rdname int_methods+ indent <- indent + indent_mod(obj) |
||
| 1614 | +420 |
- setMethod(+ |
||
| 1615 | -+ | |||
| 421 | +20x |
- "content_indent_mod", "Split",+ invisible(NULL) |
||
| 1616 | -1202x | +|||
| 422 | +
- function(obj) obj@content_indent_modifier+ } |
|||
| 1617 | +423 |
) |
||
| 1618 | +424 | |||
| 1619 | +425 |
#' @rdname int_methods |
||
| 1620 | +426 |
setMethod( |
||
| 1621 | +427 |
- "content_indent_mod", "VTableNodeInfo",+ "table_structure_inner", "LabelRow", |
||
| 1622 | -! | +|||
| 428 | +
- function(obj) obj@content_indent_modifier+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
|||
| 1623 | -+ | |||
| 429 | +25x |
- )+ indent <- indent + indent_mod(obj) |
||
| 1624 | +430 | |||
| 1625 | -+ | |||
| 431 | +25x |
- #' @rdname int_methods+ txtvis <- if (!obj_visible(obj)) " - <not visible>" else "" |
||
| 1626 | +432 |
- setGeneric(+ |
||
| 1627 | -+ | |||
| 433 | +25x |
- "content_indent_mod<-",+ scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
|
||
| 1628 | -105x | +434 | +25x |
- function(obj, value) standardGeneric("content_indent_mod<-")
+ txtvis,+ |
+
| 435 | +25x | +
+ indent = print_indent |
||
| 1629 | +436 |
- )+ ) |
||
| 1630 | +437 | |||
| 1631 | -+ | |||
| 438 | +25x |
- #' @rdname int_methods+ obj_visible(obj) |
||
| 1632 | +439 |
- setMethod(+ } |
||
| 1633 | +440 |
- "content_indent_mod<-", "Split",+ ) |
| 1634 | +1 |
- function(obj, value) {
+ .reindex_one_pos <- function(refs, cur_idx_fun) {
|
||
| 1635 | -105x | +2 | +2374x |
- obj@content_indent_modifier <- as.integer(value)+ if (length(refs) == 0) {
|
| 1636 | -105x | +3 | +2260x |
- obj+ return(refs) |
| 1637 | +4 |
} |
||
| 1638 | -- |
- )- |
- ||
| 1639 | +5 | |||
| 1640 | -+ | |||
| 6 | +114x |
- #' @rdname int_methods+ lapply(refs, function(refi) {
|
||
| 1641 | +7 |
- setMethod(+ ## these can be symbols, e.g. ^, †now, those are |
||
| 1642 | +8 |
- "content_indent_mod<-", "VTableNodeInfo",+ ## special and don't get reindexed cause they're not numbered |
||
| 1643 | +9 |
- function(obj, value) {
+ ## to begin with |
||
| 1644 | -! | +|||
| 10 | +119x |
- obj@content_indent_modifier <- as.integer(value)+ idx <- ref_index(refi) |
||
| 1645 | -! | +|||
| 11 | +119x |
- obj+ if (is.na(idx) || !is.na(as.integer(idx))) {
|
||
| 1646 | -+ | |||
| 12 | +119x |
- }+ ref_index(refi) <- cur_idx_fun(refi) |
||
| 1647 | +13 |
- )+ } |
||
| 1648 | -+ | |||
| 14 | +119x |
-
+ refi |
||
| 1649 | +15 |
- ## TODO export these?+ }) |
||
| 1650 | +16 |
- #' @rdname int_methods+ } |
||
| 1651 | +17 |
- #' @export+ |
||
| 1652 | -132371x | +18 | +72x |
- setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))
+ setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))
|
| 1653 | +19 | |||
| 1654 | +20 |
- #' @rdname int_methods- |
- ||
| 1655 | -! | -
- setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)
+ setMethod( |
||
| 1656 | +21 |
-
+ ".idx_helper", "TableRow", |
||
| 1657 | +22 |
- #' @rdname int_methods+ function(tr, cur_idx_fun) {
|
||
| 1658 | -30x | +23 | +70x |
- setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)
+ row_footnotes(tr) <- .reindex_one_pos( |
| 1659 | -+ | |||
| 24 | +70x |
-
+ row_footnotes(tr), |
||
| 1660 | -+ | |||
| 25 | +70x |
- #' @rdname int_methods+ cur_idx_fun |
||
| 1661 | -3416x | +|||
| 26 | +
- setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))
+ ) |
|||
| 1662 | +27 | |||
| 1663 | -+ | |||
| 28 | +70x |
- #' @rdname int_methods+ cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs, |
||
| 1664 | -1900x | +29 | +70x |
- setMethod("rawvalues", "ANY", function(obj) obj)
+ .reindex_one_pos, |
| 1665 | -+ | |||
| 30 | +70x |
-
+ cur_idx_fun = cur_idx_fun |
||
| 1666 | +31 |
- #' @rdname int_methods+ ) |
||
| 1667 | -87325x | +32 | +70x |
- setMethod("rawvalues", "CellValue", function(obj) obj[[1]])
+ tr |
| 1668 | +33 |
-
+ } |
||
| 1669 | +34 |
- #' @rdname int_methods+ ) |
||
| 1670 | +35 |
- setMethod(+ |
||
| 1671 | +36 |
- "rawvalues", "TreePos",- |
- ||
| 1672 | -228x | -
- function(obj) rawvalues(pos_splvals(obj))+ setMethod( |
||
| 1673 | +37 |
- )+ ".idx_helper", "VTableTree", |
||
| 1674 | +38 |
-
+ function(tr, cur_idx_fun) {
|
||
| 1675 | -+ | |||
| 39 | +2x |
- #' @rdname int_methods+ if (!labelrow_visible(tr)) {
|
||
| 1676 | +40 |
- setMethod(+ stop("got a row footnote on a non-visible label row. this should never happen") # nocov
|
||
| 1677 | +41 |
- "rawvalues", "RowsVerticalSection",+ } |
||
| 1678 | +42 | 2x |
- function(obj) unlist(obj, recursive = FALSE)+ lr <- tt_labelrow(tr) |
|
| 1679 | -- |
- )- |
- ||
| 1680 | +43 | |||
| 1681 | -+ | |||
| 44 | +2x |
- #' @rdname int_methods+ row_footnotes(lr) <- .reindex_one_pos( |
||
| 1682 | -+ | |||
| 45 | +2x |
- #' @export+ row_footnotes(lr), |
||
| 1683 | -45745x | +46 | +2x |
- setGeneric("value_names", function(obj) standardGeneric("value_names"))
+ cur_idx_fun |
| 1684 | +47 |
-
+ ) |
||
| 1685 | +48 |
- #' @rdname int_methods+ |
||
| 1686 | -+ | |||
| 49 | +2x |
- setMethod(+ tt_labelrow(tr) <- lr |
||
| 1687 | +50 |
- "value_names", "ANY",+ |
||
| 1688 | -38x | +51 | +2x |
- function(obj) as.character(rawvalues(obj))+ tr |
| 1689 | +52 |
- )+ } |
||
| 1690 | +53 |
-
+ ) |
||
| 1691 | +54 |
- #' @rdname int_methods+ |
||
| 1692 | +55 |
- setMethod(+ index_col_refs <- function(tt, cur_idx_fun) {
|
||
| 1693 | -+ | |||
| 56 | +424x |
- "value_names", "TreePos",+ ctree <- coltree(tt) |
||
| 1694 | -1592x | +57 | +424x |
- function(obj) value_names(pos_splvals(obj))+ ctree <- .index_col_refs_inner(ctree, cur_idx_fun)+ |
+
| 58 | +424x | +
+ coltree(tt) <- ctree+ |
+ ||
| 59 | +424x | +
+ tt |
||
| 1695 | +60 |
- )+ } |
||
| 1696 | +61 | |||
| 1697 | +62 |
- #' @rdname int_methods+ .index_col_refs_inner <- function(ctree, cur_idx_fun) {
|
||
| 1698 | -+ | |||
| 63 | +2045x |
- setMethod(+ col_footnotes(ctree) <- .reindex_one_pos( |
||
| 1699 | -+ | |||
| 64 | +2045x |
- "value_names", "list",+ col_footnotes(ctree), |
||
| 1700 | -3579x | +65 | +2045x |
- function(obj) lapply(obj, value_names)+ cur_idx_fun |
| 1701 | +66 |
- )+ ) |
||
| 1702 | +67 | |||
| 1703 | -+ | |||
| 68 | +2045x |
- #' @rdname int_methods+ if (is(ctree, "LayoutColTree")) {
|
||
| 1704 | -+ | |||
| 69 | +765x |
- setMethod(+ tree_children(ctree) <- lapply(tree_children(ctree), |
||
| 1705 | -+ | |||
| 70 | +765x |
- "value_names", "ValueWrapper",+ .index_col_refs_inner, |
||
| 1706 | -! | +|||
| 71 | +765x |
- function(obj) rawvalues(obj)+ cur_idx_fun = cur_idx_fun |
||
| 1707 | +72 |
- )+ ) |
||
| 1708 | +73 |
-
+ }+ |
+ ||
| 74 | +2045x | +
+ ctree |
||
| 1709 | +75 |
- #' @rdname int_methods+ ## cfs <- col_footnotes(ctree) |
||
| 1710 | +76 |
- setMethod(+ ## if(length(unlist(cfs)) > 0) {
|
||
| 1711 | +77 |
- "value_names", "LevelComboSplitValue",+ ## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs, |
||
| 1712 | -332x | +|||
| 78 | +
- function(obj) obj@value+ ## function(refs) lapply(refs, function(refi) {
|
|||
| 1713 | +79 |
- ) ## obj@comboname)+ } |
||
| 1714 | +80 | |||
| 1715 | +81 |
- #' @rdname int_methods+ #' Update footnote indices on a built table |
||
| 1716 | +82 |
- setMethod(+ #' |
||
| 1717 | +83 |
- "value_names", "RowsVerticalSection",+ #' Re-indexes footnotes within a built table. |
||
| 1718 | -3180x | +|||
| 84 | +
- function(obj) attr(obj, "row_names", exact = TRUE)+ #' |
|||
| 1719 | +85 |
- ) ## obj@row_names)+ #' @inheritParams gen_args |
||
| 1720 | +86 |
-
+ #' |
||
| 1721 | +87 |
- ## not sure if I need these anywhere+ #' @details |
||
| 1722 | +88 |
- ## XXX+ #' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes |
||
| 1723 | +89 |
- #' @rdname int_methods+ #' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based |
||
| 1724 | -5488x | +|||
| 90 | +
- setGeneric("value_labels", function(obj) standardGeneric("value_labels"))
+ #' on the full table. |
|||
| 1725 | +91 |
-
+ #' |
||
| 1726 | +92 |
- #' @rdname int_methods+ #' @note In the future this should not generally need to be called manually. |
||
| 1727 | -! | +|||
| 93 | +
- setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))
+ #' |
|||
| 1728 | +94 |
-
+ #' @export |
||
| 1729 | +95 |
- #' @rdname int_methods+ update_ref_indexing <- function(tt) {
|
||
| 1730 | -+ | |||
| 96 | +424x |
- setMethod(+ col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt)) |
||
| 1731 | -+ | |||
| 97 | +424x |
- "value_labels", "TreePos",+ row_fnotes <- row_footnotes(tt) |
||
| 1732 | -! | +|||
| 98 | +424x |
- function(obj) sapply(pos_splvals(obj), obj_label)+ cell_fnotes <- cell_footnotes(tt) |
||
| 1733 | -+ | |||
| 99 | +424x |
- )+ all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))+ |
+ ||
| 100 | +424x | +
+ all_fns <- unlist(t(all_fns))+ |
+ ||
| 101 | +424x | +
+ unique_fnotes <- unique(sapply(all_fns, ref_msg)) |
||
| 1734 | +102 | |||
| 103 | +424x | +
+ cur_index <- function(ref_fn) {
+ |
+ ||
| 104 | +119x | +
+ match(ref_msg(ref_fn), unique_fnotes)+ |
+ ||
| 1735 | +105 |
- #' @rdname int_methods+ } |
||
| 1736 | +106 |
- setMethod("value_labels", "list", function(obj) {
+
|
||
| 1737 | -3837x | +107 | +424x |
- ret <- lapply(obj, obj_label)+ if (ncol(tt) > 0) {
|
| 1738 | -3837x | +108 | +424x |
- if (!is.null(names(obj))) {
+ tt <- index_col_refs(tt, cur_index) |
| 1739 | -539x | +|||
| 109 | +
- inds <- vapply(ret, function(x) length(x) == 0, NA)+ } ## col_info(tt) <- index_col_refs(col_info(tt), cur_index) |
|||
| 1740 | -539x | +|||
| 110 | +
- ret[inds] <- names(obj)[inds]+ ## TODO when column refs are a thing we will |
|||
| 1741 | +111 |
- }+ ## still need to do those here before returning!!! |
||
| 1742 | -3837x | +112 | +424x |
- ret+ if (nrow(tt) == 0) {
+ |
+
| 113 | +16x | +
+ return(tt) |
||
| 1743 | +114 |
- })+ } |
||
| 1744 | +115 | |||
| 1745 | -+ | |||
| 116 | +408x |
- #' @rdname int_methods+ rdf <- make_row_df(tt) |
||
| 1746 | +117 |
- setMethod(+ |
||
| 1747 | -+ | |||
| 118 | +408x |
- "value_labels",+ rdf <- rdf[rdf$nreflines > 0, ] |
||
| 1748 | -+ | |||
| 119 | +408x |
- "RowsVerticalSection",+ if (nrow(rdf) == 0) {
|
||
| 1749 | -1603x | +120 | +371x |
- function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj))+ return(tt) |
| 1750 | +121 |
- )+ } |
||
| 1751 | +122 | |||
| 1752 | -+ | |||
| 123 | +37x |
- #' @rdname int_methods+ for (i in seq_len(nrow(rdf))) {
|
||
| 1753 | -! | +|||
| 124 | +72x |
- setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))
+ path <- unname(rdf$path[[i]]) |
||
| 1754 | -+ | |||
| 125 | +72x |
-
+ tt_at_path(tt, path) <- |
||
| 1755 | -+ | |||
| 126 | +72x |
- #' @rdname int_methods+ .idx_helper(+ |
+ ||
| 127 | +72x | +
+ tt_at_path(tt, path),+ |
+ ||
| 128 | +72x | +
+ cur_index |
||
| 1756 | +129 |
- setMethod(+ ) |
||
| 1757 | +130 |
- "value_labels", "LevelComboSplitValue",+ } |
||
| 1758 | -! | +|||
| 131 | +37x |
- function(obj) obj_label(obj)+ tt |
||
| 1759 | +132 |
- )+ } |
| 1760 | +1 |
-
+ ## XXX Do we want add.labrows here or no? |
||
| 1761 | +2 |
- #' @rdname int_methods+ ## we have to choose one and stick to it. |
||
| 1762 | -48x | +|||
| 3 | +
- setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)
+
|
|||
| 1763 | +4 |
-
+ #' Internal generics and methods |
||
| 1764 | +5 |
- #' @rdname int_methods+ #' |
||
| 1765 | -3804x | +|||
| 6 | +
- setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
+ #' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no |
|||
| 1766 | +7 |
- #' @rdname int_methods+ #' attention to this documentation. |
||
| 1767 | -58x | +|||
| 8 | +
- setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
+ #' |
|||
| 1768 | +9 |
- #' @rdname int_methods+ #' @param x (`ANY`)\cr the object. |
||
| 1769 | -! | +|||
| 10 | +
- setMethod("value_expr", "ANY", function(obj) NULL)
+ #' @param obj (`ANY`)\cr the object. |
|||
| 1770 | +11 |
- ## no setters for now, we'll see about that.+ #' |
||
| 1771 | +12 |
-
+ #' @name internal_methods |
||
| 1772 | +13 |
-
+ #' @rdname int_methods |
||
| 1773 | +14 |
- #' @rdname int_methods+ #' @aliases int_methods |
||
| 1774 | -6x | +|||
| 15 | +
- setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))
+ NULL |
|||
| 1775 | +16 | |||
| 1776 | +17 |
- #' @rdname int_methods+ #' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object. |
||
| 1777 | -6x | +|||
| 18 | +
- setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)
+ #' |
|||
| 1778 | +19 |
-
+ #' @rdname dimensions |
||
| 1779 | +20 |
- #' @rdname int_methods+ #' @exportMethod nrow |
||
| 1780 | +21 |
- setGeneric(+ setMethod( |
||
| 1781 | +22 |
- "spl_varlabels<-",+ "nrow", "VTableTree", |
||
| 1782 | -2x | +23 | +2361x |
- function(object, value) standardGeneric("spl_varlabels<-")
+ function(x) length(collect_leaves(x, TRUE, TRUE)) |
| 1783 | +24 |
) |
||
| 1784 | +25 | |||
| 1785 | +26 |
#' @rdname int_methods |
||
| 1786 | +27 |
- setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
+ #' @exportMethod nrow |
||
| 1787 | -2x | +|||
| 28 | +
- object@var_labels <- value+ setMethod(+ |
+ |||
| 29 | ++ |
+ "nrow", "TableRow", |
||
| 1788 | -2x | +30 | +979x |
- object+ function(x) 1L |
| 1789 | +31 |
- })+ ) |
||
| 1790 | +32 | |||
| 1791 | +33 |
- ## These two are similar enough we could probably combine+ #' Table dimensions |
||
| 1792 | +34 |
- ## them but conceptually they are pretty different+ #' |
||
| 1793 | +35 |
- ## split_exargs is a list of extra arguments that apply+ #' @param x (`TableTree` or `ElementaryTable`)\cr a table object. |
||
| 1794 | +36 |
- ## to *all the chidlren*,+ #' |
||
| 1795 | +37 |
- ## while splv_extra is for *child-specific* extra arguments,+ #' @examples |
||
| 1796 | +38 |
- ## associated with specific values of the split+ #' lyt <- basic_table() %>% |
||
| 1797 | +39 |
- #' @rdname int_methods- |
- ||
| 1798 | -3086x | -
- setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))
+ #' split_cols_by("ARM") %>%
|
||
| 1799 | +40 |
-
+ #' analyze(c("SEX", "AGE"))
|
||
| 1800 | +41 |
- #' @rdname int_methods+ #' |
||
| 1801 | +42 |
- setMethod(+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 1802 | +43 |
- "splv_extra", "SplitValue",+ #' |
||
| 1803 | -3086x | +|||
| 44 | +
- function(obj) obj@extra+ #' dim(tbl) |
|||
| 1804 | +45 |
- )+ #' nrow(tbl) |
||
| 1805 | +46 |
-
+ #' ncol(tbl) |
||
| 1806 | +47 |
- #' @rdname int_methods+ #' |
||
| 1807 | +48 |
- setGeneric(+ #' NROW(tbl) |
||
| 1808 | +49 |
- "splv_extra<-",+ #' NCOL(tbl) |
||
| 1809 | -1711x | +|||
| 50 | +
- function(obj, value) standardGeneric("splv_extra<-")
+ #' |
|||
| 1810 | +51 |
- )+ #' @rdname dimensions |
||
| 1811 | +52 |
- #' @rdname int_methods+ #' @exportMethod ncol |
||
| 1812 | +53 |
setMethod( |
||
| 1813 | +54 |
- "splv_extra<-", "SplitValue",+ "ncol", "VTableNodeInfo", |
||
| 1814 | +55 |
- function(obj, value) {
- |
- ||
| 1815 | -1711x | -
- obj@extra <- value+ function(x) {
|
||
| 1816 | -1711x | +56 | +23155x |
- obj+ ncol(col_info(x)) |
| 1817 | +57 |
} |
||
| 1818 | +58 |
) |
||
| 1819 | +59 | |||
| 1820 | +60 |
#' @rdname int_methods |
||
| 1821 | -2127x | -
- setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))
- |
- ||
| 1822 | +61 |
-
+ #' @exportMethod ncol |
||
| 1823 | +62 |
- #' @rdname int_methods+ setMethod( |
||
| 1824 | +63 |
- setMethod(+ "ncol", "TableRow", |
||
| 1825 | +64 |
- "split_exargs", "Split",+ function(x) {
|
||
| 1826 | -2076x | +65 | +70310x |
- function(obj) obj@extra_args+ if (!no_colinfo(x)) {
|
| 1827 | -+ | |||
| 66 | +69258x |
- )+ ncol(col_info(x)) |
||
| 1828 | +67 |
-
+ } else {
|
||
| 1829 | -+ | |||
| 68 | +1052x |
- #' @rdname int_methods+ length(spanned_values(x)) |
||
| 1830 | +69 |
- setGeneric(+ } |
||
| 1831 | +70 |
- "split_exargs<-",- |
- ||
| 1832 | -1x | -
- function(obj, value) standardGeneric("split_exargs<-")
+ } |
||
| 1833 | +71 |
) |
||
| 1834 | +72 | |||
| 1835 | +73 |
#' @rdname int_methods |
||
| 1836 | +74 |
- setMethod(+ #' @exportMethod ncol |
||
| 1837 | +75 |
- "split_exargs<-", "Split",+ setMethod( |
||
| 1838 | +76 |
- function(obj, value) {
+ "ncol", "LabelRow", |
||
| 1839 | -1x | +|||
| 77 | +
- obj@extra_args <- value+ function(x) {
|
|||
| 1840 | -1x | +78 | +23428x |
- obj+ ncol(col_info(x)) |
| 1841 | +79 |
} |
||
| 1842 | +80 |
) |
||
| 1843 | +81 | |||
| 1844 | -! | +|||
| 82 | +
- is_labrow <- function(obj) is(obj, "LabelRow")+ #' @rdname int_methods |
|||
| 1845 | +83 |
-
+ #' @exportMethod ncol |
||
| 1846 | +84 |
- spl_ref_group <- function(obj) {
+ setMethod( |
||
| 1847 | -17x | +|||
| 85 | +
- stopifnot(is(obj, "VarLevWBaselineSplit"))+ "ncol", "InstantiatedColumnInfo",+ |
+ |||
| 86 | ++ |
+ function(x) {
|
||
| 1848 | -17x | +87 | +117874x |
- obj@ref_group_value+ length(col_exprs(x)) |
| 1849 | +88 |
- }+ } |
||
| 1850 | +89 | ++ |
+ )+ |
+ |
| 90 | ||||
| 1851 | +91 |
- ### column info+ #' @rdname dimensions |
||
| 1852 | +92 |
-
+ #' @exportMethod dim |
||
| 1853 | +93 |
- #' Column information/structure accessors+ setMethod( |
||
| 1854 | +94 |
- #'+ "dim", "VTableNodeInfo",+ |
+ ||
| 95 | +19143x | +
+ function(x) c(nrow(x), ncol(x)) |
||
| 1855 | +96 |
- #' @inheritParams gen_args+ ) |
||
| 1856 | +97 |
- #' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being+ |
||
| 1857 | +98 |
- #' generated from a pre-data layout object.+ #' Retrieve or set the direct children of a tree-style object |
||
| 1858 | +99 |
- #' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only.+ #' |
||
| 1859 | +100 |
- #' Path (in column structure).+ #' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure. |
||
| 1860 | +101 |
- #' @param rtpos (`TreePos`)\cr root position.+ #' @param value (`list`)\cr new list of children. |
||
| 1861 | +102 |
#' |
||
| 1862 | +103 |
- #' @return A `LayoutColTree` object.+ #' @return A list of direct children of `x`. |
||
| 1863 | +104 |
#' |
||
| 1864 | +105 |
- #' @rdname col_accessors+ #' @export |
||
| 1865 | +106 |
- #' @export+ #' @rdname tree_children |
||
| 1866 | -2674x | +107 | +248594x |
- setGeneric("clayout", function(obj) standardGeneric("clayout"))
+ setGeneric("tree_children", function(x) standardGeneric("tree_children"))
|
| 1867 | +108 | |||
| 1868 | +109 |
- #' @rdname col_accessors+ #' @exportMethod tree_children |
||
| 1869 | +110 |
- #' @exportMethod clayout+ #' @rdname int_methods |
||
| 1870 | +111 |
setMethod( |
||
| 1871 | +112 |
- "clayout", "VTableNodeInfo",+ "tree_children", c(x = "VTree"), |
||
| 1872 | -7x | +|||
| 113 | +! |
- function(obj) coltree(col_info(obj))+ function(x) x@children |
||
| 1873 | +114 |
) |
||
| 1874 | +115 | |||
| 1875 | +116 |
- #' @rdname col_accessors+ #' @exportMethod tree_children |
||
| 1876 | +117 |
- #' @exportMethod clayout+ #' @rdname int_methods |
||
| 1877 | +118 |
setMethod( |
||
| 1878 | +119 |
- "clayout", "PreDataTableLayouts",+ "tree_children", c(x = "VTableTree"), |
||
| 1879 | -2667x | +120 | +66899x |
- function(obj) obj@col_layout+ function(x) x@children |
| 1880 | +121 |
) |
||
| 1881 | +122 | |||
| 1882 | +123 |
- ## useful convenience for the cascading methods in colby_constructors+ ## this includes VLeaf but also allows for general methods |
||
| 1883 | +124 |
- #' @rdname col_accessors+ ## needed for table_inset being carried around by rows and |
||
| 1884 | +125 |
- #' @exportMethod clayout+ ## such. |
||
| 1885 | -! | +|||
| 126 | +
- setMethod("clayout", "ANY", function(obj) PreDataColLayout())
+ #' @exportMethod tree_children |
|||
| 1886 | +127 |
-
+ #' @rdname int_methods |
||
| 1887 | +128 |
- #' @rdname col_accessors+ setMethod( |
||
| 1888 | +129 |
- #' @export+ "tree_children", c(x = "ANY"), ## "VLeaf"), |
||
| 1889 | -884x | +130 | +12228x |
- setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))
+ function(x) list() |
| 1890 | +131 |
-
+ ) |
||
| 1891 | +132 |
- #' @rdname col_accessors+ |
||
| 1892 | +133 |
- #' @exportMethod clayout<-+ #' @export |
||
| 1893 | +134 |
- setMethod(+ #' @rdname tree_children |
||
| 1894 | -+ | |||
| 135 | +57768x |
- "clayout<-", "PreDataTableLayouts",+ setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))
|
||
| 1895 | +136 |
- function(object, value) {
+
|
||
| 1896 | -884x | +|||
| 137 | +
- object@col_layout <- value+ #' @exportMethod tree_children<- |
|||
| 1897 | -884x | +|||
| 138 | +
- object+ #' @rdname int_methods |
|||
| 1898 | +139 |
- }+ setMethod( |
||
| 1899 | +140 |
- )+ "tree_children<-", c(x = "VTree"), |
||
| 1900 | +141 |
-
+ function(x, value) {
|
||
| 1901 | -+ | |||
| 142 | +! |
- #' @rdname col_accessors+ x@children <- value+ |
+ ||
| 143 | +! | +
+ x |
||
| 1902 | +144 |
- #' @export+ } |
||
| 1903 | -271032x | +|||
| 145 | +
- setGeneric("col_info", function(obj) standardGeneric("col_info"))
+ ) |
|||
| 1904 | +146 | |||
| 1905 | +147 |
- #' @rdname col_accessors+ #' @exportMethod tree_children<- |
||
| 1906 | +148 |
- #' @exportMethod col_info+ #' @rdname int_methods |
||
| 1907 | +149 |
setMethod( |
||
| 1908 | +150 |
- "col_info", "VTableNodeInfo",+ "tree_children<-", c(x = "VTableTree"),+ |
+ ||
| 151 | ++ |
+ function(x, value) {
|
||
| 1909 | -237598x | +152 | +52272x |
- function(obj) obj@col_info+ x@children <- value+ |
+
| 153 | +52272x | +
+ x |
||
| 1910 | +154 | ++ |
+ }+ |
+ |
| 155 |
) |
|||
| 1911 | +156 | |||
| 1912 | +157 |
- ### XXX I've made this recursive. Do we ALWAYS want it to be?+ #' Retrieve or set content table from a `TableTree` |
||
| 1913 | +158 |
- ###+ #' |
||
| 1914 | +159 |
- ### I think we do.+ #' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise. |
||
| 1915 | +160 |
- #' @rdname col_accessors+ #' |
||
| 1916 | +161 |
- #' @export+ #' @param obj (`TableTree`)\cr the table object. |
||
| 1917 | -70278x | +|||
| 162 | +
- setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))
+ #' |
|||
| 1918 | +163 |
-
+ #' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not |
||
| 1919 | +164 |
- #' @return Returns various information about columns, depending on the accessor used.+ #' a formal table object). |
||
| 1920 | +165 |
#' |
||
| 1921 | +166 |
- #' @exportMethod col_info<-+ #' @export |
||
| 1922 | +167 |
- #' @rdname col_accessors+ #' @rdname content_table |
||
| 1923 | -+ | |||
| 168 | +92876x |
- setMethod(+ setGeneric("content_table", function(obj) standardGeneric("content_table"))
|
||
| 1924 | +169 |
- "col_info<-", "TableRow",+ |
||
| 1925 | +170 |
- function(obj, value) {
+ #' @exportMethod content_table |
||
| 1926 | -42119x | +|||
| 171 | +
- obj@col_info <- value+ #' @rdname int_methods |
|||
| 1927 | -42119x | +|||
| 172 | +
- obj+ setMethod( |
|||
| 1928 | +173 |
- }+ "content_table", "TableTree",+ |
+ ||
| 174 | +61286x | +
+ function(obj) obj@content |
||
| 1929 | +175 |
) |
||
| 1930 | +176 | |||
| 1931 | +177 |
- .set_cinfo_kids <- function(obj) {
+ #' @exportMethod content_table |
||
| 1932 | -21882x | +|||
| 178 | +
- kids <- lapply(+ #' @rdname int_methods |
|||
| 1933 | -21882x | +|||
| 179 | +
- tree_children(obj),+ setMethod( |
|||
| 1934 | -21882x | +|||
| 180 | +
- function(x) {
+ "content_table", "ANY", |
|||
| 1935 | -51789x | +181 | +10896x |
- col_info(x) <- col_info(obj)+ function(obj) NULL |
| 1936 | -51789x | +|||
| 182 | +
- x+ ) |
|||
| 1937 | +183 |
- }+ |
||
| 1938 | +184 |
- )+ #' @param value (`ElementaryTable`)\cr the new content table for `obj`. |
||
| 1939 | -21882x | +|||
| 185 | +
- tree_children(obj) <- kids+ #' |
|||
| 1940 | -21882x | +|||
| 186 | +
- obj+ #' @export |
|||
| 1941 | +187 |
- }+ #' @rdname content_table+ |
+ ||
| 188 | +6330x | +
+ setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))
|
||
| 1942 | +189 | |||
| 1943 | +190 |
- #' @rdname col_accessors+ #' @exportMethod "content_table<-" |
||
| 1944 | +191 |
- #' @exportMethod col_info<-+ #' @rdname int_methods |
||
| 1945 | +192 |
setMethod( |
||
| 1946 | +193 |
- "col_info<-", "ElementaryTable",+ "content_table<-", c("TableTree", "ElementaryTable"),
|
||
| 1947 | +194 |
function(obj, value) {
|
||
| 1948 | -14162x | +195 | +6330x |
- obj@col_info <- value+ obj@content <- value |
| 1949 | -14162x | +196 | +6330x |
- .set_cinfo_kids(obj)+ obj |
| 1950 | +197 |
} |
||
| 1951 | +198 |
) |
||
| 1952 | +199 | |||
| 1953 | +200 |
- #' @rdname col_accessors+ #' @param for_analyze (`flag`) whether split is an analyze split. |
||
| 1954 | +201 |
- #' @exportMethod col_info<-+ #' @rdname int_methods |
||
| 1955 | -+ | |||
| 202 | +1103x |
- setMethod(+ setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))
|
||
| 1956 | +203 |
- "col_info<-", "TableTree",+ |
||
| 1957 | +204 |
- function(obj, value) {
+ #' @rdname int_methods |
||
| 1958 | -7720x | +|||
| 205 | +
- obj@col_info <- value+ setMethod( |
|||
| 1959 | -7720x | +|||
| 206 | +
- if (nrow(content_table(obj))) {
+ "next_rpos", "PreDataTableLayouts", |
|||
| 1960 | -2010x | +|||
| 207 | +
- ct <- content_table(obj)+ function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze) |
|||
| 1961 | -2010x | +|||
| 208 | +
- col_info(ct) <- value+ ) |
|||
| 1962 | -2010x | +|||
| 209 | +
- content_table(obj) <- ct+ |
|||
| 1963 | +210 |
- }+ .check_if_nest <- function(obj, nested, for_analyze) {
|
||
| 1964 | -7720x | -
- .set_cinfo_kids(obj)- |
- ||
| 1965 | -+ | 211 | +258x |
- }+ if (!nested) {
|
| 1966 | -+ | |||
| 212 | +17x |
- )+ FALSE |
||
| 1967 | +213 |
-
+ } else {
|
||
| 1968 | +214 |
- #' @rdname col_accessors+ ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?) |
||
| 1969 | -+ | |||
| 215 | +241x |
- #' @export+ for_analyze || |
||
| 1970 | +216 |
- setGeneric(+ ## If its not an analyze split it can't go under an analyze split |
||
| 1971 | -+ | |||
| 217 | +241x |
- "coltree",+ !(is(last_rowsplit(obj), "VAnalyzeSplit") || |
||
| 1972 | -9621x | +218 | +241x |
- function(obj, df = NULL, rtpos = TreePos()) standardGeneric("coltree")
+ is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint |
| 1973 | +219 |
- )+ } |
||
| 1974 | +220 |
-
+ } |
||
| 1975 | +221 |
- #' @rdname col_accessors+ |
||
| 1976 | +222 |
- #' @exportMethod coltree+ #' @rdname int_methods |
||
| 1977 | +223 |
setMethod( |
||
| 1978 | +224 |
- "coltree", "InstantiatedColumnInfo",+ "next_rpos", "PreDataRowLayout", |
||
| 1979 | +225 |
- function(obj, df = NULL, rtpos = TreePos()) {
+ function(obj, nested, for_analyze) {
|
||
| 1980 | -7449x | +226 | +551x |
- if (!is.null(df)) {
+ l <- length(obj) |
| 1981 | -! | +|||
| 227 | +551x |
- warning("Ignoring df argument and retrieving already-computed LayoutColTree")
+ if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
+ |
+ ||
| 228 | +26x | +
+ l <- l + 1L |
||
| 1982 | +229 |
} |
||
| 1983 | -7449x | +230 | +551x |
- obj@tree_layout+ l |
| 1984 | +231 |
} |
||
| 1985 | +232 |
) |
||
| 1986 | +233 | |||
| 1987 | +234 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 1988 | -+ | |||
| 235 | +1x |
- #' @export coltree+ setMethod("next_rpos", "ANY", function(obj, nested) 1L)
|
||
| 1989 | +236 |
- setMethod(+ |
||
| 1990 | +237 |
- "coltree", "PreDataTableLayouts",+ #' @rdname int_methods |
||
| 1991 | -+ | |||
| 238 | +633x |
- function(obj, df, rtpos) coltree(clayout(obj), df, rtpos)+ setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))
|
||
| 1992 | +239 |
- )+ |
||
| 1993 | +240 |
-
+ #' @rdname int_methods |
||
| 1994 | +241 |
- #' @rdname col_accessors+ setMethod( |
||
| 1995 | +242 |
- #' @export coltree+ "next_cpos", "PreDataTableLayouts", |
||
| 1996 | +243 |
- setMethod(+ function(obj, nested) next_cpos(clayout(obj), nested) |
||
| 1997 | +244 |
- "coltree", "PreDataColLayout",+ ) |
||
| 1998 | +245 |
- function(obj, df, rtpos) {
+
|
||
| 1999 | -310x | +|||
| 246 | +
- obj <- set_def_child_ord(obj, df)+ #' @rdname int_methods |
|||
| 2000 | -310x | +|||
| 247 | +
- kids <- lapply(+ setMethod( |
|||
| 2001 | -310x | +|||
| 248 | +
- obj,+ "next_cpos", "PreDataColLayout", |
|||
| 2002 | -310x | +|||
| 249 | +
- function(x) {
+ function(obj, nested) {
|
|||
| 2003 | -315x | +250 | +316x |
- splitvec_to_coltree(+ if (nested || length(obj[[length(obj)]]) == 0) {
|
| 2004 | -315x | +251 | +308x |
- df = df,+ length(obj) |
| 2005 | -315x | +|||
| 252 | +
- splvec = x,+ } else {
|
|||
| 2006 | -315x | +253 | +8x |
- pos = rtpos+ length(obj) + 1L |
| 2007 | +254 |
- )+ } |
||
| 2008 | +255 |
- }+ } |
||
| 2009 | +256 |
- )+ ) |
||
| 2010 | -307x | +|||
| 257 | +
- if (length(kids) == 1) {
+
|
|||
| 2011 | -303x | +|||
| 258 | +
- res <- kids[[1]]+ #' @rdname int_methods |
|||
| 2012 | +259 |
- } else {
+ setMethod("next_cpos", "ANY", function(obj, nested) 1L)
|
||
| 2013 | -4x | +|||
| 260 | +
- res <- LayoutColTree(+ |
|||
| 2014 | -4x | +|||
| 261 | +
- lev = 0L,+ #' @rdname int_methods |
|||
| 2015 | -4x | +262 | +2626x |
- kids = kids,+ setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))
|
| 2016 | -4x | +|||
| 263 | +
- tpos = rtpos,+ |
|||
| 2017 | -4x | +|||
| 264 | +
- spl = RootSplit()+ #' @rdname int_methods |
|||
| 2018 | +265 |
- )+ setMethod( |
||
| 2019 | +266 |
- }+ "last_rowsplit", "NULL", |
||
| 2020 | -307x | +|||
| 267 | +! |
- disp_ccounts(res) <- disp_ccounts(obj)+ function(obj) NULL |
||
| 2021 | -307x | +|||
| 268 | +
- res+ ) |
|||
| 2022 | +269 |
- }+ |
||
| 2023 | +270 |
- )+ #' @rdname int_methods |
||
| 2024 | +271 |
-
+ setMethod( |
||
| 2025 | +272 |
- #' @rdname col_accessors+ "last_rowsplit", "SplitVector", |
||
| 2026 | +273 |
- #' @export coltree+ function(obj) {
+ |
+ ||
| 274 | +1030x | +
+ if (length(obj) == 0) {
+ |
+ ||
| 275 | +222x | +
+ NULL |
||
| 2027 | +276 |
- setMethod(+ } else {
+ |
+ ||
| 277 | +808x | +
+ obj[[length(obj)]] |
||
| 2028 | +278 |
- "coltree", "LayoutColTree",+ } |
||
| 2029 | +279 |
- function(obj, df, rtpos) obj+ } |
||
| 2030 | +280 |
) |
||
| 2031 | +281 | |||
| 2032 | +282 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 2033 | +283 |
- #' @export coltree+ setMethod( |
||
| 2034 | +284 |
- setMethod(+ "last_rowsplit", "PreDataRowLayout", |
||
| 2035 | +285 |
- "coltree", "VTableTree",+ function(obj) {
+ |
+ ||
| 286 | +1030x | +
+ if (length(obj) == 0) {
+ |
+ ||
| 287 | +! | +
+ NULL |
||
| 2036 | +288 |
- function(obj, df, rtpos) coltree(col_info(obj))+ } else {
+ |
+ ||
| 289 | +1030x | +
+ last_rowsplit(obj[[length(obj)]]) |
||
| 2037 | +290 |
- )+ } |
||
| 2038 | +291 |
-
+ } |
||
| 2039 | +292 |
- #' @rdname col_accessors+ ) |
||
| 2040 | +293 |
- #' @export coltree+ |
||
| 2041 | +294 |
- setMethod(+ #' @rdname int_methods |
||
| 2042 | +295 |
- "coltree", "TableRow",+ setMethod( |
||
| 2043 | +296 |
- function(obj, df, rtpos) coltree(col_info(obj))+ "last_rowsplit", "PreDataTableLayouts",+ |
+ ||
| 297 | +564x | +
+ function(obj) last_rowsplit(rlayout(obj)) |
||
| 2044 | +298 |
) |
||
| 2045 | +299 | |||
| 2046 | -819x | +|||
| 300 | +
- setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
+ # rlayout ---- |
|||
| 2047 | +301 |
- setMethod(+ ## TODO maybe export these? |
||
| 2048 | +302 |
- "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
+
|
||
| 2049 | +303 |
- function(obj, value) {
+ #' @rdname int_methods |
||
| 2050 | -410x | +304 | +3756x |
- obj@tree_layout <- value+ setGeneric("rlayout", function(obj) standardGeneric("rlayout"))
|
| 2051 | -410x | +|||
| 305 | +
- obj+ |
|||
| 2052 | +306 |
- }+ #' @rdname int_methods |
||
| 2053 | +307 |
- )+ setMethod( |
||
| 2054 | +308 |
-
+ "rlayout", "PreDataTableLayouts",+ |
+ ||
| 309 | +3756x | +
+ function(obj) obj@row_layout |
||
| 2055 | +310 |
- setMethod(+ ) |
||
| 2056 | +311 |
- "coltree<-", c("VTableTree", "LayoutColTree"),
+
|
||
| 2057 | +312 |
- function(obj, value) {
+ #' @rdname int_methods |
||
| 2058 | -409x | +|||
| 313 | +! |
- cinfo <- col_info(obj)+ setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())
|
||
| 2059 | -409x | +|||
| 314 | +
- coltree(cinfo) <- value+ |
|||
| 2060 | -409x | +|||
| 315 | +
- col_info(obj) <- cinfo+ #' @rdname int_methods |
|||
| 2061 | -409x | +316 | +1666x |
- obj+ setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))
|
| 2062 | +317 |
- }+ |
||
| 2063 | +318 |
- )+ #' @rdname int_methods |
||
| 2064 | +319 |
-
+ setMethod( |
||
| 2065 | +320 |
- #' @rdname col_accessors+ "rlayout<-", "PreDataTableLayouts", |
||
| 2066 | +321 |
- #' @export+ function(object, value) {
|
||
| 2067 | -123677x | +322 | +1666x |
- setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))
+ object@row_layout <- value |
| 2068 | -+ | |||
| 323 | +1666x |
-
+ object |
||
| 2069 | +324 |
- #' @rdname col_accessors+ } |
||
| 2070 | +325 |
- #' @export col_exprs+ ) |
||
| 2071 | +326 |
- setMethod(+ |
||
| 2072 | +327 |
- "col_exprs", "PreDataTableLayouts",+ #' @rdname int_methods |
||
| 2073 | -1x | +328 | +63750x |
- function(obj, df = NULL) col_exprs(clayout(obj), df)+ setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))
|
| 2074 | +329 |
- )+ |
||
| 2075 | +330 |
-
+ ## setMethod("tree_pos", "VNodeInfo",
|
||
| 2076 | +331 |
- #' @rdname col_accessors+ ## function(obj) obj@pos_in_tree) |
||
| 2077 | +332 |
- #' @export col_exprs+ |
||
| 2078 | +333 |
- setMethod(+ #' @rdname int_methods |
||
| 2079 | +334 |
- "col_exprs", "PreDataColLayout",+ setMethod( |
||
| 2080 | +335 |
- function(obj, df = NULL) {
+ "tree_pos", "VLayoutNode", |
||
| 2081 | -1x | +|||
| 336 | +! |
- if (is.null(df)) {
+ function(obj) obj@pos_in_tree |
||
| 2082 | -! | +|||
| 337 | +
- stop("can't determine col_exprs without data")
+ ) |
|||
| 2083 | +338 |
- }+ |
||
| 2084 | -1x | +|||
| 339 | +
- ct <- coltree(obj, df = df)+ #' @rdname int_methods |
|||
| 2085 | -1x | +340 | +1376x |
- make_col_subsets(ct, df = df)+ setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))
|
| 2086 | +341 |
- }+ |
||
| 2087 | +342 |
- )+ #' @rdname int_methods |
||
| 2088 | +343 |
-
+ setMethod( |
||
| 2089 | +344 |
- #' @rdname col_accessors+ "pos_subset", "TreePos",+ |
+ ||
| 345 | +1376x | +
+ function(obj) obj@subset |
||
| 2090 | +346 |
- #' @export col_exprs+ ) |
||
| 2091 | +347 |
- setMethod(+ |
||
| 2092 | +348 |
- "col_exprs", "InstantiatedColumnInfo",+ #' @rdname int_methods+ |
+ ||
| 349 | +103x | +
+ setGeneric("tree_pos<-", function(obj, value) standardGeneric("tree_pos<-"))
|
||
| 2093 | +350 |
- function(obj, df = NULL) {
+
|
||
| 2094 | +351 |
- if (!is.null(df)) {
+ #' @rdname int_methods |
||
| 2095 | -! | +|||
| 352 | +
- warning("Ignoring df method when extracted precomputed column subsetting expressions.")
+ setMethod( |
|||
| 2096 | +353 |
- }+ "tree_pos<-", "VLayoutNode",+ |
+ ||
| 354 | ++ |
+ function(obj, value) {
|
||
| 2097 | -123675x | +355 | +103x |
- obj@subset_exprs+ obj@pos_in_tree <- value+ |
+
| 356 | +103x | +
+ obj |
||
| 2098 | +357 |
} |
||
| 2099 | +358 |
) |
||
| 2100 | +359 | |||
| 2101 | +360 |
- #' @rdname int_methods+ ## setMethod("pos_subset", "VNodeInfo",
|
||
| 2102 | -2515x | +|||
| 361 | +
- setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))
+ ## function(obj) pos_subset(tree_pos(obj))) |
|||
| 2103 | +362 | |||
| 2104 | +363 |
#' @rdname int_methods |
||
| 2105 | +364 |
setMethod( |
||
| 2106 | -- |
- "col_extra_args", "InstantiatedColumnInfo",- |
- ||
| 2107 | +365 |
- function(obj, df) {
- |
- ||
| 2108 | -2208x | -
- if (!is.null(df)) {
+ "pos_subset", "VLayoutNode", |
||
| 2109 | +366 | ! |
- warning("Ignorning df when retrieving already-computed column extra arguments.")
+ function(obj) pos_subset(tree_pos(obj)) |
|
| 2110 | +367 |
- }+ ) |
||
| 2111 | -2208x | +|||
| 368 | +
- obj@cextra_args+ |
|||
| 2112 | +369 |
- }+ #' @rdname int_methods |
||
| 2113 | -+ | |||
| 370 | +51808x |
- )+ setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))
|
||
| 2114 | +371 | |||
| 2115 | +372 |
#' @rdname int_methods |
||
| 2116 | +373 |
setMethod( |
||
| 2117 | +374 |
- "col_extra_args", "PreDataTableLayouts",+ "pos_splits", "TreePos", |
||
| 2118 | -+ | |||
| 375 | +51808x |
- function(obj, df) col_extra_args(clayout(obj), df)+ function(obj) obj@splits |
||
| 2119 | +376 |
) |
||
| 2120 | +377 | |||
| 2121 | +378 |
- #' @rdname int_methods+ ## setMethod("pos_splits", "VNodeInfo",
|
||
| 2122 | +379 |
- setMethod(+ ## function(obj) pos_splits(tree_pos(obj))) |
||
| 2123 | +380 |
- "col_extra_args", "PreDataColLayout",+ |
||
| 2124 | +381 |
- function(obj, df) {
+ #' @rdname int_methods |
||
| 2125 | -! | +|||
| 382 | +
- col_extra_args(coltree(obj, df), NULL)+ setMethod( |
|||
| 2126 | +383 |
- }+ "pos_splits", "VLayoutNode",+ |
+ ||
| 384 | +! | +
+ function(obj) pos_splits(tree_pos(obj)) |
||
| 2127 | +385 |
) |
||
| 2128 | +386 | |||
| 2129 | +387 |
#' @rdname int_methods |
||
| 2130 | -+ | |||
| 388 | +103x |
- setMethod(+ setGeneric("pos_splits<-", function(obj, value) standardGeneric("pos_splits<-"))
|
||
| 2131 | +389 |
- "col_extra_args", "LayoutColTree",+ |
||
| 2132 | +390 |
- function(obj, df) {
+ #' @rdname int_methods |
||
| 2133 | -307x | +|||
| 391 | +
- if (!is.null(df)) {
+ setMethod( |
|||
| 2134 | -! | +|||
| 392 | +
- warning("Ignoring df argument and returning already calculated extra arguments")
+ "pos_splits<-", "TreePos", |
|||
| 2135 | +393 |
- }+ function(obj, value) {
|
||
| 2136 | -307x | +394 | +103x |
- get_col_extras(obj)+ obj@splits <- value+ |
+
| 395 | +103x | +
+ obj |
||
| 2137 | +396 |
} |
||
| 2138 | +397 |
) |
||
| 2139 | +398 | |||
| 2140 | +399 |
#' @rdname int_methods |
||
| 2141 | +400 |
setMethod( |
||
| 2142 | +401 |
- "col_extra_args", "LayoutColLeaf",+ "pos_splits<-", "VLayoutNode", |
||
| 2143 | +402 |
- function(obj, df) {
+ function(obj, value) {
|
||
| 2144 | +403 | ! |
- if (!is.null(df)) {
+ pos <- tree_pos(obj) |
|
| 2145 | +404 | ! |
- warning("Ignoring df argument and returning already calculated extra arguments")
+ pos_splits(pos) <- value |
|
| 2146 | -+ | |||
| 405 | +! |
- }+ tree_pos(obj) <- pos |
||
| 2147 | -+ | |||
| 406 | +! |
-
+ obj |
||
| 2148 | +407 | ! |
- get_pos_extra(pos = tree_pos(obj))+ obj |
|
| 2149 | +408 |
} |
||
| 2150 | +409 |
) |
||
| 2151 | +410 | |||
| 2152 | +411 |
- #' @export+ |
||
| 2153 | +412 |
- #' @rdname col_accessors+ |
||
| 2154 | -2032x | +|||
| 413 | +
- setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))
+
|
|||
| 2155 | +414 |
-
+ #' @rdname int_methods+ |
+ ||
| 415 | +58173x | +
+ setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))
|
||
| 2156 | +416 |
- #' @export+ |
||
| 2157 | +417 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 2158 | +418 |
setMethod( |
||
| 2159 | +419 |
- "col_counts", "InstantiatedColumnInfo",+ "pos_splvals", "TreePos", |
||
| 2160 | -2019x | +420 | +58173x |
- function(obj, path = NULL) obj@counts[.path_to_pos(path, obj, cols = TRUE)]+ function(obj) obj@s_values |
| 2161 | +421 |
) |
||
| 2162 | +422 | |||
| 2163 | +423 |
- #' @export+ ## setMethod("pos_splvals", "VNodeInfo",
|
||
| 2164 | +424 |
- #' @rdname col_accessors+ ## function(obj) pos_splvals(tree_pos(obj))) |
||
| 2165 | +425 |
- setMethod(+ |
||
| 2166 | +426 |
- "col_counts", "VTableNodeInfo",- |
- ||
| 2167 | -13x | -
- function(obj, path = NULL) col_counts(col_info(obj), path = path)+ #' @rdname int_methods |
||
| 2168 | +427 |
- )+ setMethod( |
||
| 2169 | +428 |
-
+ "pos_splvals", "VLayoutNode", |
||
| 2170 | -+ | |||
| 429 | +! |
- #' @export+ function(obj) pos_splvals(tree_pos(obj)) |
||
| 2171 | +430 |
- #' @rdname col_accessors- |
- ||
| 2172 | -5x | -
- setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))
+ ) |
||
| 2173 | +431 | |||
| 2174 | +432 |
- #' @export+ #' @rdname int_methods+ |
+ ||
| 433 | +103x | +
+ setGeneric("pos_splvals<-", function(obj, value) standardGeneric("pos_splvals<-"))
|
||
| 2175 | +434 |
- #' @rdname col_accessors+ |
||
| 2176 | +435 |
- setMethod(+ #' @rdname int_methods |
||
| 2177 | +436 |
- "col_counts<-", "InstantiatedColumnInfo",+ setMethod( |
||
| 2178 | +437 |
- function(obj, path = NULL, value) {
+ "pos_splvals<-", "TreePos", |
||
| 2179 | +438 |
- ## all methods funnel to this one so ensure integer-ness here.+ function(obj, value) {
|
||
| 2180 | -3x | +439 | +103x |
- obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- as.integer(value)+ obj@s_values <- value |
| 2181 | -3x | +440 | +103x |
obj |
| 2182 | +441 |
} |
||
| 2183 | +442 |
) |
||
| 2184 | +443 | |||
| 2185 | +444 |
- #' @export+ ## setMethod("pos_splvals", "VNodeInfo",
|
||
| 2186 | +445 |
- #' @rdname col_accessors+ ## function(obj) pos_splvals(tree_pos(obj))) |
||
| 2187 | +446 | ++ | + + | +|
| 447 | ++ |
+ #' @rdname int_methods+ |
+ ||
| 448 |
setMethod( |
|||
| 2188 | +449 |
- "col_counts<-", "VTableNodeInfo",+ "pos_splvals<-", "VLayoutNode", |
||
| 2189 | +450 |
- function(obj, path = NULL, value) {
+ function(obj, value) {
|
||
| 2190 | -2x | +|||
| 451 | +! |
- cinfo <- col_info(obj)+ pos <- tree_pos(obj) |
||
| 2191 | -2x | +|||
| 452 | +! |
- col_counts(cinfo, path = path) <- value+ pos_splvals(pos) <- value |
||
| 2192 | -2x | +|||
| 453 | +! |
- col_info(obj) <- cinfo+ tree_pos(obj) <- pos |
||
| 2193 | -2x | +|||
| 454 | +! |
obj |
||
| 2194 | +455 |
} |
||
| 2195 | +456 |
) |
||
| 2196 | +457 | |||
| 2197 | +458 |
- #' @export+ |
||
| 2198 | +459 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 2199 | -1583x | +460 | +1376x |
- setGeneric("col_total", function(obj) standardGeneric("col_total"))
+ setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))
|
| 2200 | +461 | |||
| 2201 | -- |
- #' @export- |
- ||
| 2202 | +462 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 2203 | +463 |
setMethod( |
||
| 2204 | +464 |
- "col_total", "InstantiatedColumnInfo",+ "pos_splval_labels", "TreePos", |
||
| 2205 | -1582x | +465 | +1376x |
- function(obj) obj@total_count+ function(obj) obj@sval_labels |
| 2206 | +466 |
) |
||
| 2207 | +467 |
-
+ ## no longer used |
||
| 2208 | +468 |
- #' @export+ |
||
| 2209 | +469 |
- #' @rdname col_accessors+ ## setMethod("pos_splval_labels", "VNodeInfo",
|
||
| 2210 | +470 |
- setMethod(+ ## function(obj) pos_splval_labels(tree_pos(obj))) |
||
| 2211 | +471 |
- "col_total", "VTableNodeInfo",- |
- ||
| 2212 | -1x | -
- function(obj) col_total(col_info(obj))+ ## #' @rdname int_methods |
||
| 2213 | +472 |
- )+ ## setMethod("pos_splval_labels", "VLayoutNode",
|
||
| 2214 | +473 |
-
+ ## function(obj) pos_splval_labels(tree_pos(obj))) |
||
| 2215 | +474 |
- #' @export+ |
||
| 2216 | +475 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 2217 | -2x | +476 | +15024x |
- setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))
+ setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))
|
| 2218 | +477 | |||
| 2219 | +478 |
- #' @export+ #' @rdname int_methods+ |
+ ||
| 479 | +15024x | +
+ setMethod("spl_payload", "Split", function(obj) obj@payload)
|
||
| 2220 | +480 |
- #' @rdname col_accessors+ |
||
| 2221 | +481 |
- setMethod(+ #' @rdname int_methods+ |
+ ||
| 482 | +3x | +
+ setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))
|
||
| 2222 | +483 |
- "col_total<-", "InstantiatedColumnInfo",+ |
||
| 2223 | +484 |
- function(obj, value) {
+ #' @rdname int_methods |
||
| 2224 | +485 |
- ## all methods funnel to this one so ensure integer-ness here.+ setMethod("spl_payload<-", "Split", function(obj, value) {
|
||
| 2225 | -1x | +486 | +3x |
- obj@total_count <- as.integer(value)+ obj@payload <- value |
| 2226 | -1x | +487 | +3x |
- obj+ obj |
| 2227 | +488 |
- }+ }) |
||
| 2228 | +489 |
- )+ |
||
| 2229 | +490 |
-
+ #' @rdname int_methods |
||
| 2230 | -+ | |||
| 491 | +717x |
- #' @export+ setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))
|
||
| 2231 | +492 |
- #' @rdname col_accessors+ |
||
| 2232 | +493 |
- setMethod(+ #' @rdname int_methods |
||
| 2233 | -+ | |||
| 494 | +714x |
- "col_total<-", "VTableNodeInfo",+ setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)
|
||
| 2234 | +495 |
- function(obj, value) {
+
|
||
| 2235 | -1x | +|||
| 496 | +
- cinfo <- col_info(obj)+ ## TODO revisit. do we want to do this? used in vars_in_layout, but only |
|||
| 2236 | -1x | +|||
| 497 | +
- col_total(cinfo) <- value+ ## for convenience. |
|||
| 2237 | -1x | +|||
| 498 | +
- col_info(obj) <- cinfo+ #' @rdname int_methods |
|||
| 2238 | -1x | +499 | +3x |
- obj+ setMethod("spl_label_var", "Split", function(obj) NULL)
|
| 2239 | +500 |
- }+ |
||
| 2240 | +501 |
- )+ ### name related things |
||
| 2241 | +502 |
-
+ # #' @inherit formatters::formatter_methods |
||
| 2242 | +503 |
- #' @rdname int_methods- |
- ||
| 2243 | -2143x | -
- setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))
+ #' Methods for generics in the `formatters` package |
||
| 2244 | +504 |
-
+ #' |
||
| 2245 | +505 |
- #' @rdname int_methods+ #' See the `formatters` documentation for descriptions of these generics. |
||
| 2246 | +506 |
- setMethod(+ #' |
||
| 2247 | +507 |
- "disp_ccounts", "VTableTree",- |
- ||
| 2248 | -317x | -
- function(obj) disp_ccounts(col_info(obj))+ #' @inheritParams gen_args |
||
| 2249 | +508 |
- )+ #' |
||
| 2250 | +509 |
-
+ #' @return |
||
| 2251 | +510 |
- #' @rdname int_methods+ #' * Accessor functions return the current value of the component being accessed of `obj` |
||
| 2252 | +511 |
- setMethod(+ #' * Setter functions return a modified copy of `obj` with the new value. |
||
| 2253 | +512 |
- "disp_ccounts", "InstantiatedColumnInfo",- |
- ||
| 2254 | -919x | -
- function(obj) obj@display_columncounts+ #' |
||
| 2255 | +513 |
- )+ #' @rdname formatters_methods |
||
| 2256 | +514 |
-
+ #' @aliases formatters_methods |
||
| 2257 | +515 |
- #' @rdname int_methods+ #' @exportMethod obj_name |
||
| 2258 | +516 |
setMethod( |
||
| 2259 | +517 |
- "disp_ccounts", "PreDataTableLayouts",+ "obj_name", "VNodeInfo", |
||
| 2260 | -300x | +518 | +48723x |
- function(obj) disp_ccounts(clayout(obj))+ function(obj) obj@name |
| 2261 | +519 |
) |
||
| 2262 | +520 | |||
| 2263 | +521 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 2264 | +522 | ++ |
+ #' @exportMethod obj_name+ |
+ |
| 523 |
setMethod( |
|||
| 2265 | +524 |
- "disp_ccounts", "PreDataColLayout",+ "obj_name", "Split", |
||
| 2266 | -607x | +525 | +114436x |
- function(obj) obj@display_columncounts+ function(obj) obj@name |
| 2267 | +526 |
) |
||
| 2268 | +527 | |||
| 2269 | -- |
- #' @rdname int_methods- |
- ||
| 2270 | -463x | -
- setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))
- |
- ||
| 2271 | +528 |
-
+ #' @rdname formatters_methods |
||
| 2272 | +529 |
- #' @rdname int_methods+ #' @exportMethod obj_name<- |
||
| 2273 | +530 |
setMethod( |
||
| 2274 | +531 |
- "disp_ccounts<-", "VTableTree",+ "obj_name<-", "VNodeInfo", |
||
| 2275 | +532 |
function(obj, value) {
|
||
| 2276 | -1x | -
- cinfo <- col_info(obj)- |
- ||
| 2277 | -1x | -
- disp_ccounts(cinfo) <- value- |
- ||
| 2278 | -1x | +533 | +23x |
- col_info(obj) <- cinfo+ obj@name <- value |
| 2279 | -1x | +534 | +23x |
obj |
| 2280 | +535 |
} |
||
| 2281 | +536 |
) |
||
| 2282 | +537 | |||
| 2283 | +538 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 2284 | +539 | ++ |
+ #' @exportMethod obj_name<-+ |
+ |
| 540 |
setMethod( |
|||
| 2285 | +541 |
- "disp_ccounts<-", "InstantiatedColumnInfo",+ "obj_name<-", "Split", |
||
| 2286 | +542 |
function(obj, value) {
|
||
| 2287 | +543 | 3x |
- obj@display_columncounts <- value+ obj@name <- value |
|
| 2288 | +544 | 3x |
obj |
|
| 2289 | +545 |
} |
||
| 2290 | +546 |
) |
||
| 2291 | +547 | |||
| 2292 | -- |
- #' @rdname int_methods- |
- ||
| 2293 | +548 |
- setMethod(+ ### Label related things |
||
| 2294 | +549 |
- "disp_ccounts<-", "PreDataColLayout",+ #' @rdname formatters_methods |
||
| 2295 | +550 |
- function(obj, value) {
+ #' @exportMethod obj_label |
||
| 2296 | -76x | +551 | +2118x |
- obj@display_columncounts <- value+ setMethod("obj_label", "Split", function(obj) obj@split_label)
|
| 2297 | -76x | +|||
| 552 | +
- obj+ |
|||
| 2298 | +553 |
- }+ #' @rdname formatters_methods |
||
| 2299 | +554 |
- )+ #' @exportMethod obj_label |
||
| 2300 | -+ | |||
| 555 | +42548x |
-
+ setMethod("obj_label", "TableRow", function(obj) obj@label)
|
||
| 2301 | +556 |
- #' @rdname int_methods+ |
||
| 2302 | +557 |
- setMethod(+ ## XXX Do we want a convenience for VTableTree that |
||
| 2303 | +558 |
- "disp_ccounts<-", "LayoutColTree",+ ## grabs the label from the LabelRow or will |
||
| 2304 | +559 |
- function(obj, value) {
+ ## that just muddy the waters? |
||
| 2305 | -307x | +|||
| 560 | +
- obj@display_columncounts <- value+ #' @rdname formatters_methods |
|||
| 2306 | -307x | +|||
| 561 | +
- obj+ #' @exportMethod obj_label |
|||
| 2307 | +562 |
- }+ setMethod( |
||
| 2308 | +563 | ++ |
+ "obj_label", "VTableTree",+ |
+ |
| 564 | +270x | +
+ function(obj) obj_label(tt_labelrow(obj))+ |
+ ||
| 565 |
) |
|||
| 2309 | +566 | |||
| 2310 | +567 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 2311 | +568 |
- setMethod(+ #' @exportMethod obj_label+ |
+ ||
| 569 | +! | +
+ setMethod("obj_label", "ValueWrapper", function(obj) obj@label)
|
||
| 2312 | +570 |
- "disp_ccounts<-", "PreDataTableLayouts",+ |
||
| 2313 | +571 |
- function(obj, value) {
+ #' @rdname formatters_methods |
||
| 2314 | -76x | +|||
| 572 | +
- clyt <- clayout(obj)+ #' @exportMethod obj_label<- |
|||
| 2315 | -76x | +|||
| 573 | +
- disp_ccounts(clyt) <- value+ setMethod(+ |
+ |||
| 574 | ++ |
+ "obj_label<-", "Split",+ |
+ ||
| 575 | ++ |
+ function(obj, value) {
|
||
| 2316 | -76x | +576 | +1x |
- clayout(obj) <- clyt+ obj@split_label <- value |
| 2317 | -76x | +577 | +1x |
obj |
| 2318 | +578 |
} |
||
| 2319 | +579 |
) |
||
| 2320 | +580 | |||
| 2321 | +581 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 2322 | +582 |
- #' @export- |
- ||
| 2323 | -1012x | -
- setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))
+ #' @exportMethod obj_label<- |
||
| 2324 | +583 |
-
+ setMethod( |
||
| 2325 | +584 |
- #' @rdname int_methods+ "obj_label<-", "TableRow", |
||
| 2326 | +585 |
- #' @export+ function(obj, value) {
|
||
| 2327 | -+ | |||
| 586 | +32x |
- setMethod(+ obj@label <- value |
||
| 2328 | -+ | |||
| 587 | +32x |
- "colcount_format", "InstantiatedColumnInfo",+ obj |
||
| 2329 | -368x | +|||
| 588 | +
- function(obj) obj@columncount_format+ } |
|||
| 2330 | +589 |
) |
||
| 2331 | +590 | |||
| 2332 | +591 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 2333 | +592 |
- #' @export+ #' @exportMethod obj_label<- |
||
| 2334 | +593 |
setMethod( |
||
| 2335 | +594 |
- "colcount_format", "VTableNodeInfo",- |
- ||
| 2336 | -44x | -
- function(obj) colcount_format(col_info(obj))+ "obj_label<-", "ValueWrapper", |
||
| 2337 | +595 |
- )+ function(obj, value) {
|
||
| 2338 | -+ | |||
| 596 | +! |
-
+ obj@label <- value |
||
| 2339 | -+ | |||
| 597 | +! |
- #' @rdname int_methods+ obj |
||
| 2340 | +598 |
- #' @export+ } |
||
| 2341 | +599 |
- setMethod(+ ) |
||
| 2342 | +600 |
- "colcount_format", "PreDataColLayout",- |
- ||
| 2343 | -300x | -
- function(obj) obj@columncount_format+ |
||
| 2344 | +601 |
- )+ #' @rdname formatters_methods |
||
| 2345 | +602 |
-
+ #' @exportMethod obj_label<- |
||
| 2346 | +603 |
- #' @rdname int_methods+ setMethod( |
||
| 2347 | +604 |
- #' @export+ "obj_label<-", "VTableTree", |
||
| 2348 | +605 |
- setMethod(+ function(obj, value) {
|
||
| 2349 | -+ | |||
| 606 | +11x |
- "colcount_format", "PreDataTableLayouts",+ lr <- tt_labelrow(obj) |
||
| 2350 | -300x | +607 | +11x |
- function(obj) colcount_format(clayout(obj))+ obj_label(lr) <- value |
| 2351 | -+ | |||
| 608 | +11x |
- )+ if (!is.na(value) && nzchar(value)) {
|
||
| 2352 | -+ | |||
| 609 | +10x |
-
+ labelrow_visible(lr) <- TRUE |
||
| 2353 | -+ | |||
| 610 | +1x |
- #' @rdname int_methods+ } else if (is.na(value)) {
|
||
| 2354 | -+ | |||
| 611 | +1x |
- #' @export+ labelrow_visible(lr) <- FALSE |
||
| 2355 | +612 |
- setGeneric(+ } |
||
| 2356 | -+ | |||
| 613 | +11x |
- "colcount_format<-",+ tt_labelrow(obj) <- lr |
||
| 2357 | -154x | +614 | +11x |
- function(obj, value) standardGeneric("colcount_format<-")
+ obj |
| 2358 | +615 | ++ |
+ }+ |
+ |
| 616 |
) |
|||
| 2359 | +617 | |||
| 2360 | +618 |
- #' @export+ ### Label rows. |
||
| 2361 | +619 |
#' @rdname int_methods |
||
| 620 | +139285x | +
+ setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))
+ |
+ ||
| 2362 | +621 |
- setMethod(+ |
||
| 2363 | +622 |
- "colcount_format<-", "InstantiatedColumnInfo",+ #' @rdname int_methods |
||
| 2364 | +623 |
- function(obj, value) {
+ setMethod( |
||
| 2365 | -1x | +|||
| 624 | +
- obj@columncount_format <- value+ "tt_labelrow", "VTableTree", |
|||
| 2366 | -1x | +625 | +51273x |
- obj+ function(obj) obj@labelrow |
| 2367 | +626 |
- }+ ) |
||
| 2368 | +627 |
- )+ |
||
| 2369 | +628 |
-
+ #' @rdname int_methods+ |
+ ||
| 629 | +4081x | +
+ setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))
|
||
| 2370 | +630 |
- #' @rdname int_methods+ |
||
| 2371 | +631 |
- #' @export+ #' @rdname int_methods |
||
| 2372 | +632 |
setMethod( |
||
| 2373 | +633 |
- "colcount_format<-", "VTableNodeInfo",+ "tt_labelrow<-", c("VTableTree", "LabelRow"),
|
||
| 2374 | +634 |
function(obj, value) {
|
||
| 2375 | -1x | +635 | +4081x |
- cinfo <- col_info(obj)+ if (no_colinfo(value)) {
|
| 2376 | +636 | 1x |
- colcount_format(cinfo) <- value+ col_info(value) <- col_info(obj)+ |
+ |
| 637 | ++ |
+ } |
||
| 2377 | -1x | +638 | +4081x |
- col_info(obj) <- cinfo+ obj@labelrow <- value |
| 2378 | -1x | +639 | +4081x |
obj |
| 2379 | +640 |
} |
||
| 2380 | +641 |
) |
||
| 2381 | +642 | |||
| 2382 | +643 |
#' @rdname int_methods |
||
| 644 | +210443x | +
+ setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))
+ |
+ ||
| 2383 | +645 |
- #' @export+ |
||
| 2384 | +646 |
- setMethod(+ #' @rdname int_methods |
||
| 2385 | +647 |
- "colcount_format<-", "PreDataColLayout",+ setMethod( |
||
| 2386 | +648 |
- function(obj, value) {
+ "labelrow_visible", "VTableTree", |
||
| 2387 | -76x | +|||
| 649 | +
- obj@columncount_format <- value+ function(obj) {
|
|||
| 2388 | -76x | +650 | +31235x |
- obj+ labelrow_visible(tt_labelrow(obj)) |
| 2389 | +651 |
} |
||
| 2390 | +652 |
) |
||
| 2391 | +653 | |||
| 2392 | +654 |
#' @rdname int_methods |
||
| 2393 | +655 |
- #' @export+ setMethod( |
||
| 2394 | +656 |
- setMethod(+ "labelrow_visible", "LabelRow",+ |
+ ||
| 657 | +115332x | +
+ function(obj) obj@visible |
||
| 2395 | +658 |
- "colcount_format<-", "PreDataTableLayouts",+ ) |
||
| 2396 | +659 |
- function(obj, value) {
+
|
||
| 2397 | -76x | +|||
| 660 | +
- clyt <- clayout(obj)+ #' @rdname int_methods |
|||
| 2398 | -76x | +|||
| 661 | +
- colcount_format(clyt) <- value+ setMethod( |
|||
| 2399 | -76x | +|||
| 662 | +
- clayout(obj) <- clyt+ "labelrow_visible", "VAnalyzeSplit", |
|||
| 2400 | -76x | +663 | +1409x |
- obj+ function(obj) .labelkids_helper(obj@var_label_position) |
| 2401 | +664 |
- }+ ) |
||
| 2402 | +665 |
- )+ |
||
| 2403 | +666 |
-
+ #' @rdname int_methods |
||
| 2404 | -+ | |||
| 667 | +2936x |
- #' Exported for use in `tern`+ setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))
|
||
| 2405 | +668 |
- #'+ |
||
| 2406 | +669 |
- #' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information?+ #' @rdname int_methods |
||
| 2407 | +670 |
- #'+ setMethod( |
||
| 2408 | +671 |
- #' @inheritParams gen_args+ "labelrow_visible<-", "VTableTree", |
||
| 2409 | +672 |
- #'+ function(obj, value) {
|
||
| 2410 | -+ | |||
| 673 | +1327x |
- #' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise.+ lr <- tt_labelrow(obj) |
||
| 2411 | -+ | |||
| 674 | +1327x |
- #'+ labelrow_visible(lr) <- value |
||
| 2412 | -+ | |||
| 675 | +1327x |
- #' @rdname no_info+ tt_labelrow(obj) <- lr+ |
+ ||
| 676 | +1327x | +
+ obj |
||
| 2413 | +677 |
- #' @export+ } |
||
| 2414 | -180019x | +|||
| 678 | +
- setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))
+ ) |
|||
| 2415 | +679 | |||
| 2416 | +680 |
- #' @exportMethod no_colinfo+ #' @rdname int_methods |
||
| 2417 | +681 |
- #' @rdname no_info+ setMethod( |
||
| 2418 | +682 |
- setMethod(+ "labelrow_visible<-", "LabelRow", |
||
| 2419 | +683 |
- "no_colinfo", "VTableNodeInfo",+ function(obj, value) {
|
||
| 2420 | -77008x | +684 | +1338x |
- function(obj) no_colinfo(col_info(obj))+ obj@visible <- value+ |
+
| 685 | +1338x | +
+ obj |
||
| 2421 | +686 | ++ |
+ }+ |
+ |
| 687 |
) |
|||
| 2422 | +688 | |||
| 2423 | +689 |
- #' @exportMethod no_colinfo+ #' @rdname int_methods |
||
| 2424 | +690 |
- #' @rdname no_info+ setMethod( |
||
| 2425 | +691 |
- setMethod(+ "labelrow_visible<-", "VAnalyzeSplit", |
||
| 2426 | +692 |
- "no_colinfo", "InstantiatedColumnInfo",+ function(obj, value) {
|
||
| 2427 | -92980x | +693 | +271x |
- function(obj) length(obj@subset_exprs) == 0+ obj@var_label_position <- value |
| 2428 | -+ | |||
| 694 | +271x |
- ) ## identical(obj, EmptyColInfo))+ obj |
||
| 2429 | +695 |
-
+ } |
||
| 2430 | +696 |
- #' Names of a `TableTree`+ ) |
||
| 2431 | +697 |
- #'+ |
||
| 2432 | +698 |
- #' @param x (`TableTree`)\cr the object.+ ## TRUE is always, FALSE is never, NA is only when no |
||
| 2433 | +699 |
- #'+ ## content function (or rows in an instantiated table) is present |
||
| 2434 | +700 |
- #' @details+ #' @rdname int_methods |
||
| 2435 | -+ | |||
| 701 | +1524x |
- #' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level+ setGeneric("label_kids", function(spl) standardGeneric("label_kids"))
|
||
| 2436 | +702 |
- #' split values repped out across the columns that they span.+ |
||
| 2437 | +703 |
- #'+ #' @rdname int_methods |
||
| 2438 | -+ | |||
| 704 | +1524x |
- #' @return The column names of `x`, as defined in the details above.+ setMethod("label_kids", "Split", function(spl) spl@label_children)
|
||
| 2439 | +705 |
- #'+ |
||
| 2440 | +706 |
- #' @exportMethod names+ #' @rdname int_methods+ |
+ ||
| 707 | +3x | +
+ setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))
|
||
| 2441 | +708 |
- #' @rdname names+ |
||
| 2442 | +709 |
- setMethod(+ #' @rdname int_methods |
||
| 2443 | +710 |
- "names", "VTableNodeInfo",+ setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
|
||
| 2444 | -91x | +711 | +1x |
- function(x) names(col_info(x))+ label_kids(spl) <- .labelkids_helper(value) |
| 2445 | -+ | |||
| 712 | +1x |
- )+ spl |
||
| 2446 | +713 |
-
+ }) |
||
| 2447 | +714 |
- #' @rdname names+ |
||
| 2448 | +715 |
- #' @exportMethod names+ #' @rdname int_methods |
||
| 2449 | +716 |
- setMethod(+ setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
|
||
| 2450 | -+ | |||
| 717 | +2x |
- "names", "InstantiatedColumnInfo",+ spl@label_children <- value |
||
| 2451 | -91x | +718 | +2x |
- function(x) names(coltree(x))+ spl |
| 2452 | +719 |
- )+ }) |
||
| 2453 | +720 | |||
| 2454 | +721 |
- #' @rdname names+ #' @rdname int_methods |
||
| 2455 | -+ | |||
| 722 | +406x |
- #' @exportMethod names+ setGeneric("vis_label", function(spl) standardGeneric("vis_label"))
|
||
| 2456 | +723 |
- setMethod(+ |
||
| 2457 | +724 |
- "names", "LayoutColTree",+ #' @rdname int_methods |
||
| 2458 | +725 |
- function(x) {
+ setMethod("vis_label", "Split", function(spl) {
|
||
| 2459 | -91x | +726 | +406x |
- unname(unlist(lapply(+ .labelkids_helper(label_position(spl)) |
| 2460 | -91x | +|||
| 727 | +
- tree_children(x),+ }) |
|||
| 2461 | -91x | +|||
| 728 | +
- function(obj) {
+
|
|||
| 2462 | -130x | +|||
| 729 | +
- nm <- obj_name(obj)+ ## #' @rdname int_methods |
|||
| 2463 | -130x | +|||
| 730 | +
- rep(nm, n_leaves(obj))+ ## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
|
|||
| 2464 | +731 |
- }+ ## #' @rdname int_methods |
||
| 2465 | +732 |
- )))+ ## setMethod("vis_label<-", "Split", function(spl, value) {
|
||
| 2466 | +733 |
- }+ ## stop("defunct")
|
||
| 2467 | +734 |
- )+ ## if(is.na(value)) |
||
| 2468 | +735 |
-
+ ## stop("split label visibility must be TRUE or FALSE, got NA")
|
||
| 2469 | +736 |
- #' @rdname names+ ## # spl@split_label_visible <- value |
||
| 2470 | +737 |
- #' @exportMethod row.names+ ## spl |
||
| 2471 | +738 |
- setMethod(+ ## }) |
||
| 2472 | +739 |
- "row.names", "VTableTree",+ |
||
| 2473 | +740 |
- function(x) {
+ #' @rdname int_methods |
||
| 2474 | -102x | +741 | +1036x |
- unname(sapply(collect_leaves(x, add.labrows = TRUE),+ setGeneric("label_position", function(spl) standardGeneric("label_position"))
|
| 2475 | -102x | +|||
| 742 | +
- obj_label,+ |
|||
| 2476 | -102x | +|||
| 743 | +
- USE.NAMES = FALSE+ #' @rdname int_methods |
|||
| 2477 | -102x | +744 | +706x |
- )) ## XXXX this should probably be obj_name???+ setMethod("label_position", "Split", function(spl) spl@split_label_position)
|
| 2478 | +745 |
- }+ |
||
| 2479 | +746 |
- )+ #' @rdname int_methods+ |
+ ||
| 747 | +330x | +
+ setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)
|
||
| 2480 | +748 | |||
| 2481 | +749 |
- #' Convert to a vector+ #' @rdname int_methods |
||
| 2482 | -+ | |||
| 750 | +50x |
- #'+ setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))
|
||
| 2483 | +751 |
- #' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in+ |
||
| 2484 | +752 |
- #' realistic scenarios.+ #' @rdname int_methods |
||
| 2485 | +753 |
- #'+ setMethod("label_position<-", "Split", function(spl, value) {
|
||
| 2486 | -+ | |||
| 754 | +50x |
- #' @param x (`ANY`)\cr the object to be converted to a vector.+ value <- match.arg(value, valid_lbl_pos) |
||
| 2487 | -+ | |||
| 755 | +50x |
- #' @param mode (`string`)\cr passed on to [as.vector()].+ spl@split_label_position <- value |
||
| 2488 | -+ | |||
| 756 | +50x |
- #'+ spl |
||
| 2489 | +757 |
- #' @return A vector of the chosen mode (or an error is raised if more than one row was present).+ }) |
||
| 2490 | +758 |
- #'+ |
||
| 2491 | +759 |
- #' @note This only works for a table with a single row or a row object.+ ### Function accessors (summary, tabulation and split) ---- |
||
| 2492 | +760 |
- #'+ |
||
| 2493 | +761 |
- #' @name asvec+ #' @rdname int_methods |
||
| 2494 | -+ | |||
| 762 | +3280x |
- #' @aliases as.vector,VTableTree-method+ setGeneric("content_fun", function(obj) standardGeneric("content_fun"))
|
||
| 2495 | +763 |
- #' @exportMethod as.vector+ |
||
| 2496 | +764 |
- setMethod("as.vector", "VTableTree", function(x, mode) {
+ #' @rdname int_methods |
||
| 2497 | -12x | +765 | +3229x |
- stopifnot(nrow(x) == 1L)+ setMethod("content_fun", "Split", function(obj) obj@content_fun)
|
| 2498 | -12x | +|||
| 766 | +
- if (nrow(content_table(x)) == 1L) {
+
|
|||
| 2499 | -! | +|||
| 767 | +
- tab <- content_table(x)+ #' @rdname int_methods+ |
+ |||
| 768 | +105x | +
+ setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))
|
||
| 2500 | +769 |
- } else {
+
|
||
| 2501 | -12x | +|||
| 770 | +
- tab <- x+ #' @rdname int_methods |
|||
| 2502 | +771 |
- }+ setMethod("content_fun<-", "Split", function(object, value) {
|
||
| 2503 | -12x | +772 | +105x |
- as.vector(tree_children(tab)[[1]], mode = mode)+ object@content_fun <- value+ |
+
| 773 | +105x | +
+ object |
||
| 2504 | +774 |
}) |
||
| 2505 | +775 | |||
| 2506 | +776 |
- #' @inheritParams asvec+ #' @rdname int_methods+ |
+ ||
| 777 | +1738x | +
+ setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))
|
||
| 2507 | +778 |
- #'+ |
||
| 2508 | +779 |
#' @rdname int_methods |
||
| 2509 | -+ | |||
| 780 | +1643x |
- #' @exportMethod as.vector+ setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)
|
||
| 2510 | +781 |
- setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))
+
|
||
| 2511 | +782 |
-
+ #' @rdname int_methods+ |
+ ||
| 783 | +95x | +
+ setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)
|
||
| 2512 | +784 |
- #' @rdname int_methods+ |
||
| 2513 | +785 |
- #' @exportMethod as.vector+ ## not used and probably not needed |
||
| 2514 | +786 |
- setMethod("as.vector", "ElementaryTable", function(x, mode) {
+ ## #' @rdname int_methods |
||
| 2515 | -2x | +|||
| 787 | +
- stopifnot(nrow(x) == 1L)+ ## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))
|
|||
| 2516 | -2x | +|||
| 788 | +
- as.vector(tree_children(x)[[1]], mode = mode)+ |
|||
| 2517 | +789 |
- })+ ## #' @rdname int_methods |
||
| 2518 | +790 |
-
+ ## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
|
||
| 2519 | +791 |
- ## cuts ----+ ## object@analysis_fun <- value |
||
| 2520 | +792 |
-
+ ## object |
||
| 2521 | +793 |
- #' @rdname int_methods+ ## }) |
||
| 2522 | -154x | +|||
| 794 | +
- setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))
+ ## #' @rdname int_methods |
|||
| 2523 | +795 |
-
+ ## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
|
||
| 2524 | +796 |
- #' @rdname int_methods+ ## if(is(value, "function")) |
||
| 2525 | +797 |
- setMethod(+ ## value <- list(value) |
||
| 2526 | +798 |
- "spl_cuts", "VarStaticCutSplit",+ ## object@analysis_fun <- value |
||
| 2527 | -154x | +|||
| 799 | +
- function(obj) obj@cuts+ ## object |
|||
| 2528 | +800 |
- )+ ## }) |
||
| 2529 | +801 | |||
| 2530 | +802 |
#' @rdname int_methods |
||
| 2531 | -198x | +803 | +1088x |
- setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))
+ setGeneric("split_fun", function(obj) standardGeneric("split_fun"))
|
| 2532 | +804 | |||
| 2533 | +805 |
#' @rdname int_methods |
||
| 806 | +918x | +
+ setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)
+ |
+ ||
| 2534 | +807 |
- setMethod(+ |
||
| 2535 | +808 |
- "spl_cutlabels", "VarStaticCutSplit",+ ## Only that type of split currently has the slot |
||
| 2536 | -198x | +|||
| 809 | +
- function(obj) obj@cut_labels+ ## this should probably change? for now define |
|||
| 2537 | +810 |
- )+ ## an accessor that just returns NULL |
||
| 2538 | +811 | ++ |
+ #' @rdname int_methods+ |
+ |
| 812 | +119x | +
+ setMethod("split_fun", "Split", function(obj) NULL)
+ |
+ ||
| 813 | ||||
| 2539 | +814 |
#' @rdname int_methods |
||
| 2540 | -5x | +815 | +13x |
- setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))
+ setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))
|
| 2541 | +816 | |||
| 2542 | +817 |
#' @rdname int_methods |
||
| 2543 | +818 |
- setMethod(+ setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
|
||
| 2544 | -+ | |||
| 819 | +13x |
- "spl_cutfun", "VarDynCutSplit",+ obj@split_fun <- value |
||
| 2545 | -5x | +820 | +13x |
- function(obj) obj@cut_fun+ obj |
| 2546 | +821 |
- )+ }) |
||
| 2547 | +822 | |||
| 2548 | +823 |
- #' @rdname int_methods+ # nocov start |
||
| 2549 | -5x | +|||
| 824 | +
- setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))
+ ## Only that type of split currently has the slot |
|||
| 2550 | +825 |
-
+ ## this should probably change? for now define |
||
| 2551 | +826 |
- #' @rdname int_methods+ ## an accessor that just returns NULL |
||
| 2552 | +827 |
- setMethod(+ #' @rdname int_methods |
||
| 2553 | +828 |
- "spl_cutlabelfun", "VarDynCutSplit",+ setMethod( |
||
| 2554 | -5x | +|||
| 829 | +
- function(obj) obj@cut_label_fun+ "split_fun<-", "Split", |
|||
| 2555 | +830 |
- )+ function(obj, value) {
|
||
| 2556 | +831 |
-
+ stop( |
||
| 2557 | +832 |
- #' @rdname int_methods+ "Attempted to set a custom split function on a non-customizable split.", |
||
| 2558 | -5x | +|||
| 833 | +
- setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))
+ "This should not happen, please contact the maintainers." |
|||
| 2559 | +834 |
-
+ ) |
||
| 2560 | +835 |
- #' @rdname int_methods+ } |
||
| 2561 | +836 |
- setMethod(+ ) |
||
| 2562 | +837 |
- "spl_is_cmlcuts", "VarDynCutSplit",+ # nocov end |
||
| 2563 | -5x | +|||
| 838 | +
- function(obj) obj@cumulative_cuts+ |
|||
| 2564 | +839 |
- )+ ## Content specification related accessors ---- |
||
| 2565 | +840 | |||
| 2566 | +841 |
#' @rdname int_methods |
||
| 842 | +459x | +
+ setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))
+ |
+ ||
| 2567 | +843 |
- setGeneric(+ |
||
| 2568 | +844 |
- "spl_varnames",+ #' @rdname int_methods |
||
| 2569 | -198x | +845 | +459x |
- function(obj) standardGeneric("spl_varnames")
+ setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)
|
| 2570 | +846 |
- )+ |
||
| 2571 | +847 |
-
+ #' @rdname int_methods+ |
+ ||
| 848 | +105x | +
+ setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))
|
||
| 2572 | +849 |
- #' @rdname int_methods+ |
||
| 2573 | +850 |
- setMethod(+ #' @rdname int_methods |
||
| 2574 | +851 |
- "spl_varnames", "MultiVarSplit",+ setMethod("content_extra_args<-", "Split", function(object, value) {
|
||
| 2575 | -198x | +852 | +105x |
- function(obj) obj@var_names+ object@content_extra_args <- value+ |
+
| 853 | +105x | +
+ object |
||
| 2576 | +854 |
- )+ }) |
||
| 2577 | +855 | |||
| 2578 | +856 |
#' @rdname int_methods |
||
| 857 | +1838x | +
+ setGeneric("content_var", function(obj) standardGeneric("content_var"))
+ |
+ ||
| 2579 | +858 |
- setGeneric(+ |
||
| 2580 | +859 |
- "spl_varnames<-",+ #' @rdname int_methods |
||
| 2581 | -2x | +860 | +1838x |
- function(object, value) standardGeneric("spl_varnames<-")
+ setMethod("content_var", "Split", function(obj) obj@content_var)
|
| 2582 | +861 |
- )+ |
||
| 2583 | +862 |
-
+ #' @rdname int_methods |
||
| 2584 | -+ | |||
| 863 | +105x |
- #' @rdname int_methods+ setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))
|
||
| 2585 | +864 |
- setMethod(+ |
||
| 2586 | +865 |
- "spl_varnames<-", "MultiVarSplit",+ #' @rdname int_methods |
||
| 2587 | +866 |
- function(object, value) {
+ setMethod("content_var<-", "Split", function(object, value) {
|
||
| 2588 | -2x | +867 | +105x |
- oldvnms <- spl_varnames(object)+ object@content_var <- value |
| 2589 | -2x | +868 | +105x |
- oldvlbls <- spl_varlabels(object)+ object |
| 2590 | -2x | +|||
| 869 | +
- object@var_names <- value+ }) |
|||
| 2591 | -2x | +|||
| 870 | +
- if (identical(oldvnms, oldvlbls)) {
+
|
|||
| 2592 | -1x | +|||
| 871 | +
- spl_varlabels(object) <- value+ ### Miscellaneous accessors ---- |
|||
| 2593 | +872 |
- }+ + |
+ ||
| 873 | ++ |
+ #' @rdname int_methods |
||
| 2594 | -2x | +874 | +1131x |
- object+ setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))
|
| 2595 | +875 |
- }+ |
||
| 2596 | +876 |
- )+ #' @rdname int_methods |
||
| 2597 | +877 |
-
+ setMethod( |
||
| 2598 | +878 |
- #' Top left material+ "avar_inclNAs", "VAnalyzeSplit",+ |
+ ||
| 879 | +1131x | +
+ function(obj) obj@include_NAs |
||
| 2599 | +880 |
- #'+ ) |
||
| 2600 | +881 |
- #' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the+ |
||
| 2601 | +882 |
- #' area of the table between the column header display and the label of the first row. These functions access+ #' @rdname int_methods+ |
+ ||
| 883 | +! | +
+ setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))
|
||
| 2602 | +884 |
- #' and modify that material.+ |
||
| 2603 | +885 |
- #'+ #' @rdname int_methods |
||
| 2604 | +886 |
- #' @inheritParams gen_args+ setMethod( |
||
| 2605 | +887 |
- #'+ "avar_inclNAs<-", "VAnalyzeSplit", |
||
| 2606 | +888 |
- #' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the+ function(obj, value) {
+ |
+ ||
| 889 | +! | +
+ obj@include_NAs <- value |
||
| 2607 | +890 |
- #' case of the setter).+ } |
||
| 2608 | +891 |
- #'+ ) |
||
| 2609 | +892 |
- #' @export+ |
||
| 2610 | +893 |
- #' @rdname top_left+ #' @rdname int_methods |
||
| 2611 | -6866x | +894 | +839x |
- setGeneric("top_left", function(obj) standardGeneric("top_left"))
+ setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))
|
| 2612 | +895 | |||
| 2613 | -- |
- #' @export- |
- ||
| 2614 | +896 |
- #' @rdname top_left+ #' @rdname int_methods |
||
| 2615 | -2990x | +897 | +839x |
- setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))
+ setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)
|
| 2616 | +898 | |||
| 2617 | -- |
- #' @export- |
- ||
| 2618 | +899 |
- #' @rdname top_left+ #' @rdname int_methods |
||
| 2619 | -3567x | +900 | +2813x |
- setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)
+ setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))
|
| 2620 | +901 | |||
| 2621 | +902 |
- #' @export+ #' @rdname int_methods |
||
| 2622 | -+ | |||
| 903 | +2525x |
- #' @rdname top_left+ setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)
|
||
| 2623 | -309x | +|||
| 904 | +
- setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)
+
|
|||
| 2624 | +905 |
-
+ #' @rdname int_methods |
||
| 2625 | +906 |
- #' @export+ setGeneric( |
||
| 2626 | +907 |
- #' @rdname top_left+ "spl_child_order<-", |
||
| 2627 | -5911x | +908 | +635x |
- setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))
+ function(obj, value) standardGeneric("spl_child_order<-")
|
| 2628 | +909 | ++ |
+ )+ |
+ |
| 910 | ||||
| 2629 | +911 |
- #' @export+ #' @rdname int_methods |
||
| 2630 | +912 |
- #' @rdname top_left+ setMethod( |
||
| 2631 | +913 |
- setMethod("top_left<-", "VTableTree", function(obj, value) {
+ "spl_child_order<-", "VarLevelSplit", |
||
| 2632 | -2955x | +|||
| 914 | +
- cinfo <- col_info(obj)+ function(obj, value) {
|
|||
| 2633 | -2955x | +915 | +635x |
- top_left(cinfo) <- value+ obj@value_order <- value |
| 2634 | -2955x | +916 | +635x |
- col_info(obj) <- cinfo+ obj |
| 2635 | -2955x | +|||
| 917 | +
- obj+ } |
|||
| 2636 | +918 |
- })+ ) |
||
| 2637 | +919 | |||
| 2638 | +920 |
- #' @export+ #' @rdname int_methods |
||
| 2639 | +921 |
- #' @rdname top_left+ setMethod( |
||
| 2640 | +922 |
- setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
+ "spl_child_order", |
||
| 2641 | -2955x | +|||
| 923 | +
- obj@top_left <- value+ "ManualSplit", |
|||
| 2642 | -2955x | +924 | +51x |
- obj+ function(obj) obj@levels |
| 2643 | +925 |
- })+ ) |
||
| 2644 | +926 | |||
| 2645 | +927 |
- #' @export+ #' @rdname int_methods |
||
| 2646 | +928 |
- #' @rdname top_left+ setMethod( |
||
| 2647 | +929 |
- setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
+ "spl_child_order", |
||
| 2648 | -1x | +|||
| 930 | +
- obj@top_left <- value+ "MultiVarSplit", |
|||
| 2649 | -1x | +931 | +96x |
- obj+ function(obj) spl_varnames(obj) |
| 2650 | +932 |
- })+ ) |
||
| 2651 | +933 | |||
| 2652 | +934 |
- vil_collapse <- function(x) {
+ #' @rdname int_methods |
||
| 2653 | -14x | +|||
| 935 | +
- x <- unlist(x)+ setMethod( |
|||
| 2654 | -14x | +|||
| 936 | +
- x <- x[!is.na(x)]+ "spl_child_order", |
|||
| 2655 | -14x | +|||
| 937 | +
- x <- unique(x)+ "AllSplit", |
|||
| 2656 | -14x | +938 | +97x |
- x[nzchar(x)]+ function(obj) character() |
| 2657 | +939 |
- }+ ) |
||
| 2658 | +940 | |||
| 2659 | +941 |
- #' List variables required by a pre-data table layout+ #' @rdname int_methods |
||
| 2660 | +942 |
- #'+ setMethod( |
||
| 2661 | +943 |
- #' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof).+ "spl_child_order", |
||
| 2662 | +944 |
- #'+ "VarStaticCutSplit", |
||
| 2663 | -+ | |||
| 945 | +44x |
- #' @details+ function(obj) spl_cutlabels(obj) |
||
| 2664 | +946 |
- #' This will walk the layout declaration and return a vector of the names of the unique variables that are used+ ) |
||
| 2665 | +947 |
- #' in any of the following ways:+ |
||
| 2666 | +948 |
- #'+ #' @rdname int_methods |
||
| 2667 | -+ | |||
| 949 | +965x |
- #' * Variable being split on (directly or via cuts)+ setGeneric("root_spl", function(obj) standardGeneric("root_spl"))
|
||
| 2668 | +950 |
- #' * Element of a Multi-variable column split+ |
||
| 2669 | +951 |
- #' * Content variable+ #' @rdname int_methods |
||
| 2670 | +952 |
- #' * Value-label variable+ setMethod( |
||
| 2671 | +953 |
- #'+ "root_spl", "PreDataAxisLayout", |
||
| 2672 | -+ | |||
| 954 | +965x |
- #' @return A character vector containing the unique variables explicitly used in the layout (see the notes below).+ function(obj) obj@root_split |
||
| 2673 | +955 |
- #'+ ) |
||
| 2674 | +956 |
- #' @note+ |
||
| 2675 | +957 |
- #' * This function will not detect dependencies implicit in analysis or summary functions which accept `x`+ #' @rdname int_methods |
||
| 2676 | -+ | |||
| 958 | +9x |
- #' or `df` and then rely on the existence of particular variables not being split on/analyzed.+ setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))
|
||
| 2677 | +959 |
- #' * The order these variable names appear within the return vector is undefined and should not be relied upon.+ |
||
| 2678 | +960 |
- #'+ #' @rdname int_methods |
||
| 2679 | +961 |
- #' @examples+ setMethod( |
||
| 2680 | +962 |
- #' lyt <- basic_table() %>%+ "root_spl<-", "PreDataAxisLayout", |
||
| 2681 | +963 |
- #' split_cols_by("ARM") %>%
+ function(obj, value) {
|
||
| 2682 | -+ | |||
| 964 | +9x |
- #' split_cols_by("SEX") %>%
+ obj@root_split <- value |
||
| 2683 | -+ | |||
| 965 | +9x |
- #' summarize_row_groups(label_fstr = "Overall (N)") %>%+ obj |
||
| 2684 | +966 |
- #' split_rows_by("RACE",
+ } |
||
| 2685 | +967 |
- #' split_label = "Ethnicity", labels_var = "ethn_lab",+ ) |
||
| 2686 | +968 |
- #' split_fun = drop_split_levels+ |
||
| 2687 | +969 |
- #' ) %>%+ #' Row attribute accessors |
||
| 2688 | +970 |
- #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
+ #' |
||
| 2689 | +971 |
- #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
+ #' @inheritParams gen_args |
||
| 2690 | +972 |
#' |
||
| 2691 | +973 |
- #' vars_in_layout(lyt)+ #' @return Various return values depending on the accessor called. |
||
| 2692 | +974 |
#' |
||
| 2693 | +975 |
#' @export |
||
| 2694 | +976 |
- #' @rdname vil+ #' @rdname row_accessors |
||
| 2695 | -15x | +977 | +84x |
- setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))
+ setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))
|
| 2696 | +978 | |||
| 2697 | +979 |
- #' @rdname vil+ #' @rdname row_accessors |
||
| 2698 | +980 |
- setMethod(+ #' @exportMethod obj_avar+ |
+ ||
| 981 | +64x | +
+ setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)
|
||
| 2699 | +982 |
- "vars_in_layout", "PreDataTableLayouts",+ |
||
| 2700 | +983 |
- function(lyt) {
+ #' @rdname row_accessors |
||
| 2701 | -1x | +|||
| 984 | +
- vil_collapse(c(+ #' @exportMethod obj_avar |
|||
| 2702 | -1x | +985 | +20x |
- vars_in_layout(clayout(lyt)),+ setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)
|
| 2703 | -1x | +|||
| 986 | +
- vars_in_layout(rlayout(lyt))+ |
|||
| 2704 | +987 |
- ))+ #' @export |
||
| 2705 | +988 |
- }+ #' @rdname row_accessors |
||
| 2706 | -+ | |||
| 989 | +71930x |
- )+ setGeneric("row_cells", function(obj) standardGeneric("row_cells"))
|
||
| 2707 | +990 | |||
| 2708 | +991 |
- #' @rdname vil+ #' @rdname row_accessors |
||
| 2709 | +992 |
- setMethod(+ #' @exportMethod row_cells+ |
+ ||
| 993 | +8335x | +
+ setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)
|
||
| 2710 | +994 |
- "vars_in_layout", "PreDataAxisLayout",+ |
||
| 2711 | +995 |
- function(lyt) {
+ #' @rdname row_accessors |
||
| 2712 | -2x | +996 | +4051x |
- vil_collapse(lapply(lyt, vars_in_layout))+ setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))
|
| 2713 | +997 |
- }+ |
||
| 2714 | +998 |
- )+ #' @rdname row_accessors |
||
| 2715 | +999 |
-
+ #' @exportMethod row_cells |
||
| 2716 | +1000 |
- #' @rdname vil+ setMethod("row_cells<-", "TableRow", function(obj, value) {
+ |
+ ||
| 1001 | +4051x | +
+ obj@leaf_value <- value+ |
+ ||
| 1002 | +4051x | +
+ obj |
||
| 2717 | +1003 |
- setMethod(+ }) |
||
| 2718 | +1004 |
- "vars_in_layout", "SplitVector",+ |
||
| 2719 | +1005 |
- function(lyt) {
+ #' @export+ |
+ ||
| 1006 | ++ |
+ #' @rdname row_accessors |
||
| 2720 | -3x | +1007 | +2321x |
- vil_collapse(lapply(lyt, vars_in_layout))+ setGeneric("row_values", function(obj) standardGeneric("row_values"))
|
| 2721 | +1008 |
- }+ |
||
| 2722 | +1009 |
- )+ #' @rdname row_accessors |
||
| 2723 | +1010 |
-
+ #' @exportMethod row_values+ |
+ ||
| 1011 | +529x | +
+ setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))
|
||
| 2724 | +1012 |
- #' @rdname vil+ |
||
| 2725 | +1013 |
- setMethod(+ |
||
| 2726 | +1014 |
- "vars_in_layout", "Split",+ #' @rdname row_accessors |
||
| 2727 | +1015 |
- function(lyt) {
+ #' @exportMethod row_values<- |
||
| 2728 | -7x | +1016 | +1234x |
- vil_collapse(c(+ setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))
|
| 2729 | -7x | +|||
| 1017 | +
- spl_payload(lyt),+ |
|||
| 2730 | +1018 |
- ## for an AllSplit/RootSplit+ #' @rdname row_accessors |
||
| 2731 | +1019 |
- ## doesn't have to be same as payload+ #' @exportMethod row_values<- |
||
| 2732 | -7x | +|||
| 1020 | +
- content_var(lyt),+ setMethod( |
|||
| 2733 | -7x | +|||
| 1021 | +
- spl_label_var(lyt)+ "row_values<-", "TableRow", |
|||
| 2734 | +1022 |
- ))+ function(obj, value) {
+ |
+ ||
| 1023 | +1234x | +
+ obj@leaf_value <- lapply(value, rcell)+ |
+ ||
| 1024 | +1234x | +
+ obj |
||
| 2735 | +1025 |
} |
||
| 2736 | +1026 |
) |
||
| 2737 | +1027 | |||
| 2738 | +1028 |
- #' @rdname vil+ #' @rdname row_accessors |
||
| 2739 | +1029 |
- setMethod(+ #' @exportMethod row_values<- |
||
| 2740 | +1030 |
- "vars_in_layout", "CompoundSplit",+ setMethod( |
||
| 2741 | -1x | +|||
| 1031 | +
- function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout))+ "row_values<-", "LabelRow", |
|||
| 2742 | +1032 |
- )+ function(obj, value) {
+ |
+ ||
| 1033 | +! | +
+ stop("LabelRows cannot have row values.")
|
||
| 2743 | +1034 |
-
+ } |
||
| 2744 | +1035 |
- #' @rdname vil+ ) |
||
| 2745 | +1036 |
- setMethod(+ |
||
| 2746 | +1037 |
- "vars_in_layout", "ManualSplit",+ #' @rdname int_methods |
||
| 2747 | -1x | +1038 | +1053x |
- function(lyt) character()+ setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))
|
| 2748 | +1039 |
- )+ |
||
| 2749 | +1040 |
-
+ #' @rdname int_methods |
||
| 2750 | +1041 |
- ## Titles and footers ----+ setMethod( |
||
| 2751 | +1042 |
-
+ "spanned_values", "TableRow", |
||
| 2752 | +1043 |
- # ##' Titles and Footers+ function(obj) {
+ |
+ ||
| 1044 | +1053x | +
+ rawvalues(spanned_cells(obj)) |
||
| 2753 | +1045 |
- # ##'+ } |
||
| 2754 | +1046 |
- # ##' Get or set the titles and footers on an object+ ) |
||
| 2755 | +1047 |
- # ##'+ |
||
| 2756 | +1048 |
- # ##' @inheritParams gen_args+ #' @rdname int_methods |
||
| 2757 | +1049 |
- # ##'+ setMethod( |
||
| 2758 | +1050 |
- # ##' @rdname title_footer+ "spanned_values", "LabelRow", |
||
| 2759 | +1051 |
- # ##' @export+ function(obj) {
+ |
+ ||
| 1052 | +! | +
+ rep(list(NULL), ncol(obj)) |
||
| 2760 | +1053 |
- #' @rdname formatters_methods+ } |
||
| 2761 | +1054 |
- #' @export+ ) |
||
| 2762 | +1055 |
- setMethod(+ |
||
| 2763 | +1056 |
- "main_title", "VTitleFooter",+ #' @rdname int_methods |
||
| 2764 | -3578x | +1057 | +1053x |
- function(obj) obj@main_title+ setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))
|
| 2765 | +1058 |
- )+ |
||
| 2766 | +1059 |
-
+ #' @rdname int_methods |
||
| 2767 | +1060 |
- ##' @rdname formatters_methods+ setMethod( |
||
| 2768 | +1061 |
- ##' @export+ "spanned_cells", "TableRow", |
||
| 2769 | +1062 |
- setMethod(+ function(obj) {
|
||
| 2770 | -+ | |||
| 1063 | +1053x |
- "main_title<-", "VTitleFooter",+ sp <- row_cspans(obj) |
||
| 2771 | -+ | |||
| 1064 | +1053x |
- function(obj, value) {
+ rvals <- row_cells(obj) |
||
| 2772 | -3153x | +1065 | +1053x |
- stopifnot(length(value) == 1)+ unlist( |
| 2773 | -3153x | +1066 | +1053x |
- obj@main_title <- value+ mapply(function(v, s) rep(list(v), times = s), |
| 2774 | -3153x | +1067 | +1053x |
- obj+ v = rvals, s = sp |
| 2775 | +1068 |
- }+ ), |
||
| 2776 | -+ | |||
| 1069 | +1053x |
- )+ recursive = FALSE |
||
| 2777 | +1070 |
-
+ ) |
||
| 2778 | +1071 |
- # Getters for TableRow is here for convenience for binding (no need of setters)+ } |
||
| 2779 | +1072 |
- #' @rdname formatters_methods+ ) |
||
| 2780 | +1073 |
- #' @export+ |
||
| 2781 | +1074 |
- setMethod(+ #' @rdname int_methods |
||
| 2782 | +1075 |
- "main_title", "TableRow",+ setMethod( |
||
| 2783 | -6x | +|||
| 1076 | +
- function(obj) ""+ "spanned_cells", "LabelRow", |
|||
| 2784 | +1077 |
- )+ function(obj) {
|
||
| 2785 | -+ | |||
| 1078 | +! |
-
+ rep(list(NULL), ncol(obj)) |
||
| 2786 | +1079 |
- #' @rdname formatters_methods+ } |
||
| 2787 | +1080 |
- #' @export+ ) |
||
| 2788 | +1081 |
- setMethod(+ |
||
| 2789 | +1082 |
- "subtitles", "VTitleFooter",+ #' @rdname int_methods |
||
| 2790 | -3568x | +1083 | +3x |
- function(obj) obj@subtitles+ setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))
|
| 2791 | +1084 |
- )+ |
||
| 2792 | +1085 |
-
+ #' @rdname int_methods |
||
| 2793 | +1086 |
- #' @rdname formatters_methods+ setMethod( |
||
| 2794 | +1087 |
- #' @export+ "spanned_values<-", "TableRow", |
||
| 2795 | +1088 |
- setMethod(+ function(obj, value) {
+ |
+ ||
| 1089 | +2x | +
+ sp <- row_cspans(obj) |
||
| 2796 | +1090 |
- "subtitles<-", "VTitleFooter",+ ## this is 3 times too clever!!!+ |
+ ||
| 1091 | +2x | +
+ valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1)))) |
||
| 2797 | +1092 |
- function(obj, value) {
+
|
||
| 2798 | -3148x | +1093 | +2x |
- obj@subtitles <- value+ splvec <- cumsum(valindices) |
| 2799 | -3148x | +1094 | +2x |
- obj+ lapply( |
| 2800 | -+ | |||
| 1095 | +2x |
- }+ split(value, splvec), |
||
| 2801 | -+ | |||
| 1096 | +2x |
- )+ function(v) {
|
||
| 2802 | -+ | |||
| 1097 | +3x |
-
+ if (length(unique(v)) > 1) {
|
||
| 2803 | -+ | |||
| 1098 | +1x |
- #' @rdname formatters_methods+ stop( |
||
| 2804 | -+ | |||
| 1099 | +1x |
- #' @export+ "Got more than one unique value within a span, ", |
||
| 2805 | -+ | |||
| 1100 | +1x |
- setMethod(+ "new spanned values do not appear to match the ", |
||
| 2806 | -+ | |||
| 1101 | +1x |
- "subtitles", "TableRow", # Only getter: see main_title for TableRow+ "existing spanning pattern of the row (",
|
||
| 2807 | -6x | +1102 | +1x |
- function(obj) character()+ paste(sp, collapse = " "), ")" |
| 2808 | +1103 |
- )+ ) |
||
| 2809 | +1104 |
-
+ } |
||
| 2810 | +1105 |
- #' @rdname formatters_methods+ } |
||
| 2811 | +1106 |
- #' @export+ )+ |
+ ||
| 1107 | +1x | +
+ rvals <- value[valindices] |
||
| 2812 | +1108 |
- setMethod(+ |
||
| 2813 | +1109 |
- "main_footer", "VTitleFooter",+ ## rvals = lapply(split(value, splvec), |
||
| 2814 | -3578x | +|||
| 1110 | +
- function(obj) obj@main_footer+ ## function(v) {
|
|||
| 2815 | +1111 |
- )+ ## if(length(v) == 1) |
||
| 2816 | +1112 |
-
+ ## return(v) |
||
| 2817 | +1113 |
- #' @rdname formatters_methods+ ## stopifnot(length(unique(v)) == 1L) |
||
| 2818 | +1114 |
- #' @export+ ## rcell(unique(v), colspan<- length(v)) |
||
| 2819 | +1115 |
- setMethod(+ ## }) |
||
| 2820 | +1116 |
- "main_footer<-", "VTitleFooter",+ ## if(any(splvec > 1)) |
||
| 2821 | +1117 |
- function(obj, value) {
+ ## rvals <- lapply(rvals, function(x) x[[1]]) |
||
| 2822 | -3153x | +1118 | +1x |
- obj@main_footer <- value+ row_values(obj) <- rvals |
| 2823 | -3153x | +1119 | +1x |
obj |
| 2824 | +1120 |
} |
||
| 2825 | +1121 |
) |
||
| 2826 | +1122 | |||
| 2827 | +1123 |
- #' @rdname formatters_methods+ #' @rdname int_methods |
||
| 2828 | +1124 |
- #' @export+ setMethod( |
||
| 2829 | +1125 |
- setMethod(+ "spanned_values<-", "LabelRow", |
||
| 2830 | +1126 |
- "main_footer", "TableRow", # Only getter: see main_title for TableRow+ function(obj, value) {
|
||
| 2831 | -6x | +1127 | +1x |
- function(obj) character()+ if (!is.null(value)) {
|
| 2832 | -+ | |||
| 1128 | +1x |
- )+ stop("Label rows can't have non-null cell values, got", value)
|
||
| 2833 | +1129 |
-
+ } |
||
| 2834 | -+ | |||
| 1130 | +! |
- #' @rdname formatters_methods+ obj |
||
| 2835 | +1131 |
- #' @export+ } |
||
| 2836 | +1132 |
- setMethod(+ ) |
||
| 2837 | +1133 |
- "prov_footer", "VTitleFooter",+ |
||
| 2838 | -3561x | +|||
| 1134 | +
- function(obj) obj@provenance_footer+ ### Format manipulation |
|||
| 2839 | +1135 |
- )+ ### obj_format<- is not recursive |
||
| 2840 | +1136 |
-
+ ## TODO export these? |
||
| 2841 | +1137 |
#' @rdname formatters_methods |
||
| 2842 | +1138 |
#' @export |
||
| 1139 | +7012x | +
+ setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)
+ |
+ ||
| 2843 | +1140 |
- setMethod(+ |
||
| 2844 | +1141 |
- "prov_footer<-", "VTitleFooter",+ #' @rdname formatters_methods |
||
| 2845 | +1142 |
- function(obj, value) {
+ #' @export |
||
| 2846 | -3147x | +1143 | +113417x |
- obj@provenance_footer <- value+ setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))
|
| 2847 | -3147x | +|||
| 1144 | +
- obj+ |
|||
| 2848 | +1145 |
- }+ #' @rdname formatters_methods |
||
| 2849 | +1146 |
- )+ #' @export+ |
+ ||
| 1147 | +2303x | +
+ setMethod("obj_format", "Split", function(obj) obj@split_format)
|
||
| 2850 | +1148 | |||
| 2851 | +1149 |
#' @rdname formatters_methods |
||
| 2852 | +1150 |
#' @export |
||
| 2853 | +1151 |
- setMethod(+ setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
|
||
| 2854 | -+ | |||
| 1152 | +1640x |
- "prov_footer", "TableRow", # Only getter: see main_title for TableRow+ obj@format <- value |
||
| 2855 | -6x | +1153 | +1640x |
- function(obj) character()+ obj |
| 2856 | +1154 |
- )+ }) |
||
| 2857 | +1155 | |||
| 2858 | +1156 |
- make_ref_value <- function(value) {
+ #' @rdname formatters_methods |
||
| 2859 | -3141x | +|||
| 1157 | +
- if (is(value, "RefFootnote")) {
+ #' @export |
|||
| 2860 | -! | +|||
| 1158 | +
- value <- list(value)+ setMethod("obj_format<-", "Split", function(obj, value) {
|
|||
| 2861 | -3141x | +1159 | +1x |
- } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
+ obj@split_format <- value |
| 2862 | -11x | +1160 | +1x |
- value <- lapply(value, RefFootnote)+ obj |
| 2863 | +1161 |
- }+ }) |
||
| 2864 | -3141x | +|||
| 1162 | +
- value+ |
|||
| 2865 | +1163 |
- }+ #' @rdname formatters_methods |
||
| 2866 | +1164 |
-
+ #' @export |
||
| 2867 | +1165 |
- #' Referential footnote accessors+ setMethod("obj_format<-", "CellValue", function(obj, value) {
|
||
| 2868 | -+ | |||
| 1166 | +1221x |
- #'+ attr(obj, "format") <- value |
||
| 2869 | -+ | |||
| 1167 | +1221x |
- #' Access and set the referential footnotes aspects of a built table.+ obj |
||
| 2870 | +1168 |
- #'+ }) |
||
| 2871 | +1169 |
- #' @inheritParams gen_args+ |
||
| 2872 | +1170 |
- #'+ #' @rdname int_methods |
||
| 2873 | +1171 |
#' @export |
||
| 2874 | +1172 |
- #' @rdname ref_fnotes+ setMethod("obj_na_str<-", "CellValue", function(obj, value) {
|
||
| 2875 | -54074x | +1173 | +4235x |
- setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))
+ attr(obj, "format_na_str") <- value+ |
+
| 1174 | +4235x | +
+ obj |
||
| 2876 | +1175 |
-
+ }) |
||
| 2877 | +1176 |
- #' @export+ |
||
| 2878 | +1177 |
#' @rdname int_methods |
||
| 2879 | +1178 |
- setMethod(+ #' @export |
||
| 2880 | +1179 |
- "row_footnotes", "TableRow",+ setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
|
||
| 2881 | -52087x | +1180 | +26x |
- function(obj) obj@row_footnotes+ obj@na_str <- value |
| 2882 | -+ | |||
| 1181 | +26x |
- )+ obj |
||
| 2883 | +1182 |
-
+ }) |
||
| 2884 | +1183 |
- #' @export+ |
||
| 2885 | +1184 |
#' @rdname int_methods |
||
| 2886 | +1185 |
- setMethod(+ #' @export |
||
| 2887 | +1186 |
- "row_footnotes", "RowsVerticalSection",+ setMethod("obj_na_str<-", "Split", function(obj, value) {
|
||
| 2888 | -1577x | +|||
| 1187 | +! |
- function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list()+ obj@split_na_str <- value+ |
+ ||
| 1188 | +! | +
+ obj |
||
| 2889 | +1189 |
- )+ }) |
||
| 2890 | +1190 | |||
| 2891 | +1191 |
- #' @export+ #' @rdname int_methods |
||
| 2892 | +1192 |
- #' @rdname ref_fnotes+ #' @export |
||
| 2893 | -82x | +1193 | +29435x |
- setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))
+ setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)
|
| 2894 | +1194 | |||
| 2895 | +1195 |
- #' @export+ #' @rdname formatters_methods |
||
| 2896 | +1196 |
- #' @rdname int_methods+ #' @export |
||
| 2897 | -+ | |||
| 1197 | +1173x |
- setMethod(+ setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)
|
||
| 2898 | +1198 |
- "row_footnotes<-", "TableRow",+ |
||
| 2899 | +1199 |
- function(obj, value) {
+ .no_na_str <- function(x) {
|
||
| 2900 | -82x | +1200 | +15220x |
- obj@row_footnotes <- make_ref_value(value)+ if (!is.character(x)) {
|
| 2901 | -82x | +1201 | +6192x |
- obj+ x <- obj_na_str(x) |
| 2902 | +1202 |
} |
||
| 2903 | -+ | |||
| 1203 | +15220x |
- )+ length(x) == 0 || all(is.na(x)) |
||
| 2904 | +1204 |
-
+ } |
||
| 2905 | +1205 |
- #' @export+ |
||
| 2906 | +1206 |
#' @rdname int_methods |
||
| 2907 | -- |
- setMethod(- |
- ||
| 2908 | -- |
- "row_footnotes", "VTableTree",- |
- ||
| 2909 | +1207 |
- function(obj) {
- |
- ||
| 2910 | -410x | -
- rws <- collect_leaves(obj, TRUE, TRUE)- |
- ||
| 2911 | -410x | -
- cells <- lapply(rws, row_footnotes)+ setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
|
||
| 2912 | -410x | -
- cells- |
- ||
| 2913 | -+ | 1208 | +9021x |
- }+ standardGeneric("set_format_recursive")
|
| 2914 | +1209 |
- )+ }) |
||
| 2915 | +1210 | |||
| 2916 | +1211 |
- #' @export+ #' @param override (`flag`)\cr whether to override attribute. |
||
| 2917 | +1212 |
- #' @rdname ref_fnotes- |
- ||
| 2918 | -210455x | -
- setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))
+ #' |
||
| 2919 | +1213 |
-
+ #' @rdname int_methods |
||
| 2920 | +1214 |
- #' @export+ setMethod( |
||
| 2921 | +1215 |
- #' @rdname int_methods+ "set_format_recursive", "TableRow", |
||
| 2922 | +1216 |
- setMethod(+ function(obj, format, na_str, override = FALSE) {
|
||
| 2923 | -+ | |||
| 1217 | +1030x |
- "cell_footnotes", "CellValue",+ if (is.null(format) && .no_na_str(na_str)) {
|
||
| 2924 | -168401x | +1218 | +514x |
- function(obj) attr(obj, "footnotes", exact = TRUE) %||% list()+ return(obj) |
| 2925 | +1219 |
- )+ } |
||
| 2926 | +1220 | |||
| 2927 | -+ | |||
| 1221 | +516x |
- #' @export+ if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
|
||
| 2928 | -+ | |||
| 1222 | +515x |
- #' @rdname int_methods+ obj_format(obj) <- format |
||
| 2929 | +1223 |
- setMethod(+ } |
||
| 2930 | -+ | |||
| 1224 | +516x |
- "cell_footnotes", "TableRow",+ if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
|
||
| 2931 | -+ | |||
| 1225 | +! |
- function(obj) {
+ obj_na_str(obj) <- na_str |
||
| 2932 | -37073x | +|||
| 1226 | +
- ret <- lapply(row_cells(obj), cell_footnotes)+ } |
|||
| 2933 | -37073x | +1227 | +516x |
- if (length(ret) != ncol(obj)) {
+ lcells <- row_cells(obj) |
| 2934 | -131x | -
- ret <- rep(ret, row_cspans(obj))- |
- ||
| 2935 | -+ | 1228 | +516x |
- }+ lvals <- lapply(lcells, function(x) {
|
| 2936 | -37073x | +1229 | +1920x |
- ret+ if (!is.null(x) && (override || is.null(obj_format(x)))) {
|
| 2937 | -+ | |||
| 1230 | +53x |
- }+ obj_format(x) <- obj_format(obj) |
||
| 2938 | +1231 |
- )+ } |
||
| 2939 | -+ | |||
| 1232 | +1920x |
-
+ if (!is.null(x) && (override || .no_na_str(x))) {
|
||
| 2940 | -+ | |||
| 1233 | +1920x |
- #' @export+ obj_na_str(x) <- obj_na_str(obj) |
||
| 2941 | +1234 |
- #' @rdname int_methods+ } |
||
| 2942 | -+ | |||
| 1235 | +1920x |
- setMethod(+ x |
||
| 2943 | +1236 |
- "cell_footnotes", "LabelRow",+ }) |
||
| 2944 | -+ | |||
| 1237 | +516x |
- function(obj) {
+ row_values(obj) <- lvals |
||
| 2945 | -4571x | +1238 | +516x |
- rep(list(list()), ncol(obj))+ obj |
| 2946 | +1239 |
} |
||
| 2947 | +1240 |
) |
||
| 2948 | +1241 | |||
| 2949 | -- |
- #' @export- |
- ||
| 2950 | +1242 |
#' @rdname int_methods |
||
| 2951 | +1243 |
setMethod( |
||
| 2952 | -- |
- "cell_footnotes", "VTableTree",- |
- ||
| 2953 | +1244 |
- function(obj) {
- |
- ||
| 2954 | -410x | -
- rws <- collect_leaves(obj, TRUE, TRUE)+ "set_format_recursive", "LabelRow", |
||
| 2955 | -410x | +1245 | +11x |
- cells <- lapply(rws, cell_footnotes)+ function(obj, format, override = FALSE) obj |
| 2956 | -410x | +|||
| 1246 | +
- do.call(rbind, cells)+ ) |
|||
| 2957 | +1247 |
- }+ |
||
| 2958 | +1248 |
- )+ setMethod( |
||
| 2959 | +1249 |
-
+ "set_format_recursive", "VTableTree", |
||
| 2960 | +1250 |
- #' @export+ function(obj, format, na_str, override = FALSE) {
|
||
| 2961 | -+ | |||
| 1251 | +1696x |
- #' @rdname ref_fnotes+ force(format) |
||
| 2962 | -717x | +1252 | +1696x |
- setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))
+ if (is.null(format) && .no_na_str(na_str)) {
|
| 2963 | -+ | |||
| 1253 | +1689x |
-
+ return(obj) |
||
| 2964 | +1254 |
- #' @export+ } |
||
| 2965 | +1255 |
- #' @rdname int_methods+ |
||
| 2966 | -+ | |||
| 1256 | +7x |
- setMethod(+ if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
|
||
| 2967 | -+ | |||
| 1257 | +7x |
- "cell_footnotes<-", "CellValue",+ obj_format(obj) <- format |
||
| 2968 | +1258 |
- function(obj, value) {
+ } |
||
| 2969 | -640x | +1259 | +7x |
- attr(obj, "footnotes") <- make_ref_value(value)+ if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
|
| 2970 | -640x | +|||
| 1260 | +! |
- obj+ obj_na_str(obj) <- na_str |
||
| 2971 | +1261 |
- }+ } |
||
| 2972 | +1262 |
- )+ |
||
| 2973 | -+ | |||
| 1263 | +7x |
-
+ kids <- tree_children(obj) |
||
| 2974 | -+ | |||
| 1264 | +7x |
- .cfn_set_helper <- function(obj, value) {
+ kids <- lapply(kids, function(x, format2, na_str2, oride) {
|
||
| 2975 | -77x | +1265 | +33x |
- if (length(value) != ncol(obj)) {
+ set_format_recursive(x, |
| 2976 | -! | +|||
| 1266 | +33x |
- stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.")
+ format = format2, na_str = na_str2, override = oride |
||
| 2977 | +1267 |
- }+ ) |
||
| 2978 | +1268 |
-
+ }, |
||
| 2979 | -77x | +1269 | +7x |
- row_cells(obj) <- mapply(+ format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override |
| 2980 | -77x | +|||
| 1270 | +
- function(cell, fns) {
+ ) |
|||
| 2981 | -283x | +1271 | +7x |
- if (is.list(fns)) {
+ tree_children(obj) <- kids |
| 2982 | -276x | +1272 | +7x |
- cell_footnotes(cell) <- lapply(fns, RefFootnote)+ obj |
| 2983 | +1273 |
- } else {
- |
- ||
| 2984 | -7x | -
- cell_footnotes(cell) <- list(RefFootnote(fns))+ } |
||
| 2985 | +1274 |
- }+ ) |
||
| 2986 | -283x | +|||
| 1275 | +
- cell+ |
|||
| 2987 | +1276 |
- },+ #' @rdname int_methods |
||
| 2988 | -77x | +1277 | +1830x |
- cell = row_cells(obj),+ setGeneric("content_format", function(obj) standardGeneric("content_format"))
|
| 2989 | -77x | +|||
| 1278 | +
- fns = value, SIMPLIFY = FALSE+ |
|||
| 2990 | +1279 |
- )+ #' @rdname int_methods |
||
| 2991 | -77x | -
- obj- |
- ||
| 2992 | -+ | 1280 | +1830x |
- }+ setMethod("content_format", "Split", function(obj) obj@content_format)
|
| 2993 | +1281 | |||
| 2994 | +1282 |
- #' @export+ #' @rdname int_methods |
||
| 2995 | -+ | |||
| 1283 | +105x |
- #' @rdname int_methods+ setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))
|
||
| 2996 | +1284 |
- setMethod("cell_footnotes<-", "DataRow",
+
|
||
| 2997 | +1285 |
- definition = .cfn_set_helper+ #' @rdname int_methods |
||
| 2998 | +1286 |
- )+ setMethod("content_format<-", "Split", function(obj, value) {
|
||
| 2999 | -+ | |||
| 1287 | +105x |
-
+ obj@content_format <- value |
||
| 3000 | -+ | |||
| 1288 | +105x |
- #' @export+ obj |
||
| 3001 | +1289 |
- #' @rdname int_methods+ }) |
||
| 3002 | +1290 |
- setMethod("cell_footnotes<-", "ContentRow",
+
|
||
| 3003 | +1291 |
- definition = .cfn_set_helper+ #' @rdname int_methods |
||
| 3004 | -+ | |||
| 1292 | +1830x |
- )+ setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))
|
||
| 3005 | +1293 | |||
| 3006 | +1294 |
- # Deprecated methods ----+ #' @rdname int_methods |
||
| 3007 | -+ | |||
| 1295 | +1830x |
-
+ setMethod("content_na_str", "Split", function(obj) obj@content_na_str)
|
||
| 3008 | +1296 |
- #' @export+ |
||
| 3009 | +1297 |
- #' @rdname ref_fnotes+ #' @rdname int_methods |
||
| 3010 | +1298 | ! |
- setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))
+ setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-"))
|
|
| 3011 | +1299 | |||
| 3012 | -- |
- #' @export- |
- ||
| 3013 | +1300 |
- #' @rdname ref_fnotes+ #' @rdname int_methods |
||
| 3014 | +1301 |
- setMethod("col_fnotes_here", "ANY", function(obj) {
+ setMethod("content_na_str<-", "Split", function(obj, value) {
|
||
| 3015 | +1302 | ! |
- lifecycle::deprecate_warn(+ obj@content_na_str <- value |
|
| 3016 | +1303 | ! |
- when = "0.6.6",+ obj |
|
| 3017 | -! | +|||
| 1304 | +
- what = "col_fnotes_here()",+ }) |
|||
| 3018 | -! | +|||
| 1305 | +
- with = "col_footnotes()"+ |
|||
| 3019 | +1306 |
- )+ #' Value formats |
||
| 3020 | -! | +|||
| 1307 | +
- col_footnotes(obj)+ #' |
|||
| 3021 | +1308 |
- })+ #' Returns a matrix of formats for the cells in a table. |
||
| 3022 | +1309 |
-
+ #' |
||
| 3023 | +1310 |
- #' @export+ #' @param obj (`VTableTree` or `TableRow`)\cr a table or row object. |
||
| 3024 | +1311 |
- #' @rdname ref_fnotes+ #' @param default (`string`, `function`, or `list`)\cr default format. |
||
| 3025 | -! | +|||
| 1312 | +
- setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
+ #' |
|||
| 3026 | +1313 |
-
+ #' @return Matrix (storage mode list) containing the effective format for each cell position in the table |
||
| 3027 | +1314 |
- #' @export+ #' (including 'virtual' cells implied by label rows, whose formats are always `NULL`). |
||
| 3028 | +1315 |
- #' @rdname int_methods+ #' |
||
| 3029 | +1316 |
- setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
+ #' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure. |
||
| 3030 | -! | +|||
| 1317 | +
- lifecycle::deprecate_warn(+ #' |
|||
| 3031 | -! | +|||
| 1318 | +
- when = "0.6.6",+ #' @examples |
|||
| 3032 | -! | +|||
| 1319 | +
- what = I("col_fnotes_here()<-"),
+ #' lyt <- basic_table() %>% |
|||
| 3033 | -! | +|||
| 1320 | +
- with = I("col_footnotes()<-")
+ #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
|
|||
| 3034 | +1321 |
- )+ #' analyze("AGE")
|
||
| 3035 | -! | +|||
| 1322 | +
- col_footnotes(obj) <- value+ #' |
|||
| 3036 | +1323 |
- })+ #' tbl <- build_table(lyt, DM) |
||
| 3037 | +1324 |
-
+ #' value_formats(tbl) |
||
| 3038 | +1325 |
- #' @export+ #' |
||
| 3039 | +1326 |
- #' @rdname ref_fnotes+ #' @export |
||
| 3040 | -21244x | +1327 | +1123x |
- setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))
+ setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))
|
| 3041 | +1328 | |||
| 3042 | +1329 |
- #' @export+ #' @rdname value_formats |
||
| 3043 | +1330 |
- #' @rdname int_methods+ setMethod( |
||
| 3044 | -1299x | +|||
| 1331 | +
- setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)
+ "value_formats", "ANY", |
|||
| 3045 | +1332 |
-
+ function(obj, default) {
|
||
| 3046 | -+ | |||
| 1333 | +762x |
- #' @export+ obj_format(obj) %||% default |
||
| 3047 | +1334 |
- #' @rdname int_methods+ } |
||
| 3048 | -19536x | +|||
| 1335 | +
- setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)
+ ) |
|||
| 3049 | +1336 | |||
| 3050 | +1337 |
- #' @export+ #' @rdname value_formats |
||
| 3051 | +1338 |
- #' @rdname ref_fnotes+ setMethod( |
||
| 3052 | -1866x | +|||
| 1339 | +
- setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))
+ "value_formats", "TableRow", |
|||
| 3053 | +1340 |
-
+ function(obj, default) {
|
||
| 3054 | -+ | |||
| 1341 | +245x |
- #' @export+ if (!is.null(obj_format(obj))) {
|
||
| 3055 | -+ | |||
| 1342 | +215x |
- #' @rdname int_methods+ default <- obj_format(obj) |
||
| 3056 | +1343 |
- setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
+ } |
||
| 3057 | -694x | +1344 | +245x |
- obj@col_footnotes <- make_ref_value(value)+ formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default) |
| 3058 | -694x | +1345 | +245x |
- obj+ formats |
| 3059 | +1346 |
- })+ } |
||
| 3060 | +1347 | ++ |
+ )+ |
+ |
| 1348 | ||||
| 3061 | +1349 |
- #' @export+ #' @rdname value_formats |
||
| 3062 | +1350 |
- #' @rdname int_methods+ setMethod( |
||
| 3063 | +1351 |
- setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
+ "value_formats", "LabelRow", |
||
| 3064 | -1172x | +|||
| 1352 | +
- obj@col_footnotes <- make_ref_value(value)+ function(obj, default) {
|
|||
| 3065 | -1172x | +1353 | +102x |
- obj+ rep(list(NULL), ncol(obj)) |
| 3066 | +1354 |
- })+ } |
||
| 3067 | +1355 |
-
+ ) |
||
| 3068 | +1356 |
- #' @export+ |
||
| 3069 | +1357 |
- #' @rdname int_methods+ #' @rdname value_formats |
||
| 3070 | +1358 |
setMethod( |
||
| 3071 | +1359 |
- "col_footnotes", "VTableTree",+ "value_formats", "VTableTree", |
||
| 3072 | +1360 |
- function(obj) {
+ function(obj, default) {
|
||
| 3073 | -409x | +1361 | +14x |
- ctree <- coltree(obj)+ if (!is.null(obj_format(obj))) {
|
| 3074 | -409x | +|||
| 1362 | +! |
- cols <- tree_children(ctree)+ default <- obj_format(obj) |
||
| 3075 | -409x | +|||
| 1363 | +
- while (all(sapply(cols, is, "LayoutColTree"))) {
+ } |
|||
| 3076 | -123x | +1364 | +14x |
- cols <- lapply(cols, tree_children)+ rws <- collect_leaves(obj, TRUE, TRUE) |
| 3077 | -123x | -
- cols <- unlist(cols, recursive = FALSE)- |
- ||
| 3078 | -+ | 1365 | +14x |
- }+ formatrws <- lapply(rws, value_formats, default = default) |
| 3079 | -409x | +1366 | +14x |
- all_col_fnotes <- lapply(cols, col_footnotes)+ mat <- do.call(rbind, formatrws) |
| 3080 | -409x | +1367 | +14x |
- if (is.null(unlist(all_col_fnotes))) {
+ row.names(mat) <- row.names(obj) |
| 3081 | -404x | +1368 | +14x |
- return(NULL)+ mat |
| 3082 | +1369 |
- }+ } |
||
| 3083 | +1370 |
-
+ ) |
||
| 3084 | -5x | +|||
| 1371 | +
- return(all_col_fnotes)+ |
|||
| 3085 | +1372 |
- }+ ### Collect all leaves of a current tree |
||
| 3086 | +1373 |
- )+ ### This is a workhorse function in various |
||
| 3087 | +1374 |
-
+ ### places |
||
| 3088 | +1375 |
- #' @export+ ### NB this is written generally enought o |
||
| 3089 | +1376 |
- #' @rdname ref_fnotes+ ### be used on all tree-based structures in the |
||
| 3090 | -3912x | +|||
| 1377 | +
- setGeneric("ref_index", function(obj) standardGeneric("ref_index"))
+ ### framework. |
|||
| 3091 | +1378 | |||
| 3092 | +1379 |
- #' @export+ #' Collect leaves of a `TableTree` |
||
| 3093 | +1380 |
- #' @rdname int_methods+ #' |
||
| 3094 | +1381 |
- setMethod(+ #' @inheritParams gen_args |
||
| 3095 | +1382 |
- "ref_index", "RefFootnote",+ #' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`. |
||
| 3096 | -3912x | +|||
| 1383 | +
- function(obj) obj@index+ #' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`. |
|||
| 3097 | +1384 |
- )+ #' |
||
| 3098 | +1385 |
-
+ #' @return A list of `TableRow` objects for all rows in the table. |
||
| 3099 | +1386 |
- #' @export+ #' |
||
| 3100 | +1387 |
- #' @rdname ref_fnotes+ #' @export |
||
| 3101 | -119x | +|||
| 1388 | +
- setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))
+ setGeneric("collect_leaves",
|
|||
| 3102 | +1389 |
-
+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
|
||
| 3103 | -+ | |||
| 1390 | +112529x |
- #' @export+ standardGeneric("collect_leaves")
|
||
| 3104 | +1391 |
- #' @rdname int_methods+ }, |
||
| 3105 | +1392 |
- setMethod(+ signature = "tt" |
||
| 3106 | +1393 |
- "ref_index<-", "RefFootnote",+ ) |
||
| 3107 | +1394 |
- function(obj, value) {
+
|
||
| 3108 | -119x | +|||
| 1395 | +
- obj@index <- value+ #' @inheritParams collect_leaves |
|||
| 3109 | -119x | +|||
| 1396 | +
- obj+ #' |
|||
| 3110 | +1397 |
- }+ #' @rdname int_methods |
||
| 3111 | +1398 |
- )+ #' @exportMethod collect_leaves |
||
| 3112 | +1399 |
-
+ setMethod( |
||
| 3113 | +1400 |
- #' @export+ "collect_leaves", "TableTree", |
||
| 3114 | +1401 |
- #' @rdname ref_fnotes+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
|
||
| 3115 | -3793x | +1402 | +25990x |
- setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))
+ ret <- c( |
| 3116 | -+ | |||
| 1403 | +25990x |
-
+ if (add.labrows && labelrow_visible(tt)) {
|
||
| 3117 | -+ | |||
| 1404 | +10626x |
- #' @export+ tt_labelrow(tt) |
||
| 3118 | +1405 |
- #' @rdname int_methods+ }, |
||
| 3119 | -+ | |||
| 1406 | +25990x |
- setMethod(+ if (incl.cont) {
+ |
+ ||
| 1407 | +25990x | +
+ tree_children(content_table(tt)) |
||
| 3120 | +1408 |
- "ref_symbol", "RefFootnote",+ }, |
||
| 3121 | -3793x | +1409 | +25990x |
- function(obj) obj@symbol+ lapply(tree_children(tt), |
| 3122 | -+ | |||
| 1410 | +25990x |
- )+ collect_leaves, |
||
| 3123 | -+ | |||
| 1411 | +25990x |
-
+ incl.cont = incl.cont, add.labrows = add.labrows |
||
| 3124 | +1412 |
- #' @export+ ) |
||
| 3125 | +1413 |
- #' @rdname ref_fnotes+ ) |
||
| 3126 | -! | +|||
| 1414 | +25990x |
- setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))
+ unlist(ret, recursive = TRUE) |
||
| 3127 | +1415 |
-
+ } |
||
| 3128 | +1416 |
- #' @export+ ) |
||
| 3129 | +1417 |
- #' @rdname int_methods+ |
||
| 3130 | +1418 |
- setMethod(+ #' @rdname int_methods |
||
| 3131 | +1419 |
- "ref_symbol<-", "RefFootnote",+ #' @exportMethod collect_leaves |
||
| 3132 | +1420 |
- function(obj, value) {
- |
- ||
| 3133 | -! | -
- obj@symbol <- value+ setMethod( |
||
| 3134 | -! | +|||
| 1421 | +
- obj+ "collect_leaves", "ElementaryTable", |
|||
| 3135 | +1422 |
- }+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
|
||
| 3136 | -+ | |||
| 1423 | +56789x |
- )+ ret <- tree_children(tt) |
||
| 3137 | -+ | |||
| 1424 | +56789x |
-
+ if (add.labrows && labelrow_visible(tt)) {
|
||
| 3138 | -+ | |||
| 1425 | +11080x |
- #' @export+ ret <- c(tt_labelrow(tt), ret) |
||
| 3139 | +1426 |
- #' @rdname ref_fnotes+ } |
||
| 3140 | -2929x | +1427 | +56789x |
- setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))
+ ret |
| 3141 | +1428 |
-
+ } |
||
| 3142 | +1429 |
- #' @export+ ) |
||
| 3143 | +1430 |
- #' @rdname int_methods+ |
||
| 3144 | +1431 |
- setMethod(+ #' @rdname int_methods |
||
| 3145 | +1432 |
- "ref_msg", "RefFootnote",- |
- ||
| 3146 | -2929x | -
- function(obj) obj@value+ #' @exportMethod collect_leaves |
||
| 3147 | +1433 |
- )+ setMethod( |
||
| 3148 | +1434 | - - | -||
| 3149 | -24x | -
- setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))
+ "collect_leaves", "VTree", |
||
| 3150 | +1435 |
-
+ function(tt, incl.cont, add.labrows) {
|
||
| 3151 | -+ | |||
| 1436 | +! |
- setMethod(+ ret <- lapply( |
||
| 3152 | -+ | |||
| 1437 | +! |
- ".fnote_set_inner<-", c("TableRow", "NULL"),
+ tree_children(tt), |
||
| 3153 | -+ | |||
| 1438 | +! |
- function(ttrp, colpath, value) {
+ collect_leaves |
||
| 3154 | -8x | +|||
| 1439 | +
- row_footnotes(ttrp) <- value+ ) |
|||
| 3155 | -8x | +|||
| 1440 | +! |
- ttrp+ unlist(ret, recursive = TRUE) |
||
| 3156 | +1441 |
} |
||
| 3157 | +1442 |
) |
||
| 3158 | +1443 | |||
| 3159 | +1444 |
- setMethod(+ #' @rdname int_methods |
||
| 3160 | +1445 |
- ".fnote_set_inner<-", c("TableRow", "character"),
+ #' @exportMethod collect_leaves |
||
| 3161 | +1446 |
- function(ttrp, colpath, value) {
- |
- ||
| 3162 | -7x | -
- ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE)- |
- ||
| 3163 | -7x | -
- cfns <- cell_footnotes(ttrp)+ setMethod( |
||
| 3164 | -7x | +|||
| 1447 | +
- cfns[[ind]] <- value+ "collect_leaves", "VLeaf", |
|||
| 3165 | -7x | +|||
| 1448 | +
- cell_footnotes(ttrp) <- cfns+ function(tt, incl.cont, add.labrows) {
|
|||
| 3166 | -7x | +1449 | +686x |
- ttrp+ list(tt) |
| 3167 | +1450 |
} |
||
| 3168 | +1451 |
) |
||
| 3169 | +1452 | |||
| 3170 | +1453 |
- setMethod(+ #' @rdname int_methods |
||
| 3171 | +1454 |
- ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
+ #' @exportMethod collect_leaves |
||
| 3172 | +1455 |
- function(ttrp, colpath, value) {
+ setMethod( |
||
| 3173 | -1x | +|||
| 1456 | +
- ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value)+ "collect_leaves", "NULL", |
|||
| 3174 | -1x | +|||
| 1457 | +
- coltree(ttrp) <- ctree+ function(tt, incl.cont, add.labrows) {
|
|||
| 3175 | -1x | +|||
| 1458 | +! |
- ttrp+ list() |
||
| 3176 | +1459 |
} |
||
| 3177 | +1460 |
) |
||
| 3178 | +1461 | |||
| 3179 | +1462 |
- setMethod(+ #' @rdname int_methods |
||
| 3180 | +1463 |
- ".fnote_set_inner<-", c("VTableTree", "ANY"),
+ #' @exportMethod collect_leaves |
||
| 3181 | +1464 |
- function(ttrp, colpath, value) {
- |
- ||
| 3182 | -8x | -
- if (labelrow_visible(ttrp) && !is.null(value)) {
+ setMethod( |
||
| 3183 | -2x | +|||
| 1465 | +
- lblrw <- tt_labelrow(ttrp)+ "collect_leaves", "ANY", |
|||
| 3184 | -2x | +|||
| 1466 | +
- row_footnotes(lblrw) <- value+ function(tt, incl.cont, add.labrows) {
|
|||
| 3185 | -2x | +|||
| 1467 | +! |
- tt_labelrow(ttrp) <- lblrw+ stop("class ", class(tt), " does not inherit from VTree or VLeaf")
|
||
| 3186 | -6x | +|||
| 1468 | +
- } else if (NROW(content_table(ttrp)) == 1L) {
+ } |
|||
| 3187 | -6x | +|||
| 1469 | +
- ctbl <- content_table(ttrp)+ ) |
|||
| 3188 | -6x | +|||
| 1470 | +
- pth <- make_row_df(ctbl)$path[[1]]+ |
|||
| 3189 | -6x | +|||
| 1471 | +
- fnotes_at_path(ctbl, pth, colpath) <- value+ n_leaves <- function(tt, ...) {
|
|||
| 3190 | -6x | +1472 | +202x |
- content_table(ttrp) <- ctbl+ length(collect_leaves(tt, ...)) |
| 3191 | +1473 |
- } else {
+ } |
||
| 3192 | +1474 |
- stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
+
|
||
| 3193 | +1475 |
- }+ ### Spanning information ---- |
||
| 3194 | -8x | +|||
| 1476 | +
- ttrp+ |
|||
| 3195 | +1477 |
- }+ #' @rdname int_methods |
||
| 3196 | -+ | |||
| 1478 | +56545x |
- )+ setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))
|
||
| 3197 | +1479 | |||
| 3198 | +1480 |
- #' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should+ #' @rdname int_methods |
||
| 3199 | -+ | |||
| 1481 | +5194x |
- #' go on the column rather than cell.+ setMethod("row_cspans", "TableRow", function(obj) obj@colspans)
|
||
| 3200 | +1482 |
- #' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go+ |
||
| 3201 | +1483 |
- #' on the row rather than cell.+ #' @rdname int_methods |
||
| 3202 | +1484 |
- #' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately+ setMethod( |
||
| 3203 | +1485 |
- #' recalculated. Defaults to `TRUE`.+ "row_cspans", "LabelRow", |
||
| 3204 | -+ | |||
| 1486 | +1655x |
- #'+ function(obj) rep(1L, ncol(obj)) |
||
| 3205 | +1487 |
- #' @examples+ ) |
||
| 3206 | +1488 |
- #' # How to add referencial footnotes after having created a table+ |
||
| 3207 | +1489 |
- #' lyt <- basic_table() %>%+ #' @rdname int_methods |
||
| 3208 | -+ | |||
| 1490 | +3974x |
- #' split_rows_by("SEX", page_by = TRUE) %>%
+ setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))
|
||
| 3209 | +1491 |
- #' analyze("AGE")
+
|
||
| 3210 | +1492 |
- #'+ #' @rdname int_methods |
||
| 3211 | +1493 |
- #' tbl <- build_table(lyt, DM)+ setMethod("row_cspans<-", "TableRow", function(obj, value) {
|
||
| 3212 | -+ | |||
| 1494 | +3974x |
- #' tbl <- trim_rows(tbl)+ obj@colspans <- value |
||
| 3213 | -+ | |||
| 1495 | +3974x |
- #' # Check the row and col structure to add precise references+ obj |
||
| 3214 | +1496 |
- #' # row_paths(tbl)+ }) |
||
| 3215 | +1497 |
- #' # col_paths(t)+ |
||
| 3216 | +1498 |
- #' # row_paths_summary(tbl)+ #' @rdname int_methods |
||
| 3217 | +1499 |
- #' # col_paths_summary(tbl)+ setMethod("row_cspans<-", "LabelRow", function(obj, value) {
|
||
| 3218 | +1500 |
- #'+ stop("attempted to set colspans for LabelRow") # nocov
|
||
| 3219 | +1501 |
- #' # Add the citation numbers on the table and relative references in the footnotes+ }) |
||
| 3220 | +1502 |
- #' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
+
|
||
| 3221 | +1503 |
- #' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
+ ## XXX TODO colapse with above? |
||
| 3222 | +1504 |
- #' # tbl+ #' @rdname int_methods |
||
| 3223 | -+ | |||
| 1505 | +47486x |
- #'+ setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))
|
||
| 3224 | +1506 |
- #' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()]+ |
||
| 3225 | +1507 |
- #'+ #' @rdname int_methods |
||
| 3226 | +1508 |
- #' @export+ setMethod( |
||
| 3227 | +1509 |
- #' @rdname ref_fnotes+ "cell_cspan", "CellValue",+ |
+ ||
| 1510 | +47486x | +
+ function(obj) attr(obj, "colspan", exact = TRUE) |
||
| 3228 | +1511 |
- setGeneric("fnotes_at_path<-", function(obj,
+ ) ## obj@colspan) |
||
| 3229 | +1512 |
- rowpath = NULL,+ |
||
| 3230 | +1513 |
- colpath = NULL,+ #' @rdname int_methods |
||
| 3231 | +1514 |
- reset_idx = TRUE,+ setGeneric( |
||
| 3232 | +1515 |
- value) {
+ "cell_cspan<-", |
||
| 3233 | -24x | +1516 | +6892x |
- standardGeneric("fnotes_at_path<-")
+ function(obj, value) standardGeneric("cell_cspan<-")
|
| 3234 | +1517 |
- })+ ) |
||
| 3235 | +1518 | |||
| 3236 | +1519 |
- ## non-null rowpath, null or non-null colpath+ #' @rdname int_methods |
||
| 3237 | +1520 |
- #' @inheritParams fnotes_at_path<-+ setMethod("cell_cspan<-", "CellValue", function(obj, value) {
|
||
| 3238 | +1521 |
- #'+ ## obj@colspan <- value |
||
| 3239 | -+ | |||
| 1522 | +6892x |
- #' @export+ attr(obj, "colspan") <- value |
||
| 3240 | -+ | |||
| 1523 | +6892x |
- #' @rdname int_methods+ obj |
||
| 3241 | +1524 |
- setMethod(+ }) |
||
| 3242 | +1525 |
- "fnotes_at_path<-", c("VTableTree", "character"),
+
|
||
| 3243 | +1526 |
- function(obj,+ #' @rdname int_methods+ |
+ ||
| 1527 | +28328x | +
+ setGeneric("cell_align", function(obj) standardGeneric("cell_align"))
|
||
| 3244 | +1528 |
- rowpath = NULL,+ |
||
| 3245 | +1529 |
- colpath = NULL,+ #' @rdname int_methods |
||
| 3246 | +1530 |
- reset_idx = TRUE,+ setMethod( |
||
| 3247 | +1531 |
- value) {
+ "cell_align", "CellValue", |
||
| 3248 | -23x | +1532 | +28328x |
- rw <- tt_at_path(obj, rowpath)+ function(obj) attr(obj, "align", exact = TRUE) %||% "center" |
| 3249 | -23x | +|||
| 1533 | +
- .fnote_set_inner(rw, colpath) <- value+ ) ## obj@colspan) |
|||
| 3250 | -23x | +|||
| 1534 | +
- tt_at_path(obj, rowpath) <- rw+ |
|||
| 3251 | -23x | +|||
| 1535 | +
- if (reset_idx) {
+ #' @rdname int_methods |
|||
| 3252 | -23x | +|||
| 1536 | +
- obj <- update_ref_indexing(obj)+ setGeneric( |
|||
| 3253 | +1537 |
- }+ "cell_align<-", |
||
| 3254 | -23x | +1538 | +56x |
- obj+ function(obj, value) standardGeneric("cell_align<-")
|
| 3255 | +1539 |
- }+ ) |
||
| 3256 | +1540 |
- )+ |
||
| 3257 | +1541 |
-
+ #' @rdname int_methods |
||
| 3258 | +1542 |
- #' @export+ setMethod("cell_align<-", "CellValue", function(obj, value) {
|
||
| 3259 | +1543 |
- #' @rdname int_methods+ ## obj@colspan <- value |
||
| 3260 | -+ | |||
| 1544 | +56x |
- setMethod(+ if (is.null(value)) {
|
||
| 3261 | -+ | |||
| 1545 | +! |
- "fnotes_at_path<-", c("VTableTree", "NULL"),
+ value <- "center" |
||
| 3262 | +1546 |
- function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
+ } else {
|
||
| 3263 | -1x | +1547 | +56x |
- cinfo <- col_info(obj)+ value <- tolower(value) |
| 3264 | -1x | +|||
| 1548 | +
- .fnote_set_inner(cinfo, colpath) <- value+ } |
|||
| 3265 | -1x | +1549 | +56x |
- col_info(obj) <- cinfo+ check_aligns(value) |
| 3266 | -1x | +1550 | +56x |
- if (reset_idx) {
+ attr(obj, "align") <- value |
| 3267 | -1x | +1551 | +56x |
- obj <- update_ref_indexing(obj)+ obj |
| 3268 | +1552 |
- }- |
- ||
| 3269 | -1x | -
- obj+ }) |
||
| 3270 | +1553 |
- }+ |
||
| 3271 | +1554 |
- )+ ### Level (indent) in tree structure ---- |
||
| 3272 | +1555 | |||
| 3273 | -2832x | -
- setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))
- |
- ||
| 3274 | +1556 |
-
+ #' @rdname int_methods |
||
| 3275 | -357x | +1557 | +215x |
- setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))
+ setGeneric("tt_level", function(obj) standardGeneric("tt_level"))
|
| 3276 | +1558 | |||
| 3277 | -1510x | -
- setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))
- |
- ||
| 3278 | +1559 | - - | -||
| 3279 | -914x | -
- setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)
+ ## this will hit everything via inheritence |
||
| 3280 | +1560 |
-
+ #' @rdname int_methods |
||
| 3281 | -2332x | +1561 | +215x |
- setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))
+ setMethod("tt_level", "VNodeInfo", function(obj) obj@level)
|
| 3282 | +1562 | |||
| 3283 | -365x | -
- setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)
- |
- ||
| 3284 | +1563 |
-
+ #' @rdname int_methods |
||
| 3285 | -1916x | +1564 | +2x |
- setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)
+ setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))
|
| 3286 | +1565 | |||
| 3287 | -! | -
- setMethod("ptitle_prefix", "ANY", function(obj) NULL)
- |
- ||
| 3288 | +1566 | - - | -||
| 3289 | -376x | -
- setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)
+ ## this will hit everyhing via inheritence |
||
| 3290 | +1567 |
-
+ #' @rdname int_methods |
||
| 3291 | +1568 |
- setMethod("page_titles<-", "VTableTree", function(obj, value) {
+ setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
|
||
| 3292 | -19x | +1569 | +1x |
- obj@page_titles <- value+ obj@level <- as.integer(value) |
| 3293 | -19x | +1570 | +1x |
obj |
| 3294 | +1571 |
}) |
||
| 3295 | +1572 | |||
| 3296 | +1573 |
- ## Horizontal separator --------------------------------------------------------+ #' @rdname int_methods |
||
| 3297 | +1574 |
-
+ setMethod( |
||
| 3298 | +1575 |
- #' Access or recursively set header-body separator for tables+ "tt_level<-", "VTableTree", |
||
| 3299 | +1576 |
- #'+ function(obj, value) {
|
||
| 3300 | -+ | |||
| 1577 | +1x |
- #' @inheritParams gen_args+ obj@level <- as.integer(value) |
||
| 3301 | -+ | |||
| 1578 | +1x |
- #' @param value (`string`)\cr string to use as new header/body separator.+ tree_children(obj) <- lapply(tree_children(obj), |
||
| 3302 | -+ | |||
| 1579 | +1x |
- #'+ `tt_level<-`,+ |
+ ||
| 1580 | +1x | +
+ value = as.integer(value) + 1L |
||
| 3303 | +1581 |
- #' @return+ )+ |
+ ||
| 1582 | +1x | +
+ obj |
||
| 3304 | +1583 |
- #' * `horizontal_sep` returns the string acting as the header separator.+ } |
||
| 3305 | +1584 |
- #' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its+ ) |
||
| 3306 | +1585 |
- #' subtables.+ |
||
| 3307 | +1586 |
- #'+ #' @rdname int_methods |
||
| 3308 | +1587 |
#' @export |
||
| 3309 | -354x | +1588 | +56224x |
- setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))
+ setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))
|
| 3310 | +1589 | |||
| 3311 | -- |
- #' @rdname horizontal_sep- |
- ||
| 3312 | +1590 |
- #' @export+ #' @rdname int_methods |
||
| 3313 | +1591 |
setMethod( |
||
| 3314 | +1592 |
- "horizontal_sep", "VTableTree",+ "indent_mod", "Split", |
||
| 3315 | -354x | +1593 | +2942x |
- function(obj) obj@horizontal_sep+ function(obj) obj@indent_modifier |
| 3316 | +1594 |
) |
||
| 3317 | +1595 | |||
| 3318 | +1596 |
- #' @rdname horizontal_sep+ #' @rdname int_methods |
||
| 3319 | +1597 |
- #' @export- |
- ||
| 3320 | -23886x | -
- setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))
+ setMethod( |
||
| 3321 | +1598 |
-
+ "indent_mod", "VTableNodeInfo", |
||
| 3322 | -+ | |||
| 1599 | +26729x |
- #' @rdname horizontal_sep+ function(obj) obj@indent_modifier |
||
| 3323 | +1600 |
- #' @export+ ) |
||
| 3324 | +1601 |
- setMethod(+ |
||
| 3325 | +1602 |
- "horizontal_sep<-", "VTableTree",+ #' @rdname int_methods |
||
| 3326 | +1603 |
- function(obj, value) {
- |
- ||
| 3327 | -13381x | -
- cont <- content_table(obj)- |
- ||
| 3328 | -13381x | -
- if (NROW(cont) > 0) {
+ setMethod( |
||
| 3329 | -1878x | +|||
| 1604 | +
- horizontal_sep(cont) <- value+ "indent_mod", "ANY", |
|||
| 3330 | -1878x | +1605 | +23068x |
- content_table(obj) <- cont+ function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L |
| 3331 | +1606 |
- }+ ) |
||
| 3332 | +1607 | |||
| 3333 | -13381x | +|||
| 1608 | +
- kids <- lapply(tree_children(obj),+ #' @rdname int_methods |
|||
| 3334 | -13381x | +|||
| 1609 | +
- `horizontal_sep<-`,+ setMethod( |
|||
| 3335 | -13381x | +|||
| 1610 | +
- value = value+ "indent_mod", "RowsVerticalSection", |
|||
| 3336 | +1611 |
- )+ ## function(obj) setNames(obj@indent_mods,names(obj))) |
||
| 3337 | +1612 |
-
+ function(obj) {
|
||
| 3338 | -13381x | +1613 | +1611x |
- tree_children(obj) <- kids+ val <- attr(obj, "indent_mods", exact = TRUE) %||% |
| 3339 | -13381x | +1614 | +1611x |
- obj@horizontal_sep <- value+ vapply(obj, indent_mod, 1L) ## rep(0L, length(obj)) |
| 3340 | -13381x | +1615 | +1611x |
- obj+ setNames(val, names(obj)) |
| 3341 | +1616 |
} |
||
| 3342 | +1617 |
) |
||
| 3343 | +1618 | |||
| 3344 | +1619 |
- #' @rdname horizontal_sep+ #' @examples |
||
| 3345 | +1620 |
- #' @export+ #' indent_mod(tbl) |
||
| 3346 | +1621 |
- setMethod(+ #' indent_mod(tbl) <- 1L |
||
| 3347 | +1622 |
- "horizontal_sep<-", "TableRow",+ #' tbl |
||
| 3348 | -10505x | +|||
| 1623 | +
- function(obj, value) obj+ #' |
|||
| 3349 | +1624 |
- )+ #' @rdname int_methods |
||
| 3350 | +1625 |
-
+ #' @export |
||
| 3351 | -+ | |||
| 1626 | +1452x |
- ## Section dividers ------------------------------------------------------------+ setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))
|
||
| 3352 | +1627 | |||
| 3353 | +1628 |
- # Used for splits+ #' @rdname int_methods |
||
| 3354 | -1630x | +|||
| 1629 | +
- setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))
+ setMethod( |
|||
| 3355 | +1630 |
-
+ "indent_mod<-", "Split", |
||
| 3356 | +1631 |
- setMethod(+ function(obj, value) {
|
||
| 3357 | -+ | |||
| 1632 | +1x |
- "spl_section_div", "Split",+ obj@indent_modifier <- as.integer(value) |
||
| 3358 | -1630x | +1633 | +1x |
- function(obj) obj@child_section_div+ obj |
| 3359 | +1634 |
- )+ } |
||
| 3360 | +1635 |
-
+ ) |
||
| 3361 | -! | +|||
| 1636 | +
- setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))
+
|
|||
| 3362 | +1637 |
-
+ #' @rdname int_methods |
||
| 3363 | +1638 |
setMethod( |
||
| 3364 | +1639 |
- "spl_section_div<-", "Split",+ "indent_mod<-", "VTableNodeInfo", |
||
| 3365 | +1640 |
function(obj, value) {
|
||
| 3366 | -! | +|||
| 1641 | +1448x |
- obj@child_section_div <- value+ obj@indent_modifier <- as.integer(value) |
||
| 3367 | -! | +|||
| 1642 | +1448x |
obj |
||
| 3368 | +1643 |
} |
||
| 3369 | +1644 |
) |
||
| 3370 | +1645 | |||
| 3371 | +1646 |
- # Used for table object parts+ #' @rdname int_methods |
||
| 3372 | -26919x | +|||
| 1647 | +
- setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
+ setMethod( |
|||
| 3373 | -10574x | +|||
| 1648 | +
- setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
+ "indent_mod<-", "CellValue",+ |
+ |||
| 1649 | ++ |
+ function(obj, value) {
|
||
| 3374 | -5143x | +1650 | +2x |
- setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
+ attr(obj, "indent_mod") <- as.integer(value) |
| 3375 | -11202x | +1651 | +2x |
- setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)
+ obj |
| 3376 | +1652 |
-
+ } |
||
| 3377 | -1629x | +|||
| 1653 | +
- setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
+ ) |
|||
| 3378 | +1654 |
- setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
+
|
||
| 3379 | -1530x | +|||
| 1655 | +
- obj@trailing_section_div <- value+ #' @rdname int_methods |
|||
| 3380 | -1530x | +|||
| 1656 | +
- obj+ setMethod( |
|||
| 3381 | +1657 |
- })+ "indent_mod<-", "RowsVerticalSection", |
||
| 3382 | +1658 |
- setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
+ function(obj, value) {
|
||
| 3383 | -40x | +1659 | +1x |
- obj@trailing_section_div <- value+ if (length(value) != 1 && length(value) != length(obj)) {
|
| 3384 | -40x | +|||
| 1660 | +! |
- obj+ stop( |
||
| 3385 | -+ | |||
| 1661 | +! |
- })+ "When setting indent mods on a RowsVerticalSection the value ",+ |
+ ||
| 1662 | +! | +
+ "must have length 1 or the number of rows" |
||
| 3386 | +1663 |
- setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
+ ) |
||
| 3387 | -59x | +|||
| 1664 | +
- obj@trailing_section_div <- value+ } |
|||
| 3388 | -59x | +1665 | +1x |
- obj+ attr(obj, "indent_mods") <- as.integer(value) |
| 3389 | -+ | |||
| 1666 | +1x |
- })+ obj |
||
| 3390 | +1667 | |||
| 3391 | +1668 |
- #' Section dividers accessor and setter+ ## obj@indent_mods <- value |
||
| 3392 | +1669 |
- #'+ ## obj |
||
| 3393 | +1670 |
- #' `section_div` can be used to set or get the section divider for a table object+ } |
||
| 3394 | +1671 |
- #' produced by [build_table()]. When assigned in post-processing (`section_div<-`)+ ) |
||
| 3395 | +1672 |
- #' the table can have a section divider after every row, each assigned independently.+ |
||
| 3396 | +1673 |
- #' If assigning during layout creation, only [split_rows_by()] (and its related row-wise+ #' @rdname int_methods |
||
| 3397 | +1674 |
- #' splits) and [analyze()] have a `section_div` parameter that will produce separators+ setGeneric( |
||
| 3398 | +1675 |
- #' between split sections and data subgroups, respectively.+ "content_indent_mod", |
||
| 3399 | -+ | |||
| 1676 | +1202x |
- #'+ function(obj) standardGeneric("content_indent_mod")
|
||
| 3400 | +1677 |
- #' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree`+ ) |
||
| 3401 | +1678 |
- #' or `TableRow`/`LabelRow`.+ |
||
| 3402 | +1679 |
- #' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows+ #' @rdname int_methods |
||
| 3403 | +1680 |
- #' you to set the section divider only for sections that are splits or analyses if the number of+ setMethod( |
||
| 3404 | +1681 |
- #' values is less than the number of rows in the table. If `TRUE`, the section divider will+ "content_indent_mod", "Split", |
||
| 3405 | -+ | |||
| 1682 | +1202x |
- #' be set for all rows of the table.+ function(obj) obj@content_indent_modifier |
||
| 3406 | +1683 |
- #' @param value (`character`)\cr vector of single characters to use as section dividers. Each character+ ) |
||
| 3407 | +1684 |
- #' is repeated such that all section dividers span the width of the table. Each character that is+ |
||
| 3408 | +1685 |
- #' not `NA_character_` will produce a trailing separator for each row of the table. `value` length+ #' @rdname int_methods |
||
| 3409 | +1686 |
- #' should reflect the number of rows, or be between 1 and the number of splits/levels.+ setMethod( |
||
| 3410 | +1687 |
- #' See the Details section below for more information.+ "content_indent_mod", "VTableNodeInfo", |
||
| 3411 | -+ | |||
| 1688 | +! |
- #'+ function(obj) obj@content_indent_modifier |
||
| 3412 | +1689 |
- #' @return The section divider string. Each line that does not have a trailing separator+ ) |
||
| 3413 | +1690 |
- #' will have `NA_character_` as section divider.+ |
||
| 3414 | +1691 |
- #'+ #' @rdname int_methods |
||
| 3415 | +1692 |
- #' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global+ setGeneric( |
||
| 3416 | +1693 |
- #' section dividers.+ "content_indent_mod<-", |
||
| 3417 | -+ | |||
| 1694 | +105x |
- #'+ function(obj, value) standardGeneric("content_indent_mod<-")
|
||
| 3418 | +1695 |
- #' @details+ ) |
||
| 3419 | +1696 |
- #' Assigned value to section divider must be a character vector. If any value is `NA_character_`+ |
||
| 3420 | +1697 |
- #' the section divider will be absent for that row or section. When you want to only affect sections+ #' @rdname int_methods |
||
| 3421 | +1698 |
- #' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows.+ setMethod( |
||
| 3422 | +1699 |
- #' Ideally, the length of the vector should be less than the number of splits with, eventually, the+ "content_indent_mod<-", "Split", |
||
| 3423 | +1700 |
- #' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted,+ function(obj, value) {
|
||
| 3424 | -+ | |||
| 1701 | +105x |
- #' only the first split will be affected.+ obj@content_indent_modifier <- as.integer(value) |
||
| 3425 | -+ | |||
| 1702 | +105x |
- #' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table+ obj |
||
| 3426 | +1703 |
- #' construction, the section divider will be set for all the splits and eventually analyses, but+ } |
||
| 3427 | +1704 |
- #' not for the header or each row of the table. This can be set with `header_section_div` in+ ) |
||
| 3428 | +1705 |
- #' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section+ |
||
| 3429 | +1706 |
- #' divider will be set for all the rows of the table.+ #' @rdname int_methods |
||
| 3430 | +1707 |
- #'+ setMethod( |
||
| 3431 | +1708 |
- #' @examples+ "content_indent_mod<-", "VTableNodeInfo", |
||
| 3432 | +1709 |
- #' # Data+ function(obj, value) {
|
||
| 3433 | -+ | |||
| 1710 | +! |
- #' df <- data.frame(+ obj@content_indent_modifier <- as.integer(value) |
||
| 3434 | -+ | |||
| 1711 | +! |
- #' cat = c(+ obj |
||
| 3435 | +1712 |
- #' "really long thing its so ", "long"+ } |
||
| 3436 | +1713 |
- #' ),+ ) |
||
| 3437 | +1714 |
- #' value = c(6, 3, 10, 1)+ |
||
| 3438 | +1715 |
- #' )+ ## TODO export these? |
||
| 3439 | +1716 |
- #' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
+ #' @rdname int_methods |
||
| 3440 | +1717 |
- #'+ #' @export |
||
| 3441 | -+ | |||
| 1718 | +172903x |
- #' tbl <- basic_table() %>%+ setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))
|
||
| 3442 | +1719 |
- #' split_rows_by("cat", section_div = "~") %>%
+
|
||
| 3443 | +1720 |
- #' analyze("value", afun = fast_afun, section_div = " ") %>%
+ #' @rdname int_methods |
||
| 3444 | -+ | |||
| 1721 | +! |
- #' build_table(df)+ setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)
|
||
| 3445 | +1722 |
- #'+ |
||
| 3446 | +1723 |
- #' # Getter+ #' @rdname int_methods |
||
| 3447 | -+ | |||
| 1724 | +66x |
- #' section_div(tbl)+ setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)
|
||
| 3448 | +1725 |
- #'+ |
||
| 3449 | +1726 |
- #' # Setter+ #' @rdname int_methods |
||
| 3450 | -+ | |||
| 1727 | +3602x |
- #' section_div(tbl) <- letters[seq_len(nrow(tbl))]+ setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))
|
||
| 3451 | +1728 |
- #' tbl+ |
||
| 3452 | +1729 |
- #'+ #' @rdname int_methods |
||
| 3453 | -+ | |||
| 1730 | +4998x |
- #' # last letter can appear if there is another table+ setMethod("rawvalues", "ANY", function(obj) obj)
|
||
| 3454 | +1731 |
- #' rbind(tbl, tbl)+ |
||
| 3455 | +1732 |
- #'+ #' @rdname int_methods |
||
| 3456 | -+ | |||
| 1733 | +88719x |
- #' # header_section_div+ setMethod("rawvalues", "CellValue", function(obj) obj[[1]])
|
||
| 3457 | +1734 |
- #' header_section_div(tbl) <- "+"+ |
||
| 3458 | +1735 |
- #' tbl+ #' @rdname int_methods |
||
| 3459 | +1736 |
- #'+ setMethod( |
||
| 3460 | +1737 |
- #' @docType methods+ "rawvalues", "TreePos", |
||
| 3461 | -+ | |||
| 1738 | +228x |
- #' @rdname section_div+ function(obj) rawvalues(pos_splvals(obj)) |
||
| 3462 | +1739 |
- #' @export- |
- ||
| 3463 | -362x | -
- setGeneric("section_div", function(obj) standardGeneric("section_div"))
+ ) |
||
| 3464 | +1740 | |||
| 3465 | +1741 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3466 | +1742 |
- #' @aliases section_div,VTableTree-method+ setMethod( |
||
| 3467 | +1743 |
- setMethod("section_div", "VTableTree", function(obj) {
- |
- ||
| 3468 | -150x | -
- content_row_tbl <- content_table(obj)- |
- ||
| 3469 | -150x | -
- is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL+ "rawvalues", "RowsVerticalSection", |
||
| 3470 | -150x | +1744 | +2x |
- if (labelrow_visible(obj) || is_content_table) {
+ function(obj) unlist(obj, recursive = FALSE) |
| 3471 | -67x | +|||
| 1745 | +
- section_div <- trailing_section_div(obj)+ ) |
|||
| 3472 | -67x | +|||
| 1746 | +
- labelrow_div <- trailing_section_div(tt_labelrow(obj))+ |
|||
| 3473 | -67x | +|||
| 1747 | +
- rest_of_tree <- section_div(tree_children(obj))+ #' @rdname int_methods |
|||
| 3474 | +1748 |
- # Case it is the section itself and not the labels to have a trailing sep+ #' @export |
||
| 3475 | -67x | +1749 | +84311x |
- if (!is.na(section_div)) {
+ setGeneric("value_names", function(obj) standardGeneric("value_names"))
|
| 3476 | -45x | +|||
| 1750 | +
- rest_of_tree[length(rest_of_tree)] <- section_div+ |
|||
| 3477 | +1751 |
- }+ #' @rdname int_methods |
||
| 3478 | -67x | +|||
| 1752 | +
- unname(c(labelrow_div, rest_of_tree))+ setMethod( |
|||
| 3479 | +1753 |
- } else {
+ "value_names", "ANY", |
||
| 3480 | -83x | -
- unname(section_div(tree_children(obj)))- |
- ||
| 3481 | -+ | 1754 | +38x |
- }+ function(obj) as.character(rawvalues(obj)) |
| 3482 | +1755 |
- })+ ) |
||
| 3483 | +1756 | |||
| 3484 | +1757 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3485 | +1758 |
- #' @aliases section_div,list-method+ setMethod( |
||
| 3486 | +1759 |
- setMethod("section_div", "list", function(obj) {
+ "value_names", "TreePos", |
||
| 3487 | -150x | +1760 | +1372x |
- unlist(lapply(obj, section_div))+ function(obj) value_names(pos_splvals(obj)) |
| 3488 | +1761 |
- })+ ) |
||
| 3489 | +1762 | |||
| 3490 | +1763 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3491 | +1764 |
- #' @aliases section_div,TableRow-method+ setMethod( |
||
| 3492 | +1765 |
- setMethod("section_div", "TableRow", function(obj) {
+ "value_names", "list", |
||
| 3493 | -62x | +1766 | +6645x |
- trailing_section_div(obj)+ function(obj) lapply(obj, value_names) |
| 3494 | +1767 |
- })+ ) |
||
| 3495 | +1768 | |||
| 3496 | -- |
- # section_div setter from table object- |
- ||
| 3497 | +1769 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3498 | +1770 |
- #' @export+ setMethod( |
||
| 3499 | +1771 |
- setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
+ "value_names", "ValueWrapper", |
||
| 3500 | -217x | +|||
| 1772 | +! |
- standardGeneric("section_div<-")
+ function(obj) rawvalues(obj) |
||
| 3501 | +1773 |
- })+ ) |
||
| 3502 | +1774 | |||
| 3503 | +1775 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3504 | +1776 |
- #' @aliases section_div<-,VTableTree-method+ setMethod( |
||
| 3505 | +1777 |
- setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
- |
- ||
| 3506 | -90x | -
- char_v <- as.character(value)- |
- ||
| 3507 | -90x | -
- tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1)))+ "value_names", "LevelComboSplitValue", |
||
| 3508 | -90x | +1778 | +1601x |
- max_tree_depth <- max(tree_depths)+ function(obj) obj@value |
| 3509 | -90x | +|||
| 1779 | +
- stopifnot(is.logical(only_sep_sections))+ ) ## obj@comboname) |
|||
| 3510 | -90x | +|||
| 1780 | +
- .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj))+ |
|||
| 3511 | +1781 |
-
+ #' @rdname int_methods |
||
| 3512 | +1782 |
- # Automatic establishment of intent+ setMethod( |
||
| 3513 | -90x | +|||
| 1783 | +
- if (length(char_v) < nrow(obj)) {
+ "value_names", "RowsVerticalSection", |
|||
| 3514 | -3x | +1784 | +3198x |
- only_sep_sections <- TRUE+ function(obj) attr(obj, "row_names", exact = TRUE) |
| 3515 | +1785 |
- }+ ) ## obj@row_names) |
||
| 3516 | +1786 | |||
| 3517 | +1787 |
- # Case where only separators or splits need to change externally+ ## not sure if I need these anywhere |
||
| 3518 | -90x | +|||
| 1788 | +
- if (only_sep_sections && length(char_v) < nrow(obj)) {
+ ## XXX |
|||
| 3519 | +1789 |
- # Case where char_v is longer than the max depth+ #' @rdname int_methods |
||
| 3520 | -3x | +1790 | +5506x |
- char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))]+ setGeneric("value_labels", function(obj) standardGeneric("value_labels"))
|
| 3521 | +1791 |
- # Filling up with NAs the rest of the tree depth section div chr vector+ |
||
| 3522 | -3x | +|||
| 1792 | +
- missing_char_v_len <- max_tree_depth - length(char_v)+ #' @rdname int_methods |
|||
| 3523 | -3x | +|||
| 1793 | +! |
- char_v <- c(char_v, rep(NA_character_, missing_char_v_len))+ setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))
|
||
| 3524 | +1794 |
- }+ |
||
| 3525 | +1795 |
-
+ #' @rdname int_methods |
||
| 3526 | +1796 |
- # Retrieving if it is a contentRow (no need for labelrow to be visible in this case)+ setMethod( |
||
| 3527 | -90x | +|||
| 1797 | +
- content_row_tbl <- content_table(obj)+ "value_labels", "TreePos", |
|||
| 3528 | -90x | +|||
| 1798 | +! |
- is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0+ function(obj) sapply(pos_splvals(obj), obj_label) |
||
| 3529 | +1799 |
-
+ ) |
||
| 3530 | +1800 |
- # Main table structure change- |
- ||
| 3531 | -90x | -
- if (labelrow_visible(obj) || is_content_table) {
+
|
||
| 3532 | -40x | +|||
| 1801 | +
- if (only_sep_sections) {
+ #' @rdname int_methods |
|||
| 3533 | +1802 |
- # Only tables are modified+ setMethod("value_labels", "list", function(obj) {
|
||
| 3534 | -34x | +1803 | +3846x |
- trailing_section_div(tt_labelrow(obj)) <- NA_character_+ ret <- lapply(obj, obj_label) |
| 3535 | -34x | +1804 | +3846x |
- trailing_section_div(obj) <- char_v[1]+ if (!is.null(names(obj))) {
|
| 3536 | -34x | +1805 | +539x |
- section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]+ inds <- vapply(ret, function(x) length(x) == 0, NA) |
| 3537 | -+ | |||
| 1806 | +539x |
- } else {
+ ret[inds] <- names(obj)[inds] |
||
| 3538 | +1807 |
- # All leaves are modified+ } |
||
| 3539 | -6x | +1808 | +3846x |
- trailing_section_div(tt_labelrow(obj)) <- char_v[1]+ ret |
| 3540 | -6x | +|||
| 1809 | +
- trailing_section_div(obj) <- NA_character_+ }) |
|||
| 3541 | -6x | +|||
| 1810 | +
- section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]+ |
|||
| 3542 | +1811 |
- }+ #' @rdname int_methods |
||
| 3543 | +1812 |
- } else {
+ setMethod( |
||
| 3544 | -50x | +|||
| 1813 | +
- section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v+ "value_labels", |
|||
| 3545 | +1814 |
- }+ "RowsVerticalSection", |
||
| 3546 | -90x | +1815 | +1612x |
- obj+ function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj)) |
| 3547 | +1816 |
- })+ ) |
||
| 3548 | +1817 | |||
| 3549 | +1818 |
- #' @rdname section_div+ #' @rdname int_methods+ |
+ ||
| 1819 | +! | +
+ setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))
|
||
| 3550 | +1820 |
- #' @aliases section_div<-,list-method+ |
||
| 3551 | +1821 |
- setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
+ #' @rdname int_methods |
||
| 3552 | -90x | +|||
| 1822 | +
- char_v <- as.character(value)+ setMethod( |
|||
| 3553 | -90x | +|||
| 1823 | +
- for (i in seq_along(obj)) {
+ "value_labels", "LevelComboSplitValue", |
|||
| 3554 | -121x | +|||
| 1824 | +! |
- stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow"))+ function(obj) obj_label(obj) |
||
| 3555 | -121x | +|||
| 1825 | +
- list_element_size <- nrow(obj[[i]])+ ) |
|||
| 3556 | -121x | +|||
| 1826 | +
- if (only_sep_sections) {
+
|
|||
| 3557 | -97x | +|||
| 1827 | +
- char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))]+ #' @rdname int_methods |
|||
| 3558 | -97x | +1828 | +48x |
- char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i)))+ setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)
|
| 3559 | +1829 |
- } else {
- |
- ||
| 3560 | -24x | -
- init <- (i - 1) * list_element_size + 1+ |
||
| 3561 | -24x | +|||
| 1830 | +
- chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1)+ #' @rdname int_methods |
|||
| 3562 | -24x | +1831 | +5578x |
- char_v_i <- char_v[chunk_of_char_v_to_take]+ setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
|
| 3563 | +1832 |
- }+ #' @rdname int_methods |
||
| 3564 | -121x | +1833 | +110x |
- section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i+ setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
|
| 3565 | +1834 |
- }+ #' @rdname int_methods |
||
| 3566 | -90x | +|||
| 1835 | +! |
- obj+ setMethod("value_expr", "ANY", function(obj) NULL)
|
||
| 3567 | +1836 |
- })+ ## no setters for now, we'll see about that. |
||
| 3568 | +1837 | |||
| 3569 | +1838 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3570 | -+ | |||
| 1839 | +6x |
- #' @aliases section_div<-,TableRow-method+ setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))
|
||
| 3571 | +1840 |
- setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
+
|
||
| 3572 | -37x | +|||
| 1841 | +
- trailing_section_div(obj) <- value+ #' @rdname int_methods |
|||
| 3573 | -37x | -
- obj- |
- ||
| 3574 | -+ | 1842 | +6x |
- })+ setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)
|
| 3575 | +1843 | |||
| 3576 | +1844 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3577 | +1845 |
- #' @aliases section_div<-,LabelRow-method+ setGeneric( |
||
| 3578 | +1846 |
- setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
- |
- ||
| 3579 | -! | -
- trailing_section_div(obj) <- value+ "spl_varlabels<-", |
||
| 3580 | -! | +|||
| 1847 | +2x |
- obj+ function(object, value) standardGeneric("spl_varlabels<-")
|
||
| 3581 | +1848 |
- })+ ) |
||
| 3582 | +1849 | |||
| 3583 | +1850 |
- # Helper check function+ #' @rdname int_methods |
||
| 3584 | +1851 |
- .check_char_vector_for_section_div <- function(char_v, min_splits, max) {
+ setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
|
||
| 3585 | -90x | +1852 | +2x |
- lcv <- length(char_v)+ object@var_labels <- value |
| 3586 | -90x | +1853 | +2x |
- if (lcv < 1 || lcv > max) {
+ object |
| 3587 | -! | +|||
| 1854 | +
- stop("section_div must be a vector of length between 1 and numer of table rows.")
+ }) |
|||
| 3588 | +1855 |
- }+ |
||
| 3589 | -90x | +|||
| 1856 | +
- if (lcv > min_splits && lcv < max) {
+ ## These two are similar enough we could probably combine |
|||
| 3590 | -! | +|||
| 1857 | +
- warning(+ ## them but conceptually they are pretty different |
|||
| 3591 | -! | +|||
| 1858 | +
- "section_div will be truncated to the number of splits (", min_splits, ")",
+ ## split_exargs is a list of extra arguments that apply |
|||
| 3592 | -! | +|||
| 1859 | +
- " because it is shorter than the number of rows (", max, ")."
+ ## to *all the chidlren*, |
|||
| 3593 | +1860 |
- )+ ## while splv_extra is for *child-specific* extra arguments, |
||
| 3594 | +1861 |
- }+ ## associated with specific values of the split |
||
| 3595 | -90x | +|||
| 1862 | +
- nchar_check_v <- nchar(char_v)+ #' @rdname int_methods |
|||
| 3596 | -90x | -
- if (any(nchar_check_v > 1, na.rm = TRUE)) {
- |
- ||
| 3597 | -! | -
- stop("section_div must be a vector of single characters or NAs")
- |
- ||
| 3598 | -+ | 1863 | +3645x |
- }+ setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))
|
| 3599 | +1864 |
- }+ |
||
| 3600 | +1865 |
-
+ #' @rdname int_methods |
||
| 3601 | +1866 |
- #' @rdname section_div+ setMethod( |
||
| 3602 | +1867 |
- #' @export+ "splv_extra", "SplitValue", |
||
| 3603 | -597x | +1868 | +3645x |
- setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))
+ function(obj) obj@extra |
| 3604 | +1869 |
-
+ ) |
||
| 3605 | +1870 |
- #' @rdname section_div+ |
||
| 3606 | +1871 |
- #' @aliases header_section_div,PreDataTableLayouts-method+ #' @rdname int_methods |
||
| 3607 | +1872 |
- setMethod(+ setGeneric( |
||
| 3608 | +1873 |
- "header_section_div", "PreDataTableLayouts",+ "splv_extra<-", |
||
| 3609 | -286x | +1874 | +2026x |
- function(obj) obj@header_section_div+ function(obj, value) standardGeneric("splv_extra<-")
|
| 3610 | +1875 |
) |
||
| 3611 | +1876 |
-
+ #' @rdname int_methods |
||
| 3612 | +1877 |
- #' @rdname section_div+ setMethod( |
||
| 3613 | +1878 |
- #' @aliases header_section_div,PreDataTableLayouts-method+ "splv_extra<-", "SplitValue", |
||
| 3614 | +1879 |
- setMethod(+ function(obj, value) {
|
||
| 3615 | -+ | |||
| 1880 | +2026x |
- "header_section_div", "VTableTree",+ obj@extra <- value |
||
| 3616 | -311x | +1881 | +2026x |
- function(obj) obj@header_section_div+ obj |
| 3617 | +1882 |
- )+ } |
||
| 3618 | +1883 |
-
+ ) |
||
| 3619 | +1884 |
- #' @rdname section_div+ |
||
| 3620 | +1885 |
- #' @export+ #' @rdname int_methods |
||
| 3621 | -241x | +1886 | +2191x |
- setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))
+ setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))
|
| 3622 | +1887 | |||
| 3623 | +1888 |
- #' @rdname section_div+ #' @rdname int_methods |
||
| 3624 | +1889 |
- #' @aliases header_section_div<-,PreDataTableLayouts-method+ setMethod( |
||
| 3625 | +1890 |
- setMethod(+ "split_exargs", "Split", |
||
| 3626 | -+ | |||
| 1891 | +2140x |
- "header_section_div<-", "PreDataTableLayouts",+ function(obj) obj@extra_args |
||
| 3627 | +1892 |
- function(obj, value) {
+ ) |
||
| 3628 | -1x | +|||
| 1893 | +
- .check_header_section_div(value)+ |
|||
| 3629 | -1x | +|||
| 1894 | +
- obj@header_section_div <- value+ #' @rdname int_methods |
|||
| 3630 | -1x | +|||
| 1895 | +
- obj+ setGeneric( |
|||
| 3631 | +1896 |
- }+ "split_exargs<-", |
||
| 3632 | -+ | |||
| 1897 | +1x |
- )+ function(obj, value) standardGeneric("split_exargs<-")
|
||
| 3633 | +1898 |
-
+ ) |
||
| 3634 | +1899 |
- #' @rdname section_div+ |
||
| 3635 | +1900 |
- #' @aliases header_section_div<-,PreDataTableLayouts-method+ #' @rdname int_methods |
||
| 3636 | +1901 |
setMethod( |
||
| 3637 | +1902 |
- "header_section_div<-", "VTableTree",+ "split_exargs<-", "Split", |
||
| 3638 | +1903 |
function(obj, value) {
|
||
| 3639 | -240x | -
- .check_header_section_div(value)- |
- ||
| 3640 | -240x | +1904 | +1x |
- obj@header_section_div <- value+ obj@extra_args <- value |
| 3641 | -240x | +1905 | +1x |
obj |
| 3642 | +1906 |
} |
||
| 3643 | +1907 |
) |
||
| 3644 | +1908 | |||
| 1909 | +! | +
+ is_labrow <- function(obj) is(obj, "LabelRow")+ |
+ ||
| 3645 | +1910 |
- .check_header_section_div <- function(chr) {
+
+ |
+ ||
| 1911 | ++ |
+ spl_ref_group <- function(obj) {
|
||
| 3646 | -541x | +1912 | +17x |
- if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
+ stopifnot(is(obj, "VarLevWBaselineSplit")) |
| 3647 | -! | +|||
| 1913 | +17x |
- stop("header_section_div must be a single character or NA_character_ if not used")
+ obj@ref_group_value |
||
| 3648 | +1914 |
- }+ } |
||
| 3649 | -541x | +|||
| 1915 | +
- invisible(TRUE)+ |
|||
| 3650 | +1916 |
- }+ ### column info |
||
| 3651 | +1917 | |||
| 3652 | +1918 |
- #' @rdname section_div+ #' Column information/structure accessors |
||
| 3653 | +1919 |
- #' @export+ #' |
||
| 3654 | -290x | +|||
| 1920 | +
- setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))
+ #' @inheritParams gen_args |
|||
| 3655 | +1921 |
-
+ #' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being |
||
| 3656 | +1922 |
- #' @rdname section_div+ #' generated from a pre-data layout object. |
||
| 3657 | +1923 |
- #' @aliases top_level_section_div,PreDataTableLayouts-method+ #' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only. |
||
| 3658 | +1924 |
- setMethod(+ #' Path (in column structure). |
||
| 3659 | +1925 |
- "top_level_section_div", "PreDataTableLayouts",+ #' @param rtpos (`TreePos`)\cr root position. |
||
| 3660 | -290x | +|||
| 1926 | +
- function(obj) obj@top_level_section_div+ #' |
|||
| 3661 | +1927 |
- )+ #' @return A `LayoutColTree` object. |
||
| 3662 | +1928 |
-
+ #' |
||
| 3663 | +1929 |
- #' @rdname section_div+ #' @rdname col_accessors |
||
| 3664 | +1930 |
#' @export |
||
| 3665 | -1x | +1931 | +3891x |
- setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))
+ setGeneric("clayout", function(obj) standardGeneric("clayout"))
|
| 3666 | +1932 | |||
| 3667 | +1933 |
- #' @rdname section_div+ #' @rdname col_accessors |
||
| 3668 | +1934 |
- #' @aliases top_level_section_div<-,PreDataTableLayouts-method+ #' @exportMethod clayout |
||
| 3669 | +1935 |
setMethod( |
||
| 3670 | -- |
- "top_level_section_div<-", "PreDataTableLayouts",- |
- ||
| 3671 | +1936 |
- function(obj, value) {
- |
- ||
| 3672 | -1x | -
- checkmate::assert_character(value, len = 1, n.chars = 1)- |
- ||
| 3673 | -1x | -
- obj@top_level_section_div <- value+ "clayout", "VTableNodeInfo", |
||
| 3674 | -1x | +1937 | +7x |
- obj+ function(obj) coltree(col_info(obj)) |
| 3675 | +1938 |
- }+ ) |
||
| 3676 | +1939 |
- )+ |
||
| 3677 | +1940 |
-
+ #' @rdname col_accessors |
||
| 3678 | +1941 |
- ## table_inset ----------------------------------------------------------+ #' @exportMethod clayout |
||
| 3679 | +1942 |
-
+ setMethod( |
||
| 3680 | +1943 |
- #' @rdname formatters_methods+ "clayout", "PreDataTableLayouts", |
||
| 3681 | -+ | |||
| 1944 | +3884x |
- #' @export+ function(obj) obj@col_layout |
||
| 3682 | +1945 |
- setMethod(+ ) |
||
| 3683 | +1946 |
- "table_inset", "VTableNodeInfo", ## VTableTree",+ |
||
| 3684 | -316x | +|||
| 1947 | +
- function(obj) obj@table_inset+ ## useful convenience for the cascading methods in colby_constructors |
|||
| 3685 | +1948 |
- )+ #' @rdname col_accessors |
||
| 3686 | +1949 |
-
+ #' @exportMethod clayout |
||
| 3687 | -+ | |||
| 1950 | +! |
- #' @rdname formatters_methods+ setMethod("clayout", "ANY", function(obj) PreDataColLayout())
|
||
| 3688 | +1951 |
- #' @export+ |
||
| 3689 | +1952 |
- setMethod(+ #' @rdname col_accessors |
||
| 3690 | +1953 |
- "table_inset", "PreDataTableLayouts",+ #' @export |
||
| 3691 | -285x | +1954 | +1378x |
- function(obj) obj@table_inset+ setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))
|
| 3692 | +1955 |
- )+ |
||
| 3693 | +1956 |
-
+ #' @rdname col_accessors |
||
| 3694 | +1957 |
- ## #' @rdname formatters_methods+ #' @exportMethod clayout<- |
||
| 3695 | +1958 |
- ## #' @export+ setMethod( |
||
| 3696 | +1959 |
- ## setMethod("table_inset", "InstantiatedColumnInfo",
+ "clayout<-", "PreDataTableLayouts", |
||
| 3697 | +1960 |
- ## function(obj) obj@table_inset)+ function(object, value) {
|
||
| 3698 | -+ | |||
| 1961 | +1378x |
-
+ object@col_layout <- value |
||
| 3699 | -+ | |||
| 1962 | +1378x |
- #' @rdname formatters_methods+ object |
||
| 3700 | +1963 |
- #' @export+ } |
||
| 3701 | +1964 |
- setMethod(+ ) |
||
| 3702 | +1965 |
- "table_inset<-", "VTableNodeInfo", ## "VTableTree",+ |
||
| 3703 | +1966 |
- function(obj, value) {
+ #' @rdname col_accessors |
||
| 3704 | -16005x | +|||
| 1967 | +
- if (!is.integer(value)) {
+ #' @export |
|||
| 3705 | -5x | +1968 | +273372x |
- value <- as.integer(value)+ setGeneric("col_info", function(obj) standardGeneric("col_info"))
|
| 3706 | +1969 |
- }+ |
||
| 3707 | -16005x | +|||
| 1970 | +
- if (is.na(value) || value < 0) {
+ #' @rdname col_accessors |
|||
| 3708 | -! | +|||
| 1971 | +
- stop("Got invalid table_inset value, must be an integer > 0")
+ #' @exportMethod col_info |
|||
| 3709 | +1972 |
- }+ setMethod( |
||
| 3710 | -16005x | +|||
| 1973 | +
- cont <- content_table(obj)+ "col_info", "VTableNodeInfo", |
|||
| 3711 | -16005x | +1974 | +239837x |
- if (NROW(cont) > 0) {
+ function(obj) obj@col_info |
| 3712 | -1433x | +|||
| 1975 | +
- table_inset(cont) <- value+ ) |
|||
| 3713 | -1433x | +|||
| 1976 | +
- content_table(obj) <- cont+ |
|||
| 3714 | +1977 |
- }+ ### XXX I've made this recursive. Do we ALWAYS want it to be? |
||
| 3715 | +1978 |
-
+ ### |
||
| 3716 | -16005x | +|||
| 1979 | +
- if (length(tree_children(obj)) > 0) {
+ ### I think we do. |
|||
| 3717 | -4880x | +|||
| 1980 | +
- kids <- lapply(tree_children(obj),+ #' @rdname col_accessors |
|||
| 3718 | -4880x | +|||
| 1981 | +
- `table_inset<-`,+ #' @export |
|||
| 3719 | -4880x | +1982 | +70391x |
- value = value+ setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))
|
| 3720 | +1983 |
- )+ |
||
| 3721 | -4880x | +|||
| 1984 | +
- tree_children(obj) <- kids+ #' @return Returns various information about columns, depending on the accessor used. |
|||
| 3722 | +1985 |
- }+ #' |
||
| 3723 | -16005x | +|||
| 1986 | +
- obj@table_inset <- value+ #' @exportMethod col_info<- |
|||
| 3724 | -16005x | +|||
| 1987 | +
- obj+ #' @rdname col_accessors |
|||
| 3725 | +1988 |
- }+ setMethod( |
||
| 3726 | +1989 |
- )+ "col_info<-", "TableRow", |
||
| 3727 | +1990 |
-
+ function(obj, value) {
|
||
| 3728 | -+ | |||
| 1991 | +42161x |
- #' @rdname formatters_methods+ obj@col_info <- value+ |
+ ||
| 1992 | +42161x | +
+ obj |
||
| 3729 | +1993 |
- #' @export+ } |
||
| 3730 | +1994 |
- setMethod(+ ) |
||
| 3731 | +1995 |
- "table_inset<-", "PreDataTableLayouts",+ |
||
| 3732 | +1996 |
- function(obj, value) {
+ .set_cinfo_kids <- function(obj) {
|
||
| 3733 | -! | +|||
| 1997 | +21918x |
- if (!is.integer(value)) {
+ kids <- lapply( |
||
| 3734 | -! | +|||
| 1998 | +21918x |
- value <- as.integer(value)+ tree_children(obj), |
||
| 3735 | -+ | |||
| 1999 | +21918x |
- }+ function(x) {
|
||
| 3736 | -! | +|||
| 2000 | +51825x |
- if (is.na(value) || value < 0) {
+ col_info(x) <- col_info(obj) |
||
| 3737 | -! | +|||
| 2001 | +51825x |
- stop("Got invalid table_inset value, must be an integer > 0")
+ x |
||
| 3738 | +2002 |
} |
||
| 3739 | +2003 | - - | -||
| 3740 | -! | -
- obj@table_inset <- value+ ) |
||
| 3741 | -! | +|||
| 2004 | +21918x |
- obj+ tree_children(obj) <- kids |
||
| 3742 | -+ | |||
| 2005 | +21918x |
- }+ obj |
||
| 3743 | +2006 |
- )+ } |
||
| 3744 | +2007 | |||
| 3745 | +2008 |
- #' @rdname formatters_methods+ #' @rdname col_accessors |
||
| 3746 | +2009 |
- #' @export+ #' @exportMethod col_info<- |
||
| 3747 | +2010 |
setMethod( |
||
| 3748 | +2011 |
- "table_inset<-", "InstantiatedColumnInfo",+ "col_info<-", "ElementaryTable", |
||
| 3749 | +2012 |
function(obj, value) {
|
||
| 3750 | -! | +|||
| 2013 | +14198x |
- if (!is.integer(value)) {
+ obj@col_info <- value |
||
| 3751 | -! | +|||
| 2014 | +14198x |
- value <- as.integer(value)+ .set_cinfo_kids(obj) |
||
| 3752 | +2015 |
- }+ } |
||
| 3753 | -! | +|||
| 2016 | +
- if (is.na(value) || value < 0) {
+ ) |
|||
| 3754 | -! | +|||
| 2017 | +
- stop("Got invalid table_inset value, must be an integer > 0")
+
|
|||
| 3755 | +2018 |
- }+ #' @rdname col_accessors |
||
| 3756 | -! | +|||
| 2019 | +
- obj@table_inset <- value+ #' @exportMethod col_info<- |
|||
| 3757 | -! | +|||
| 2020 | +
- obj+ setMethod( |
|||
| 3758 | +2021 |
- }+ "col_info<-", "TableTree", |
||
| 3759 | +2022 |
- )+ function(obj, value) {
|
| 1 | -+ | |||
| 2023 | +7720x |
- #' Variable associated with a split+ obj@col_info <- value |
||
| 2 | -+ | |||
| 2024 | +7720x |
- #'+ if (nrow(content_table(obj))) {
|
||
| 3 | -+ | |||
| 2025 | +2010x |
- #' This function is intended for use when writing custom splitting logic. In cases where the split is associated with+ ct <- content_table(obj) |
||
| 4 | -+ | |||
| 2026 | +2010x |
- #' a single variable, the name of that variable will be returned. At time of writing this includes splits generated+ col_info(ct) <- value |
||
| 5 | -+ | |||
| 2027 | +2010x |
- #' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],+ content_table(obj) <- ct |
||
| 6 | +2028 |
- #' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.+ } |
||
| 7 | -+ | |||
| 2029 | +7720x |
- #'+ .set_cinfo_kids(obj) |
||
| 8 | +2030 |
- #' @param spl (`VarLevelSplit`)\cr the split object.+ } |
||
| 9 | +2031 |
- #'+ ) |
||
| 10 | +2032 |
- #' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.+ |
||
| 11 | +2033 |
- #'+ #' @rdname col_accessors |
||
| 12 | +2034 |
- #' @export+ #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for column |
||
| 13 | +2035 |
- #' @seealso \code{\link{make_split_fun}}
+ #' counts throughout this column tree (i.e. if not overridden by a more specific format |
||
| 14 | -2x | +|||
| 2036 | +
- setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
+ #' specification). |
|||
| 15 | +2037 |
-
+ #' @export |
||
| 16 | +2038 |
- #' @rdname spl_variable+ setGeneric( |
||
| 17 | +2039 |
- #' @export+ "coltree", |
||
| 18 | -1x | +2040 | +12124x |
- setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
+ function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format = "(N=xx)") standardGeneric("coltree")
|
| 19 | +2041 |
-
+ ) |
||
| 20 | +2042 |
- #' @rdname spl_variable+ |
||
| 21 | +2043 |
- #' @export+ #' @rdname col_accessors |
||
| 22 | -! | +|||
| 2044 | +
- setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
+ #' @exportMethod coltree |
|||
| 23 | +2045 |
-
+ setMethod( |
||
| 24 | +2046 |
- #' @rdname spl_variable+ "coltree", "InstantiatedColumnInfo", |
||
| 25 | +2047 |
- #' @export+ function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format) {
+ |
+ ||
| 2048 | +7978x | +
+ if (!is.null(df)) {
|
||
| 26 | +2049 | ! |
- setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
+ warning("Ignoring df argument and retrieving already-computed LayoutColTree")
|
|
| 27 | +2050 |
-
+ }+ |
+ ||
| 2051 | +7978x | +
+ obj@tree_layout |
||
| 28 | +2052 |
- #' @rdname spl_variable+ } |
||
| 29 | +2053 |
- #' @export+ ) |
||
| 30 | +2054 |
- setMethod(+ |
||
| 31 | +2055 |
- "spl_variable", "Split",+ #' @rdname col_accessors |
||
| 32 | -1x | +|||
| 2056 | +
- function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
+ #' @export coltree |
|||
| 33 | +2057 |
- )+ setMethod( |
||
| 34 | +2058 |
-
+ "coltree", "PreDataTableLayouts", |
||
| 35 | +2059 |
- in_col_split <- function(spl_ctx) {
+ function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
|
||
| 36 | -! | +|||
| 2060 | +1x |
- identical(+ coltree(clayout(obj), df, rtpos, alt_counts_df = alt_counts_df, ccount_format = ccount_format) |
||
| 37 | -! | +|||
| 2061 | +
- names(spl_ctx),+ } |
|||
| 38 | -! | +|||
| 2062 | +
- names(context_df_row(cinfo = NULL))+ ) |
|||
| 39 | +2063 |
- )+ |
||
| 40 | +2064 |
- }+ #' @rdname col_accessors |
||
| 41 | +2065 |
-
+ #' @export coltree |
||
| 42 | +2066 |
- assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
+ setMethod( |
||
| 43 | -45x | +|||
| 2067 | +
- msg_2_append <- ""+ "coltree", "PreDataColLayout", |
|||
| 44 | -45x | +|||
| 2068 | +
- if (!is.null(component)) {
+ function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
|
|||
| 45 | -33x | +2069 | +319x |
- msg_2_append <- paste0(+ obj <- set_def_child_ord(obj, df) |
| 46 | -33x | +2070 | +319x |
- "Invalid split function constructed by upstream call to ",+ kids <- lapply( |
| 47 | -33x | +2071 | +319x |
- "make_split_fun. Problem source: ",+ obj, |
| 48 | -33x | +2072 | +319x |
- component, " argument."+ function(x) {
|
| 49 | -+ | |||
| 2073 | +327x |
- )+ splitvec_to_coltree( |
||
| 50 | -+ | |||
| 2074 | +327x |
- }+ df = df, |
||
| 51 | -45x | +2075 | +327x |
- if (!(nm %in% names(pinfo))) {
+ splvec = x, |
| 52 | -! | +|||
| 2076 | +327x |
- stop(+ pos = rtpos, |
||
| 53 | -! | +|||
| 2077 | +327x |
- "Split result does not have required element: ", nm, ".",+ alt_counts_df = alt_counts_df, |
||
| 54 | -! | +|||
| 2078 | +327x |
- msg_2_append+ global_cc_format = ccount_format |
||
| 55 | +2079 |
- )+ ) |
||
| 56 | +2080 |
- }- |
- ||
| 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 | +2081 |
) |
||
| 62 | -+ | |||
| 2082 | +312x |
- }+ if (length(kids) == 1) {
|
||
| 63 | -45x | +2083 | +305x |
- TRUE+ res <- kids[[1]] |
| 64 | +2084 |
- }+ } else {
|
||
| 65 | -+ | |||
| 2085 | +7x |
-
+ res <- LayoutColTree( |
||
| 66 | -+ | |||
| 2086 | +7x |
- validate_split_result <- function(pinfo, component = NULL) {
+ lev = 0L, |
||
| 67 | -15x | +2087 | +7x |
- assert_splres_element(pinfo, "datasplit", component = component)+ kids = kids, |
| 68 | -15x | +2088 | +7x |
- len <- length(pinfo$datasplit)+ tpos = rtpos, |
| 69 | -15x | +2089 | +7x |
- assert_splres_element(pinfo, "values", len, component = component)+ spl = RootSplit(), |
| 70 | -15x | +2090 | +7x |
- assert_splres_element(pinfo, "labels", len, component = component)+ colcount = NROW(alt_counts_df), |
| 71 | -15x | +2091 | +7x |
- TRUE+ colcount_format = ccount_format |
| 72 | +2092 |
- }+ ) |
||
| 73 | +2093 |
-
+ } |
||
| 74 | -+ | |||
| 2094 | +312x |
- #' Construct split result object+ disp_ccounts(res) <- disp_ccounts(obj) |
||
| 75 | -+ | |||
| 2095 | +312x |
- #'+ res |
||
| 76 | +2096 |
- #' These functions can be used to create or add to a split result in functions which implement core splitting or+ } |
||
| 77 | +2097 |
- #' post-processing within a custom split function.+ ) |
||
| 78 | +2098 |
- #'+ |
||
| 79 | +2099 |
- #' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.+ #' @rdname col_accessors |
||
| 80 | +2100 |
- #' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.+ #' @export coltree |
||
| 81 | +2101 |
- #' @param labels (`character`)\cr the labels associated with each facet.+ setMethod( |
||
| 82 | +2102 |
- #' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to+ "coltree", "LayoutColTree", |
||
| 83 | +2103 |
- #' analysis functions applied within the facet.+ function(obj, df, rtpos, alt_counts_df, ccount_format) obj |
||
| 84 | +2104 |
- #' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,+ ) |
||
| 85 | +2105 |
- #' created with `quote()`) to be used during column subsetting.+ |
||
| 86 | +2106 |
- #'+ #' @rdname col_accessors |
||
| 87 | +2107 |
- #' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and+ #' @export coltree |
||
| 88 | +2108 |
- #' `labels`, which are the same length and correspond to each other element-wise.+ setMethod( |
||
| 89 | +2109 |
- #'+ "coltree", "VTableTree", |
||
| 90 | +2110 |
- #' @details+ function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj)) |
||
| 91 | +2111 |
- #' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables+ ) |
||
| 92 | +2112 |
- #' internals expect it, most of which are not relevant to end users.+ |
||
| 93 | +2113 |
- #'+ #' @rdname col_accessors |
||
| 94 | +2114 |
- #' @note Column splitting will not work correctly if a split function+ #' @export coltree |
||
| 95 | +2115 |
- #' calls `make_split_result` without specifying subset expressions;+ setMethod( |
||
| 96 | +2116 |
- #' row splitting will work as normal. This is due to the fact that+ "coltree", "TableRow", |
||
| 97 | +2117 |
- #' subsetting expressions are used during column splitting to+ function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj)) |
||
| 98 | +2118 |
- #' represent the data associated with facets, while actual data+ ) |
||
| 99 | +2119 |
- #' subsets are used during row splitting.+ |
||
| 100 | -+ | |||
| 2120 | +926x |
- #'+ setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
|
||
| 101 | +2121 |
- #' @examples+ setMethod( |
||
| 102 | +2122 |
- #' splres <- make_split_result(+ "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
|
||
| 103 | +2123 |
- #' values = c("hi", "lo"),
+ function(obj, value) {
|
||
| 104 | -+ | |||
| 2124 | +499x |
- #' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),+ obj@tree_layout <- value |
||
| 105 | -+ | |||
| 2125 | +499x |
- #' labels = c("more data", "less data"),
+ obj |
||
| 106 | +2126 |
- #' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))+ } |
||
| 107 | +2127 |
- #' )+ ) |
||
| 108 | +2128 |
- #'+ |
||
| 109 | +2129 |
- #' splres2 <- add_to_split_result(splres,+ setMethod( |
||
| 110 | +2130 |
- #' values = "med",+ "coltree<-", c("VTableTree", "LayoutColTree"),
|
||
| 111 | +2131 |
- #' datasplit = list(med = mtcars[1:20, ]),+ function(obj, value) {
|
||
| 112 | -+ | |||
| 2132 | +427x |
- #' labels = "kinda some data",+ cinfo <- col_info(obj) |
||
| 113 | -+ | |||
| 2133 | +427x |
- #' subset_exprs = quote(seq_along(wt) <= 20)+ coltree(cinfo) <- value |
||
| 114 | -+ | |||
| 2134 | +427x |
- #' )+ col_info(obj) <- cinfo |
||
| 115 | -+ | |||
| 2135 | +427x |
- #'+ obj |
||
| 116 | +2136 |
- #' @family make_custom_split+ } |
||
| 117 | +2137 |
- #' @rdname make_split_result+ ) |
||
| 118 | +2138 |
- #' @export+ |
||
| 119 | +2139 |
- #' @family make_custom_split+ #' @rdname col_accessors |
||
| 120 | +2140 |
- make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
+ #' @export |
||
| 121 | -9x | -
- if (length(values) == 1 && is(datasplit, "data.frame")) {
- |
- ||
| 122 | -! | +2141 | +124014x |
- datasplit <- list(datasplit)+ setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))
|
| 123 | +2142 |
- }+ |
||
| 124 | -9x | +|||
| 2143 | +
- ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)+ #' @rdname col_accessors |
|||
| 125 | -9x | +|||
| 2144 | +
- if (!is.null(extras)) {
+ #' @export col_exprs |
|||
| 126 | -! | +|||
| 2145 | +
- ret$extras <- extras+ setMethod( |
|||
| 127 | +2146 |
- }+ "col_exprs", "PreDataTableLayouts", |
||
| 128 | -9x | +2147 | +1x |
- .fixupvals(ret)+ function(obj, df = NULL) col_exprs(clayout(obj), df) |
| 129 | +2148 |
- }+ ) |
||
| 130 | +2149 | |||
| 131 | +2150 |
- #' @param splres (`list`)\cr a list representing the result of splitting.+ #' @rdname col_accessors |
||
| 132 | +2151 |
- #'+ #' @export col_exprs |
||
| 133 | +2152 |
- #' @rdname make_split_result+ setMethod( |
||
| 134 | +2153 |
- #' @export+ "col_exprs", "PreDataColLayout", |
||
| 135 | +2154 |
- add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
+ function(obj, df = NULL) {
|
||
| 136 | -4x | +2155 | +1x |
- validate_split_result(splres)+ if (is.null(df)) {
|
| 137 | -4x | -
- newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))- |
- ||
| 138 | -4x | -
- ret <- lapply(- |
- ||
| 139 | -4x | -
- names(splres),- |
- ||
| 140 | -4x | +|||
| 2156 | +! |
- function(nm) c(splres[[nm]], newstuff[[nm]])+ stop("can't determine col_exprs without data")
|
||
| 141 | +2157 |
- )+ } |
||
| 142 | -4x | +2158 | +1x |
- names(ret) <- names(splres)+ ct <- coltree(obj, df = df) |
| 143 | -4x | +2159 | +1x |
- .fixupvals(ret)+ make_col_subsets(ct, df = df) |
| 144 | +2160 |
- }+ } |
||
| 145 | +2161 |
-
+ ) |
||
| 146 | +2162 | |||
| 147 | -13x | +|||
| 2163 | +
- .can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
+ #' @rdname col_accessors |
|||
| 148 | +2164 |
-
+ #' @export col_exprs |
||
| 149 | +2165 |
- #' Create a custom splitting function+ setMethod( |
||
| 150 | +2166 |
- #'+ "col_exprs", "InstantiatedColumnInfo", |
||
| 151 | +2167 |
- #' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that+ function(obj, df = NULL) {
|
||
| 152 | -+ | |||
| 2168 | +124012x |
- #' should split via `core_split`. They will be called on the data in the order they appear in the list.+ if (!is.null(df)) {
|
||
| 153 | -+ | |||
| 2169 | +! |
- #' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that+ warning("Ignoring df method when extracted precomputed column subsetting expressions.")
|
||
| 154 | +2170 |
- #' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior+ } |
||
| 155 | -+ | |||
| 2171 | +124012x |
- #' cannot be used in column splits.+ obj@subset_exprs |
||
| 156 | +2172 |
- #' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting.+ } |
||
| 157 | +2173 |
- #'+ ) |
||
| 158 | +2174 |
- #' @details+ |
||
| 159 | +2175 |
- #' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:+ #' @rdname int_methods |
||
| 160 | -+ | |||
| 2176 | +2548x |
- #'+ setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))
|
||
| 161 | +2177 |
- #' 1. Pre-processing of the incoming data to be split.+ |
||
| 162 | +2178 |
- #' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets.+ #' @rdname int_methods |
||
| 163 | +2179 |
- #' 3. Post-processing operations on the set of facets (groups) generated by the split.+ setMethod( |
||
| 164 | +2180 |
- #'+ "col_extra_args", "InstantiatedColumnInfo", |
||
| 165 | +2181 |
- #' This function provides an interface to create custom split functions by implementing and specifying sets of+ function(obj, df) {
|
||
| 166 | -+ | |||
| 2182 | +2236x |
- #' operations in each of those classes of customization independently.+ if (!is.null(df)) {
|
||
| 167 | -+ | |||
| 2183 | +! |
- #'+ warning("Ignorning df when retrieving already-computed column extra arguments.")
|
||
| 168 | +2184 |
- #' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept+ } |
||
| 169 | -+ | |||
| 2185 | +2236x |
- #' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.+ obj@cextra_args |
||
| 170 | +2186 |
- #' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if+ } |
||
| 171 | +2187 |
- #' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables,+ ) |
||
| 172 | +2188 |
- #' because they will not be present when validity checking is done).+ |
||
| 173 | +2189 |
- #'+ #' @rdname int_methods |
||
| 174 | +2190 |
- #' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones+ setMethod( |
||
| 175 | +2191 |
- #' or to reorder levels based on observed counts, etc.+ "col_extra_args", "PreDataTableLayouts", |
||
| 176 | +2192 |
- #'+ function(obj, df) col_extra_args(clayout(obj), df) |
||
| 177 | +2193 |
- #' Core splitting functions override the fundamental+ ) |
||
| 178 | +2194 |
- #' splitting procedure, and are only necessary in rare cases. These+ |
||
| 179 | +2195 |
- #' must accept `spl`, `df`, `vals`, `labels`, and can optionally+ #' @rdname int_methods |
||
| 180 | +2196 |
- #' accept `.spl_context`. They should return a split result object+ setMethod( |
||
| 181 | +2197 |
- #' constructed via `make_split_result()`.+ "col_extra_args", "PreDataColLayout", |
||
| 182 | +2198 |
- #'+ function(obj, df) {
|
||
| 183 | -+ | |||
| 2199 | +! |
- #' In particular, if the custom split function will be used in+ col_extra_args(coltree(obj, df), NULL) |
||
| 184 | +2200 |
- #' column space, subsetting expressions (e.g., as returned by+ } |
||
| 185 | +2201 |
- #' `quote()` or `bquote` must be provided, while they are+ ) |
||
| 186 | +2202 |
- #' optional (and largely ignored, currently) in row space.+ |
||
| 187 | +2203 |
- #'+ #' @rdname int_methods |
||
| 188 | +2204 |
- #'+ setMethod( |
||
| 189 | +2205 |
- #' Post-processing functions (3) must accept the result of the core split as their first argument (which can be+ "col_extra_args", "LayoutColTree", |
||
| 190 | +2206 |
- #' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a+ function(obj, df) {
|
||
| 191 | -+ | |||
| 2207 | +312x |
- #' modified version of the same structure specified above for core splitting.+ if (!is.null(df)) {
|
||
| 192 | -+ | |||
| 2208 | +! |
- #'+ warning("Ignoring df argument and returning already calculated extra arguments")
|
||
| 193 | +2209 |
- #' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied+ } |
||
| 194 | -+ | |||
| 2210 | +312x |
- #' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).+ get_col_extras(obj) |
||
| 195 | +2211 |
- #'+ } |
||
| 196 | +2212 |
- #' @return A custom function that can be used as a split function.+ ) |
||
| 197 | +2213 |
- #'+ |
||
| 198 | +2214 |
- #' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.+ #' @rdname int_methods |
||
| 199 | +2215 |
- #'+ setMethod( |
||
| 200 | +2216 |
- #' @examples+ "col_extra_args", "LayoutColLeaf", |
||
| 201 | +2217 |
- #' mysplitfun <- make_split_fun(+ function(obj, df) {
|
||
| 202 | -+ | |||
| 2218 | +! |
- #' pre = list(drop_facet_levels),+ if (!is.null(df)) {
|
||
| 203 | -+ | |||
| 2219 | +! |
- #' post = list(add_overall_facet("ALL", "All Arms"))
+ warning("Ignoring df argument and returning already calculated extra arguments")
|
||
| 204 | +2220 |
- #' )+ } |
||
| 205 | +2221 |
- #'+ |
||
| 206 | -+ | |||
| 2222 | +! |
- #' basic_table(show_colcounts = TRUE) %>%+ get_pos_extra(pos = tree_pos(obj)) |
||
| 207 | +2223 |
- #' split_cols_by("ARM", split_fun = mysplitfun) %>%
+ } |
||
| 208 | +2224 |
- #' analyze("AGE") %>%
+ ) |
||
| 209 | +2225 |
- #' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
+
|
||
| 210 | +2226 |
- #'+ #' @seealso [facet_colcount()] |
||
| 211 | +2227 |
- #' ## post (and pre) arguments can take multiple functions, here+ #' @export |
||
| 212 | +2228 |
- #' ## we add an overall facet and the reorder the facets+ #' @rdname col_accessors |
||
| 213 | -+ | |||
| 2229 | +2014x |
- #' reorder_facets <- function(splret, spl, fulldf, ...) {
+ setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))
|
||
| 214 | +2230 |
- #' ord <- order(names(splret$values))+ |
||
| 215 | +2231 |
- #' make_split_result(+ #' @export |
||
| 216 | +2232 |
- #' splret$values[ord],+ #' @rdname col_accessors |
||
| 217 | +2233 |
- #' splret$datasplit[ord],+ setMethod( |
||
| 218 | +2234 |
- #' splret$labels[ord]+ "col_counts", "InstantiatedColumnInfo", |
||
| 219 | +2235 |
- #' )+ function(obj, path = NULL) {
|
||
| 220 | -+ | |||
| 2236 | +1999x |
- #' }+ if (is.null(path)) {
|
||
| 221 | -+ | |||
| 2237 | +1998x |
- #'+ lfs <- collect_leaves(coltree(obj)) |
||
| 222 | -+ | |||
| 2238 | +1998x |
- #' mysplitfun2 <- make_split_fun(+ ret <- vapply(lfs, facet_colcount, 1L, path = NULL) |
||
| 223 | +2239 |
- #' pre = list(drop_facet_levels),+ } else {
|
||
| 224 | -+ | |||
| 2240 | +1x |
- #' post = list(+ ret <- facet_colcount(obj, path) |
||
| 225 | +2241 |
- #' add_overall_facet("ALL", "All Arms"),
+ } |
||
| 226 | +2242 |
- #' reorder_facets+ ## required for strict backwards compatibility, |
||
| 227 | +2243 |
- #' )+ ## even though its undesirable behavior. |
||
| 228 | -+ | |||
| 2244 | +1999x |
- #' )+ unname(ret) |
||
| 229 | +2245 |
- #' basic_table(show_colcounts = TRUE) %>%+ } |
||
| 230 | +2246 |
- #' split_cols_by("ARM", split_fun = mysplitfun2) %>%
+ ) |
||
| 231 | +2247 |
- #' analyze("AGE") %>%
+
|
||
| 232 | +2248 |
- #' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
+ #' @export |
||
| 233 | +2249 |
- #'+ #' @rdname col_accessors |
||
| 234 | +2250 |
- #' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
+ setMethod( |
||
| 235 | +2251 |
- #' make_split_result(c("stupid", "silly"),
+ "col_counts", "VTableNodeInfo", |
||
| 236 | -+ | |||
| 2252 | +15x |
- #' datasplit = list(df[1:10, ], df[11:30, ]),+ function(obj, path = NULL) col_counts(col_info(obj), path = path) |
||
| 237 | +2253 |
- #' labels = c("first 10", "second 20")
+ ) |
||
| 238 | +2254 |
- #' )+ |
||
| 239 | +2255 |
- #' }+ #' @export |
||
| 240 | +2256 |
- #'+ #' @rdname col_accessors |
||
| 241 | -+ | |||
| 2257 | +14x |
- #' dumb_30_facet <- add_combo_facet("dumb",
+ setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))
|
||
| 242 | +2258 |
- #' label = "thirty patients",+ |
||
| 243 | +2259 |
- #' levels = c("stupid", "silly")
+ #' @export |
||
| 244 | +2260 |
- #' )+ #' @rdname col_accessors |
||
| 245 | +2261 |
- #' nonsense_splfun <- make_split_fun(+ setMethod( |
||
| 246 | +2262 |
- #' core_split = very_stupid_core,+ "col_counts<-", "InstantiatedColumnInfo", |
||
| 247 | +2263 |
- #' post = list(dumb_30_facet)+ function(obj, path = NULL, value) {
|
||
| 248 | +2264 |
- #' )+ ## obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value |
||
| 249 | +2265 |
- #'+ ## obj |
||
| 250 | -+ | |||
| 2266 | +9x |
- #' ## recall core split overriding is not supported in column space+ if (!is.null(path)) {
|
||
| 251 | -+ | |||
| 2267 | +1x |
- #' ## currently, but we can see it in action in row space+ all_paths <- list(path) |
||
| 252 | +2268 |
- #'+ } else {
|
||
| 253 | -+ | |||
| 2269 | +8x |
- #' lyt_silly <- basic_table() %>%+ all_paths <- make_col_df(obj, visible_only = TRUE)$path |
||
| 254 | +2270 |
- #' split_rows_by("ARM", split_fun = nonsense_splfun) %>%
+ } |
||
| 255 | -+ | |||
| 2271 | +9x |
- #' summarize_row_groups() %>%+ if (length(value) != length(all_paths)) {
|
||
| 256 | -+ | |||
| 2272 | +! |
- #' analyze("AGE")
+ stop( |
||
| 257 | -+ | |||
| 2273 | +! |
- #' silly_table <- build_table(lyt_silly, DM)+ "Got ", length(value), " values for ", |
||
| 258 | -+ | |||
| 2274 | +! |
- #' silly_table+ length(all_paths), " column paths", |
||
| 259 | -+ | |||
| 2275 | +! |
- #'+ if (is.null(path)) " (from path = NULL)", |
||
| 260 | +2276 |
- #' @family make_custom_split+ "." |
||
| 261 | +2277 |
- #' @export+ ) |
||
| 262 | +2278 |
- make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
+ } |
||
| 263 | -7x | +2279 | +9x |
- function(df,+ ctree <- coltree(obj) |
| 264 | -7x | +2280 | +9x |
- spl,+ for (i in seq_along(all_paths)) {
|
| 265 | -7x | +2281 | +73x |
- vals = NULL,+ facet_colcount(ctree, all_paths[[i]]) <- value[i] |
| 266 | -7x | +|||
| 2282 | +
- labels = NULL,+ } |
|||
| 267 | -7x | +2283 | +9x |
- trim = FALSE,+ coltree(obj) <- ctree |
| 268 | -7x | +2284 | +9x |
- .spl_context) {
+ obj |
| 269 | -11x | +|||
| 2285 | +
- orig_columns <- names(df)+ } |
|||
| 270 | -11x | +|||
| 2286 | +
- for (pre_fn in pre) {
+ ) |
|||
| 271 | -5x | +|||
| 2287 | +
- if (.can_take_spl_context(pre_fn)) {
+
|
|||
| 272 | -5x | +|||
| 2288 | +
- df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)+ #' @export |
|||
| 273 | +2289 |
- } else {
+ #' @rdname col_accessors |
||
| 274 | -! | +|||
| 2290 | +
- df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)+ setMethod( |
|||
| 275 | +2291 |
- }+ "col_counts<-", "VTableNodeInfo", |
||
| 276 | -3x | +|||
| 2292 | +
- if (!is(df, "data.frame")) {
+ function(obj, path = NULL, value) {
|
|||
| 277 | -! | +|||
| 2293 | +5x |
- stop(+ cinfo <- col_info(obj) |
||
| 278 | -! | +|||
| 2294 | +5x |
- "Error in custom split function, pre-split step did not return a data.frame. ",+ col_counts(cinfo, path = path) <- value |
||
| 279 | -! | +|||
| 2295 | +5x |
- "See upstream call to make_split_fun for original source of error."+ col_info(obj) <- cinfo |
||
| 280 | -+ | |||
| 2296 | +5x |
- )+ obj |
||
| 281 | +2297 |
- }+ } |
||
| 282 | +2298 |
- }+ ) |
||
| 283 | +2299 | |||
| 284 | -9x | +|||
| 2300 | +
- if (!all(orig_columns %in% names(df))) {
+ #' @export |
|||
| 285 | -! | +|||
| 2301 | +
- stop(+ #' @rdname col_accessors |
|||
| 286 | -! | +|||
| 2302 | +1592x |
- "Preprocessing functions(s) in custom split function removed a column from the incoming data.",+ setGeneric("col_total", function(obj) standardGeneric("col_total"))
|
||
| 287 | -! | +|||
| 2303 | +
- " This is not supported. See upstread make_split_fun call (pre argument) for original source of error."+ |
|||
| 288 | +2304 |
- )+ #' @export |
||
| 289 | +2305 |
- }+ #' @rdname col_accessors |
||
| 290 | +2306 |
-
+ setMethod( |
||
| 291 | -9x | +|||
| 2307 | +
- if (is.null(core_split)) {
+ "col_total", "InstantiatedColumnInfo", |
|||
| 292 | -7x | +2308 | +1591x |
- ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)+ function(obj) obj@total_count |
| 293 | +2309 |
- } else {
- |
- ||
| 294 | -2x | -
- ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)+ ) |
||
| 295 | -2x | +|||
| 2310 | +
- validate_split_result(ret, component = "core_split")+ |
|||
| 296 | +2311 |
- }+ #' @export |
||
| 297 | +2312 |
-
+ #' @rdname col_accessors |
||
| 298 | -9x | +|||
| 2313 | +
- for (post_fn in post) {
+ setMethod( |
|||
| 299 | -8x | +|||
| 2314 | +
- if (.can_take_spl_context(post_fn)) {
+ "col_total", "VTableNodeInfo", |
|||
| 300 | -8x | +2315 | +1x |
- ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)+ function(obj) col_total(col_info(obj)) |
| 301 | +2316 |
- } else {
+ ) |
||
| 302 | -! | +|||
| 2317 | +
- ret <- post_fn(ret, spl = spl, fulldf = df)+ |
|||
| 303 | +2318 |
- }+ #' @export |
||
| 304 | +2319 |
- }+ #' @rdname col_accessors |
||
| 305 | -9x | +2320 | +2x |
- validate_split_result(ret, "post")+ setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))
|
| 306 | -9x | +|||
| 2321 | +
- ret+ |
|||
| 307 | +2322 |
- }+ #' @export |
||
| 308 | +2323 |
- }+ #' @rdname col_accessors |
||
| 309 | +2324 |
-
+ setMethod( |
||
| 310 | +2325 |
- #' Add a combination facet in post-processing+ "col_total<-", "InstantiatedColumnInfo", |
||
| 311 | +2326 |
- #'+ function(obj, value) {
|
||
| 312 | +2327 |
- #' Add a combination facet during the post-processing stage in a custom split fun.+ ## all methods funnel to this one so ensure integer-ness here. |
||
| 313 | -+ | |||
| 2328 | +1x |
- #'+ obj@total_count <- as.integer(value) |
||
| 314 | -+ | |||
| 2329 | +1x |
- #' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).+ obj |
||
| 315 | +2330 |
- #' @param label (`string`)\cr label for the resulting facet.+ } |
||
| 316 | +2331 |
- #' @param levels (`character`)\cr vector of levels to combine within the resulting facet.+ ) |
||
| 317 | +2332 |
- #' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.+ |
||
| 318 | +2333 |
- #'+ #' @export |
||
| 319 | +2334 |
- #' @details+ #' @rdname col_accessors |
||
| 320 | +2335 |
- #' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for+ setMethod( |
||
| 321 | +2336 |
- #' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data+ "col_total<-", "VTableNodeInfo", |
||
| 322 | +2337 |
- #' that appears in both will be duplicated.+ function(obj, value) {
|
||
| 323 | -+ | |||
| 2338 | +1x |
- #'+ cinfo <- col_info(obj) |
||
| 324 | -+ | |||
| 2339 | +1x |
- #' @return A function which can be used within the `post` argument in [make_split_fun()].+ col_total(cinfo) <- value |
||
| 325 | -+ | |||
| 2340 | +1x |
- #'+ col_info(obj) <- cinfo |
||
| 326 | -+ | |||
| 2341 | +1x |
- #' @seealso [make_split_fun()]+ obj |
||
| 327 | +2342 |
- #'+ } |
||
| 328 | +2343 |
- #' @examples+ ) |
||
| 329 | +2344 |
- #' mysplfun <- make_split_fun(post = list(+ |
||
| 330 | +2345 |
- #' add_combo_facet("A_B",
+ #' @rdname int_methods |
||
| 331 | -+ | |||
| 2346 | +19352x |
- #' label = "Arms A+B",+ setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))
|
||
| 332 | +2347 |
- #' levels = c("A: Drug X", "B: Placebo")
+
|
||
| 333 | +2348 |
- #' ),+ #' @rdname int_methods |
||
| 334 | +2349 |
- #' add_overall_facet("ALL", label = "All Arms")
+ setMethod( |
||
| 335 | +2350 |
- #' ))+ "disp_ccounts", "VTableTree",+ |
+ ||
| 2351 | +329x | +
+ function(obj) disp_ccounts(col_info(obj)) |
||
| 336 | +2352 |
- #'+ ) |
||
| 337 | +2353 |
- #' lyt <- basic_table(show_colcounts = TRUE) %>%+ |
||
| 338 | +2354 |
- #' split_cols_by("ARM", split_fun = mysplfun) %>%
+ #' @rdname int_methods |
||
| 339 | +2355 |
- #' analyze("AGE")
+ setMethod( |
||
| 340 | +2356 |
- #'+ "disp_ccounts", "InstantiatedColumnInfo",+ |
+ ||
| 2357 | +628x | +
+ function(obj) obj@display_columncounts |
||
| 341 | +2358 |
- #' tbl <- build_table(lyt, DM)+ ) |
||
| 342 | +2359 |
- #'+ |
||
| 343 | +2360 |
- #' @family make_custom_split+ #' @rdname int_methods |
||
| 344 | +2361 |
- #' @export+ setMethod( |
||
| 345 | +2362 |
- add_combo_facet <- function(name, label = name, levels, extra = list()) {
+ "disp_ccounts", "PreDataTableLayouts", |
||
| 346 | -3x | +2363 | +952x |
- function(ret, spl, .spl_context, fulldf) {
+ function(obj) disp_ccounts(clayout(obj)) |
| 347 | -4x | +|||
| 2364 | +
- if (is(levels, "AllLevelsSentinel")) {
+ ) |
|||
| 348 | -1x | +|||
| 2365 | +
- subexpr <- expression(TRUE)+ |
|||
| 349 | -1x | +|||
| 2366 | +
- datpart <- list(fulldf)+ #' @rdname int_methods |
|||
| 350 | +2367 |
- } else {
+ setMethod( |
||
| 351 | -3x | +|||
| 2368 | +
- subexpr <- .combine_value_exprs(ret$values[levels])+ "disp_ccounts", "PreDataColLayout", |
|||
| 352 | -3x | +2369 | +1264x |
- datpart <- list(do.call(rbind, ret$datasplit[levels]))+ function(obj) obj@display_columncounts |
| 353 | +2370 |
- }+ ) |
||
| 354 | +2371 | |||
| 355 | -4x | -
- val <- LevelComboSplitValue(- |
- ||
| 356 | -4x | +|||
| 2372 | +
- val = name, extr = extra, combolevels = levels, label = label,+ #' @rdname int_methods |
|||
| 357 | -4x | +|||
| 2373 | +
- sub_expr = subexpr+ setMethod( |
|||
| 358 | +2374 |
- )+ "disp_ccounts", "LayoutColTree", |
||
| 359 | -4x | +2375 | +819x |
- add_to_split_result(ret,+ function(obj) obj@display_columncounts |
| 360 | -4x | +|||
| 2376 | +
- values = list(val), labels = label,+ ) |
|||
| 361 | -4x | +|||
| 2377 | +
- datasplit = datpart+ |
|||
| 362 | +2378 |
- )+ #' @rdname int_methods |
||
| 363 | +2379 |
- }+ setMethod( |
||
| 364 | +2380 |
- }+ "disp_ccounts", "LayoutColLeaf",+ |
+ ||
| 2381 | +13990x | +
+ function(obj) obj@display_columncounts |
||
| 365 | +2382 |
-
+ ) |
||
| 366 | +2383 |
- .combine_value_exprs <- function(val_lst, spl) {
+
|
||
| 367 | -3x | +|||
| 2384 | +
- exprs <- lapply(val_lst, value_expr)+ #' @rdname int_methods |
|||
| 368 | -3x | +|||
| 2385 | +
- nulls <- vapply(exprs, is.null, TRUE)+ setMethod( |
|||
| 369 | -3x | +|||
| 2386 | +
- if (all(nulls)) {
+ "disp_ccounts", "Split", |
|||
| 370 | -1x | +2387 | +1235x |
- return(NULL) # default behavior all the way down the line, no need to do anything.+ function(obj) obj@child_show_colcounts |
| 371 | -2x | +|||
| 2388 | +
- } else if (any(nulls)) {
+ ) |
|||
| 372 | -! | +|||
| 2389 | +
- exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))+ |
|||
| 373 | +2390 |
- }+ #' @rdname int_methods |
||
| 374 | -2x | +2391 | +2217x |
- Reduce(.or_combine_exprs, exprs)+ setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))
|
| 375 | +2392 |
- }+ |
||
| 376 | +2393 |
-
+ #' @rdname int_methods |
||
| 377 | +2394 |
- ## no NULLS coming in here, everything has been populated+ setMethod( |
||
| 378 | +2395 |
- ## by either custom subsetting expressions or the result of make_subset_expr(spl, val)+ "disp_ccounts<-", "VTableTree", |
||
| 379 | +2396 |
- .or_combine_exprs <- function(ex1, ex2) {
+ function(obj, value) {
|
||
| 380 | -2x | -
- if (identical(ex1, expression(FALSE))) {
- |
- ||
| 381 | -! | +2397 | +1x |
- return(ex2)+ cinfo <- col_info(obj) |
| 382 | -2x | -
- } else if (identical(ex2, expression(FALSE))) {
- |
- ||
| 383 | -! | +2398 | +1x |
- return(ex1)+ disp_ccounts(cinfo) <- value |
| 384 | -2x | +2399 | +1x |
- } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
+ col_info(obj) <- cinfo |
| 385 | -! | +|||
| 2400 | +1x |
- return(TRUE)+ obj |
||
| 386 | +2401 |
} |
||
| 387 | -2x | -
- as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]])))- |
- ||
| 388 | +2402 |
- }+ ) |
||
| 389 | +2403 | |||
| 390 | +2404 |
- #' @rdname add_combo_facet+ #' @rdname int_methods |
||
| 391 | +2405 |
- #' @export+ setMethod( |
||
| 392 | +2406 |
- add_overall_facet <- function(name, label, extra = list()) {
+ "disp_ccounts<-", "InstantiatedColumnInfo", |
||
| 393 | -1x | +|||
| 2407 | +
- add_combo_facet(+ function(obj, value) {
|
|||
| 394 | -1x | +2408 | +2x |
- name = name, label = label, levels = select_all_levels,+ obj@display_columncounts <- value |
| 395 | -1x | +2409 | +2x |
- extra = extra+ obj |
| 396 | +2410 |
- )+ } |
||
| 397 | +2411 |
- }+ ) |
||
| 398 | +2412 | |||
| 399 | +2413 |
- #' Trim levels of another variable from each facet (post-processing split step)+ #' @rdname int_methods |
||
| 400 | +2414 |
- #'+ setMethod( |
||
| 401 | +2415 |
- #' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.+ "disp_ccounts<-", "PreDataColLayout", |
||
| 402 | +2416 |
- #'+ function(obj, value) {
|
||
| 403 | -+ | |||
| 2417 | +314x |
- #' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.+ obj@display_columncounts <- value |
||
| 404 | -+ | |||
| 2418 | +314x |
- #'+ obj |
||
| 405 | +2419 |
- #' @seealso [make_split_fun()]+ } |
||
| 406 | +2420 |
- #'+ ) |
||
| 407 | +2421 |
- #' @family make_custom_split+ |
||
| 408 | +2422 |
- #' @export+ #' @rdname int_methods |
||
| 409 | +2423 |
- trim_levels_in_facets <- function(innervar) {
- |
- ||
| 410 | -1x | -
- function(ret, ...) {
- |
- ||
| 411 | -1x | -
- for (var in innervar) {
- |
- ||
| 412 | -1x | -
- ret$datasplit <- lapply(ret$datasplit, function(df) {
- |
- ||
| 413 | -2x | -
- df[[var]] <- factor(df[[var]])+ setMethod( |
||
| 414 | -2x | +|||
| 2424 | +
- df+ "disp_ccounts<-", "LayoutColTree", |
|||
| 415 | +2425 |
- })+ function(obj, value) {
|
||
| 416 | -+ | |||
| 2426 | +313x |
- }+ obj@display_columncounts <- value |
||
| 417 | -1x | +2427 | +313x |
- ret+ obj |
| 418 | +2428 |
} |
||
| 419 | +2429 |
- }+ ) |
||
| 420 | +2430 | |||
| 421 | +2431 |
- #' Pre-processing function for use in `make_split_fun`+ #' @rdname int_methods |
||
| 422 | +2432 |
- #'+ setMethod( |
||
| 423 | +2433 |
- #' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called+ "disp_ccounts<-", "LayoutColLeaf", |
||
| 424 | +2434 |
- #' directly by end users.+ function(obj, value) {
|
||
| 425 | -+ | |||
| 2435 | +1273x |
- #'+ obj@display_columncounts <- value |
||
| 426 | -+ | |||
| 2436 | +1273x |
- #' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.+ obj |
||
| 427 | +2437 |
- #' @param spl (`VarLevelSplit`)\cr the split.+ } |
||
| 428 | +2438 |
- #' @param ... additional parameters passed internally.+ ) |
||
| 429 | +2439 |
- #'+ |
||
| 430 | +2440 |
- #' @seealso [make_split_fun()]+ #' @rdname int_methods |
||
| 431 | +2441 |
- #'+ setMethod( |
||
| 432 | +2442 |
- #' @family make_custom_split+ "disp_ccounts<-", "PreDataTableLayouts", |
||
| 433 | +2443 |
- #' @export+ function(obj, value) {
|
||
| 434 | -+ | |||
| 2444 | +314x |
- drop_facet_levels <- function(df, spl, ...) {
+ clyt <- clayout(obj) |
||
| 435 | -2x | +2445 | +314x |
- if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) {
+ disp_ccounts(clyt) <- value |
| 436 | -! | +|||
| 2446 | +314x |
- stop("Unable to determine faceting variable in drop_facet_levels application.")
+ clayout(obj) <- clyt+ |
+ ||
| 2447 | +314x | +
+ obj |
||
| 437 | +2448 |
} |
||
| 438 | -2x | +|||
| 2449 | +
- var <- spl_payload(spl)+ ) |
|||
| 439 | -2x | +|||
| 2450 | +
- df[[var]] <- factor(df[[var]])+ |
|||
| 440 | -2x | +|||
| 2451 | +
- df+ |
|||
| 441 | +2452 |
- }+ ## this is a horrible hack but when we have non-nested siblings at the top level |
| 1 | +2453 |
- ## NB handling the case where there are no values is done during tabulation+ ## the beginning of the "path <-> position" relationship breaks down. |
||
| 2 | +2454 |
- ## which is the only reason expression(TRUE) is ok, because otherwise+ ## we probably *should* have e.g., c("root", "top_level_splname_1",
|
||
| 3 | +2455 |
- ## we (sometimes) run into+ ## "top_level_splname_1, "top_level_splname_1_value", ...) |
||
| 4 | +2456 |
- ## factor()[TRUE] giving <NA> (i.e. length 1)+ ## but its pretty clear why no one will be happy with that, I think |
||
| 5 | -2562x | +|||
| 2457 | +
- setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
+ ## so we punt on the problem for now with an explicit workaround |
|||
| 6 | +2458 |
-
+ ## |
||
| 7 | +2459 |
- setMethod(+ ## those first non-nested siblings currently have (incorrect) |
||
| 8 | +2460 |
- "make_subset_expr", "VarLevelSplit",+ ## empty tree_pos elements so we just look at the obj_name |
||
| 9 | +2461 |
- function(spl, val) {
+
|
||
| 10 | +2462 |
- ## this is how custom split functions will communicate the correct expression+ pos_singleton_path <- function(obj) {
|
||
| 11 | -+ | |||
| 2463 | +5915x |
- ## to the column modeling code+ pos <- tree_pos(obj) |
||
| 12 | -1903x | +2464 | +5915x |
- if (length(value_expr(val)) > 0) {
+ splvals <- pos_splvals(pos) |
| 13 | -8x | +2465 | +5915x |
- return(value_expr(val))+ length(splvals) == 0 ||+ |
+
| 2466 | +5915x | +
+ (length(splvals) == 1 && is.na(unlist(value_names(splvals)))) |
||
| 14 | +2467 |
- }+ } |
||
| 15 | +2468 | |||
| 16 | -1895x | +|||
| 2469 | +
- v <- unlist(rawvalues(val))+ ## close to a duplicate of tt_at_path, but... not quite :( |
|||
| 17 | +2470 |
- ## XXX if we're including all levels should even missing be included?+ #' @rdname int_methods+ |
+ ||
| 2471 | ++ |
+ coltree_at_path <- function(obj, path, ...) {
|
||
| 18 | -1895x | +2472 | +3094x |
- if (is(v, "AllLevelsSentinel")) {
+ if (length(path) == 0) {
|
| 19 | -6x | +2473 | +746x |
- as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))+ return(obj) |
| 20 | +2474 |
- } else {
+ } |
||
| 21 | -1889x | +2475 | +2348x |
- as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(+ stopifnot( |
| 22 | -1889x | +2476 | +2348x |
- a = as.name(spl_payload(spl)),+ is(path, "character"), |
| 23 | -1889x | +2477 | +2348x |
- b = v+ length(path) > 0 |
| 24 | +2478 |
- )))+ ) |
||
| 25 | -+ | |||
| 2479 | +2348x |
- }+ if (any(grepl("@content", path, fixed = TRUE))) {
|
||
| 26 | -+ | |||
| 2480 | +! |
- }+ stop("@content token is not valid for column paths.")
|
||
| 27 | +2481 |
- )+ } |
||
| 28 | +2482 | |||
| 29 | -+ | |||
| 2483 | +2348x |
- setMethod(+ cur <- obj |
||
| 30 | -+ | |||
| 2484 | +2348x |
- "make_subset_expr", "MultiVarSplit",+ curpath <- pos_to_path(tree_pos(obj)) # path |
||
| 31 | -+ | |||
| 2485 | +2348x |
- function(spl, val) {
+ num_consume_path <- 2 |
||
| 32 | -+ | |||
| 2486 | +2348x |
- ## this is how custom split functions will communicate the correct expression+ while (!identical(curpath, path) && !is(cur, "LayoutColLeaf")) { # length(curpath) > 0) {
|
||
| 33 | -+ | |||
| 2487 | +4105x |
- ## to the column modeling code+ kids <- tree_children(cur) |
||
| 34 | -198x | +2488 | +4105x |
- if (length(value_expr(val)) > 0) {
+ kidmatch <- find_kid_path_match(kids, path)+ |
+
| 2489 | +4105x | +
+ if (length(kidmatch) == 0) {
|
||
| 35 | +2490 | ! |
- return(value_expr(val))+ stop( |
|
| 36 | -+ | |||
| 2491 | +! |
- }+ "unable to match full path: ", paste(path, sep = "->"), |
||
| 37 | -+ | |||
| 2492 | +! |
-
+ "\n path of last match: ", paste(curpath, sep = "->") |
||
| 38 | +2493 |
- ## v = rawvalues(val)+ ) |
||
| 39 | +2494 |
- ## as.expression(bquote(!is.na(.(a)), list(a = v)))+ } |
||
| 40 | -198x | +2495 | +4105x |
- expression(TRUE)+ cur <- kids[[kidmatch]]+ |
+
| 2496 | +4105x | +
+ curpath <- pos_to_path(tree_pos(cur)) |
||
| 41 | +2497 |
} |
||
| 42 | -+ | |||
| 2498 | +2348x |
- )+ cur |
||
| 43 | +2499 |
-
+ } |
||
| 44 | +2500 |
- setMethod(+ |
||
| 45 | +2501 |
- "make_subset_expr", "AnalyzeVarSplit",+ find_kid_path_match <- function(kids, path) {
|
||
| 46 | -+ | |||
| 2502 | +8206x |
- function(spl, val) {
+ if (length(kids) == 0) {
|
||
| 47 | +2503 | ! |
- if (avar_inclNAs(spl)) {
+ return(integer()) |
|
| 48 | -! | +|||
| 2504 | +
- expression(TRUE)+ }+ |
+ |||
| 2505 | +8206x | +
+ kidpaths <- lapply(kids, function(k) pos_to_path(tree_pos(k))) |
||
| 49 | +2506 |
- } else {
+
|
||
| 50 | -! | +|||
| 2507 | +8206x |
- as.expression(bquote(+ matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA) |
||
| 51 | -! | +|||
| 2508 | +8206x |
- !is.na(.(a)),+ firstkidpos <- tree_pos(kids[[1]]) |
||
| 52 | -! | +|||
| 2509 | +8206x |
- list(a = as.name(spl_payload(spl)))+ if (all(matches) && pos_singleton_path(kids[[1]])) {
|
||
| 53 | -+ | |||
| 2510 | +664x |
- ))+ kidpaths <- lapply(seq_along(kidpaths), function(i) c(kidpaths[[i]], obj_name(kids[[i]]))) |
||
| 54 | -+ | |||
| 2511 | +664x |
- }+ matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA) |
||
| 55 | +2512 |
} |
||
| 56 | -+ | |||
| 2513 | +8206x |
- )+ which(matches) |
||
| 57 | +2514 |
-
+ } |
||
| 58 | +2515 |
- setMethod(+ |
||
| 59 | +2516 |
- "make_subset_expr", "AnalyzeColVarSplit",+ |
||
| 60 | +2517 |
- function(spl, val) {
+ ## almost a duplicate of recursive_replace, but I spent a bunch |
||
| 61 | -! | +|||
| 2518 | +
- expression(TRUE)+ ## of time ramming my head against the different way pathing happens |
|||
| 62 | +2519 |
- }+ ## in column space (unfortunately) before giving up building |
||
| 63 | +2520 |
- )+ ## coltree_at_path around recursive_replace, so here we are. |
||
| 64 | +2521 | |||
| 65 | +2522 |
- ## XXX these are going to be ridiculously slow+ ct_recursive_replace <- function(ctree, path, value, pos = 1) {
|
||
| 66 | -+ | |||
| 2523 | +6447x |
- ## FIXME+ pos <- tree_pos(ctree) |
||
| 67 | -+ | |||
| 2524 | +6447x |
-
+ curpth <- pos_to_path(pos) |
||
| 68 | -+ | |||
| 2525 | +6447x |
- setMethod(+ if (identical(path, curpth)) {
|
||
| 69 | -+ | |||
| 2526 | +2346x |
- "make_subset_expr", "VarStaticCutSplit",+ return(value) |
||
| 70 | -+ | |||
| 2527 | +4101x |
- function(spl, val) {
+ } else if (is(ctree, "LayoutColLeaf")) {
|
||
| 71 | -90x | +|||
| 2528 | +! |
- v <- rawvalues(val)+ stop(+ |
+ ||
| 2529 | +! | +
+ "unable to match full path: ", paste(path, sep = "->"),+ |
+ ||
| 2530 | +! | +
+ "\n path at leaf: ", paste(curpth, sep = "->") |
||
| 72 | +2531 |
- ## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),+ ) |
||
| 73 | -90x | +|||
| 2532 | +
- as.expression(bquote(+ } |
|||
| 74 | -90x | +2533 | +4101x |
- cut(.(a),+ kids <- tree_children(ctree) |
| 75 | -90x | +2534 | +4101x |
- breaks = .(brk), labels = .(labels),+ kids_singl <- pos_singleton_path(kids[[1]]) |
| 76 | -90x | +2535 | +4101x |
- include.lowest = TRUE+ kidind <- find_kid_path_match(kids, path) |
| 77 | -90x | +|||
| 2536 | +
- ) == .(b),+ |
|||
| 78 | -90x | +2537 | +4101x |
- list(+ if (length(kidind) == 0) {
|
| 79 | -90x | +|||
| 2538 | +! |
- a = as.name(spl_payload(spl)),+ stop("Path appears invalid for this tree at step ", path[1])
|
||
| 80 | -90x | +2539 | +4101x |
- b = v,+ } else if (length(kidind) > 1) {
|
| 81 | -90x | +|||
| 2540 | +! |
- brk = spl_cuts(spl),+ stop( |
||
| 82 | -90x | +|||
| 2541 | +! |
- labels = spl_cutlabels(spl)+ "singleton step (root, cbind_root, etc) in path appears to have matched multiple children. ", |
||
| 83 | -+ | |||
| 2542 | +! |
- )+ "This shouldn't happen, please contact the maintainers." |
||
| 84 | +2543 |
- ))+ ) |
||
| 85 | +2544 |
} |
||
| 86 | +2545 |
- )+ |
||
| 87 | -+ | |||
| 2546 | +4101x |
-
+ kids[[kidind]] <- ct_recursive_replace( |
||
| 88 | -+ | |||
| 2547 | +4101x |
- ## NB this assumes spl_cutlabels(spl) is in order!!!!!!+ kids[[kidind]], |
||
| 89 | -+ | |||
| 2548 | +4101x |
- setMethod(+ path, value |
||
| 90 | +2549 |
- "make_subset_expr", "CumulativeCutSplit",+ ) |
||
| 91 | -+ | |||
| 2550 | +4101x |
- function(spl, val) {
+ tree_children(ctree) <- kids |
||
| 92 | -42x | +2551 | +4101x |
- v <- rawvalues(val)+ ctree |
| 93 | +2552 |
- ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),+ } |
||
| 94 | -42x | +|||
| 2553 | +
- as.expression(bquote(+ |
|||
| 95 | -42x | +|||
| 2554 | +
- as.integer(cut(.(a),+ `coltree_at_path<-` <- function(obj, path, value) {
|
|||
| 96 | -42x | +2555 | +2346x |
- breaks = .(brk),+ obj <- ct_recursive_replace(obj, path, value) |
| 97 | -42x | +2556 | +2346x |
- labels = .(labels),+ obj |
| 98 | -42x | +|||
| 2557 | +
- include.lowest = TRUE+ } |
|||
| 99 | +2558 |
- )) <=+ |
||
| 100 | -42x | +|||
| 2559 | +
- as.integer(factor(.(b), levels = .(labels))),+ #' Set visibility of column counts for a group of sibling facets |
|||
| 101 | -42x | +|||
| 2560 | +
- list(+ #' |
|||
| 102 | -42x | +|||
| 2561 | +
- a = as.name(spl_payload(spl)),+ #' @inheritParams gen_args |
|||
| 103 | -42x | +|||
| 2562 | +
- b = v,+ #' @param path (`character`)\cr the path *to the parent of the |
|||
| 104 | -42x | +|||
| 2563 | +
- brk = spl_cuts(spl),+ #' desired siblings*. The last element in the path should |
|||
| 105 | -42x | +|||
| 2564 | +
- labels = spl_cutlabels(spl)+ #' be a split name. |
|||
| 106 | +2565 |
- )+ #' @return obj, modified with the desired column count. |
||
| 107 | +2566 |
- ))+ #' display behavior |
||
| 108 | +2567 |
- }+ #' |
||
| 109 | +2568 |
- )+ #' @seealso [colcount_visible()] |
||
| 110 | +2569 |
-
+ #' |
||
| 111 | +2570 |
- ## I think this one is unnecessary,+ #' @export |
||
| 112 | +2571 |
- ## build_table collapses DynCutSplits into+ `facet_colcounts_visible<-` <- function(obj, path, value) {
+ |
+ ||
| 2572 | +1x | +
+ coldf <- make_col_df(obj, visible_only = FALSE)+ |
+ ||
| 2573 | +1x | +
+ allpaths <- coldf$path+ |
+ ||
| 2574 | +1x | +
+ lenpath <- length(path)+ |
+ ||
| 2575 | +1x | +
+ match_paths <- vapply(allpaths, function(path_i) {
+ |
+ ||
| 2576 | +10x | +
+ (length(path_i) == lenpath + 1) &&+ |
+ ||
| 2577 | +10x | +
+ (all(head(path_i, -1) == path))+ |
+ ||
| 2578 | +1x | +
+ }, TRUE)+ |
+ ||
| 2579 | +1x | +
+ for (curpath in allpaths[match_paths]) {
+ |
+ ||
| 2580 | +2x | +
+ colcount_visible(obj, curpath) <- value |
||
| 113 | +2581 |
- ## static ones.+ }+ |
+ ||
| 2582 | +1x | +
+ obj |
||
| 114 | +2583 |
- ##+ } |
||
| 115 | +2584 |
- ## XXX TODO fixme+ |
||
| 116 | +2585 |
- ## setMethod("make_subset_expr", "VarDynCutSplit",
+ #' Get or set column count for a facet in column space |
||
| 117 | +2586 |
- ## function(spl, val) {
+ #' |
||
| 118 | +2587 |
- ## v = rawvalues(val)+ #' @inheritParams gen_args |
||
| 119 | +2588 |
- ## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)),+ #' @param path character. This path must end on a |
||
| 120 | +2589 |
- ## as.expression(bquote(.(fun)(.(a)) == .(b)),+ #' split value, e.g., the level of a categorical variable |
||
| 121 | +2590 |
- ## list(a = as.name(spl_payload(spl)),+ #' that was split on in column space, but it need not |
||
| 122 | +2591 |
- ## b = v,+ #' be the path to an individual column. |
||
| 123 | +2592 |
- ## fun = spl@cut_fun))+ #' |
||
| 124 | +2593 |
- ## })+ #' @return for `facet_colcount` the current count associated |
||
| 125 | +2594 |
-
+ #' with that facet in column space, for `facet_colcount<-`, |
||
| 126 | +2595 |
- setMethod(+ #' `obj` modified with the new column count for the specified |
||
| 127 | +2596 |
- "make_subset_expr", "AllSplit",+ #' facet. |
||
| 128 | -194x | +|||
| 2597 | +
- function(spl, val) expression(TRUE)+ #' |
|||
| 129 | +2598 |
- )+ #' @note Updating a lower-level (more specific) |
||
| 130 | +2599 |
-
+ #' column count manually **will not** update the |
||
| 131 | +2600 |
- ## probably don't need this+ #' counts for its parent facets. This cannot be made |
||
| 132 | +2601 |
-
+ #' automatic because the rtables framework does not |
||
| 133 | +2602 |
- setMethod(+ #' require sibling facets to be mutually exclusive |
||
| 134 | +2603 |
- "make_subset_expr", "expression",+ #' (e.g., total "arm", faceting into cumulative |
||
| 135 | -! | +|||
| 2604 | +
- function(spl, val) spl+ #' quantiles, etc) and thus the count of a parent facet |
|||
| 136 | +2605 |
- )+ #' will not always be simply the sum of the counts for |
||
| 137 | +2606 |
-
+ #' all of its children. |
||
| 138 | +2607 |
- setMethod(+ #' |
||
| 139 | +2608 |
- "make_subset_expr", "character",+ #' @seealso [col_counts()] |
||
| 140 | +2609 |
- function(spl, val) {
+ #' |
||
| 141 | -! | +|||
| 2610 | +
- newspl <- VarLevelSplit(spl, spl)+ #' @examples |
|||
| 142 | -! | +|||
| 2611 | +
- make_subset_expr(newspl, val)+ #' lyt <- basic_table() %>% |
|||
| 143 | +2612 |
- }+ #' split_cols_by("ARM", show_colcounts = TRUE) %>%
|
||
| 144 | +2613 |
- )+ #' split_cols_by("SEX",
|
||
| 145 | +2614 |
-
+ #' split_fun = keep_split_levels(c("F", "M")),
|
||
| 146 | +2615 |
- .combine_subset_exprs <- function(ex1, ex2) {
+ #' show_colcounts = TRUE |
||
| 147 | -2562x | +|||
| 2616 | +
- if (is.null(ex1) || identical(ex1, expression(TRUE))) {
+ #' ) %>% |
|||
| 148 | -1743x | +|||
| 2617 | +
- if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
+ #' split_cols_by("STRATA1", show_colcounts = TRUE) %>%
|
|||
| 149 | -1334x | +|||
| 2618 | +
- return(ex2)+ #' analyze("AGE")
|
|||
| 150 | +2619 |
- } else {
+ #' |
||
| 151 | -409x | +|||
| 2620 | +
- return(expression(TRUE))+ #' tbl <- build_table(lyt, ex_adsl) |
|||
| 152 | +2621 |
- }+ #' |
||
| 153 | +2622 |
- }+ #' facet_colcount(tbl, c("ARM", "A: Drug X"))
|
||
| 154 | +2623 |
-
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F"))
|
||
| 155 | -819x | +|||
| 2624 | +
- if (is.null(ex2)) {
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A"))
|
|||
| 156 | -! | +|||
| 2625 | +
- ex2 <- expression(TRUE)+ #' |
|||
| 157 | +2626 |
- }+ #' ## modify specific count after table creation |
||
| 158 | -819x | +|||
| 2627 | +
- stopifnot(is.expression(ex1), is.expression(ex2))+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A")) <- 25
|
|||
| 159 | -819x | +|||
| 2628 | +
- as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))+ #' |
|||
| 160 | +2629 |
- }+ #' ## show black space for certain counts by assign NA |
||
| 161 | +2630 |
-
+ #' |
||
| 162 | +2631 |
- make_pos_subset <- function(spls = pos_splits(pos),+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "C")) <- NA
|
||
| 163 | +2632 |
- svals = pos_splvals(pos),+ #' |
||
| 164 | +2633 |
- pos) {
+ #' @export |
||
| 165 | -915x | +|||
| 2634 | +
- expr <- NULL+ setGeneric( |
|||
| 166 | -915x | +|||
| 2635 | +
- for (i in seq_along(spls)) {
+ "facet_colcount", |
|||
| 167 | -1325x | +2636 | +21054x |
- newexpr <- make_subset_expr(spls[[i]], svals[[i]])+ function(obj, path) standardGeneric("facet_colcount")
|
| 168 | -1325x | +|||
| 2637 | +
- expr <- .combine_subset_exprs(expr, newexpr)+ ) |
|||
| 169 | +2638 |
- }+ |
||
| 170 | -915x | +|||
| 2639 | +
- expr+ #' @rdname facet_colcount |
|||
| 171 | +2640 |
- }+ #' @export |
||
| 172 | +2641 |
-
+ setMethod( |
||
| 173 | +2642 |
- get_pos_extra <- function(svals = pos_splvals(pos),+ "facet_colcount", "LayoutColTree", |
||
| 174 | +2643 |
- pos) {
+ function(obj, path = NULL) {
|
||
| 175 | -921x | +|||
| 2644 | +
- ret <- list()+ ## if(length(path) == 0L) |
|||
| 176 | -921x | +|||
| 2645 | +
- for (i in seq_along(svals)) {
+ ## stop("face_colcount requires a non-null path") #nocov
|
|||
| 177 | -1337x | +2646 | +747x |
- extrs <- splv_extra(svals[[i]])+ subtree <- coltree_at_path(obj, path) |
| 178 | -1337x | +2647 | +747x |
- if (any(names(ret) %in% names(extrs))) {
+ subtree@column_count |
| 179 | -! | +|||
| 2648 | +
- stop("same extra argument specified at multiple levels of nesting. Not currently supported")
+ } |
|||
| 180 | +2649 |
- }+ ) |
||
| 181 | -1337x | +|||
| 2650 | +
- ret <- c(ret, extrs)+ |
|||
| 182 | +2651 |
- }+ #' @rdname facet_colcount |
||
| 183 | -921x | +|||
| 2652 | +
- ret+ #' @export |
|||
| 184 | +2653 |
- }+ setMethod( |
||
| 185 | +2654 |
-
+ "facet_colcount", "LayoutColLeaf", |
||
| 186 | +2655 |
- get_col_extras <- function(ctree) {
+ function(obj, path = NULL) {
|
||
| 187 | -307x | +|||
| 2656 | +
- leaves <- collect_leaves(ctree)+ ## not sure if we should check for null here as above |
|||
| 188 | -307x | +2657 | +20306x |
- lapply(+ obj@column_count |
| 189 | -307x | +|||
| 2658 | +
- leaves,+ } |
|||
| 190 | -307x | +|||
| 2659 | +
- function(x) get_pos_extra(pos = tree_pos(x))+ ) |
|||
| 191 | +2660 |
- )+ |
||
| 192 | +2661 |
- }+ #' @rdname facet_colcount |
||
| 193 | +2662 |
-
+ #' @export |
||
| 194 | +2663 |
- setGeneric(+ setMethod( |
||
| 195 | +2664 |
- "make_col_subsets",+ "facet_colcount", "VTableTree", |
||
| 196 | -1221x | +|||
| 2665 | +! |
- function(lyt, df) standardGeneric("make_col_subsets")
+ function(obj, path) facet_colcount(coltree(obj), path = path) |
||
| 197 | +2666 |
) |
||
| 198 | +2667 | |||
| 199 | +2668 |
- setMethod(+ #' @rdname facet_colcount |
||
| 200 | +2669 |
- "make_col_subsets", "LayoutColTree",+ #' @export |
||
| 201 | +2670 |
- function(lyt, df) {
+ setMethod( |
||
| 202 | -306x | +|||
| 2671 | +
- leaves <- collect_leaves(lyt)+ "facet_colcount", "InstantiatedColumnInfo", |
|||
| 203 | -306x | +2672 | +1x |
- lapply(leaves, make_col_subsets)+ function(obj, path) facet_colcount(coltree(obj), path = path) |
| 204 | +2673 |
- }+ ) |
||
| 205 | +2674 |
- )+ |
||
| 206 | +2675 |
-
+ #' @rdname facet_colcount |
||
| 207 | +2676 |
- setMethod(+ #' @export |
||
| 208 | +2677 |
- "make_col_subsets", "LayoutColLeaf",+ setGeneric( |
||
| 209 | +2678 |
- function(lyt, df) {
+ "facet_colcount<-", |
||
| 210 | -915x | +2679 | +1074x |
- make_pos_subset(pos = tree_pos(lyt))+ function(obj, path, value) standardGeneric("facet_colcount<-")
|
| 211 | +2680 |
- }+ ) |
||
| 212 | +2681 |
- )+ |
||
| 213 | +2682 |
-
+ #' @rdname facet_colcount |
||
| 214 | +2683 |
- create_colinfo <- function(lyt, df, rtpos = TreePos(),+ #' @export |
||
| 215 | +2684 |
- counts = NULL,+ setMethod( |
||
| 216 | +2685 |
- alt_counts_df = NULL,+ "facet_colcount<-", "LayoutColTree", |
||
| 217 | +2686 |
- total = NULL,+ function(obj, path, value) {
|
||
| 218 | -+ | |||
| 2687 | +1072x |
- topleft = NULL) {
+ ct <- coltree_at_path(obj, path)+ |
+ ||
| 2688 | +1072x | +
+ ct@column_count <- as.integer(value)+ |
+ ||
| 2689 | +1072x | +
+ coltree_at_path(obj, path) <- ct+ |
+ ||
| 2690 | +1072x | +
+ obj |
||
| 219 | +2691 |
- ## this will work whether clayout is pre or post+ } |
||
| 220 | +2692 |
- ## data+ ) |
||
| 221 | -308x | +|||
| 2693 | +
- clayout <- clayout(lyt)+ |
|||
| 222 | -308x | +|||
| 2694 | +
- if (is.null(topleft)) {
+ #' @rdname facet_colcount |
|||
| 223 | -308x | +|||
| 2695 | +
- topleft <- top_left(lyt)+ #' @export |
|||
| 224 | +2696 |
- }+ setMethod( |
||
| 225 | -308x | +|||
| 2697 | +
- ctree <- coltree(clayout, df = df, rtpos = rtpos)+ "facet_colcount<-", "LayoutColLeaf", |
|||
| 226 | +2698 |
-
+ function(obj, path, value) {
|
||
| 227 | -305x | +|||
| 2699 | +! |
- cexprs <- make_col_subsets(ctree, df)+ obj@column_count <- as.integer(value) |
||
| 228 | -305x | +|||
| 2700 | +! |
- colextras <- col_extra_args(ctree)+ obj |
||
| 229 | +2701 |
-
+ } |
||
| 230 | +2702 |
- ## calculate the counts based on the df+ ) |
||
| 231 | +2703 |
- ## This presumes that it is called on the WHOLE dataset,+ |
||
| 232 | +2704 |
- ## NOT after any splitting has occurred. Otherwise+ #' @rdname facet_colcount |
||
| 233 | +2705 |
- ## the counts will obviously be wrong.+ #' @export |
||
| 234 | -305x | +|||
| 2706 | +
- if (is.null(counts)) {
+ setMethod( |
|||
| 235 | -303x | +|||
| 2707 | +
- counts <- rep(NA_integer_, length(cexprs))+ "facet_colcount<-", "VTableTree", |
|||
| 236 | +2708 |
- } else {
+ function(obj, path, value) {
|
||
| 237 | -2x | +2709 | +1x |
- if (length(counts) != length(cexprs)) {
+ cinfo <- col_info(obj) |
| 238 | +2710 | 1x |
- stop(+ facet_colcount(cinfo, path) <- value |
|
| 239 | +2711 | 1x |
- "Length of overriding counts must equal number of columns. Got ",+ col_info(obj) <- cinfo |
|
| 240 | +2712 | 1x |
- length(counts), " values for ", length(cexprs), " columns. ",+ obj |
|
| 241 | -1x | +|||
| 2713 | +
- "Use NAs to specify that the default counting machinery should be ",+ } |
|||
| 242 | -1x | +|||
| 2714 | +
- "used for that position."+ ) |
|||
| 243 | +2715 |
- )+ |
||
| 244 | +2716 |
- }+ #' @rdname facet_colcount |
||
| 245 | -1x | +|||
| 2717 | +
- counts <- as.integer(counts)+ #' @export |
|||
| 246 | +2718 |
- }+ setMethod( |
||
| 247 | +2719 |
-
+ "facet_colcount<-", "InstantiatedColumnInfo",+ |
+ ||
| 2720 | ++ |
+ function(obj, path, value) {
|
||
| 248 | -304x | +2721 | +1x |
- counts_df_name <- "alt_counts_df"+ ct <- coltree(obj) |
| 249 | -304x | +2722 | +1x |
- if (is.null(alt_counts_df)) {
+ facet_colcount(ct, path) <- value |
| 250 | -285x | +2723 | +1x |
- alt_counts_df <- df+ coltree(obj) <- ct |
| 251 | -285x | +2724 | +1x |
- counts_df_name <- "df"+ obj |
| 252 | +2725 |
} |
||
| 253 | -304x | +|||
| 2726 | +
- calcpos <- is.na(counts)+ ) |
|||
| 254 | +2727 | |||
| 255 | -304x | +|||
| 2728 | +
- calccounts <- sapply(cexprs, function(ex) {
+ #' Value and Visibility of specific column counts by path |
|||
| 256 | -899x | +|||
| 2729 | +
- if (identical(ex, expression(TRUE))) {
+ #' |
|||
| 257 | -137x | +|||
| 2730 | +
- nrow(alt_counts_df)+ #' @inheritParams gen_args |
|||
| 258 | -762x | +|||
| 2731 | +
- } else if (identical(ex, expression(FALSE))) {
+ #' |
|||
| 259 | -! | +|||
| 2732 | +
- 0L+ #' @return for `colcount_visible` a logical scalar |
|||
| 260 | +2733 |
- } else {
+ #' indicating whether the specified position in |
||
| 261 | -762x | +|||
| 2734 | +
- vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)+ #' the column hierarchy is set to display its column count; |
|||
| 262 | -762x | +|||
| 2735 | +
- if (is(vec, "try-error")) {
+ #' for `colcount_visible<-`, `obj` updated with |
|||
| 263 | -4x | +|||
| 2736 | +
- stop(sprintf(+ #' the specified count displaying behavior set. |
|||
| 264 | -4x | +|||
| 2737 | +
- paste(+ #' |
|||
| 265 | -4x | +|||
| 2738 | +
- counts_df_name, "appears",+ #' @note Users generally should not call `colcount_visible` |
|||
| 266 | -4x | +|||
| 2739 | +
- "incompatible with column-split",+ #' directly, as setting sibling facets to have differing |
|||
| 267 | -4x | +|||
| 2740 | +
- "structure. Offending column subset",+ #' column count visibility will result in an error when |
|||
| 268 | -4x | +|||
| 2741 | +
- "expression: %s\nOriginal error",+ #' printing or paginating the table. |
|||
| 269 | -4x | +|||
| 2742 | +
- "message: %s"+ #' |
|||
| 270 | -4x | +|||
| 2743 | +
- ), deparse(ex[[1]]),+ #' @export |
|||
| 271 | -4x | +2744 | +2x |
- conditionMessage(attr(vec, "condition"))+ setGeneric("colcount_visible", function(obj, path) standardGeneric("colcount_visible"))
|
| 272 | +2745 |
- ))+ |
||
| 273 | +2746 |
- }+ #' @rdname colcount_visible |
||
| 274 | -758x | +|||
| 2747 | +
- if (is(vec, "numeric")) {
+ #' @export |
|||
| 275 | -! | +|||
| 2748 | +
- length(vec)+ setMethod( |
|||
| 276 | -758x | +|||
| 2749 | +
- } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
+ "colcount_visible", "VTableTree", |
|||
| 277 | -758x | +2750 | +1x |
- sum(vec, na.rm = TRUE)+ function(obj, path) colcount_visible(coltree(obj), path) |
| 278 | +2751 |
- }+ ) |
||
| 279 | +2752 |
- }+ |
||
| 280 | +2753 |
- })+ #' @rdname colcount_visible |
||
| 281 | -300x | +|||
| 2754 | +
- counts[calcpos] <- calccounts[calcpos]+ #' @export |
|||
| 282 | -300x | +|||
| 2755 | +
- counts <- as.integer(counts)+ setMethod( |
|||
| 283 | -300x | +|||
| 2756 | +
- if (is.null(total)) {
+ "colcount_visible", "InstantiatedColumnInfo", |
|||
| 284 | +2757 | ! |
- total <- sum(counts)+ function(obj, path) colcount_visible(coltree(obj), path) |
|
| 285 | +2758 |
- }+ ) |
||
| 286 | -300x | +|||
| 2759 | +
- format <- colcount_format(lyt)+ |
|||
| 287 | -300x | +|||
| 2760 | +
- InstantiatedColumnInfo(+ #' @rdname colcount_visible |
|||
| 288 | -300x | +|||
| 2761 | +
- treelyt = ctree,+ #' @export |
|||
| 289 | -300x | +|||
| 2762 | +
- csubs = cexprs,+ setMethod( |
|||
| 290 | -300x | +|||
| 2763 | +
- extras = colextras,+ "colcount_visible", "LayoutColTree", |
|||
| 291 | -300x | +|||
| 2764 | +
- cnts = counts,+ function(obj, path) {
|
|||
| 292 | -300x | +2765 | +1x |
- dispcounts = disp_ccounts(lyt),+ subtree <- coltree_at_path(obj, path) |
| 293 | -300x | +2766 | +1x |
- countformat = format,+ disp_ccounts(subtree) |
| 294 | -300x | +|||
| 2767 | +
- total_cnt = total,+ } |
|||
| 295 | -300x | +|||
| 2768 | +
- topleft = topleft+ ) |
|||
| 296 | +2769 |
- )+ |
||
| 297 | +2770 |
- }+ #' @rdname colcount_visible |
| 1 | +2771 |
- #' @importFrom utils browseURL+ #' @export |
||
| 2 | -+ | |||
| 2772 | +1298x |
- NULL+ setGeneric("colcount_visible<-", function(obj, path, value) standardGeneric("colcount_visible<-"))
|
||
| 3 | +2773 | |||
| 4 | +2774 |
- #' Display an `rtable` object in the Viewer pane in RStudio or in a browser+ #' @rdname colcount_visible |
||
| 5 | +2775 |
- #'+ #' @export |
||
| 6 | +2776 |
- #' The table will be displayed using bootstrap styling.+ setMethod( |
||
| 7 | +2777 |
- #'+ "colcount_visible<-", "VTableTree", |
||
| 8 | +2778 |
- #' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).+ function(obj, path, value) {
|
||
| 9 | -+ | |||
| 2779 | +3x |
- #' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.+ ctree <- coltree(obj) |
||
| 10 | -+ | |||
| 2780 | +3x |
- #' @param ... arguments passed to [as_html()].+ colcount_visible(ctree, path) <- value |
||
| 11 | -+ | |||
| 2781 | +3x |
- #'+ coltree(obj) <- ctree |
||
| 12 | -+ | |||
| 2782 | +3x |
- #' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.+ obj |
||
| 13 | +2783 |
- #'+ } |
||
| 14 | +2784 |
- #' @examples+ ) |
||
| 15 | +2785 |
- #' if (interactive()) {
+
|
||
| 16 | +2786 |
- #' sl5 <- factor(iris$Sepal.Length > 5,+ #' @rdname colcount_visible |
||
| 17 | +2787 |
- #' levels = c(TRUE, FALSE),+ #' @export |
||
| 18 | +2788 |
- #' labels = c("S.L > 5", "S.L <= 5")
+ setMethod( |
||
| 19 | +2789 |
- #' )+ "colcount_visible<-", "InstantiatedColumnInfo", |
||
| 20 | +2790 |
- #'+ function(obj, path, value) {
|
||
| 21 | -+ | |||
| 2791 | +21x |
- #' df <- cbind(iris, sl5 = sl5)+ ctree <- coltree(obj) |
||
| 22 | -+ | |||
| 2792 | +21x |
- #'+ colcount_visible(ctree, path) <- value |
||
| 23 | -+ | |||
| 2793 | +21x |
- #' lyt <- basic_table() %>%+ coltree(obj) <- ctree+ |
+ ||
| 2794 | +21x | +
+ obj |
||
| 24 | +2795 |
- #' split_cols_by("sl5") %>%
+ } |
||
| 25 | +2796 |
- #' analyze("Sepal.Length")
+ ) |
||
| 26 | +2797 |
- #'+ |
||
| 27 | +2798 |
- #' tbl <- build_table(lyt, df)+ |
||
| 28 | +2799 |
- #'+ #' @rdname colcount_visible |
||
| 29 | +2800 |
- #' Viewer(tbl)+ #' @export |
||
| 30 | +2801 |
- #' Viewer(tbl, tbl)+ setMethod( |
||
| 31 | +2802 |
- #'+ "colcount_visible<-", "LayoutColTree", |
||
| 32 | +2803 |
- #'+ function(obj, path, value) {
+ |
+ ||
| 2804 | +1274x | +
+ subtree <- coltree_at_path(obj, path)+ |
+ ||
| 2805 | +1274x | +
+ disp_ccounts(subtree) <- value+ |
+ ||
| 2806 | +1274x | +
+ coltree_at_path(obj, path) <- subtree+ |
+ ||
| 2807 | +1274x | +
+ obj |
||
| 33 | +2808 |
- #' tbl2 <- htmltools::tags$div(+ } |
||
| 34 | +2809 |
- #' class = "table-responsive",+ ) |
||
| 35 | +2810 |
- #' as_html(tbl, class_table = "table")+ |
||
| 36 | +2811 |
- #' )+ #' @rdname int_methods |
||
| 37 | +2812 |
- #'+ #' @export+ |
+ ||
| 2813 | +16350x | +
+ setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))
|
||
| 38 | +2814 |
- #' Viewer(tbl, tbl2)+ |
||
| 39 | +2815 |
- #' }+ #' @rdname int_methods |
||
| 40 | +2816 |
#' @export |
||
| 41 | +2817 |
- Viewer <- function(x, y = NULL, ...) {
+ setMethod( |
||
| 42 | -3x | +|||
| 2818 | +
- check_convert <- function(x, name, accept_NULL = FALSE) {
+ "colcount_format", "InstantiatedColumnInfo", |
|||
| 43 | -6x | +2819 | +669x |
- if (accept_NULL && is.null(x)) {
+ function(obj) obj@columncount_format |
| 44 | -3x | +|||
| 2820 | +
- NULL+ ) |
|||
| 45 | -3x | +|||
| 2821 | +
- } else if (is(x, "shiny.tag")) {
+
|
|||
| 46 | -! | +|||
| 2822 | +
- x+ #' @rdname int_methods |
|||
| 47 | -3x | +|||
| 2823 | +
- } else if (is(x, "VTableTree")) {
+ #' @export |
|||
| 48 | -3x | +|||
| 2824 | +
- as_html(x, ...)+ setMethod( |
|||
| 49 | +2825 |
- } else {
+ "colcount_format", "VTableNodeInfo", |
||
| 50 | -! | +|||
| 2826 | +375x |
- stop("object of class rtable or shiny tag excepted for ", name)
+ function(obj) colcount_format(col_info(obj)) |
||
| 51 | +2827 |
- }+ ) |
||
| 52 | +2828 |
- }+ |
||
| 53 | +2829 |
-
+ #' @rdname int_methods |
||
| 54 | -3x | +|||
| 2830 | +
- x_tag <- check_convert(x, "x", FALSE)+ #' @export |
|||
| 55 | -3x | +|||
| 2831 | +
- y_tag <- check_convert(y, "y", TRUE)+ setMethod( |
|||
| 56 | +2832 |
-
+ "colcount_format", "PreDataColLayout", |
||
| 57 | -3x | +2833 | +317x |
- html_output <- if (is.null(y)) {
+ function(obj) obj@columncount_format |
| 58 | -3x | +|||
| 2834 | +
- x_tag+ ) |
|||
| 59 | +2835 |
- } else {
+
|
||
| 60 | -! | +|||
| 2836 | +
- tags$div(class = "container-fluid", htmltools::tags$div(+ #' @rdname int_methods |
|||
| 61 | -! | +|||
| 2837 | +
- class = "row",+ #' @export |
|||
| 62 | -! | +|||
| 2838 | +
- tags$div(class = "col-xs-6", x_tag),+ setMethod( |
|||
| 63 | -! | +|||
| 2839 | +
- tags$div(class = "col-xs-6", y_tag)+ "colcount_format", "PreDataTableLayouts", |
|||
| 64 | -+ | |||
| 2840 | +317x |
- ))+ function(obj) colcount_format(clayout(obj)) |
||
| 65 | +2841 |
- }+ ) |
||
| 66 | +2842 | |||
| 67 | -3x | +|||
| 2843 | +
- sandbox_folder <- file.path(tempdir(), "rtable")+ #' @rdname int_methods |
|||
| 68 | +2844 |
-
+ #' @export |
||
| 69 | -3x | +|||
| 2845 | +
- if (!dir.exists(sandbox_folder)) {
+ setMethod( |
|||
| 70 | -1x | +|||
| 2846 | +
- dir.create(sandbox_folder, recursive = TRUE)+ "colcount_format", "Split", |
|||
| 71 | -1x | +2847 | +1235x |
- pbs <- file.path(path.package(package = "rtables"), "bootstrap/")+ function(obj) obj@child_colcount_format |
| 72 | -1x | +|||
| 2848 | +
- file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)+ ) |
|||
| 73 | +2849 |
- # list.files(sandbox_folder)+ |
||
| 74 | +2850 |
- }+ #' @rdname int_methods |
||
| 75 | +2851 |
-
+ #' @export |
||
| 76 | +2852 |
- # get html name+ setMethod( |
||
| 77 | -3x | +|||
| 2853 | +
- n_try <- 10000+ "colcount_format", "LayoutColTree", |
|||
| 78 | -3x | +2854 | +746x |
- for (i in seq_len(n_try)) {
+ function(obj) obj@columncount_format |
| 79 | -6x | +|||
| 2855 | +
- htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
+ ) |
|||
| 80 | +2856 | |||
| 81 | -6x | +|||
| 2857 | +
- if (!file.exists(htmlFile)) {
+ #' @rdname int_methods |
|||
| 82 | -3x | +|||
| 2858 | +
- break+ #' @export |
|||
| 83 | -3x | +|||
| 2859 | +
- } else if (i == n_try) {
+ setMethod( |
|||
| 84 | -! | +|||
| 2860 | +
- stop("too many html rtables created, restart your session")
+ "colcount_format", "LayoutColLeaf", |
|||
| 85 | -+ | |||
| 2861 | +12556x |
- }+ function(obj) obj@columncount_format |
||
| 86 | +2862 |
- }+ ) |
||
| 87 | +2863 | |||
| 88 | -3x | -
- html_bs <- tags$html(- |
- ||
| 89 | -3x | +|||
| 2864 | +
- lang = "en",+ |
|||
| 90 | -3x | +|||
| 2865 | +
- tags$head(+ |
|||
| 91 | -3x | +|||
| 2866 | +
- tags$meta(charset = "utf-8"),+ #' @rdname int_methods |
|||
| 92 | -3x | +|||
| 2867 | +
- tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
+ #' @export |
|||
| 93 | -3x | +|||
| 2868 | +
- tags$meta(+ setGeneric( |
|||
| 94 | -3x | +|||
| 2869 | +
- name = "viewport",+ "colcount_format<-", |
|||
| 95 | -3x | +2870 | +630x |
- content = "width=device-width, initial-scale=1"+ function(obj, value) standardGeneric("colcount_format<-")
|
| 96 | +2871 |
- ),+ ) |
||
| 97 | -3x | +|||
| 2872 | +
- tags$title("rtable"),
+
|
|||
| 98 | -3x | +|||
| 2873 | +
- tags$link(+ #' @export |
|||
| 99 | -3x | +|||
| 2874 | +
- href = "css/bootstrap.min.css",+ #' @rdname int_methods |
|||
| 100 | -3x | +|||
| 2875 | +
- rel = "stylesheet"+ setMethod( |
|||
| 101 | +2876 |
- )+ "colcount_format<-", "InstantiatedColumnInfo", |
||
| 102 | +2877 |
- ),+ function(obj, value) {
|
||
| 103 | -3x | +2878 | +1x |
- tags$body(+ obj@columncount_format <- value |
| 104 | -3x | +2879 | +1x |
- html_output+ obj |
| 105 | +2880 |
- )+ } |
||
| 106 | +2881 |
- )+ ) |
||
| 107 | +2882 | |||
| 108 | -3x | +|||
| 2883 | +
- cat(+ #' @rdname int_methods |
|||
| 109 | -3x | +|||
| 2884 | +
- paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
+ #' @export |
|||
| 110 | -3x | +|||
| 2885 | +
- file = htmlFile, append = FALSE+ setMethod( |
|||
| 111 | +2886 |
- )+ "colcount_format<-", "VTableNodeInfo", |
||
| 112 | +2887 |
-
+ function(obj, value) {
|
||
| 113 | -3x | +2888 | +1x |
- viewer <- getOption("viewer")
+ cinfo <- col_info(obj) |
| 114 | -+ | |||
| 2889 | +1x |
-
+ colcount_format(cinfo) <- value |
||
| 115 | -3x | +2890 | +1x |
- if (!is.null(viewer)) {
+ col_info(obj) <- cinfo |
| 116 | -3x | +2891 | +1x |
- viewer(htmlFile)+ obj |
| 117 | +2892 |
- } else {
+ } |
||
| 118 | -! | +|||
| 2893 | +
- browseURL(htmlFile)+ ) |
|||
| 119 | +2894 |
- }+ |
||
| 120 | +2895 |
- }+ #' @rdname int_methods |
| 1 | +2896 |
- #' @import formatters+ #' @export |
||
| 2 | +2897 |
- #' @importMethodsFrom formatters toString matrix_form nlines+ setMethod( |
||
| 3 | +2898 |
- NULL+ "colcount_format<-", "PreDataColLayout", |
||
| 4 | +2899 |
-
+ function(obj, value) {
|
||
| 5 | -+ | |||
| 2900 | +314x |
- # toString ----+ obj@columncount_format <- value |
||
| 6 | -+ | |||
| 2901 | +314x |
-
+ obj |
||
| 7 | +2902 |
- ## #' @export+ } |
||
| 8 | +2903 |
- ## setGeneric("toString", function(x,...) standardGeneric("toString"))
+ ) |
||
| 9 | +2904 | |||
| 10 | +2905 |
- ## ## preserve S3 behavior+ #' @rdname int_methods |
||
| 11 | +2906 |
- ## setMethod("toString", "ANY", base::toString)
+ #' @export |
||
| 12 | +2907 |
-
+ setMethod( |
||
| 13 | +2908 |
- ## #' @export+ "colcount_format<-", "PreDataTableLayouts", |
||
| 14 | +2909 |
- ## setMethod("print", "ANY", base::print)
+ function(obj, value) {
|
||
| 15 | -+ | |||
| 2910 | +314x |
-
+ clyt <- clayout(obj) |
||
| 16 | -+ | |||
| 2911 | +314x |
- #' Convert an `rtable` object to a string+ colcount_format(clyt) <- value |
||
| 17 | -+ | |||
| 2912 | +314x |
- #'+ clayout(obj) <- clyt |
||
| 18 | -+ | |||
| 2913 | +314x |
- #' @inheritParams formatters::toString+ obj |
||
| 19 | +2914 |
- #' @inheritParams gen_args+ } |
||
| 20 | +2915 |
- #' @inherit formatters::toString+ ) |
||
| 21 | +2916 |
- #'+ |
||
| 22 | +2917 |
- #' @return A string representation of `x` as it appears when printed.+ ## It'd probably be better if this had the full set of methods as above |
||
| 23 | +2918 |
- #'+ ## but its not currently modelled in the class and probably isn't needed |
||
| 24 | +2919 |
- #' @examples+ ## super much |
||
| 25 | +2920 |
- #' library(dplyr)+ #' @rdname int_methods |
||
| 26 | +2921 |
- #'+ #' @export |
||
| 27 | -+ | |||
| 2922 | +656x |
- #' iris2 <- iris %>%+ setGeneric("colcount_na_str", function(obj) standardGeneric("colcount_na_str"))
|
||
| 28 | +2923 |
- #' group_by(Species) %>%+ |
||
| 29 | +2924 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ #' @rdname int_methods |
||
| 30 | +2925 |
- #' ungroup()+ #' @export |
||
| 31 | +2926 |
- #'+ setMethod( |
||
| 32 | +2927 |
- #' lyt <- basic_table() %>%+ "colcount_na_str", "InstantiatedColumnInfo", |
||
| 33 | -+ | |||
| 2928 | +331x |
- #' split_cols_by("Species") %>%
+ function(obj) obj@columncount_na_str |
||
| 34 | +2929 |
- #' split_cols_by("group") %>%
+ ) |
||
| 35 | +2930 |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
+
|
||
| 36 | +2931 |
- #'+ #' @rdname int_methods |
||
| 37 | +2932 |
- #' tbl <- build_table(lyt, iris2)+ #' @export |
||
| 38 | +2933 |
- #'+ setMethod( |
||
| 39 | +2934 |
- #' cat(toString(tbl, col_gap = 3))+ "colcount_na_str", "VTableNodeInfo", |
||
| 40 | -+ | |||
| 2935 | +325x |
- #'+ function(obj) colcount_na_str(col_info(obj)) |
||
| 41 | +2936 |
- #' @rdname tostring+ ) |
||
| 42 | +2937 |
- #' @aliases tostring toString,VTableTree-method+ |
||
| 43 | +2938 |
- #' @exportMethod toString+ #' @rdname int_methods |
||
| 44 | +2939 |
- setMethod("toString", "VTableTree", function(x,
+ #' @export |
||
| 45 | +2940 |
- widths = NULL,+ setGeneric( |
||
| 46 | +2941 |
- col_gap = 3,+ "colcount_na_str<-", |
||
| 47 | -+ | |||
| 2942 | +4x |
- hsep = horizontal_sep(x),+ function(obj, value) standardGeneric("colcount_na_str<-")
|
||
| 48 | +2943 |
- indent_size = 2,+ ) |
||
| 49 | +2944 |
- tf_wrap = FALSE,+ |
||
| 50 | +2945 |
- max_width = NULL,+ #' @export |
||
| 51 | +2946 |
- fontspec = font_spec(),+ #' @rdname int_methods |
||
| 52 | +2947 |
- ttype_ok = FALSE) {
+ setMethod( |
||
| 53 | -37x | +|||
| 2948 | +
- toString(+ "colcount_na_str<-", "InstantiatedColumnInfo", |
|||
| 54 | -37x | +|||
| 2949 | +
- matrix_form(x,+ function(obj, value) {
|
|||
| 55 | -37x | +2950 | +2x |
- indent_rownames = TRUE,+ obj@columncount_na_str <- value |
| 56 | -37x | +2951 | +2x |
- indent_size = indent_size,+ obj |
| 57 | -37x | +|||
| 2952 | +
- fontspec = fontspec,+ } |
|||
| 58 | -37x | +|||
| 2953 | +
- col_gap = col_gap+ ) |
|||
| 59 | +2954 |
- ),+ |
||
| 60 | -37x | +|||
| 2955 | +
- widths = widths, col_gap = col_gap,+ #' @rdname int_methods |
|||
| 61 | -37x | +|||
| 2956 | +
- hsep = hsep,+ #' @export+ |
+ |||
| 2957 | ++ |
+ setMethod(+ |
+ ||
| 2958 | ++ |
+ "colcount_na_str<-", "VTableNodeInfo",+ |
+ ||
| 2959 | ++ |
+ function(obj, value) {
|
||
| 62 | -37x | +2960 | +2x |
- tf_wrap = tf_wrap,+ cinfo <- col_info(obj) |
| 63 | -37x | +2961 | +2x |
- max_width = max_width,+ colcount_na_str(cinfo) <- value |
| 64 | -37x | +2962 | +2x |
- fontspec = fontspec,+ col_info(obj) <- cinfo |
| 65 | -37x | +2963 | +2x |
- ttype_ok = ttype_ok+ obj |
| 66 | +2964 |
- )+ } |
||
| 67 | +2965 |
- })+ ) |
||
| 68 | +2966 | |||
| 69 | +2967 |
- #' Table shells+ #' Exported for use in `tern` |
||
| 70 | +2968 |
#' |
||
| 71 | +2969 |
- #' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather+ #' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information? |
||
| 72 | +2970 |
- #' displaying the formatting instructions for each cell.+ #' |
||
| 73 | +2971 |
- #'+ #' @inheritParams gen_args |
||
| 74 | +2972 |
- #' @inheritParams formatters::toString+ #' |
||
| 75 | +2973 |
- #' @inheritParams gen_args+ #' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise. |
||
| 76 | +2974 |
#' |
||
| 77 | +2975 |
- #' @return+ #' @rdname no_info |
||
| 78 | +2976 |
- #' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console.+ #' @export+ |
+ ||
| 2977 | +181755x | +
+ setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))
|
||
| 79 | +2978 |
- #' * `table_shell_str` returns the string representing the table shell.+ |
||
| 80 | +2979 |
- #'+ #' @exportMethod no_colinfo |
||
| 81 | +2980 |
- #' @seealso [value_formats()] for a matrix of formats for each cell in a table.+ #' @rdname no_info |
||
| 82 | +2981 |
- #'+ setMethod( |
||
| 83 | +2982 |
- #' @examples+ "no_colinfo", "VTableNodeInfo",+ |
+ ||
| 2983 | +77804x | +
+ function(obj) no_colinfo(col_info(obj)) |
||
| 84 | +2984 |
- #' library(dplyr)+ ) |
||
| 85 | +2985 |
- #'+ |
||
| 86 | +2986 |
- #' iris2 <- iris %>%+ #' @exportMethod no_colinfo |
||
| 87 | +2987 |
- #' group_by(Species) %>%+ #' @rdname no_info |
||
| 88 | +2988 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ setMethod( |
||
| 89 | +2989 |
- #' ungroup()+ "no_colinfo", "InstantiatedColumnInfo",+ |
+ ||
| 2990 | +93867x | +
+ function(obj) length(obj@subset_exprs) == 0 |
||
| 90 | +2991 |
- #'+ ) ## identical(obj, EmptyColInfo)) |
||
| 91 | +2992 |
- #' lyt <- basic_table() %>%+ |
||
| 92 | +2993 |
- #' split_cols_by("Species") %>%
+ #' Names of a `TableTree` |
||
| 93 | +2994 |
- #' split_cols_by("group") %>%
+ #' |
||
| 94 | +2995 |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
+ #' @param x (`TableTree`)\cr the object. |
||
| 95 | +2996 |
#' |
||
| 96 | +2997 |
- #' tbl <- build_table(lyt, iris2)+ #' @details |
||
| 97 | +2998 |
- #' table_shell(tbl)+ #' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level |
||
| 98 | +2999 |
- #'+ #' split values repped out across the columns that they span. |
||
| 99 | +3000 |
- #' @export+ #' |
||
| 100 | +3001 |
- table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),+ #' @return The column names of `x`, as defined in the details above. |
||
| 101 | +3002 |
- tf_wrap = FALSE, max_width = NULL) {
+ #' |
||
| 102 | -2x | +|||
| 3003 | +
- cat(table_shell_str(+ #' @exportMethod names |
|||
| 103 | -2x | +|||
| 3004 | +
- tt = tt, widths = widths, col_gap = col_gap, hsep = hsep,+ #' @rdname names |
|||
| 104 | -2x | +|||
| 3005 | +
- tf_wrap = tf_wrap, max_width = max_width+ setMethod( |
|||
| 105 | +3006 |
- ))+ "names", "VTableNodeInfo",+ |
+ ||
| 3007 | +109x | +
+ function(x) names(col_info(x)) |
||
| 106 | +3008 |
- }+ ) |
||
| 107 | +3009 | |||
| 108 | +3010 |
- ## XXX consider moving to formatters, its really just a function+ #' @rdname names |
||
| 109 | +3011 |
- ## of the MatrixPrintForm+ #' @exportMethod names |
||
| 110 | +3012 |
- #' @rdname table_shell+ setMethod( |
||
| 111 | +3013 |
- #' @export+ "names", "InstantiatedColumnInfo",+ |
+ ||
| 3014 | +127x | +
+ function(x) names(coltree(x)) |
||
| 112 | +3015 |
- table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),+ ) |
||
| 113 | +3016 |
- tf_wrap = FALSE, max_width = NULL) {
+
|
||
| 114 | -2x | +|||
| 3017 | +
- matform <- matrix_form(tt, indent_rownames = TRUE)+ #' @rdname names |
|||
| 115 | -2x | +|||
| 3018 | +
- format_strs <- vapply(+ #' @exportMethod names |
|||
| 116 | -2x | +|||
| 3019 | +
- as.vector(matform$formats),+ setMethod( |
|||
| 117 | -2x | +|||
| 3020 | +
- function(x) {
+ "names", "LayoutColTree", |
|||
| 118 | -18x | +|||
| 3021 | +
- if (inherits(x, "function")) {
+ function(x) {
|
|||
| 119 | -1x | +3022 | +163x |
- "<fnc>"+ unname(unlist(lapply( |
| 120 | -17x | +3023 | +163x |
- } else if (inherits(x, "character")) {
+ tree_children(x), |
| 121 | -17x | +3024 | +163x |
- x+ function(obj) {
|
| 122 | -+ | |||
| 3025 | +202x |
- } else {
+ nm <- obj_name(obj) |
||
| 123 | -! | +|||
| 3026 | +202x |
- stop("Don't know how to make a shell with formats of class: ", class(x))
+ rep(nm, n_leaves(obj)) |
||
| 124 | +3027 |
} |
||
| 125 | +3028 |
- }, ""+ ))) |
||
| 126 | +3029 |
- )+ } |
||
| 127 | +3030 | - - | -||
| 128 | -2x | -
- format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings))+ ) |
||
| 129 | -2x | +|||
| 3031 | +
- format_strs_mat[, 1] <- matform$strings[, 1]+ |
|||
| 130 | -2x | +|||
| 3032 | +
- nlh <- mf_nlheader(matform)+ #' @rdname names |
|||
| 131 | -2x | +|||
| 3033 | +
- format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ]+ #' @exportMethod row.names |
|||
| 132 | +3034 |
-
+ setMethod( |
||
| 133 | -2x | +|||
| 3035 | +
- matform$strings <- format_strs_mat+ "row.names", "VTableTree", |
|||
| 134 | -2x | +|||
| 3036 | +
- if (is.null(widths)) {
+ function(x) {
|
|||
| 135 | -2x | -
- widths <- propose_column_widths(matform)- |
- ||
| 136 | -+ | 3037 | +106x |
- }+ unname(sapply(collect_leaves(x, add.labrows = TRUE), |
| 137 | -2x | +3038 | +106x |
- toString(matform,+ obj_label, |
| 138 | -2x | +3039 | +106x |
- widths = widths, col_gap = col_gap, hsep = hsep,+ USE.NAMES = FALSE |
| 139 | -2x | +3040 | +106x |
- tf_wrap = tf_wrap, max_width = max_width+ )) ## XXXX this should probably be obj_name??? |
| 140 | +3041 |
- )+ } |
||
| 141 | +3042 |
- }+ ) |
||
| 142 | +3043 | |||
| 143 | +3044 |
- #' Transform an `rtable` to a list of matrices which can be used for outputting+ #' Convert to a vector |
||
| 144 | +3045 |
#' |
||
| 145 | +3046 |
- #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML+ #' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in |
||
| 146 | +3047 |
- #' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form.+ #' realistic scenarios. |
||
| 147 | +3048 |
#' |
||
| 148 | +3049 |
- #' @inheritParams gen_args+ #' @param x (`ANY`)\cr the object to be converted to a vector. |
||
| 149 | +3050 |
- #' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output+ #' @param mode (`string`)\cr passed on to [as.vector()]. |
||
| 150 | +3051 |
- #' has indented row names (strings pre-fixed).+ #' |
||
| 151 | +3052 |
- #' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain+ #' @return A vector of the chosen mode (or an error is raised if more than one row was present). |
||
| 152 | +3053 |
- #' newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`.+ #' |
||
| 153 | +3054 |
- #' @param fontspec (`font_spec` or `NULL`)\cr Font specification that should be+ #' @note This only works for a table with a single row or a row object. |
||
| 154 | +3055 |
- #' assumed during wrapping, as returned by [formatters::font_spec()].+ #' |
||
| 155 | +3056 |
- #' @param col_gap (`numeric(1)`)\cr The column gap to assume between columns, in+ #' @name asvec |
||
| 156 | +3057 |
- #' number of spaces assuming `fontspec` (this reduces to number of characters for monospace fonts).+ #' @aliases as.vector,VTableTree-method |
||
| 157 | +3058 |
- #'+ #' @exportMethod as.vector |
||
| 158 | +3059 |
- #' @details+ setMethod("as.vector", "VTableTree", function(x, mode) {
|
||
| 159 | -+ | |||
| 3060 | +12x |
- #' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell+ stopifnot(nrow(x) == 1L) |
||
| 160 | -+ | |||
| 3061 | +12x |
- #' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal+ if (nrow(content_table(x)) == 1L) {
|
||
| 161 | -+ | |||
| 3062 | +! |
- #' function.+ tab <- content_table(x) |
||
| 162 | +3063 |
- #'+ } else {
|
||
| 163 | -+ | |||
| 3064 | +12x |
- #' @return A list with the following elements:+ tab <- x |
||
| 164 | +3065 |
- #' \describe{
+ } |
||
| 165 | -+ | |||
| 3066 | +12x |
- #' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
+ as.vector(tree_children(tab)[[1]], mode = mode) |
||
| 166 | +3067 |
- #' and cell values of `tt`.}+ }) |
||
| 167 | +3068 |
- #' \item{`spans`}{The column-span information for each print-string in the `strings` matrix.}
+
|
||
| 168 | +3069 |
- #' \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.}
+ #' @inheritParams asvec |
||
| 169 | +3070 |
- #' \item{`display`}{Whether each print-string in the strings matrix should be printed.}
+ #' |
||
| 170 | +3071 |
- #' \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
+ #' @rdname int_methods |
||
| 171 | +3072 |
- #' }+ #' @exportMethod as.vector |
||
| 172 | +3073 |
- #'+ setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))
|
||
| 173 | +3074 |
- #' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines.+ |
||
| 174 | +3075 |
- #'+ #' @rdname int_methods |
||
| 175 | +3076 |
- #' @examples+ #' @exportMethod as.vector |
||
| 176 | +3077 |
- #' library(dplyr)+ setMethod("as.vector", "ElementaryTable", function(x, mode) {
|
||
| 177 | -+ | |||
| 3078 | +2x |
- #'+ stopifnot(nrow(x) == 1L) |
||
| 178 | -+ | |||
| 3079 | +2x |
- #' iris2 <- iris %>%+ as.vector(tree_children(x)[[1]], mode = mode) |
||
| 179 | +3080 |
- #' group_by(Species) %>%+ }) |
||
| 180 | +3081 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+
|
||
| 181 | +3082 |
- #' ungroup()+ ## cuts ---- |
||
| 182 | +3083 |
- #'+ |
||
| 183 | +3084 |
- #' lyt <- basic_table() %>%+ #' @rdname int_methods |
||
| 184 | -+ | |||
| 3085 | +220x |
- #' split_cols_by("Species") %>%
+ setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))
|
||
| 185 | +3086 |
- #' split_cols_by("group") %>%
+
|
||
| 186 | +3087 |
- #' analyze(c("Sepal.Length", "Petal.Width"),
+ #' @rdname int_methods |
||
| 187 | +3088 |
- #' afun = list_wrap_x(summary), format = "xx.xx"+ setMethod( |
||
| 188 | +3089 |
- #' )+ "spl_cuts", "VarStaticCutSplit", |
||
| 189 | -+ | |||
| 3090 | +220x |
- #'+ function(obj) obj@cuts |
||
| 190 | +3091 |
- #' lyt+ ) |
||
| 191 | +3092 |
- #'+ |
||
| 192 | +3093 |
- #' tbl <- build_table(lyt, iris2)+ #' @rdname int_methods |
||
| 193 | -+ | |||
| 3094 | +264x |
- #'+ setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))
|
||
| 194 | +3095 |
- #' matrix_form(tbl)+ |
||
| 195 | +3096 |
- #'+ #' @rdname int_methods |
||
| 196 | +3097 |
- #' @export+ setMethod( |
||
| 197 | +3098 |
- setMethod(+ "spl_cutlabels", "VarStaticCutSplit",+ |
+ ||
| 3099 | +264x | +
+ function(obj) obj@cut_labels |
||
| 198 | +3100 |
- "matrix_form", "VTableTree",+ ) |
||
| 199 | +3101 |
- function(obj,+ |
||
| 200 | +3102 |
- indent_rownames = FALSE,+ #' @rdname int_methods+ |
+ ||
| 3103 | +5x | +
+ setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))
|
||
| 201 | +3104 |
- expand_newlines = TRUE,+ |
||
| 202 | +3105 |
- indent_size = 2,+ #' @rdname int_methods |
||
| 203 | +3106 |
- fontspec = NULL,+ setMethod( |
||
| 204 | +3107 |
- col_gap = 3L) {
+ "spl_cutfun", "VarDynCutSplit", |
||
| 205 | -311x | +3108 | +5x |
- stopifnot(is(obj, "VTableTree"))+ function(obj) obj@cut_fun |
| 206 | -311x | +|||
| 3109 | +
- header_content <- .tbl_header_mat(obj) # first col are for row.names+ ) |
|||
| 207 | +3110 | |||
| 3111 | ++ |
+ #' @rdname int_methods+ |
+ ||
| 208 | -309x | +3112 | +5x |
- sr <- make_row_df(obj, fontspec = fontspec)+ setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))
|
| 209 | +3113 | |||
| 210 | -309x | +|||
| 3114 | +
- body_content_strings <- if (NROW(sr) == 0) {
+ #' @rdname int_methods |
|||
| 211 | -5x | +|||
| 3115 | +
- character()+ setMethod( |
|||
| 212 | +3116 |
- } else {
+ "spl_cutlabelfun", "VarDynCutSplit", |
||
| 213 | -304x | +3117 | +5x |
- cbind(as.character(sr$label), get_formatted_cells(obj))+ function(obj) obj@cut_label_fun |
| 214 | +3118 |
- }+ ) |
||
| 215 | +3119 | |||
| 216 | -309x | +|||
| 3120 | +
- formats_strings <- if (NROW(sr) == 0) {
+ #' @rdname int_methods |
|||
| 217 | +3121 | 5x |
- character()+ setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))
|
|
| 218 | +3122 |
- } else {
+
|
||
| 219 | -304x | +|||
| 3123 | +
- cbind("", get_formatted_cells(obj, shell = TRUE))
+ #' @rdname int_methods |
|||
| 220 | +3124 |
- }+ setMethod( |
||
| 221 | +3125 |
-
+ "spl_is_cmlcuts", "VarDynCutSplit", |
||
| 222 | -309x | +3126 | +5x |
- tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
+ function(obj) obj@cumulative_cuts |
| 223 | -7079x | +|||
| 3127 | +
- sp <- row_cspans(rr)+ ) |
|||
| 224 | -7079x | +|||
| 3128 | +
- rep(sp, times = sp)+ |
|||
| 225 | +3129 |
- })+ #' @rdname int_methods |
||
| 226 | +3130 |
-
+ setGeneric( |
||
| 227 | +3131 |
- ## the 1 is for row labels+ "spl_varnames", |
||
| 228 | -309x | +3132 | +198x |
- body_spans <- if (nrow(obj) > 0) {
+ function(obj) standardGeneric("spl_varnames")
|
| 229 | -304x | +|||
| 3133 | +
- cbind(1L, do.call(rbind, tsptmp))+ ) |
|||
| 230 | +3134 |
- } else {
+
|
||
| 231 | -5x | +|||
| 3135 | +
- matrix(1, nrow = 0, ncol = ncol(obj) + 1)+ #' @rdname int_methods |
|||
| 232 | +3136 |
- }+ setMethod( |
||
| 233 | +3137 |
-
+ "spl_varnames", "MultiVarSplit", |
||
| 234 | -309x | +3138 | +198x |
- body_aligns <- if (NROW(sr) == 0) {
+ function(obj) obj@var_names |
| 235 | -5x | +|||
| 3139 | +
- character()+ ) |
|||
| 236 | +3140 |
- } else {
+
|
||
| 237 | -304x | +|||
| 3141 | +
- cbind("left", get_cell_aligns(obj))
+ #' @rdname int_methods |
|||
| 238 | +3142 |
- }+ setGeneric( |
||
| 239 | +3143 |
-
+ "spl_varnames<-", |
||
| 240 | -309x | +3144 | +2x |
- body <- rbind(header_content$body, body_content_strings)+ function(object, value) standardGeneric("spl_varnames<-")
|
| 241 | +3145 |
-
+ ) |
||
| 242 | -309x | +|||
| 3146 | +
- hdr_fmt_blank <- matrix("",
+
|
|||
| 243 | -309x | +|||
| 3147 | +
- nrow = nrow(header_content$body),+ #' @rdname int_methods |
|||
| 244 | -309x | +|||
| 3148 | +
- ncol = ncol(header_content$body)+ setMethod( |
|||
| 245 | +3149 |
- )- |
- ||
| 246 | -309x | -
- if (disp_ccounts(obj)) {
- |
- ||
| 247 | -42x | -
- hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
+ "spl_varnames<-", "MultiVarSplit", |
||
| 248 | +3150 |
- }+ function(object, value) {
|
||
| 249 | -+ | |||
| 3151 | +2x |
-
+ oldvnms <- spl_varnames(object) |
||
| 250 | -309x | +3152 | +2x |
- formats <- rbind(hdr_fmt_blank, formats_strings)+ oldvlbls <- spl_varlabels(object) |
| 251 | -+ | |||
| 3153 | +2x |
-
+ object@var_names <- value |
||
| 252 | -309x | +3154 | +2x |
- spans <- rbind(header_content$span, body_spans)+ if (identical(oldvnms, oldvlbls)) {
|
| 253 | -309x | +3155 | +1x |
- row.names(spans) <- NULL+ spl_varlabels(object) <- value |
| 254 | +3156 | - - | -||
| 255 | -309x | -
- aligns <- rbind(- |
- ||
| 256 | -309x | -
- matrix(rep("center", length(header_content$body)),
+ } |
||
| 257 | -309x | +3157 | +2x |
- nrow = nrow(header_content$body)+ object |
| 258 | +3158 |
- ),+ } |
||
| 259 | -309x | +|||
| 3159 | +
- body_aligns+ ) |
|||
| 260 | +3160 |
- )+ |
||
| 261 | +3161 |
-
+ #' Top left material |
||
| 262 | -309x | +|||
| 3162 | +
- aligns[, 1] <- "left" # row names and topleft (still needed for topleft)+ #' |
|||
| 263 | +3163 |
-
+ #' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the |
||
| 264 | -309x | +|||
| 3164 | +
- nr_header <- nrow(header_content$body)+ #' area of the table between the column header display and the label of the first row. These functions access |
|||
| 265 | -309x | +|||
| 3165 | +
- if (indent_rownames) {
+ #' and modify that material. |
|||
| 266 | -239x | +|||
| 3166 | +
- body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent),+ #' |
|||
| 267 | -239x | +|||
| 3167 | +
- incr = indent_size+ #' @inheritParams gen_args |
|||
| 268 | +3168 |
- )+ #' |
||
| 269 | +3169 |
- # why also formats?+ #' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the |
||
| 270 | -239x | +|||
| 3170 | +
- formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent),+ #' case of the setter). |
|||
| 271 | -239x | +|||
| 3171 | +
- incr = indent_size+ #' |
|||
| 272 | +3172 |
- )+ #' @export |
||
| 273 | -70x | +|||
| 3173 | +
- } else if (NROW(sr) > 0) {
+ #' @rdname top_left |
|||
| 274 | -66x | +3174 | +6918x |
- sr$indent <- rep(0, NROW(sr))+ setGeneric("top_left", function(obj) standardGeneric("top_left"))
|
| 275 | +3175 |
- }+ |
||
| 276 | +3176 |
-
+ #' @export |
||
| 277 | -309x | +|||
| 3177 | +
- col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
+ #' @rdname top_left |
|||
| 278 | -2344x | +3178 | +3000x |
- if (length(x) == 0) {
+ setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))
|
| 279 | +3179 |
- ""+ |
||
| 280 | +3180 |
- } else {
- |
- ||
| 281 | -5x | -
- paste(vapply(x, format_fnote_ref, ""), collapse = " ")+ #' @export |
||
| 282 | +3181 |
- }+ #' @rdname top_left |
||
| 283 | -309x | +3182 | +3600x |
- }, ""), ncol = ncol(body))+ setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)
|
| 284 | -309x | +|||
| 3183 | +
- body_ref_strs <- get_ref_matrix(obj)+ |
|||
| 285 | +3184 |
-
+ #' @export |
||
| 286 | -309x | +|||
| 3185 | +
- body <- matrix(+ #' @rdname top_left |
|||
| 287 | -309x | +3186 | +318x |
- paste0(+ setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)
|
| 288 | -309x | +|||
| 3187 | +
- body,+ |
|||
| 289 | -309x | +|||
| 3188 | +
- rbind(+ #' @export |
|||
| 290 | -309x | +|||
| 3189 | +
- col_ref_strs,+ #' @rdname top_left |
|||
| 291 | -309x | +3190 | +5923x |
- body_ref_strs+ setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))
|
| 292 | +3191 |
- )+ |
||
| 293 | +3192 |
- ),- |
- ||
| 294 | -309x | -
- nrow = nrow(body),- |
- ||
| 295 | -309x | -
- ncol = ncol(body)+ #' @export |
||
| 296 | +3193 |
- )+ #' @rdname top_left |
||
| 297 | +3194 |
-
+ setMethod("top_left<-", "VTableTree", function(obj, value) {
|
||
| 298 | -309x | +3195 | +2961x |
- ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here+ cinfo <- col_info(obj) |
| 299 | -309x | +3196 | +2961x |
- pag_titles <- page_titles(obj)+ top_left(cinfo) <- value |
| 300 | -+ | |||
| 3197 | +2961x |
-
+ col_info(obj) <- cinfo |
||
| 301 | -309x | +3198 | +2961x |
- MatrixPrintForm(+ obj |
| 302 | -309x | +|||
| 3199 | +
- strings = body,+ }) |
|||
| 303 | -309x | +|||
| 3200 | +
- spans = spans,+ |
|||
| 304 | -309x | +|||
| 3201 | +
- aligns = aligns,+ #' @export |
|||
| 305 | -309x | +|||
| 3202 | +
- formats = formats,+ #' @rdname top_left |
|||
| 306 | +3203 |
- ## display = display, purely a function of spans, handled in constructor now+ setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
|
||
| 307 | -309x | +3204 | +2961x |
- row_info = sr,+ obj@top_left <- value |
| 308 | -309x | +3205 | +2961x |
- colpaths = make_col_df(obj)[["path"]],+ obj |
| 309 | +3206 |
- ## line_grouping handled internally now line_grouping = 1:nrow(body),- |
- ||
| 310 | -309x | -
- ref_fnotes = ref_fnotes,+ }) |
||
| 311 | -309x | +|||
| 3207 | +
- nlines_header = nr_header, ## this is fixed internally+ |
|||
| 312 | -309x | +|||
| 3208 | +
- nrow_header = nr_header,+ #' @export |
|||
| 313 | -309x | +|||
| 3209 | +
- expand_newlines = expand_newlines,+ #' @rdname top_left |
|||
| 314 | -309x | +|||
| 3210 | +
- has_rowlabs = TRUE,+ setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
|
|||
| 315 | -309x | +3211 | +1x |
- has_topleft = TRUE,+ obj@top_left <- value |
| 316 | -309x | +3212 | +1x |
- main_title = main_title(obj),+ obj |
| 317 | -309x | +|||
| 3213 | +
- subtitles = subtitles(obj),+ }) |
|||
| 318 | -309x | +|||
| 3214 | +
- page_titles = pag_titles,+ |
|||
| 319 | -309x | +|||
| 3215 | +
- main_footer = main_footer(obj),+ vil_collapse <- function(x) {
|
|||
| 320 | -309x | +3216 | +14x |
- prov_footer = prov_footer(obj),+ x <- unlist(x) |
| 321 | -309x | +3217 | +14x |
- table_inset = table_inset(obj),+ x <- x[!is.na(x)] |
| 322 | -309x | +3218 | +14x |
- header_section_div = header_section_div(obj),+ x <- unique(x) |
| 323 | -309x | +3219 | +14x |
- horizontal_sep = horizontal_sep(obj),+ x[nzchar(x)] |
| 324 | -309x | +|||
| 3220 | +
- indent_size = indent_size,+ } |
|||
| 325 | -309x | +|||
| 3221 | +
- fontspec = fontspec,+ |
|||
| 326 | -309x | +|||
| 3222 | +
- col_gap = col_gap+ #' List variables required by a pre-data table layout |
|||
| 327 | +3223 |
- )+ #' |
||
| 328 | +3224 |
- }+ #' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof). |
||
| 329 | +3225 |
- )+ #' |
||
| 330 | +3226 |
-
+ #' @details |
||
| 331 | +3227 |
- .quick_handle_nl <- function(str_v) {
+ #' This will walk the layout declaration and return a vector of the names of the unique variables that are used |
||
| 332 | -! | +|||
| 3228 | +
- if (any(grepl("\n", str_v))) {
+ #' in any of the following ways: |
|||
| 333 | -! | +|||
| 3229 | +
- return(unlist(strsplit(str_v, "\n", fixed = TRUE)))+ #' |
|||
| 334 | +3230 |
- } else {
+ #' * Variable being split on (directly or via cuts) |
||
| 335 | -! | +|||
| 3231 | +
- return(str_v)+ #' * Element of a Multi-variable column split |
|||
| 336 | +3232 |
- }+ #' * Content variable |
||
| 337 | +3233 |
- }+ #' * Value-label variable |
||
| 338 | +3234 |
-
+ #' |
||
| 339 | +3235 |
- .resolve_fn_symbol <- function(fn) {
+ #' @return A character vector containing the unique variables explicitly used in the layout (see the notes below). |
||
| 340 | -3242x | +|||
| 3236 | +
- if (!is(fn, "RefFootnote")) {
+ #' |
|||
| 341 | -! | +|||
| 3237 | +
- return(NULL)+ #' @note |
|||
| 342 | +3238 |
- }+ #' * This function will not detect dependencies implicit in analysis or summary functions which accept `x` |
||
| 343 | -3242x | +|||
| 3239 | +
- ret <- ref_symbol(fn)+ #' or `df` and then rely on the existence of particular variables not being split on/analyzed. |
|||
| 344 | -3242x | +|||
| 3240 | +
- if (is.na(ret)) {
+ #' * The order these variable names appear within the return vector is undefined and should not be relied upon. |
|||
| 345 | -3242x | +|||
| 3241 | +
- ret <- as.character(ref_index(fn))+ #' |
|||
| 346 | +3242 |
- }+ #' @examples |
||
| 347 | -3242x | +|||
| 3243 | +
- ret+ #' lyt <- basic_table() %>% |
|||
| 348 | +3244 |
- }+ #' split_cols_by("ARM") %>%
|
||
| 349 | +3245 |
-
+ #' split_cols_by("SEX") %>%
|
||
| 350 | +3246 |
- format_fnote_ref <- function(fn) {
+ #' summarize_row_groups(label_fstr = "Overall (N)") %>% |
||
| 351 | -43019x | +|||
| 3247 | +
- if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
+ #' split_rows_by("RACE",
|
|||
| 352 | -42478x | +|||
| 3248 | +
- return("")
+ #' split_label = "Ethnicity", labels_var = "ethn_lab", |
|||
| 353 | -541x | +|||
| 3249 | +
- } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
+ #' split_fun = drop_split_levels |
|||
| 354 | -! | +|||
| 3250 | +
- return(vapply(fn, format_fnote_ref, ""))+ #' ) %>% |
|||
| 355 | +3251 |
- }+ #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
|
||
| 356 | -541x | +|||
| 3252 | +
- if (is.list(fn)) {
+ #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
|
|||
| 357 | -536x | +|||
| 3253 | +
- inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol))+ #' |
|||
| 358 | +3254 |
- } else {
+ #' vars_in_layout(lyt) |
||
| 359 | -5x | +|||
| 3255 | +
- inds <- .resolve_fn_symbol(fn)+ #' |
|||
| 360 | +3256 |
- }+ #' @export |
||
| 361 | -541x | +|||
| 3257 | +
- if (length(inds) > 0) {
+ #' @rdname vil |
|||
| 362 | -541x | +3258 | +15x |
- paste0(" {", paste(unique(inds), collapse = ", "), "}")
+ setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))
|
| 363 | +3259 |
- } else {
+
|
||
| 364 | +3260 |
- ""+ #' @rdname vil |
||
| 365 | +3261 |
- }+ setMethod( |
||
| 366 | +3262 |
- }+ "vars_in_layout", "PreDataTableLayouts", |
||
| 367 | +3263 |
-
+ function(lyt) {
|
||
| 368 | -+ | |||
| 3264 | +1x |
- format_fnote_note <- function(fn) {
+ vil_collapse(c( |
||
| 369 | -2691x | +3265 | +1x |
- if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
+ vars_in_layout(clayout(lyt)), |
| 370 | -! | +|||
| 3266 | +1x |
- return(character())+ vars_in_layout(rlayout(lyt)) |
||
| 371 | +3267 |
- }+ )) |
||
| 372 | -2691x | +|||
| 3268 | +
- if (is.list(fn)) {
+ } |
|||
| 373 | -! | +|||
| 3269 | +
- return(unlist(lapply(unlist(fn), format_fnote_note)))+ ) |
|||
| 374 | +3270 |
- }+ |
||
| 375 | +3271 |
-
+ #' @rdname vil |
||
| 376 | -2691x | +|||
| 3272 | +
- if (is(fn, "RefFootnote")) {
+ setMethod( |
|||
| 377 | -2691x | +|||
| 3273 | +
- paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
+ "vars_in_layout", "PreDataAxisLayout", |
|||
| 378 | +3274 |
- } else {
+ function(lyt) {
|
||
| 379 | -! | +|||
| 3275 | +2x |
- NULL+ vil_collapse(lapply(lyt, vars_in_layout)) |
||
| 380 | +3276 |
} |
||
| 381 | +3277 |
- }+ ) |
||
| 382 | +3278 | |||
| 383 | +3279 |
- .fn_ind_extractor <- function(strs) {
- |
- ||
| 384 | -! | -
- res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
- |
- ||
| 385 | -! | -
- res[res == "NA"] <- NA_character_+ #' @rdname vil |
||
| 386 | +3280 |
- ## these mixing is allowed now with symbols+ setMethod( |
||
| 387 | +3281 |
- ## if(!(sum(is.na(res)) %in% c(0L, length(res))))+ "vars_in_layout", "SplitVector", |
||
| 388 | +3282 |
- ## stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
+ function(lyt) {
|
||
| 389 | -! | +|||
| 3283 | +3x |
- res+ vil_collapse(lapply(lyt, vars_in_layout)) |
||
| 390 | +3284 |
- }+ } |
||
| 391 | +3285 |
-
+ ) |
||
| 392 | +3286 |
- get_ref_matrix <- function(tt) {
+
|
||
| 393 | -309x | +|||
| 3287 | +
- if (ncol(tt) == 0 || nrow(tt) == 0) {
+ #' @rdname vil |
|||
| 394 | -5x | +|||
| 3288 | +
- return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
+ setMethod( |
|||
| 395 | +3289 |
- }+ "vars_in_layout", "Split", |
||
| 396 | -304x | +|||
| 3290 | +
- rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)+ function(lyt) {
|
|||
| 397 | -304x | +3291 | +7x |
- lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE)+ vil_collapse(c( |
| 398 | -304x | +3292 | +7x |
- cstrs <- unlist(lapply(lst, format_fnote_ref))+ spl_payload(lyt), |
| 399 | -304x | +|||
| 3293 | +
- bodymat <- matrix(cstrs,+ ## for an AllSplit/RootSplit |
|||
| 400 | -304x | +|||
| 3294 | +
- byrow = TRUE,+ ## doesn't have to be same as payload |
|||
| 401 | -304x | +3295 | +7x |
- nrow = nrow(tt),+ content_var(lyt), |
| 402 | -304x | +3296 | +7x |
- ncol = ncol(tt)+ spl_label_var(lyt) |
| 403 | +3297 |
- )+ )) |
||
| 404 | -304x | +|||
| 3298 | +
- cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat)+ } |
|||
| 405 | +3299 |
- }+ ) |
||
| 406 | +3300 | |||
| 407 | +3301 |
- get_formatted_fnotes <- function(tt) {
- |
- ||
| 408 | -309x | -
- colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes)- |
- ||
| 409 | -309x | -
- rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)+ #' @rdname vil |
||
| 410 | -309x | +|||
| 3302 | +
- lst <- c(+ setMethod( |
|||
| 411 | -309x | +|||
| 3303 | +
- colresfs,+ "vars_in_layout", "CompoundSplit", |
|||
| 412 | -309x | +3304 | +1x |
- unlist(+ function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout)) |
| 413 | -309x | +|||
| 3305 | +
- lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)),+ ) |
|||
| 414 | -309x | +|||
| 3306 | +
- recursive = FALSE+ |
|||
| 415 | +3307 |
- )+ #' @rdname vil |
||
| 416 | +3308 |
- )+ setMethod( |
||
| 417 | +3309 |
-
+ "vars_in_layout", "ManualSplit", |
||
| 418 | -309x | +3310 | +1x |
- inds <- vapply(lst, ref_index, 1L)- |
-
| 419 | -309x | -
- ord <- order(inds)- |
- ||
| 420 | -309x | -
- lst <- lst[ord]- |
- ||
| 421 | -309x | -
- syms <- vapply(lst, ref_symbol, "")- |
- ||
| 422 | -309x | -
- keep <- is.na(syms) | !duplicated(syms)- |
- ||
| 423 | -309x | -
- lst <- lst[keep]- |
- ||
| 424 | -309x | -
- unique(vapply(lst, format_fnote_note, ""))+ function(lyt) character() |
||
| 425 | +3311 |
-
+ ) |
||
| 426 | +3312 |
- ## , recursive = FALSE)+ |
||
| 427 | +3313 |
- ## rlst <- unlist(lapply(rows, row_footnotes))+ ## Titles and footers ---- |
||
| 428 | +3314 |
- ## lst <-+ |
||
| 429 | +3315 |
- ## syms <- vapply(lst, ref_symbol, "")+ # ##' Titles and Footers |
||
| 430 | +3316 |
- ## keep <- is.na(syms) | !duplicated(syms)+ # ##' |
||
| 431 | +3317 |
- ## lst <- lst[keep]+ # ##' Get or set the titles and footers on an object |
||
| 432 | +3318 |
- ## inds <- vapply(lst, ref_index, 1L)+ # ##' |
||
| 433 | +3319 |
- ## cellstrs <- unlist(lapply(lst, format_fnote_note))+ # ##' @inheritParams gen_args |
||
| 434 | +3320 |
- ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw))))+ # ##' |
||
| 435 | +3321 |
- ## allstrs <- c(colstrs, rstrs, cellstrs)+ # ##' @rdname title_footer |
||
| 436 | +3322 |
- ## inds <- .fn_ind_extractor(allstrs)+ # ##' @export |
||
| 437 | +3323 |
- ## allstrs[order(inds)]+ #' @rdname formatters_methods |
||
| 438 | +3324 |
- }+ #' @export |
||
| 439 | +3325 |
-
+ setMethod( |
||
| 440 | +3326 |
- .do_tbl_h_piece2 <- function(tt) {
- |
- ||
| 441 | -316x | -
- coldf <- make_col_df(tt, visible_only = FALSE)- |
- ||
| 442 | -316x | -
- remain <- seq_len(nrow(coldf))+ "main_title", "VTitleFooter", |
||
| 443 | -316x | +3327 | +3605x |
- chunks <- list()+ function(obj) obj@main_title |
| 444 | -316x | +|||
| 3328 | +
- cur <- 1+ ) |
|||
| 445 | +3329 | |||
| 446 | +3330 |
- ## each iteration of this loop identifies+ ##' @rdname formatters_methods |
||
| 447 | +3331 |
- ## all rows corresponding to one top-level column+ ##' @export |
||
| 448 | +3332 |
- ## label and its children, then processes those+ setMethod( |
||
| 449 | +3333 |
- ## with .do_header_chunk+ "main_title<-", "VTitleFooter", |
||
| 450 | -316x | +|||
| 3334 | +
- while (length(remain) > 0) {
+ function(obj, value) {
|
|||
| 451 | -845x | +3335 | +3168x |
- rw <- remain[1]+ stopifnot(length(value) == 1) |
| 452 | -845x | +3336 | +3168x |
- inds <- coldf$leaf_indices[[rw]]+ obj@main_title <- value |
| 453 | -845x | +3337 | +3168x |
- endblock <- which(coldf$abs_pos == max(inds))+ obj |
| 454 | +3338 | - - | -||
| 455 | -845x | -
- stopifnot(endblock >= rw)- |
- ||
| 456 | -845x | -
- chunks[[cur]] <- .do_header_chunk(coldf[rw:endblock, ])+ } |
||
| 457 | -845x | +|||
| 3339 | +
- remain <- remain[remain > endblock]+ ) |
|||
| 458 | -845x | +|||
| 3340 | +
- cur <- cur + 1+ |
|||
| 459 | +3341 |
- }+ # Getters for TableRow is here for convenience for binding (no need of setters) |
||
| 460 | -316x | +|||
| 3342 | +
- chunks <- .pad_tops(chunks)+ #' @rdname formatters_methods |
|||
| 461 | -316x | +|||
| 3343 | +
- lapply(+ #' @export |
|||
| 462 | -316x | +|||
| 3344 | +
- seq_len(length(chunks[[1]])),+ setMethod( |
|||
| 463 | -316x | +|||
| 3345 | +
- function(i) {
+ "main_title", "TableRow", |
|||
| 464 | -429x | +3346 | +6x |
- DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE))+ function(obj) "" |
| 465 | +3347 |
- }+ ) |
||
| 466 | +3348 |
- )+ |
||
| 467 | +3349 |
- }+ #' @rdname formatters_methods |
||
| 468 | +3350 |
-
+ #' @export |
||
| 469 | +3351 |
- .pad_end <- function(lst, padto, ncols) {
- |
- ||
| 470 | -1134x | -
- curcov <- sum(vapply(lst, cell_cspan, 0L))+ setMethod( |
||
| 471 | -1134x | +|||
| 3352 | +
- if (curcov == padto) {
+ "subtitles", "VTitleFooter", |
|||
| 472 | -1134x | +3353 | +3595x |
- return(lst)+ function(obj) obj@subtitles |
| 473 | +3354 |
- }+ ) |
||
| 474 | +3355 | |||
| 475 | -! | -
- c(lst, list(rcell("", colspan = padto - curcov)))
- |
- ||
| 476 | +3356 |
- }+ #' @rdname formatters_methods |
||
| 477 | +3357 |
-
+ #' @export |
||
| 478 | +3358 |
- .pad_tops <- function(chunks) {
- |
- ||
| 479 | -316x | -
- lens <- vapply(chunks, length, 1L)+ setMethod( |
||
| 480 | -316x | +|||
| 3359 | +
- padto <- max(lens)+ "subtitles<-", "VTitleFooter", |
|||
| 481 | -316x | +|||
| 3360 | +
- needpad <- lens != padto+ function(obj, value) {
|
|||
| 482 | -316x | +3361 | +3163x |
- if (all(!needpad)) {
+ obj@subtitles <- value |
| 483 | -314x | +3362 | +3163x |
- return(chunks)+ obj |
| 484 | +3363 |
} |
||
| 485 | +3364 | - - | -||
| 486 | -2x | -
- chunks[needpad] <- lapply(+ ) |
||
| 487 | -2x | +|||
| 3365 | +
- chunks[needpad],+ |
|||
| 488 | -2x | +|||
| 3366 | +
- function(chk) {
+ #' @rdname formatters_methods |
|||
| 489 | -4x | +|||
| 3367 | +
- span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L))+ #' @export |
|||
| 490 | -4x | +|||
| 3368 | +
- needed <- padto - length(chk)+ setMethod( |
|||
| 491 | -4x | +|||
| 3369 | +
- c(+ "subtitles", "TableRow", # Only getter: see main_title for TableRow |
|||
| 492 | -4x | +3370 | +6x |
- replicate(rcell("", colspan = span),
+ function(obj) character() |
| 493 | -4x | +|||
| 3371 | +
- n = needed+ ) |
|||
| 494 | +3372 |
- ),+ |
||
| 495 | -4x | +|||
| 3373 | +
- chk+ #' @rdname formatters_methods |
|||
| 496 | +3374 |
- )+ #' @export |
||
| 497 | +3375 |
- }+ setMethod( |
||
| 498 | +3376 |
- )+ "main_footer", "VTitleFooter", |
||
| 499 | -2x | +3377 | +3605x |
- chunks+ function(obj) obj@main_footer |
| 500 | +3378 |
- }+ ) |
||
| 501 | +3379 | |||
| 502 | +3380 |
- .do_header_chunk <- function(coldf) {
+ #' @rdname formatters_methods |
||
| 503 | +3381 |
- ## hard assumption that coldf is a section+ #' @export |
||
| 504 | +3382 |
- ## of a column dataframe summary that was+ setMethod( |
||
| 505 | +3383 |
- ## created with visible_only=FALSE- |
- ||
| 506 | -845x | -
- nleafcols <- length(coldf$leaf_indices[[1]])+ "main_footer<-", "VTitleFooter", |
||
| 507 | +3384 |
-
+ function(obj, value) {
|
||
| 508 | -845x | +3385 | +3168x |
- spldfs <- split(coldf, lengths(coldf$path))+ obj@main_footer <- value |
| 509 | -845x | +3386 | +3168x |
- toret <- lapply(+ obj |
| 510 | -845x | +|||
| 3387 | +
- seq_along(spldfs),+ } |
|||
| 511 | -845x | +|||
| 3388 | +
- function(i) {
+ ) |
|||
| 512 | -1134x | +|||
| 3389 | +
- rws <- spldfs[[i]]+ |
|||
| 513 | +3390 |
-
+ #' @rdname formatters_methods |
||
| 514 | -1134x | +|||
| 3391 | +
- thisbit <- lapply(+ #' @export |
|||
| 515 | -1134x | +|||
| 3392 | +
- seq_len(nrow(rws)),+ setMethod( |
|||
| 516 | -1134x | +|||
| 3393 | +
- function(ri) {
+ "main_footer", "TableRow", # Only getter: see main_title for TableRow |
|||
| 517 | -1429x | +3394 | +6x |
- rcell(rws[ri, "label", drop = TRUE],+ function(obj) character() |
| 518 | -1429x | +|||
| 3395 | +
- colspan = rws$total_span[ri],+ ) |
|||
| 519 | -1429x | +|||
| 3396 | +
- footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]]+ |
|||
| 520 | +3397 |
- )+ #' @rdname formatters_methods |
||
| 521 | +3398 |
- }+ #' @export |
||
| 522 | +3399 |
- )+ setMethod(+ |
+ ||
| 3400 | ++ |
+ "prov_footer", "VTitleFooter", |
||
| 523 | -1134x | +3401 | +3588x |
- .pad_end(thisbit, nleafcols)+ function(obj) obj@provenance_footer |
| 524 | +3402 |
- }+ ) |
||
| 525 | +3403 |
- )+ |
||
| 526 | +3404 |
-
+ #' @rdname formatters_methods |
||
| 527 | -845x | +|||
| 3405 | +
- toret+ #' @export |
|||
| 528 | +3406 |
- }+ setMethod( |
||
| 529 | +3407 |
-
+ "prov_footer<-", "VTitleFooter", |
||
| 530 | +3408 |
- .tbl_header_mat <- function(tt) {
+ function(obj, value) {
|
||
| 531 | -311x | +3409 | +3162x |
- rows <- .do_tbl_h_piece2(tt) ## (clyt)+ obj@provenance_footer <- value |
| 532 | -311x | +3410 | +3162x |
- cinfo <- col_info(tt)+ obj |
| 533 | +3411 | ++ |
+ }+ |
+ |
| 3412 | ++ |
+ )+ |
+ ||
| 3413 | ||||
| 534 | -311x | +|||
| 3414 | +
- nc <- ncol(tt)+ #' @rdname formatters_methods |
|||
| 535 | -311x | +|||
| 3415 | +
- body <- matrix(rapply(rows, function(x) {
+ #' @export |
|||
| 536 | -424x | +|||
| 3416 | +
- cs <- row_cspans(x)+ setMethod( |
|||
| 537 | -! | +|||
| 3417 | +
- if (is.null(cs)) cs <- rep(1, ncol(x))+ "prov_footer", "TableRow", # Only getter: see main_title for TableRow |
|||
| 538 | -424x | +3418 | +6x |
- rep(row_values(x), cs)+ function(obj) character() |
| 539 | -311x | +|||
| 3419 | +
- }), ncol = nc, byrow = TRUE)+ ) |
|||
| 540 | +3420 | |||
| 541 | -311x | +|||
| 3421 | +
- span <- matrix(rapply(rows, function(x) {
+ make_ref_value <- function(value) {
|
|||
| 542 | -424x | +3422 | +3376x |
- cs <- row_cspans(x)+ if (is(value, "RefFootnote")) {
|
| 543 | +3423 | ! |
- if (is.null(cs)) cs <- rep(1, ncol(x))+ value <- list(value) |
|
| 544 | -424x | +3424 | +3376x |
- rep(cs, cs)+ } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
|
| 545 | -311x | +3425 | +11x |
- }), ncol = nc, byrow = TRUE)+ value <- lapply(value, RefFootnote) |
| 546 | +3426 | - - | -||
| 547 | -311x | -
- fnote <- do.call(- |
- ||
| 548 | -311x | -
- rbind,+ } |
||
| 549 | -311x | +3427 | +3376x |
- lapply(rows, function(x) {
+ value |
| 550 | -424x | +|||
| 3428 | +
- cell_footnotes(x)+ } |
|||
| 551 | +3429 |
- })+ |
||
| 552 | +3430 |
- )+ #' Referential footnote accessors |
||
| 553 | +3431 |
-
+ #' |
||
| 554 | -311x | +|||
| 3432 | +
- if (disp_ccounts(cinfo)) {
+ #' Access and set the referential footnotes aspects of a built table. |
|||
| 555 | -44x | +|||
| 3433 | +
- counts <- col_counts(cinfo)+ #' |
|||
| 556 | -44x | +|||
| 3434 | +
- cformat <- colcount_format(cinfo)+ #' @inheritParams gen_args |
|||
| 557 | +3435 |
-
+ #' |
||
| 558 | +3436 |
- # allow 2d column count formats (count (%) only)+ #' @export |
||
| 559 | -44x | +|||
| 3437 | +
- cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == cformat))))+ #' @rdname ref_fnotes |
|||
| 560 | -44x | +3438 | +54196x |
- if (cfmt_dim == "2d") {
+ setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))
|
| 561 | -3x | +|||
| 3439 | +
- if (grepl("%", cformat)) {
+
|
|||
| 562 | -2x | +|||
| 3440 | +
- counts <- lapply(counts, function(x) c(x, 1))+ #' @export |
|||
| 563 | +3441 |
- } else {
+ #' @rdname int_methods |
||
| 564 | -1x | +|||
| 3442 | +
- stop(+ setMethod( |
|||
| 565 | -1x | +|||
| 3443 | +
- "This 2d format is not supported for column counts. ",+ "row_footnotes", "TableRow", |
|||
| 566 | -1x | +3444 | +52185x |
- "Please choose a 1d format or a 2d format that includes a % value."+ function(obj) obj@row_footnotes |
| 567 | +3445 |
- )+ ) |
||
| 568 | +3446 |
- }+ |
||
| 569 | -41x | +|||
| 3447 | +
- } else if (cfmt_dim == "3d") {
+ #' @export |
|||
| 570 | -1x | +|||
| 3448 | +
- stop("3d formats are not supported for column counts.")
+ #' @rdname int_methods |
|||
| 571 | +3449 |
- }+ setMethod( |
||
| 572 | +3450 |
-
+ "row_footnotes", "RowsVerticalSection", |
||
| 573 | -42x | +3451 | +1586x |
- body <- rbind(body, vapply(counts, format_rcell,+ function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list() |
| 574 | -42x | +|||
| 3452 | +
- character(1),+ ) |
|||
| 575 | -42x | +|||
| 3453 | +
- format = cformat,+ |
|||
| 576 | -42x | +|||
| 3454 | +
- na_str = ""+ #' @export |
|||
| 577 | +3455 |
- ))+ #' @rdname ref_fnotes |
||
| 578 | -42x | +3456 | +82x |
- span <- rbind(span, rep(1, nc))+ setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))
|
| 579 | -42x | +|||
| 3457 | +
- fnote <- rbind(fnote, rep(list(list()), nc))+ |
|||
| 580 | +3458 |
- }+ #' @export |
||
| 581 | +3459 |
-
+ #' @rdname int_methods |
||
| 582 | -309x | +|||
| 3460 | +
- tl <- top_left(cinfo)+ setMethod( |
|||
| 583 | -309x | +|||
| 3461 | +
- lentl <- length(tl)+ "row_footnotes<-", "TableRow", |
|||
| 584 | -309x | +|||
| 3462 | +
- nli <- nrow(body)+ function(obj, value) {
|
|||
| 585 | -309x | +3463 | +82x |
- if (lentl == 0) {
+ obj@row_footnotes <- make_ref_value(value) |
| 586 | -260x | +3464 | +82x |
- tl <- rep("", nli)
+ obj |
| 587 | -49x | +|||
| 3465 | +
- } else if (lentl > nli) {
+ } |
|||
| 588 | -19x | +|||
| 3466 | +
- tl_tmp <- paste0(tl, collapse = "\n")+ ) |
|||
| 589 | -19x | +|||
| 3467 | +
- tl <- rep("", nli)
+
|
|||
| 590 | -19x | +|||
| 3468 | +
- tl[length(tl)] <- tl_tmp+ #' @export |
|||
| 591 | -30x | +|||
| 3469 | +
- } else if (lentl < nli) {
+ #' @rdname int_methods |
|||
| 592 | +3470 |
- # We want topleft alignment that goes to the bottom!+ setMethod( |
||
| 593 | -19x | +|||
| 3471 | +
- tl <- c(rep("", nli - lentl), tl)
+ "row_footnotes", "VTableTree", |
|||
| 594 | +3472 |
- }+ function(obj) {
|
||
| 595 | -309x | +3473 | +425x |
- list(+ rws <- collect_leaves(obj, TRUE, TRUE) |
| 596 | -309x | +3474 | +425x |
- body = cbind(tl, body, deparse.level = 0), span = cbind(1, span),+ cells <- lapply(rws, row_footnotes) |
| 597 | -309x | +3475 | +425x |
- footnotes = cbind(list(list()), fnote)+ cells |
| 598 | +3476 |
- )+ } |
||
| 599 | +3477 |
- }+ ) |
||
| 600 | +3478 | |||
| 601 | +3479 |
- # get formatted cells ----+ #' @export |
||
| 602 | +3480 |
-
+ #' @rdname ref_fnotes |
||
| 603 | -+ | |||
| 3481 | +212232x |
- #' Get formatted cells+ setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))
|
||
| 604 | +3482 |
- #'+ |
||
| 605 | +3483 |
- #' @inheritParams gen_args+ #' @export |
||
| 606 | +3484 |
- #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats+ #' @rdname int_methods |
||
| 607 | +3485 |
- #' applied. Defaults to `FALSE`.+ setMethod( |
||
| 608 | +3486 |
- #'+ "cell_footnotes", "CellValue", |
||
| 609 | -+ | |||
| 3487 | +169977x |
- #' @return The formatted print-strings for all (body) cells in `obj`.+ function(obj) attr(obj, "footnotes", exact = TRUE) %||% list() |
||
| 610 | +3488 |
- #'+ ) |
||
| 611 | +3489 |
- #' @examples+ |
||
| 612 | +3490 |
- #' library(dplyr)+ #' @export |
||
| 613 | +3491 |
- #'+ #' @rdname int_methods |
||
| 614 | +3492 |
- #' iris2 <- iris %>%+ setMethod( |
||
| 615 | +3493 |
- #' group_by(Species) %>%+ "cell_footnotes", "TableRow", |
||
| 616 | +3494 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ function(obj) {
|
||
| 617 | -+ | |||
| 3495 | +37259x |
- #' ungroup()+ ret <- lapply(row_cells(obj), cell_footnotes) |
||
| 618 | -+ | |||
| 3496 | +37259x |
- #'+ if (length(ret) != ncol(obj)) {
|
||
| 619 | -+ | |||
| 3497 | +163x |
- #' tbl <- basic_table() %>%+ ret <- rep(ret, row_cspans(obj)) |
||
| 620 | +3498 |
- #' split_cols_by("Species") %>%
+ }+ |
+ ||
| 3499 | +37259x | +
+ ret |
||
| 621 | +3500 |
- #' split_cols_by("group") %>%
+ } |
||
| 622 | +3501 |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
+ ) |
||
| 623 | +3502 |
- #' build_table(iris2)+ |
||
| 624 | +3503 |
- #'+ #' @export |
||
| 625 | +3504 |
- #' get_formatted_cells(tbl)+ #' @rdname int_methods |
||
| 626 | +3505 |
- #'+ setMethod( |
||
| 627 | +3506 |
- #' @export+ "cell_footnotes", "LabelRow", |
||
| 628 | +3507 |
- #' @rdname gfc+ function(obj) {
|
||
| 629 | -41112x | +3508 | +4571x |
- setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells"))
+ rep(list(list()), ncol(obj)) |
| 630 | +3509 |
-
+ } |
||
| 631 | +3510 |
- #' @rdname gfc+ ) |
||
| 632 | +3511 |
- setMethod(+ |
||
| 633 | +3512 |
- "get_formatted_cells", "TableTree",+ #' @export |
||
| 634 | +3513 |
- function(obj, shell = FALSE) {
- |
- ||
| 635 | -3266x | -
- lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ #' @rdname int_methods |
||
| 636 | +3514 | - - | -||
| 637 | -3266x | -
- ct <- get_formatted_cells(content_table(obj), shell = shell)+ setMethod( |
||
| 638 | +3515 | - - | -||
| 639 | -3266x | -
- els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ "cell_footnotes", "VTableTree", |
||
| 640 | +3516 |
-
+ function(obj) {
|
||
| 641 | -+ | |||
| 3517 | +425x |
- ## TODO fix ncol problem for rrow()+ rws <- collect_leaves(obj, TRUE, TRUE) |
||
| 642 | -3266x | +3518 | +425x |
- if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
+ cells <- lapply(rws, cell_footnotes) |
| 643 | -909x | +3519 | +425x |
- ct <- lr[NULL, ]+ do.call(rbind, cells) |
| 644 | +3520 |
- }+ } |
||
| 645 | +3521 |
-
+ ) |
||
| 646 | -3266x | +|||
| 3522 | +
- do.call(rbind, c(list(lr), list(ct), els))+ |
|||
| 647 | +3523 |
- }+ #' @export |
||
| 648 | +3524 |
- )+ #' @rdname ref_fnotes+ |
+ ||
| 3525 | +717x | +
+ setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))
|
||
| 649 | +3526 | |||
| 650 | +3527 |
- #' @rdname gfc+ #' @export |
||
| 651 | +3528 |
- setMethod(+ #' @rdname int_methods |
||
| 652 | +3529 |
- "get_formatted_cells", "ElementaryTable",+ setMethod( |
||
| 653 | +3530 |
- function(obj, shell = FALSE) {
+ "cell_footnotes<-", "CellValue", |
||
| 654 | -6271x | +|||
| 3531 | +
- lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ function(obj, value) {
|
|||
| 655 | -6271x | +3532 | +640x |
- els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ attr(obj, "footnotes") <- make_ref_value(value) |
| 656 | -6271x | +3533 | +640x |
- do.call(rbind, c(list(lr), els))+ obj |
| 657 | +3534 |
} |
||
| 658 | +3535 |
) |
||
| 659 | +3536 | |||
| 660 | +3537 |
- #' @rdname gfc+ .cfn_set_helper <- function(obj, value) {
|
||
| 661 | -+ | |||
| 3538 | +77x |
- setMethod(+ if (length(value) != ncol(obj)) {
|
||
| 662 | -+ | |||
| 3539 | +! |
- "get_formatted_cells", "TableRow",+ stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.")
|
||
| 663 | +3540 |
- function(obj, shell = FALSE) {
+ } |
||
| 664 | +3541 |
- # Parent row format and na_str+ |
||
| 665 | -22010x | +3542 | +77x |
- pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj)+ row_cells(obj) <- mapply( |
| 666 | -22010x | +3543 | +77x |
- pr_row_na_str <- obj_na_str(obj) %||% "NA"+ function(cell, fns) {
|
| 667 | -+ | |||
| 3544 | +283x |
-
+ if (is.list(fns)) {
|
||
| 668 | -22010x | +3545 | +276x |
- matrix(+ cell_footnotes(cell) <- lapply(fns, RefFootnote) |
| 669 | -22010x | +|||
| 3546 | +
- unlist(Map(function(val, spn, shelli) {
+ } else {
|
|||
| 670 | -105601x | +3547 | +7x |
- stopifnot(is(spn, "integer"))+ cell_footnotes(cell) <- list(RefFootnote(fns)) |
| 671 | +3548 |
-
+ } |
||
| 672 | -105601x | +3549 | +283x |
- out <- format_rcell(val,+ cell |
| 673 | -105601x | +|||
| 3550 | +
- pr_row_format = pr_row_format,+ }, |
|||
| 674 | -105601x | +3551 | +77x |
- pr_row_na_str = pr_row_na_str,+ cell = row_cells(obj), |
| 675 | -105601x | +3552 | +77x |
- shell = shelli+ fns = value, SIMPLIFY = FALSE |
| 676 | +3553 |
- )- |
- ||
| 677 | -105601x | -
- if (!is.function(out) && is.character(out)) {
+ ) |
||
| 678 | -105593x | +3554 | +77x |
- out <- paste(out, collapse = ", ")+ obj |
| 679 | +3555 |
- }+ } |
||
| 680 | +3556 | |||
| 681 | -105601x | +|||
| 3557 | +
- rep(list(out), spn)+ #' @export |
|||
| 682 | -22010x | +|||
| 3558 | +
- }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)),+ #' @rdname int_methods |
|||
| 683 | -22010x | +|||
| 3559 | +
- ncol = ncol(obj)+ setMethod("cell_footnotes<-", "DataRow",
|
|||
| 684 | +3560 |
- )+ definition = .cfn_set_helper |
||
| 685 | +3561 |
- }+ ) |
||
| 686 | +3562 |
- )+ |
||
| 687 | +3563 |
-
+ #' @export |
||
| 688 | +3564 |
- #' @rdname gfc+ #' @rdname int_methods |
||
| 689 | +3565 |
- setMethod(+ setMethod("cell_footnotes<-", "ContentRow",
|
||
| 690 | +3566 |
- "get_formatted_cells", "LabelRow",+ definition = .cfn_set_helper |
||
| 691 | +3567 |
- function(obj, shell = FALSE) {
+ ) |
||
| 692 | -9565x | +|||
| 3568 | +
- nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
+
|
|||
| 693 | -9565x | +|||
| 3569 | +
- vstr <- if (shell) "-" else ""+ # Deprecated methods ---- |
|||
| 694 | -9565x | +|||
| 3570 | +
- if (labelrow_visible(obj)) {
+
|
|||
| 695 | -3310x | +|||
| 3571 | +
- matrix(rep(vstr, nc), ncol = nc)+ #' @export |
|||
| 696 | +3572 |
- } else {
+ #' @rdname ref_fnotes |
||
| 697 | -6255x | +|||
| 3573 | +! |
- matrix(character(0), ncol = nc)+ setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))
|
||
| 698 | +3574 |
- }+ |
||
| 699 | +3575 |
- }+ #' @export |
||
| 700 | +3576 |
- )+ #' @rdname ref_fnotes |
||
| 701 | +3577 |
-
+ setMethod("col_fnotes_here", "ANY", function(obj) {
|
||
| 702 | -+ | |||
| 3578 | +! |
- #' @rdname gfc+ lifecycle::deprecate_warn( |
||
| 703 | -14962x | +|||
| 3579 | +! |
- setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))
+ when = "0.6.6", |
||
| 704 | -+ | |||
| 3580 | +! |
-
+ what = "col_fnotes_here()", |
||
| 705 | -+ | |||
| 3581 | +! |
- #' @rdname gfc+ with = "col_footnotes()" |
||
| 706 | +3582 |
- setMethod(+ )+ |
+ ||
| 3583 | +! | +
+ col_footnotes(obj) |
||
| 707 | +3584 |
- "get_cell_aligns", "TableTree",+ }) |
||
| 708 | +3585 |
- function(obj) {
+
|
||
| 709 | -1631x | +|||
| 3586 | +
- lr <- get_cell_aligns(tt_labelrow(obj))+ #' @export |
|||
| 710 | +3587 |
-
+ #' @rdname ref_fnotes |
||
| 711 | -1631x | +|||
| 3588 | +! |
- ct <- get_cell_aligns(content_table(obj))+ setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
|
||
| 712 | +3589 | |||
| 713 | -1631x | +|||
| 3590 | +
- els <- lapply(tree_children(obj), get_cell_aligns)+ #' @export |
|||
| 714 | +3591 |
-
+ #' @rdname int_methods |
||
| 715 | +3592 |
- ## TODO fix ncol problem for rrow()+ setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
|
||
| 716 | -1631x | +|||
| 3593 | +! |
- if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
+ lifecycle::deprecate_warn( |
||
| 717 | -454x | +|||
| 3594 | +! |
- ct <- lr[NULL, ]+ when = "0.6.6", |
||
| 718 | -+ | |||
| 3595 | +! |
- }+ what = I("col_fnotes_here()<-"),
+ |
+ ||
| 3596 | +! | +
+ with = I("col_footnotes()<-")
|
||
| 719 | +3597 |
-
+ ) |
||
| 720 | -1631x | +|||
| 3598 | +! |
- do.call(rbind, c(list(lr), list(ct), els))+ col_footnotes(obj) <- value |
||
| 721 | +3599 |
- }+ }) |
||
| 722 | +3600 |
- )+ |
||
| 723 | +3601 |
-
+ #' @export |
||
| 724 | +3602 |
- #' @rdname gfc+ #' @rdname ref_fnotes+ |
+ ||
| 3603 | +17015x | +
+ setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))
|
||
| 725 | +3604 |
- setMethod(+ |
||
| 726 | +3605 |
- "get_cell_aligns", "ElementaryTable",+ #' @export |
||
| 727 | +3606 |
- function(obj) {
+ #' @rdname int_methods |
||
| 728 | -3131x | +3607 | +1527x |
- lr <- get_cell_aligns(tt_labelrow(obj))+ setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)
|
| 729 | -3131x | +|||
| 3608 | +
- els <- lapply(tree_children(obj), get_cell_aligns)+ + |
+ |||
| 3609 | ++ |
+ #' @export+ |
+ ||
| 3610 | ++ |
+ #' @rdname int_methods |
||
| 730 | -3131x | +3611 | +15064x |
- do.call(rbind, c(list(lr), els))+ setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)
|
| 731 | +3612 |
- }+ |
||
| 732 | +3613 |
- )+ #' @export |
||
| 733 | +3614 |
-
+ #' @rdname ref_fnotes+ |
+ ||
| 3615 | +2046x | +
+ setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))
|
||
| 734 | +3616 |
- #' @rdname gfc+ |
||
| 735 | +3617 |
- setMethod(+ #' @export |
||
| 736 | +3618 |
- "get_cell_aligns", "TableRow",+ #' @rdname int_methods |
||
| 737 | +3619 |
- function(obj) {
+ setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
|
||
| 738 | -5424x | +3620 | +765x |
- als <- vapply(row_cells(obj), cell_align, "")+ obj@col_footnotes <- make_ref_value(value) |
| 739 | -5424x | +3621 | +765x |
- spns <- row_cspans(obj)+ obj |
| 740 | +3622 |
-
+ }) |
||
| 741 | -5424x | +|||
| 3623 | +
- matrix(rep(als, times = spns),+ |
|||
| 742 | -5424x | +|||
| 3624 | +
- ncol = ncol(obj)+ #' @export |
|||
| 743 | +3625 |
- )+ #' @rdname int_methods |
||
| 744 | +3626 |
- }+ setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
+ |
+ ||
| 3627 | +1281x | +
+ obj@col_footnotes <- make_ref_value(value)+ |
+ ||
| 3628 | +1281x | +
+ obj |
||
| 745 | +3629 |
- )+ }) |
||
| 746 | +3630 | |||
| 747 | +3631 |
- #' @rdname gfc+ #' @export |
||
| 748 | +3632 | ++ |
+ #' @rdname int_methods+ |
+ |
| 3633 |
setMethod( |
|||
| 749 | +3634 |
- "get_cell_aligns", "LabelRow",+ "col_footnotes", "VTableTree", |
||
| 750 | +3635 |
function(obj) {
|
||
| 751 | -4776x | +3636 | +424x |
- nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
+ ctree <- coltree(obj) |
| 752 | -4776x | +3637 | +424x |
- if (labelrow_visible(obj)) {
+ cols <- tree_children(ctree) |
| 753 | -1655x | +3638 | +424x |
- matrix(rep("center", nc), ncol = nc)
+ while (all(sapply(cols, is, "LayoutColTree"))) {
|
| 754 | -+ | |||
| 3639 | +143x |
- } else {
+ cols <- lapply(cols, tree_children) |
||
| 755 | -3121x | +3640 | +143x |
- matrix(character(0), ncol = nc)+ cols <- unlist(cols, recursive = FALSE) |
| 756 | +3641 |
} |
||
| 3642 | +424x | +
+ all_col_fnotes <- lapply(cols, col_footnotes)+ |
+ ||
| 3643 | +424x | +
+ if (is.null(unlist(all_col_fnotes))) {
+ |
+ ||
| 3644 | +419x | +
+ return(NULL)+ |
+ ||
| 757 | +3645 |
- }+ } |
||
| 758 | +3646 |
- )+ + |
+ ||
| 3647 | +5x | +
+ return(all_col_fnotes) |
||
| 759 | +3648 |
-
+ } |
||
| 760 | +3649 |
- # utility functions ----+ ) |
||
| 761 | +3650 | |||
| 762 | +3651 |
- #' From a sorted sequence of numbers, remove numbers where diff == 1+ #' @export |
||
| 763 | +3652 |
- #'+ #' @rdname ref_fnotes+ |
+ ||
| 3653 | +3912x | +
+ setGeneric("ref_index", function(obj) standardGeneric("ref_index"))
|
||
| 764 | +3654 |
- #' @examples+ |
||
| 765 | +3655 |
- #' remove_consecutive_numbers(x = c(2, 4, 9))+ #' @export |
||
| 766 | +3656 |
- #' remove_consecutive_numbers(x = c(2, 4, 5, 9))+ #' @rdname int_methods |
||
| 767 | +3657 |
- #' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9))+ setMethod( |
||
| 768 | +3658 |
- #' remove_consecutive_numbers(x = 4:9)+ "ref_index", "RefFootnote",+ |
+ ||
| 3659 | +3912x | +
+ function(obj) obj@index |
||
| 769 | +3660 |
- #'+ ) |
||
| 770 | +3661 |
- #' @noRd+ |
||
| 771 | +3662 |
- remove_consecutive_numbers <- function(x) {
+ #' @export |
||
| 772 | +3663 |
- # actually should be integer+ #' @rdname ref_fnotes |
||
| 773 | -! | +|||
| 3664 | +119x |
- stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x))+ setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))
|
||
| 774 | +3665 | |||
| 775 | -! | +|||
| 3666 | +
- if (length(x) == 0) {
+ #' @export |
|||
| 776 | -! | +|||
| 3667 | +
- return(integer(0))+ #' @rdname int_methods |
|||
| 777 | +3668 |
- }+ setMethod( |
||
| 778 | -! | +|||
| 3669 | +
- if (!is.integer(x)) x <- as.integer(x)+ "ref_index<-", "RefFootnote", |
|||
| 779 | +3670 |
-
+ function(obj, value) {
|
||
| 780 | -! | +|||
| 3671 | +119x |
- x[c(TRUE, diff(x) != 1)]+ obj@index <- value |
||
| 781 | -+ | |||
| 3672 | +119x |
- }+ obj |
||
| 782 | +3673 |
-
+ } |
||
| 783 | +3674 |
- #' Insert an empty string+ ) |
||
| 784 | +3675 |
- #'+ |
||
| 785 | +3676 |
- #' @examples+ #' @export |
||
| 786 | +3677 |
- #' empty_string_after(letters[1:5], 2)+ #' @rdname ref_fnotes+ |
+ ||
| 3678 | +3793x | +
+ setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))
|
||
| 787 | +3679 |
- #' empty_string_after(letters[1:5], c(2, 4))+ |
||
| 788 | +3680 |
- #'+ #' @export |
||
| 789 | +3681 |
- #' @noRd+ #' @rdname int_methods |
||
| 790 | +3682 |
- empty_string_after <- function(x, indices) {
+ setMethod( |
||
| 791 | -! | +|||
| 3683 | +
- if (length(indices) > 0) {
+ "ref_symbol", "RefFootnote", |
|||
| 792 | -! | -
- offset <- 0- |
- ||
| 793 | -! | +|||
| 3684 | +3793x |
- for (i in sort(indices)) {
+ function(obj) obj@symbol |
||
| 794 | -! | +|||
| 3685 | +
- x <- append(x, "", i + offset)+ ) |
|||
| 795 | -! | +|||
| 3686 | +
- offset <- offset + 1+ |
|||
| 796 | +3687 |
- }+ #' @export |
||
| 797 | +3688 |
- }+ #' @rdname ref_fnotes |
||
| 798 | +3689 | ! |
- x+ setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))
|
|
| 799 | +3690 |
- }+ |
||
| 800 | +3691 |
-
+ #' @export |
||
| 801 | +3692 |
- #' Indent strings+ #' @rdname int_methods |
||
| 802 | +3693 |
- #'+ setMethod( |
||
| 803 | +3694 |
- #' Used in rtables to indent row names for the ASCII output.+ "ref_symbol<-", "RefFootnote", |
||
| 804 | +3695 |
- #'+ function(obj, value) {
+ |
+ ||
| 3696 | +! | +
+ obj@symbol <- value+ |
+ ||
| 3697 | +! | +
+ obj |
||
| 805 | +3698 |
- #' @param x (`character`)\cr a character vector.+ } |
||
| 806 | +3699 |
- #' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`.+ ) |
||
| 807 | +3700 |
- #' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level.+ |
||
| 808 | +3701 |
- #' @param including_newline (`flag`)\cr whether newlines should also be indented.+ #' @export |
||
| 809 | +3702 |
- #'+ #' @rdname ref_fnotes+ |
+ ||
| 3703 | +2929x | +
+ setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))
|
||
| 810 | +3704 |
- #' @return `x`, indented with left-padding with `indent * incr` white-spaces.+ |
||
| 811 | +3705 |
- #'+ #' @export |
||
| 812 | +3706 |
- #' @examples+ #' @rdname int_methods |
||
| 813 | +3707 |
- #' indent_string("a", 0)
+ setMethod( |
||
| 814 | +3708 |
- #' indent_string("a", 1)
+ "ref_msg", "RefFootnote",+ |
+ ||
| 3709 | +2929x | +
+ function(obj) obj@value |
||
| 815 | +3710 |
- #' indent_string(letters[1:3], 0:2)+ ) |
||
| 816 | +3711 |
- #' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2)+ + |
+ ||
| 3712 | +24x | +
+ setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))
|
||
| 817 | +3713 |
- #'+ |
||
| 818 | +3714 |
- #' @export+ setMethod( |
||
| 819 | +3715 |
- indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
+ ".fnote_set_inner<-", c("TableRow", "NULL"),
|
||
| 820 | -632x | +|||
| 3716 | +
- if (length(x) > 0) {
+ function(ttrp, colpath, value) {
|
|||
| 821 | -632x | +3717 | +8x |
- indent <- rep_len(indent, length.out = length(x))+ row_footnotes(ttrp) <- value |
| 822 | -632x | +3718 | +8x |
- incr <- rep_len(incr, length.out = length(x))+ ttrp |
| 823 | +3719 |
} |
||
| 824 | +3720 | ++ |
+ )+ |
+ |
| 3721 | ||||
| 825 | -632x | +|||
| 3722 | +
- indent_str <- strrep(" ", (indent > 0) * indent * incr)
+ setMethod( |
|||
| 826 | +3723 |
-
+ ".fnote_set_inner<-", c("TableRow", "character"),
+ |
+ ||
| 3724 | ++ |
+ function(ttrp, colpath, value) {
|
||
| 827 | -632x | +3725 | +7x |
- if (including_newline) {
+ ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE) |
| 828 | -632x | +3726 | +7x |
- x <- unlist(mapply(function(xi, stri) {
+ cfns <- cell_footnotes(ttrp) |
| 829 | -13850x | +3727 | +7x |
- gsub("\n", stri, xi, fixed = TRUE)
+ cfns[[ind]] <- value |
| 830 | -632x | +3728 | +7x |
- }, x, paste0("\n", indent_str)))
+ cell_footnotes(ttrp) <- cfns+ |
+
| 3729 | +7x | +
+ ttrp |
||
| 831 | +3730 |
} |
||
| 832 | +3731 |
-
+ ) |
||
| 833 | -632x | +|||
| 3732 | +
- paste0(indent_str, x)+ |
|||
| 834 | +3733 |
- }+ setMethod( |
||
| 835 | +3734 |
-
+ ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
|
||
| 836 | +3735 |
- ## .paste_no_na <- function(x, ...) {
+ function(ttrp, colpath, value) {
|
||
| 837 | -+ | |||
| 3736 | +1x |
- ## paste(na.omit(x), ...)+ ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value) |
||
| 838 | -+ | |||
| 3737 | +1x |
- ## }+ coltree(ttrp) <- ctree |
||
| 839 | -+ | |||
| 3738 | +1x |
-
+ ttrp |
||
| 840 | +3739 |
- ## #' Pad a string and align within string+ } |
||
| 841 | +3740 |
- ## #'+ ) |
||
| 842 | +3741 |
- ## #' @param x string+ |
||
| 843 | +3742 |
- ## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown+ setMethod( |
||
| 844 | +3743 |
- ## #'+ ".fnote_set_inner<-", c("VTableTree", "ANY"),
|
||
| 845 | +3744 |
- ## #' @noRd+ function(ttrp, colpath, value) {
|
||
| 846 | -+ | |||
| 3745 | +8x |
- ## #'+ if (labelrow_visible(ttrp) && !is.null(value)) {
|
||
| 847 | -+ | |||
| 3746 | +2x |
- ## #' @examples+ lblrw <- tt_labelrow(ttrp) |
||
| 848 | -+ | |||
| 3747 | +2x |
- ## #'+ row_footnotes(lblrw) <- value |
||
| 849 | -+ | |||
| 3748 | +2x |
- ## #' padstr("abc", 3)
+ tt_labelrow(ttrp) <- lblrw |
||
| 850 | -+ | |||
| 3749 | +6x |
- ## #' padstr("abc", 4)
+ } else if (NROW(content_table(ttrp)) == 1L) {
|
||
| 851 | -+ | |||
| 3750 | +6x |
- ## #' padstr("abc", 5)
+ ctbl <- content_table(ttrp) |
||
| 852 | -+ | |||
| 3751 | +6x |
- ## #' padstr("abc", 5, "left")
+ pth <- make_row_df(ctbl)$path[[1]] |
||
| 853 | -+ | |||
| 3752 | +6x |
- ## #' padstr("abc", 5, "right")
+ fnotes_at_path(ctbl, pth, colpath) <- value |
||
| 854 | -+ | |||
| 3753 | +6x |
- ## #'+ content_table(ttrp) <- ctbl |
||
| 855 | +3754 |
- ## #' if(interactive()){
+ } else {
|
||
| 856 | +3755 |
- ## #' padstr("abc", 1)
+ stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
|
||
| 857 | +3756 |
- ## #' }+ }+ |
+ ||
| 3757 | +8x | +
+ ttrp |
||
| 858 | +3758 |
- ## #'+ } |
||
| 859 | +3759 |
- ## padstr <- function(x, n, just = c("center", "left", "right")) {
+ ) |
||
| 860 | +3760 | |||
| 861 | +3761 |
- ## just <- match.arg(just)+ #' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should |
||
| 862 | +3762 |
-
+ #' go on the column rather than cell. |
||
| 863 | +3763 |
- ## if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
+ #' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go |
||
| 864 | +3764 |
- ## if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
+ #' on the row rather than cell. |
||
| 865 | +3765 |
-
+ #' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately |
||
| 866 | +3766 |
- ## if (is.na(x)) x <- "<NA>"+ #' recalculated. Defaults to `TRUE`. |
||
| 867 | +3767 |
-
+ #' |
||
| 868 | +3768 |
- ## nc <- nchar(x)+ #' @examples |
||
| 869 | +3769 |
-
+ #' # How to add referencial footnotes after having created a table |
||
| 870 | +3770 |
- ## if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
+ #' lyt <- basic_table() %>% |
||
| 871 | +3771 |
-
+ #' split_rows_by("SEX", page_by = TRUE) %>%
|
||
| 872 | +3772 |
- ## switch(+ #' analyze("AGE")
|
||
| 873 | +3773 |
- ## just,+ #' |
||
| 874 | +3774 |
- ## center = {
+ #' tbl <- build_table(lyt, DM) |
||
| 875 | +3775 |
- ## pad <- (n - nc)/2+ #' tbl <- trim_rows(tbl) |
||
| 876 | +3776 |
- ## paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))+ #' # Check the row and col structure to add precise references |
||
| 877 | +3777 |
- ## },+ #' # row_paths(tbl) |
||
| 878 | +3778 |
- ## left = paste0(x, spaces(n - nc)),+ #' # col_paths(t) |
||
| 879 | +3779 |
- ## right = paste0(spaces(n - nc), x)+ #' # row_paths_summary(tbl) |
||
| 880 | +3780 |
- ## )+ #' # col_paths_summary(tbl) |
||
| 881 | +3781 |
- ## }+ #' |
||
| 882 | +3782 |
-
+ #' # Add the citation numbers on the table and relative references in the footnotes |
||
| 883 | +3783 |
- ## spaces <- function(n) {
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
|
||
| 884 | +3784 |
- ## strrep(" ", n)
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
|
||
| 885 | +3785 |
- ## }+ #' # tbl |
||
| 886 | +3786 |
-
+ #' |
||
| 887 | +3787 |
- #' Convert matrix of strings into a string with aligned columns+ #' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()] |
||
| 888 | +3788 |
#' |
||
| 889 | +3789 |
- #' Note that this function is intended to print simple rectangular matrices and not `rtable`s.+ #' @export |
||
| 890 | +3790 |
- #'+ #' @rdname ref_fnotes |
||
| 891 | +3791 |
- #' @param mat (`matrix`)\cr a matrix of strings.+ setGeneric("fnotes_at_path<-", function(obj,
|
||
| 892 | +3792 |
- #' @param nheader (`integer(1)`)\cr number of header rows.+ rowpath = NULL, |
||
| 893 | +3793 |
- #' @param colsep (`string`)\cr a string that separates the columns.+ colpath = NULL, |
||
| 894 | +3794 |
- #' @param hsep (`character(1)`)\cr character to build line separator.+ reset_idx = TRUE, |
||
| 895 | +3795 |
- #'+ value) {
|
||
| 896 | -+ | |||
| 3796 | +24x |
- #' @return A string.+ standardGeneric("fnotes_at_path<-")
|
||
| 897 | +3797 |
- #'+ }) |
||
| 898 | +3798 |
- #' @examples+ |
||
| 899 | +3799 |
- #' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
+ ## non-null rowpath, null or non-null colpath |
||
| 900 | +3800 |
- #' cat(mat_as_string(mat))+ #' @inheritParams fnotes_at_path<- |
||
| 901 | +3801 |
- #' cat("\n")
+ #' |
||
| 902 | +3802 |
- #'+ #' @export |
||
| 903 | +3803 |
- #' @noRd+ #' @rdname int_methods |
||
| 904 | +3804 |
- mat_as_string <- function(mat, nheader = 1, colsep = " ", hsep = default_hsep()) {
+ setMethod( |
||
| 905 | -2x | +|||
| 3805 | +
- colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max)+ "fnotes_at_path<-", c("VTableTree", "character"),
|
|||
| 906 | +3806 |
-
+ function(obj, |
||
| 907 | -2x | +|||
| 3807 | +
- rows_formatted <- apply(mat, 1, function(row) {
+ rowpath = NULL, |
|||
| 908 | -36x | +|||
| 3808 | +
- paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep)+ colpath = NULL, |
|||
| 909 | +3809 |
- })+ reset_idx = TRUE, |
||
| 910 | +3810 |
-
+ value) {
|
||
| 911 | -2x | +3811 | +23x |
- header_rows <- seq_len(nheader)+ rw <- tt_at_path(obj, rowpath) |
| 912 | -2x | +3812 | +23x |
- nchwidth <- nchar(rows_formatted[1])+ .fnote_set_inner(rw, colpath) <- value |
| 913 | -2x | +3813 | +23x |
- paste(c(+ tt_at_path(obj, rowpath) <- rw |
| 914 | -2x | +3814 | +23x |
- rows_formatted[header_rows],+ if (reset_idx) {
|
| 915 | -2x | +3815 | +23x |
- substr(strrep(hsep, nchwidth), 1, nchwidth),+ obj <- update_ref_indexing(obj) |
| 916 | -2x | +|||
| 3816 | +
- rows_formatted[-header_rows]+ } |
|||
| 917 | -2x | +3817 | +23x |
- ), collapse = "\n")+ obj |
| 918 | +3818 |
- }+ } |
| 1 | +3819 |
- treestruct <- function(obj, ind = 0L) {
+ ) |
||
| 2 | -19x | +|||
| 3820 | +
- nc <- ncol(obj)+ |
|||
| 3 | -19x | +|||
| 3821 | +
- cat(rep(" ", times = ind),
+ #' @export |
|||
| 4 | -19x | +|||
| 3822 | +
- sprintf("[%s] %s", class(obj), obj_name(obj)),
+ #' @rdname int_methods |
|||
| 5 | -19x | +|||
| 3823 | +
- sep = ""+ setMethod( |
|||
| 6 | +3824 |
- )+ "fnotes_at_path<-", c("VTableTree", "NULL"),
|
||
| 7 | -19x | +|||
| 3825 | +
- if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
+ function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
|
|||
| 8 | -6x | +3826 | +1x |
- crows <- nrow(content_table(obj))+ cinfo <- col_info(obj) |
| 9 | -6x | +3827 | +1x |
- ccols <- if (crows == 0) 0 else nc+ .fnote_set_inner(cinfo, colpath) <- value |
| 10 | -6x | +3828 | +1x |
- cat(sprintf(+ col_info(obj) <- cinfo |
| 11 | -6x | +3829 | +1x |
- " [cont: %d x %d]",+ if (reset_idx) {
|
| 12 | -6x | +3830 | +1x |
- crows, ccols+ obj <- update_ref_indexing(obj) |
| 13 | +3831 |
- ))+ }+ |
+ ||
| 3832 | +1x | +
+ obj |
||
| 14 | +3833 |
} |
||
| 15 | -19x | +|||
| 3834 | +
- if (is(obj, "VTableTree") && length(tree_children(obj))) {
+ ) |
|||
| 16 | -19x | +|||
| 3835 | +
- kids <- tree_children(obj)+ |
|||
| 17 | -19x | +3836 | +2896x |
- if (are(kids, "TableRow")) {
+ setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))
|
| 18 | -9x | +|||
| 3837 | +
- cat(sprintf(+ |
|||
| 19 | -9x | +3838 | +357x |
- " (%d x %d)\n",+ setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))
|
| 20 | -9x | +|||
| 3839 | +
- length(kids), nc+ |
|||
| 21 | -+ | |||
| 3840 | +1574x |
- ))+ setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))
|
||
| 22 | +3841 |
- } else {
+
|
||
| 23 | -10x | +3842 | +914x |
- cat("\n")
+ setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)
|
| 24 | -10x | +|||
| 3843 | +
- lapply(kids, treestruct, ind = ind + 1)+ |
|||
| 25 | -+ | |||
| 3844 | +2396x |
- }+ setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))
|
||
| 26 | +3845 |
- }+ |
||
| 27 | -19x | +3846 | +365x |
- invisible(NULL)+ setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)
|
| 28 | +3847 |
- }+ + |
+ ||
| 3848 | +1980x | +
+ setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)
|
||
| 29 | +3849 | |||
| 30 | -+ | |||
| 3850 | +! |
- setGeneric(+ setMethod("ptitle_prefix", "ANY", function(obj) NULL)
|
||
| 31 | +3851 |
- "ploads_to_str",+ |
||
| 32 | -103x | +3852 | +388x |
- function(x, collapse = ":") standardGeneric("ploads_to_str")
+ setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)
|
| 33 | +3853 |
- )+ |
||
| 34 | +3854 |
-
+ setMethod("page_titles<-", "VTableTree", function(obj, value) {
|
||
| 35 | -+ | |||
| 3855 | +19x |
- setMethod(+ obj@page_titles <- value |
||
| 36 | -+ | |||
| 3856 | +19x |
- "ploads_to_str", "Split",+ obj |
||
| 37 | +3857 |
- function(x, collapse = ":") {
+ }) |
||
| 38 | -52x | +|||
| 3858 | +
- paste(sapply(spl_payload(x), ploads_to_str),+ |
|||
| 39 | -52x | +|||
| 3859 | +
- collapse = collapse+ ## Horizontal separator -------------------------------------------------------- |
|||
| 40 | +3860 |
- )+ |
||
| 41 | +3861 |
- }+ #' Access or recursively set header-body separator for tables |
||
| 42 | +3862 |
- )+ #' |
||
| 43 | +3863 |
-
+ #' @inheritParams gen_args |
||
| 44 | +3864 |
- setMethod(+ #' @param value (`string`)\cr string to use as new header/body separator. |
||
| 45 | +3865 |
- "ploads_to_str", "CompoundSplit",+ #' |
||
| 46 | +3866 |
- function(x, collapse = ":") {
+ #' @return |
||
| 47 | -6x | +|||
| 3867 | +
- paste(sapply(spl_payload(x), ploads_to_str),+ #' * `horizontal_sep` returns the string acting as the header separator. |
|||
| 48 | -6x | +|||
| 3868 | +
- collapse = collapse+ #' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its |
|||
| 49 | +3869 |
- )+ #' subtables. |
||
| 50 | +3870 |
- }+ #' |
||
| 51 | +3871 |
- )+ #' @export |
||
| 52 | -+ | |||
| 3872 | +368x |
-
+ setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))
|
||
| 53 | +3873 |
- setMethod(+ |
||
| 54 | +3874 |
- "ploads_to_str", "list",+ #' @rdname horizontal_sep |
||
| 55 | +3875 |
- function(x, collapse = ":") {
+ #' @export |
||
| 56 | -! | +|||
| 3876 | +
- stop("Please contact the maintainer")
+ setMethod( |
|||
| 57 | +3877 |
- }+ "horizontal_sep", "VTableTree", |
||
| 58 | -+ | |||
| 3878 | +368x |
- )+ function(obj) obj@horizontal_sep |
||
| 59 | +3879 |
-
+ ) |
||
| 60 | +3880 |
- setMethod(+ |
||
| 61 | +3881 |
- "ploads_to_str", "SplitVector",+ #' @rdname horizontal_sep |
||
| 62 | +3882 |
- function(x, collapse = ":") {
+ #' @export |
||
| 63 | -8x | +3883 | +23904x |
- sapply(x, ploads_to_str)+ setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))
|
| 64 | +3884 |
- }+ |
||
| 65 | +3885 |
- )+ #' @rdname horizontal_sep |
||
| 66 | +3886 |
-
+ #' @export |
||
| 67 | +3887 |
setMethod( |
||
| 68 | +3888 |
- "ploads_to_str", "ANY",+ "horizontal_sep<-", "VTableTree", |
||
| 69 | +3889 |
- function(x, collapse = ":") {
+ function(obj, value) {
|
||
| 70 | -37x | +3890 | +13390x |
- paste(x)+ cont <- content_table(obj) |
| 71 | -+ | |||
| 3891 | +13390x |
- }+ if (NROW(cont) > 0) {
+ |
+ ||
| 3892 | +1878x | +
+ horizontal_sep(cont) <- value+ |
+ ||
| 3893 | +1878x | +
+ content_table(obj) <- cont |
||
| 72 | +3894 |
- )+ } |
||
| 73 | +3895 | |||
| 74 | -40x | +3896 | +13390x |
- setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
+ kids <- lapply(tree_children(obj), |
| 75 | -+ | |||
| 3897 | +13390x |
-
+ `horizontal_sep<-`, |
||
| 76 | -+ | |||
| 3898 | +13390x |
- setMethod(+ value = value |
||
| 77 | +3899 |
- "payloadmsg", "VarLevelSplit",+ ) |
||
| 78 | +3900 |
- function(spl) {
+
|
||
| 79 | -39x | +3901 | +13390x |
- spl_payload(spl)+ tree_children(obj) <- kids+ |
+
| 3902 | +13390x | +
+ obj@horizontal_sep <- value+ |
+ ||
| 3903 | +13390x | +
+ obj |
||
| 80 | +3904 |
} |
||
| 81 | +3905 |
) |
||
| 82 | +3906 | |||
| 83 | +3907 |
- setMethod(+ #' @rdname horizontal_sep |
||
| 84 | +3908 |
- "payloadmsg", "MultiVarSplit",- |
- ||
| 85 | -1x | -
- function(spl) "var"+ #' @export |
||
| 86 | +3909 |
- )+ setMethod( |
||
| 87 | +3910 |
-
+ "horizontal_sep<-", "TableRow", |
||
| 88 | -+ | |||
| 3911 | +10514x |
- setMethod(+ function(obj, value) obj |
||
| 89 | +3912 |
- "payloadmsg", "VarLevWBaselineSplit",+ ) |
||
| 90 | +3913 |
- function(spl) {
- |
- ||
| 91 | -! | -
- paste0(- |
- ||
| 92 | -! | -
- spl_payload(spl), "[bsl ",- |
- ||
| 93 | -! | -
- spl@ref_group_value, # XXX XXX+ |
||
| 94 | +3914 |
- "]"+ ## Section dividers ------------------------------------------------------------ |
||
| 95 | +3915 |
- )+ |
||
| 96 | +3916 |
- }+ # Used for splits |
||
| 97 | -+ | |||
| 3917 | +1639x |
- )+ setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))
|
||
| 98 | +3918 | |||
| 99 | +3919 |
setMethod( |
||
| 100 | +3920 |
- "payloadmsg", "ManualSplit",+ "spl_section_div", "Split", |
||
| 101 | -! | +|||
| 3921 | +1639x |
- function(spl) "mnl"+ function(obj) obj@child_section_div |
||
| 102 | +3922 |
) |
||
| 103 | +3923 | |||
| 104 | -- |
- setMethod(- |
- ||
| 105 | -- |
- "payloadmsg", "AllSplit",- |
- ||
| 106 | +3924 | ! |
- function(spl) "all"- |
- |
| 107 | -- |
- )+ setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))
|
||
| 108 | +3925 | |||
| 109 | +3926 |
setMethod( |
||
| 110 | +3927 |
- "payloadmsg", "ANY",+ "spl_section_div<-", "Split", |
||
| 111 | +3928 |
- function(spl) {
+ function(obj, value) {
|
||
| 112 | +3929 | ! |
- warning("don't know how to make payload print message for Split of class", class(spl))
+ obj@child_section_div <- value |
|
| 113 | +3930 | ! |
- "XXX"+ obj |
|
| 114 | +3931 |
} |
||
| 115 | +3932 |
) |
||
| 116 | +3933 | |||
| 117 | +3934 |
- spldesc <- function(spl, value = "") {
- |
- ||
| 118 | -32x | -
- value <- rawvalues(value)- |
- ||
| 119 | -32x | -
- payloadmsg <- payloadmsg(spl)- |
- ||
| 120 | -32x | -
- format <- "%s (%s)"+ # Used for table object parts |
||
| 121 | -32x | +3935 | +26973x |
- sprintf(+ setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
|
| 122 | -32x | +3936 | +10601x |
- format,+ setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
|
| 123 | -32x | +3937 | +5143x |
- value,+ setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
|
| 124 | -32x | +3938 | +11229x |
- payloadmsg+ setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)
|
| 125 | +3939 |
- )+ |
||
| 126 | -+ | |||
| 3940 | +1629x |
- }+ setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
|
||
| 127 | +3941 |
-
+ setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
|
||
| 128 | -+ | |||
| 3942 | +1530x |
- layoutmsg <- function(obj) {
+ obj@trailing_section_div <- value |
||
| 129 | -+ | |||
| 3943 | +1530x |
- ## if(!is(obj, "VLayoutNode"))+ obj |
||
| 130 | +3944 |
- ## stop("how did a non layoutnode object get in docatlayout??")
+ }) |
||
| 131 | +3945 |
-
+ setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
|
||
| 132 | -28x | +3946 | +40x |
- pos <- tree_pos(obj)+ obj@trailing_section_div <- value |
| 133 | -28x | +3947 | +40x |
- spllst <- pos_splits(pos)+ obj |
| 134 | -28x | +|||
| 3948 | +
- spvallst <- pos_splvals(pos)+ }) |
|||
| 135 | -28x | +|||
| 3949 | +
- if (is(obj, "LayoutAxisTree")) {
+ setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
|
|||
| 136 | -12x | +3950 | +59x |
- kids <- tree_children(obj)+ obj@trailing_section_div <- value |
| 137 | -12x | +3951 | +59x |
- return(unlist(lapply(kids, layoutmsg)))+ obj |
| 138 | +3952 |
- }+ }) |
||
| 139 | +3953 | |||
| 140 | -16x | +|||
| 3954 | +
- msg <- paste(+ #' Section dividers accessor and setter |
|||
| 141 | -16x | +|||
| 3955 | +
- collapse = " -> ",+ #' |
|||
| 142 | -16x | +|||
| 3956 | +
- mapply(spldesc,+ #' `section_div` can be used to set or get the section divider for a table object |
|||
| 143 | -16x | +|||
| 3957 | +
- spl = spllst,+ #' produced by [build_table()]. When assigned in post-processing (`section_div<-`) |
|||
| 144 | -16x | +|||
| 3958 | +
- value = spvallst+ #' the table can have a section divider after every row, each assigned independently. |
|||
| 145 | +3959 |
- )+ #' If assigning during layout creation, only [split_rows_by()] (and its related row-wise |
||
| 146 | +3960 |
- )+ #' splits) and [analyze()] have a `section_div` parameter that will produce separators |
||
| 147 | -16x | +|||
| 3961 | +
- msg+ #' between split sections and data subgroups, respectively. |
|||
| 148 | +3962 |
- }+ #' |
||
| 149 | +3963 |
-
+ #' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree` |
||
| 150 | +3964 |
- setMethod(+ #' or `TableRow`/`LabelRow`. |
||
| 151 | +3965 |
- "show", "LayoutAxisTree",+ #' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows |
||
| 152 | +3966 |
- function(object) {
+ #' you to set the section divider only for sections that are splits or analyses if the number of |
||
| 153 | -2x | +|||
| 3967 | +
- msg <- layoutmsg(object)+ #' values is less than the number of rows in the table. If `TRUE`, the section divider will |
|||
| 154 | -2x | +|||
| 3968 | +
- cat(msg, "\n")+ #' be set for all rows of the table. |
|||
| 155 | -2x | +|||
| 3969 | +
- invisible(object)+ #' @param value (`character`)\cr vector of single characters to use as section dividers. Each character |
|||
| 156 | +3970 |
- }+ #' is repeated such that all section dividers span the width of the table. Each character that is |
||
| 157 | +3971 |
- )+ #' not `NA_character_` will produce a trailing separator for each row of the table. `value` length |
||
| 158 | +3972 |
-
+ #' should reflect the number of rows, or be between 1 and the number of splits/levels. |
||
| 159 | -46x | +|||
| 3973 | +
- setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
+ #' See the Details section below for more information. |
|||
| 160 | +3974 |
-
+ #' |
||
| 161 | +3975 |
- setMethod(+ #' @return The section divider string. Each line that does not have a trailing separator |
||
| 162 | +3976 |
- "spltype_abbrev", "VarLevelSplit",+ #' will have `NA_character_` as section divider. |
||
| 163 | -4x | +|||
| 3977 | +
- function(obj) "lvls"+ #' |
|||
| 164 | +3978 |
- )+ #' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global |
||
| 165 | +3979 |
-
+ #' section dividers. |
||
| 166 | +3980 |
- setMethod(+ #' |
||
| 167 | +3981 |
- "spltype_abbrev", "VarLevWBaselineSplit",+ #' @details |
||
| 168 | -5x | +|||
| 3982 | +
- function(obj) paste("ref_group", obj@ref_group_value)
+ #' Assigned value to section divider must be a character vector. If any value is `NA_character_` |
|||
| 169 | +3983 |
- )+ #' the section divider will be absent for that row or section. When you want to only affect sections |
||
| 170 | +3984 |
-
+ #' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows. |
||
| 171 | +3985 |
- setMethod(+ #' Ideally, the length of the vector should be less than the number of splits with, eventually, the |
||
| 172 | +3986 |
- "spltype_abbrev", "MultiVarSplit",+ #' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted, |
||
| 173 | -! | +|||
| 3987 | +
- function(obj) "vars"+ #' only the first split will be affected. |
|||
| 174 | +3988 |
- )+ #' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table |
||
| 175 | +3989 |
-
+ #' construction, the section divider will be set for all the splits and eventually analyses, but |
||
| 176 | +3990 |
- setMethod(+ #' not for the header or each row of the table. This can be set with `header_section_div` in |
||
| 177 | +3991 |
- "spltype_abbrev", "VarStaticCutSplit",+ #' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section |
||
| 178 | -10x | +|||
| 3992 | +
- function(obj) "scut"+ #' divider will be set for all the rows of the table. |
|||
| 179 | +3993 |
- )+ #' |
||
| 180 | +3994 |
-
+ #' @examples |
||
| 181 | +3995 |
- setMethod(+ #' # Data |
||
| 182 | +3996 |
- "spltype_abbrev", "VarDynCutSplit",+ #' df <- data.frame( |
||
| 183 | -5x | +|||
| 3997 | +
- function(obj) "dcut"+ #' cat = c( |
|||
| 184 | +3998 |
- )+ #' "really long thing its so ", "long" |
||
| 185 | +3999 |
- setMethod(+ #' ), |
||
| 186 | +4000 |
- "spltype_abbrev", "AllSplit",+ #' value = c(6, 3, 10, 1) |
||
| 187 | -15x | +|||
| 4001 | +
- function(obj) "all obs"+ #' ) |
|||
| 188 | +4002 |
- )+ #' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
|
||
| 189 | +4003 |
- ## setMethod("spltype_abbrev", "NULLSplit",
+ #' |
||
| 190 | +4004 |
- ## function(obj) "no obs")+ #' tbl <- basic_table() %>% |
||
| 191 | +4005 |
-
+ #' split_rows_by("cat", section_div = "~") %>%
|
||
| 192 | +4006 |
- setMethod(+ #' analyze("value", afun = fast_afun, section_div = " ") %>%
|
||
| 193 | +4007 |
- "spltype_abbrev", "AnalyzeVarSplit",+ #' build_table(df) |
||
| 194 | -1x | +|||
| 4008 | +
- function(obj) "** analysis **"+ #' |
|||
| 195 | +4009 |
- )+ #' # Getter |
||
| 196 | +4010 |
-
+ #' section_div(tbl) |
||
| 197 | +4011 |
- setMethod(+ #' |
||
| 198 | +4012 |
- "spltype_abbrev", "CompoundSplit",+ #' # Setter |
||
| 199 | -! | +|||
| 4013 | +
- function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
+ #' section_div(tbl) <- letters[seq_len(nrow(tbl))] |
|||
| 200 | +4014 |
- )+ #' tbl |
||
| 201 | +4015 |
-
+ #' |
||
| 202 | +4016 |
- setMethod(+ #' # last letter can appear if there is another table |
||
| 203 | +4017 |
- "spltype_abbrev", "AnalyzeMultiVars",+ #' rbind(tbl, tbl) |
||
| 204 | -6x | +|||
| 4018 | +
- function(obj) "** multivar analysis **"+ #' |
|||
| 205 | +4019 |
- )+ #' # header_section_div |
||
| 206 | +4020 |
- setMethod(+ #' header_section_div(tbl) <- "+" |
||
| 207 | +4021 |
- "spltype_abbrev", "AnalyzeColVarSplit",+ #' tbl |
||
| 208 | -! | +|||
| 4022 | +
- function(obj) "** col-var analysis **"+ #' |
|||
| 209 | +4023 |
- )+ #' @docType methods |
||
| 210 | +4024 |
-
+ #' @rdname section_div |
||
| 211 | +4025 |
- docat_splitvec <- function(object, indent = 0) {
+ #' @export |
||
| 212 | -8x | +4026 | +362x |
- if (indent > 0) {
+ setGeneric("section_div", function(obj) standardGeneric("section_div"))
|
| 213 | -! | +|||
| 4027 | +
- cat(rep(" ", times = indent), sep = "")
+
|
|||
| 214 | +4028 |
- }+ #' @rdname section_div |
||
| 215 | -8x | +|||
| 4029 | +
- if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
+ #' @aliases section_div,VTableTree-method |
|||
| 216 | -! | +|||
| 4030 | +
- tab <- object[[1]]+ setMethod("section_div", "VTableTree", function(obj) {
|
|||
| 217 | -! | +|||
| 4031 | +150x |
- msg <- sprintf(+ content_row_tbl <- content_table(obj) |
||
| 218 | -! | +|||
| 4032 | +150x |
- "A Pre-Existing Table [%d x %d]",+ is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL |
||
| 219 | -! | +|||
| 4033 | +150x |
- nrow(tab), ncol(tab)+ if (labelrow_visible(obj) || is_content_table) {
|
||
| 220 | -+ | |||
| 4034 | +67x |
- )+ section_div <- trailing_section_div(obj) |
||
| 221 | -+ | |||
| 4035 | +67x |
- } else {
+ labelrow_div <- trailing_section_div(tt_labelrow(obj)) |
||
| 222 | -8x | +4036 | +67x |
- plds <- ploads_to_str(object) ## lapply(object, spl_payload))+ rest_of_tree <- section_div(tree_children(obj)) |
| 223 | +4037 |
-
+ # Case it is the section itself and not the labels to have a trailing sep |
||
| 224 | -8x | +4038 | +67x |
- tabbrev <- sapply(object, spltype_abbrev)+ if (!is.na(section_div)) {
|
| 225 | -8x | +4039 | +45x |
- msg <- paste(+ rest_of_tree[length(rest_of_tree)] <- section_div |
| 226 | -8x | +|||
| 4040 | +
- collapse = " -> ",+ } |
|||
| 227 | -8x | -
- paste0(plds, " (", tabbrev, ")")
- |
- ||
| 228 | -+ | 4041 | +67x |
- )+ unname(c(labelrow_div, rest_of_tree)) |
| 229 | +4042 |
- }+ } else {
|
||
| 230 | -8x | +4043 | +83x |
- cat(msg, "\n")+ unname(section_div(tree_children(obj))) |
| 231 | +4044 |
- }+ } |
||
| 232 | +4045 |
-
+ }) |
||
| 233 | +4046 |
- setMethod(+ |
||
| 234 | +4047 |
- "show", "SplitVector",+ #' @rdname section_div |
||
| 235 | +4048 |
- function(object) {
- |
- ||
| 236 | -1x | -
- cat("A SplitVector Pre-defining a Tree Structure\n\n")
+ #' @aliases section_div,list-method |
||
| 237 | -1x | +|||
| 4049 | +
- docat_splitvec(object)+ setMethod("section_div", "list", function(obj) {
|
|||
| 238 | -1x | +4050 | +150x |
- cat("\n")
+ unlist(lapply(obj, section_div)) |
| 239 | -1x | +|||
| 4051 | +
- invisible(object)+ }) |
|||
| 240 | +4052 |
- }+ |
||
| 241 | +4053 |
- )+ #' @rdname section_div |
||
| 242 | +4054 |
-
+ #' @aliases section_div,TableRow-method |
||
| 243 | +4055 |
- docat_predataxis <- function(object, indent = 0) {
+ setMethod("section_div", "TableRow", function(obj) {
|
||
| 244 | -6x | +4056 | +62x |
- lapply(object, docat_splitvec)+ trailing_section_div(obj) |
| 245 | +4057 |
- }+ }) |
||
| 246 | +4058 | |||
| 247 | +4059 |
- setMethod(+ # section_div setter from table object |
||
| 248 | +4060 |
- "show", "PreDataColLayout",+ #' @rdname section_div |
||
| 249 | +4061 |
- function(object) {
+ #' @export |
||
| 250 | -1x | +|||
| 4062 | +
- cat("A Pre-data Column Layout Object\n\n")
+ setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
|
|||
| 251 | -1x | +4063 | +217x |
- docat_predataxis(object)+ standardGeneric("section_div<-")
|
| 252 | -1x | +|||
| 4064 | +
- invisible(object)+ }) |
|||
| 253 | +4065 |
- }+ |
||
| 254 | +4066 |
- )+ #' @rdname section_div |
||
| 255 | +4067 |
-
+ #' @aliases section_div<-,VTableTree-method |
||
| 256 | +4068 |
- setMethod(+ setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
|
||
| 257 | -+ | |||
| 4069 | +90x |
- "show", "PreDataRowLayout",+ char_v <- as.character(value) |
||
| 258 | -+ | |||
| 4070 | +90x |
- function(object) {
+ tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1))) |
||
| 259 | -1x | +4071 | +90x |
- cat("A Pre-data Row Layout Object\n\n")
+ max_tree_depth <- max(tree_depths) |
| 260 | -1x | +4072 | +90x |
- docat_predataxis(object)+ stopifnot(is.logical(only_sep_sections)) |
| 261 | -1x | +4073 | +90x |
- invisible(object)+ .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj)) |
| 262 | +4074 |
- }+ |
||
| 263 | +4075 |
- )+ # Automatic establishment of intent |
||
| 264 | -+ | |||
| 4076 | +90x |
-
+ if (length(char_v) < nrow(obj)) {
|
||
| 265 | -+ | |||
| 4077 | +3x |
- setMethod(+ only_sep_sections <- TRUE |
||
| 266 | +4078 |
- "show", "PreDataTableLayouts",+ } |
||
| 267 | +4079 |
- function(object) {
+
|
||
| 268 | -2x | +|||
| 4080 | +
- cat("A Pre-data Table Layout\n")
+ # Case where only separators or splits need to change externally |
|||
| 269 | -2x | +4081 | +90x |
- cat("\nColumn-Split Structure:\n")
+ if (only_sep_sections && length(char_v) < nrow(obj)) {
|
| 270 | -2x | +|||
| 4082 | +
- docat_predataxis(object@col_layout)+ # Case where char_v is longer than the max depth |
|||
| 271 | -2x | +4083 | +3x |
- cat("\nRow-Split Structure:\n")
+ char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))] |
| 272 | -2x | +|||
| 4084 | +
- docat_predataxis(object@row_layout)+ # Filling up with NAs the rest of the tree depth section div chr vector |
|||
| 273 | -2x | +4085 | +3x |
- cat("\n")
+ missing_char_v_len <- max_tree_depth - length(char_v) |
| 274 | -2x | +4086 | +3x |
- invisible(object)+ char_v <- c(char_v, rep(NA_character_, missing_char_v_len)) |
| 275 | +4087 |
} |
||
| 276 | +4088 |
- )+ |
||
| 277 | +4089 |
-
+ # Retrieving if it is a contentRow (no need for labelrow to be visible in this case) |
||
| 278 | -+ | |||
| 4090 | +90x |
- setMethod(+ content_row_tbl <- content_table(obj)+ |
+ ||
| 4091 | +90x | +
+ is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 |
||
| 279 | +4092 |
- "show", "InstantiatedColumnInfo",+ |
||
| 280 | +4093 |
- function(object) {
+ # Main table structure change |
||
| 281 | -2x | +4094 | +90x |
- layoutmsg <- layoutmsg(coltree(object))+ if (labelrow_visible(obj) || is_content_table) {
|
| 282 | -2x | +4095 | +40x |
- cat("An InstantiatedColumnInfo object",
+ if (only_sep_sections) {
|
| 283 | -2x | +|||
| 4096 | +
- "Columns:",+ # Only tables are modified |
|||
| 284 | -2x | +4097 | +34x |
- layoutmsg,+ trailing_section_div(tt_labelrow(obj)) <- NA_character_ |
| 285 | -2x | +4098 | +34x |
- if (disp_ccounts(object)) {
+ trailing_section_div(obj) <- char_v[1] |
| 286 | -2x | +4099 | +34x |
- paste(+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] |
| 287 | -2x | +|||
| 4100 | +
- "ColumnCounts:\n",+ } else {
|
|||
| 288 | -2x | +|||
| 4101 | +
- paste(col_counts(object),+ # All leaves are modified |
|||
| 289 | -2x | +4102 | +6x |
- collapse = ", "+ trailing_section_div(tt_labelrow(obj)) <- char_v[1] |
| 290 | -+ | |||
| 4103 | +6x |
- )+ trailing_section_div(obj) <- NA_character_ |
||
| 291 | -+ | |||
| 4104 | +6x |
- )+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] |
||
| 292 | +4105 |
- },+ } |
||
| 293 | +4106 |
- "",+ } else {
|
||
| 294 | -2x | +4107 | +50x |
- sep = "\n"+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v |
| 295 | +4108 |
- )+ } |
||
| 296 | -2x | +4109 | +90x |
- invisible(object)+ obj |
| 297 | +4110 |
- }+ }) |
||
| 298 | +4111 |
- )+ |
||
| 299 | +4112 |
-
+ #' @rdname section_div |
||
| 300 | +4113 |
- #' @rdname int_methods+ #' @aliases section_div<-,list-method |
||
| 301 | +4114 |
- setMethod("print", "VTableTree", function(x, ...) {
+ setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
|
||
| 302 | -4x | +4115 | +90x |
- msg <- toString(x, ...)+ char_v <- as.character(value) |
| 303 | -4x | +4116 | +90x |
- cat(msg)+ for (i in seq_along(obj)) {
|
| 304 | -4x | +4117 | +121x |
- invisible(x)+ stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow")) |
| 305 | -+ | |||
| 4118 | +121x |
- })+ list_element_size <- nrow(obj[[i]]) |
||
| 306 | -+ | |||
| 4119 | +121x |
-
+ if (only_sep_sections) {
|
||
| 307 | -+ | |||
| 4120 | +97x |
- #' @rdname int_methods+ char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))]+ |
+ ||
| 4121 | +97x | +
+ char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i))) |
||
| 308 | +4122 |
- setMethod("show", "VTableTree", function(object) {
+ } else {
|
||
| 309 | -! | +|||
| 4123 | +24x |
- cat(toString(object))+ init <- (i - 1) * list_element_size + 1 |
||
| 310 | -! | +|||
| 4124 | +24x |
- invisible(object)+ chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1) |
||
| 311 | -+ | |||
| 4125 | +24x |
- })+ char_v_i <- char_v[chunk_of_char_v_to_take] |
||
| 312 | +4126 |
-
+ }+ |
+ ||
| 4127 | +121x | +
+ section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i |
||
| 313 | +4128 |
- setMethod("show", "TableRow", function(object) {
+ } |
||
| 314 | -1x | +4129 | +90x |
- cat(sprintf(+ obj |
| 315 | -1x | +|||
| 4130 | +
- "[%s indent_mod %d]: %s %s\n",+ }) |
|||
| 316 | -1x | +|||
| 4131 | +
- class(object),+ |
|||
| 317 | -1x | +|||
| 4132 | +
- indent_mod(object),+ #' @rdname section_div |
|||
| 318 | -1x | +|||
| 4133 | +
- obj_label(object),+ #' @aliases section_div<-,TableRow-method+ |
+ |||
| 4134 | ++ |
+ setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
|
||
| 319 | -1x | +4135 | +37x |
- paste(as.vector(get_formatted_cells(object)),+ trailing_section_div(obj) <- value |
| 320 | -1x | +4136 | +37x |
- collapse = " "+ obj |
| 321 | +4137 |
- )+ }) |
||
| 322 | +4138 |
- ))+ |
||
| 323 | -1x | +|||
| 4139 | +
- invisible(object)+ #' @rdname section_div |
|||
| 324 | +4140 |
- })+ #' @aliases section_div<-,LabelRow-method |
| 1 | +4141 |
- match_extra_args <- function(f,+ setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
|
||
| 2 | -+ | |||
| 4142 | +! |
- .N_col,+ trailing_section_div(obj) <- value |
||
| 3 | -+ | |||
| 4143 | +! |
- .N_total,+ obj |
||
| 4 | +4144 |
- .all_col_exprs,+ }) |
||
| 5 | +4145 |
- .all_col_counts,+ |
||
| 6 | +4146 |
- .var,+ # Helper check function |
||
| 7 | +4147 |
- .ref_group = NULL,+ .check_char_vector_for_section_div <- function(char_v, min_splits, max) {
|
||
| 8 | -+ | |||
| 4148 | +90x |
- .alt_df_row = NULL,+ lcv <- length(char_v) |
||
| 9 | -+ | |||
| 4149 | +90x |
- .alt_df = NULL,+ if (lcv < 1 || lcv > max) {
|
||
| 10 | -+ | |||
| 4150 | +! |
- .ref_full = NULL,+ stop("section_div must be a vector of length between 1 and numer of table rows.")
|
||
| 11 | +4151 |
- .in_ref_col = NULL,+ } |
||
| 12 | -+ | |||
| 4152 | +90x |
- .spl_context = NULL,+ if (lcv > min_splits && lcv < max) {
|
||
| 13 | -+ | |||
| 4153 | +! |
- .N_row,+ warning( |
||
| 14 | -+ | |||
| 4154 | +! |
- .df_row,+ "section_div will be truncated to the number of splits (", min_splits, ")",
|
||
| 15 | -+ | |||
| 4155 | +! |
- extras) {
+ " because it is shorter than the number of rows (", max, ")."
|
||
| 16 | +4156 |
- # This list is always present+ ) |
||
| 17 | -5778x | +|||
| 4157 | +
- possargs <- c(+ } |
|||
| 18 | -5778x | +4158 | +90x |
- list(+ nchar_check_v <- nchar(char_v) |
| 19 | -5778x | +4159 | +90x |
- .N_col = .N_col,+ if (any(nchar_check_v > 1, na.rm = TRUE)) {
|
| 20 | -5778x | +|||
| 4160 | +! |
- .N_total = .N_total,+ stop("section_div must be a vector of single characters or NAs")
|
||
| 21 | -5778x | +|||
| 4161 | +
- .N_row = .N_row,+ } |
|||
| 22 | -5778x | +|||
| 4162 | +
- .df_row = .df_row,+ } |
|||
| 23 | -5778x | +|||
| 4163 | +
- .all_col_exprs = .all_col_exprs,+ |
|||
| 24 | -5778x | +|||
| 4164 | +
- .all_col_counts = .all_col_counts+ #' @rdname section_div |
|||
| 25 | +4165 |
- ),+ #' @export |
||
| 26 | -5778x | +4166 | +618x |
- extras+ setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))
|
| 27 | +4167 |
- )+ |
||
| 28 | +4168 |
-
+ #' @rdname section_div |
||
| 29 | +4169 |
- ## specialized arguments that must be named in formals, cannot go+ #' @aliases header_section_div,PreDataTableLayouts-method |
||
| 30 | +4170 |
- ## anonymously into ...+ setMethod( |
||
| 31 | -5778x | +|||
| 4171 | +
- if (!is.null(.var) && nzchar(.var)) {
+ "header_section_div", "PreDataTableLayouts", |
|||
| 32 | -4533x | +4172 | +295x |
- possargs <- c(possargs, list(.var = .var))+ function(obj) obj@header_section_div |
| 33 | +4173 |
- }- |
- ||
| 34 | -5778x | -
- if (!is.null(.ref_group)) {
+ ) |
||
| 35 | -1834x | +|||
| 4174 | +
- possargs <- c(possargs, list(.ref_group = .ref_group))+ |
|||
| 36 | +4175 |
- }+ #' @rdname section_div |
||
| 37 | -5778x | +|||
| 4176 | +
- if (!is.null(.alt_df_row)) {
+ #' @aliases header_section_div,PreDataTableLayouts-method |
|||
| 38 | -105x | +|||
| 4177 | +
- possargs <- c(possargs, list(.alt_df_row = .alt_df_row))+ setMethod( |
|||
| 39 | +4178 |
- }+ "header_section_div", "VTableTree", |
||
| 40 | -5778x | +4179 | +323x |
- if (!is.null(.alt_df)) {
+ function(obj) obj@header_section_div |
| 41 | -105x | +|||
| 4180 | +
- possargs <- c(possargs, list(.alt_df = .alt_df))+ ) |
|||
| 42 | +4181 |
- }+ |
||
| 43 | -5778x | +|||
| 4182 | +
- if (!is.null(.ref_full)) {
+ #' @rdname section_div+ |
+ |||
| 4183 | ++ |
+ #' @export |
||
| 44 | -141x | +4184 | +250x |
- possargs <- c(possargs, list(.ref_full = .ref_full))+ setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))
|
| 45 | +4185 |
- }+ |
||
| 46 | -5778x | +|||
| 4186 | +
- if (!is.null(.in_ref_col)) {
+ #' @rdname section_div |
|||
| 47 | -141x | +|||
| 4187 | +
- possargs <- c(possargs, list(.in_ref_col = .in_ref_col))+ #' @aliases header_section_div<-,PreDataTableLayouts-method |
|||
| 48 | +4188 |
- }+ setMethod( |
||
| 49 | +4189 |
-
+ "header_section_div<-", "PreDataTableLayouts", |
||
| 50 | +4190 |
- # Special case: .spl_context+ function(obj, value) {
|
||
| 51 | -5778x | +4191 | +1x |
- if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
+ .check_header_section_div(value) |
| 52 | -5778x | +4192 | +1x |
- possargs <- c(possargs, list(.spl_context = .spl_context))+ obj@header_section_div <- value |
| 53 | -+ | |||
| 4193 | +1x |
- } else {
+ obj |
||
| 54 | -! | +|||
| 4194 | +
- possargs$.spl_context <- NULL+ } |
|||
| 55 | +4195 |
- }+ ) |
||
| 56 | +4196 | |||
| 57 | +4197 |
- # Extra args handling+ #' @rdname section_div |
||
| 58 | -5778x | +|||
| 4198 | +
- formargs <- formals(f)+ #' @aliases header_section_div<-,PreDataTableLayouts-method |
|||
| 59 | -5778x | +|||
| 4199 | +
- formnms <- names(formargs)+ setMethod( |
|||
| 60 | -5778x | +|||
| 4200 | +
- exnms <- names(extras)+ "header_section_div<-", "VTableTree", |
|||
| 61 | -5778x | +|||
| 4201 | +
- if (is.null(formargs)) {
+ function(obj, value) {
|
|||
| 62 | -206x | +4202 | +249x |
- return(NULL)+ .check_header_section_div(value) |
| 63 | -5572x | +4203 | +249x |
- } else if ("..." %in% names(formargs)) {
+ obj@header_section_div <- value |
| 64 | -4872x | +4204 | +249x |
- formnms <- c(formnms, exnms[nzchar(exnms)])+ obj |
| 65 | +4205 |
} |
||
| 66 | -5572x | -
- possargs[names(possargs) %in% formnms]- |
- ||
| 67 | +4206 |
- }+ ) |
||
| 68 | +4207 | |||
| 69 | +4208 |
- #' @noRd+ .check_header_section_div <- function(chr) {
|
||
| 70 | -+ | |||
| 4209 | +559x |
- #' @return A `RowsVerticalSection` object representing the `k x 1` section of the+ if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
|
||
| 71 | -+ | |||
| 4210 | +! |
- #' table being generated, with `k` the number of rows the analysis function+ stop("header_section_div must be a single character or NA_character_ if not used")
|
||
| 72 | +4211 |
- #' generates.+ } |
||
| 73 | -+ | |||
| 4212 | +559x |
- gen_onerv <- function(csub, col, count, cextr, cpath,+ invisible(TRUE) |
||
| 74 | +4213 |
- dfpart, func, totcount, splextra,+ } |
||
| 75 | +4214 |
- all_col_exprs,+ |
||
| 76 | +4215 |
- all_col_counts,+ #' @rdname section_div |
||
| 77 | +4216 |
- takesdf = .takes_df(func),+ #' @export+ |
+ ||
| 4217 | +299x | +
+ setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))
|
||
| 78 | +4218 |
- baselinedf,+ |
||
| 79 | +4219 |
- alt_dfpart,+ #' @rdname section_div |
||
| 80 | +4220 |
- inclNAs,+ #' @aliases top_level_section_div,PreDataTableLayouts-method |
||
| 81 | +4221 |
- col_parent_inds,+ setMethod( |
||
| 82 | +4222 |
- spl_context) {
+ "top_level_section_div", "PreDataTableLayouts", |
||
| 83 | -5778x | +4223 | +299x |
- if (NROW(spl_context) > 0) {
+ function(obj) obj@top_level_section_div |
| 84 | -5757x | +|||
| 4224 | +
- spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".")+ ) |
|||
| 85 | -5757x | +|||
| 4225 | +
- spl_context$cur_col_subset <- col_parent_inds+ |
|||
| 86 | -5757x | +|||
| 4226 | +
- spl_context$cur_col_expr <- list(csub)+ #' @rdname section_div |
|||
| 87 | -5757x | +|||
| 4227 | +
- spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L)+ #' @export |
|||
| 88 | -5757x | +4228 | +1x |
- spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)])+ setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))
|
| 89 | -5757x | +|||
| 4229 | +
- spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)])+ |
|||
| 90 | +4230 |
- }+ #' @rdname section_div |
||
| 91 | +4231 |
-
+ #' @aliases top_level_section_div<-,PreDataTableLayouts-method |
||
| 92 | +4232 |
- # Making .alt_df from alt_dfpart (i.e. .alt_df_row)+ setMethod( |
||
| 93 | -5778x | +|||
| 4233 | +
- if (NROW(alt_dfpart) > 0) {
+ "top_level_section_div<-", "PreDataTableLayouts", |
|||
| 94 | -105x | +|||
| 4234 | +
- alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE]+ function(obj, value) {
|
|||
| 95 | -105x | +4235 | +1x |
- if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
+ checkmate::assert_character(value, len = 1, n.chars = 1) |
| 96 | -99x | +4236 | +1x |
- alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), ,+ obj@top_level_section_div <- value |
| 97 | -99x | +4237 | +1x |
- drop = FALSE+ obj |
| 98 | +4238 |
- ]+ } |
||
| 99 | +4239 |
- }+ ) |
||
| 100 | +4240 |
- } else {
- |
- ||
| 101 | -5673x | -
- alt_dfpart_fil <- alt_dfpart+ |
||
| 102 | +4241 |
- }+ ## table_inset ---------------------------------------------------------- |
||
| 103 | +4242 | |||
| 104 | +4243 |
- ## workaround for https://github.com/insightsengineering/rtables/issues/159- |
- ||
| 105 | -5778x | -
- if (NROW(dfpart) > 0) {
+ #' @rdname formatters_methods |
||
| 106 | -4904x | +|||
| 4244 | +
- inds <- eval(csub, envir = dfpart)+ #' @export |
|||
| 107 | -4904x | +|||
| 4245 | +
- dat <- dfpart[inds, , drop = FALSE]+ setMethod( |
|||
| 108 | +4246 |
- } else {
+ "table_inset", "VTableNodeInfo", ## VTableTree", |
||
| 109 | -874x | +4247 | +328x |
- dat <- dfpart+ function(obj) obj@table_inset |
| 110 | +4248 |
- }+ ) |
||
| 111 | -5778x | +|||
| 4249 | +
- if (!is.null(col) && !inclNAs) {
+
|
|||
| 112 | -4507x | +|||
| 4250 | +
- dat <- dat[!is.na(dat[[col]]), , drop = FALSE]+ #' @rdname formatters_methods |
|||
| 113 | +4251 |
- }+ #' @export |
||
| 114 | +4252 |
-
+ setMethod( |
||
| 115 | -5778x | +|||
| 4253 | +
- fullrefcoldat <- cextr$.ref_full+ "table_inset", "PreDataTableLayouts", |
|||
| 116 | -5778x | +4254 | +294x |
- if (!is.null(fullrefcoldat)) {
+ function(obj) obj@table_inset |
| 117 | -141x | +|||
| 4255 | +
- cextr$.ref_full <- NULL+ ) |
|||
| 118 | +4256 |
- }+ |
||
| 119 | -5778x | +|||
| 4257 | +
- inrefcol <- cextr$.in_ref_col+ ## #' @rdname formatters_methods |
|||
| 120 | -5778x | +|||
| 4258 | +
- if (!is.null(fullrefcoldat)) {
+ ## #' @export |
|||
| 121 | -141x | +|||
| 4259 | +
- cextr$.in_ref_col <- NULL+ ## setMethod("table_inset", "InstantiatedColumnInfo",
|
|||
| 122 | +4260 |
- }+ ## function(obj) obj@table_inset) |
||
| 123 | +4261 | |||
| 124 | -5778x | -
- exargs <- c(cextr, splextra)- |
- ||
| 125 | +4262 |
-
+ #' @rdname formatters_methods |
||
| 126 | +4263 |
- ## behavior for x/df and ref-data (full and group)+ #' @export |
||
| 127 | +4264 |
- ## match+ setMethod( |
||
| 128 | -5778x | +|||
| 4265 | +
- if (!is.null(col) && !takesdf) {
+ "table_inset<-", "VTableNodeInfo", ## "VTableTree", |
|||
| 129 | -3590x | +|||
| 4266 | +
- dat <- dat[[col]]+ function(obj, value) {
|
|||
| 130 | -3590x | +4267 | +16016x |
- fullrefcoldat <- fullrefcoldat[[col]]+ if (!is.integer(value)) {
|
| 131 | -3590x | +4268 | +5x |
- baselinedf <- baselinedf[[col]]+ value <- as.integer(value) |
| 132 | +4269 |
- }+ } |
||
| 133 | -5778x | -
- args <- list(dat)- |
- ||
| 134 | -+ | 4270 | +16016x |
-
+ if (is.na(value) || value < 0) {
|
| 135 | -5778x | +|||
| 4271 | +! |
- names(all_col_counts) <- names(all_col_exprs)+ stop("Got invalid table_inset value, must be an integer > 0")
|
||
| 136 | +4272 |
-
+ } |
||
| 137 | -5778x | +4273 | +16016x |
- exargs <- match_extra_args(func,+ cont <- content_table(obj) |
| 138 | -5778x | +4274 | +16016x |
- .N_col = count,+ if (NROW(cont) > 0) {
|
| 139 | -5778x | +4275 | +1433x |
- .N_total = totcount,+ table_inset(cont) <- value |
| 140 | -5778x | +4276 | +1433x |
- .all_col_exprs = all_col_exprs,+ content_table(obj) <- cont |
| 141 | -5778x | +|||
| 4277 | +
- .all_col_counts = all_col_counts,+ } |
|||
| 142 | -5778x | +|||
| 4278 | +
- .var = col,+ |
|||
| 143 | -5778x | +4279 | +16016x |
- .ref_group = baselinedf,+ if (length(tree_children(obj)) > 0) {
|
| 144 | -5778x | +4280 | +4880x |
- .alt_df_row = alt_dfpart,+ kids <- lapply(tree_children(obj), |
| 145 | -5778x | +4281 | +4880x |
- .alt_df = alt_dfpart_fil,+ `table_inset<-`, |
| 146 | -5778x | +4282 | +4880x |
- .ref_full = fullrefcoldat,+ value = value |
| 147 | -5778x | +|||
| 4283 | +
- .in_ref_col = inrefcol,+ ) |
|||
| 148 | -5778x | +4284 | +4880x |
- .N_row = NROW(dfpart),+ tree_children(obj) <- kids |
| 149 | -5778x | +|||
| 4285 | +
- .df_row = dfpart,+ } |
|||
| 150 | -5778x | +4286 | +16016x |
- .spl_context = spl_context,+ obj@table_inset <- value |
| 151 | -5778x | +4287 | +16016x |
- extras = c(+ obj |
| 152 | -5778x | +|||
| 4288 | +
- cextr,+ } |
|||
| 153 | -5778x | +|||
| 4289 | +
- splextra+ ) |
|||
| 154 | +4290 |
- )+ |
||
| 155 | +4291 |
- )+ #' @rdname formatters_methods |
||
| 156 | +4292 |
-
+ #' @export |
||
| 157 | -5778x | +|||
| 4293 | +
- args <- c(args, exargs)+ setMethod( |
|||
| 158 | +4294 |
-
+ "table_inset<-", "PreDataTableLayouts", |
||
| 159 | -5778x | +|||
| 4295 | +
- val <- do.call(func, args)+ function(obj, value) {
|
|||
| 160 | -5775x | +|||
| 4296 | +! |
- if (!is(val, "RowsVerticalSection")) {
+ if (!is.integer(value)) {
|
||
| 161 | -3787x | +|||
| 4297 | +! |
- if (!is(val, "list")) {
+ value <- as.integer(value) |
||
| 162 | -3298x | +|||
| 4298 | +
- val <- list(val)+ }+ |
+ |||
| 4299 | +! | +
+ if (is.na(value) || value < 0) {
+ |
+ ||
| 4300 | +! | +
+ stop("Got invalid table_inset value, must be an integer > 0")
|
||
| 163 | +4301 |
} |
||
| 164 | -3787x | +|||
| 4302 | +
- ret <- in_rows(+ |
|||
| 165 | -3787x | +|||
| 4303 | +! |
- .list = val,+ obj@table_inset <- value |
||
| 166 | -3787x | +|||
| 4304 | +! |
- .labels = unlist(value_labels(val)),+ obj |
||
| 167 | -3787x | +|||
| 4305 | +
- .names = names(val)+ } |
|||
| 168 | +4306 |
- )+ ) |
||
| 169 | +4307 |
- } else {
+
|
||
| 170 | -1988x | +|||
| 4308 | +
- ret <- val+ #' @rdname formatters_methods |
|||
| 171 | +4309 |
- }+ #' @export |
||
| 172 | -5775x | +|||
| 4310 | +
- ret+ setMethod( |
|||
| 173 | +4311 |
- }+ "table_inset<-", "InstantiatedColumnInfo", |
||
| 174 | +4312 |
-
+ function(obj, value) {
+ |
+ ||
| 4313 | +! | +
+ if (!is.integer(value)) {
+ |
+ ||
| 4314 | +! | +
+ value <- as.integer(value) |
||
| 175 | +4315 |
- strip_multivar_suffix <- function(x) {
+ } |
||
| 176 | -228x | +|||
| 4316 | +! |
- gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
+ if (is.na(value) || value < 0) {
+ |
+ ||
| 4317 | +! | +
+ stop("Got invalid table_inset value, must be an integer > 0")
|
||
| 177 | +4318 |
- }+ }+ |
+ ||
| 4319 | +! | +
+ obj@table_inset <- value+ |
+ ||
| 4320 | +! | +
+ obj |
||
| 178 | +4321 |
-
+ } |
||
| 179 | +4322 |
- ## Generate all values (one for each column) for one or more rows+ ) |
| 180 | +1 |
- ## by calling func once per column (as defined by cinfo)+ #' Create an `rtable` row |
|||
| 181 | +2 |
- #' @noRd+ #' |
|||
| 182 | +3 |
- #' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table.+ #' @inheritParams compat_args |
|||
| 183 | +4 |
- gen_rowvalues <- function(dfpart,+ #' @param ... cell values. |
|||
| 184 | +5 |
- datcol,+ #' |
|||
| 185 | +6 |
- cinfo,+ #' @return A row object of the context-appropriate type (label or data). |
|||
| 186 | +7 |
- func,+ #' |
|||
| 187 | +8 |
- splextra,+ #' @examples |
|||
| 188 | +9 |
- takesdf = NULL,+ #' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
|
|||
| 189 | +10 |
- baselines,+ #' rrow("")
|
|||
| 190 | +11 |
- alt_dfpart,+ #' |
|||
| 191 | +12 |
- inclNAs,+ #' @family compatibility |
|||
| 192 | +13 |
- spl_context = spl_context) {
+ #' @export+ |
+ |||
| 14 | ++ |
+ rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L) {
|
|||
| 193 | -1581x | +15 | +258x |
- colexprs <- col_exprs(cinfo)+ vals <- list(...) |
|
| 194 | -1581x | +16 | +258x |
- colcounts <- col_counts(cinfo)+ if (is.null(row.name)) {
|
|
| 195 | -1581x | +17 | +40x |
- colextras <- col_extra_args(cinfo, NULL)+ row.name <- "" |
|
| 196 | -1581x | +18 | +218x |
- cpaths <- col_paths(cinfo)+ } else if (!is(row.name, "character")) {
|
|
| 197 | -+ | ||||
| 19 | +! |
- ## XXX I don't think this is used anywhere???+ stop("row.name must be NULL or a character string")
|
|||
| 198 | +20 |
- ## splextra = c(splextra, list(.spl_context = spl_context))+ } |
|||
| 199 | -1581x | +21 | +258x |
- totcount <- col_total(cinfo)+ if (length(vals) == 0L) {
|
|
| 200 | -+ | ||||
| 22 | +22x |
-
+ LabelRow( |
|||
| 201 | -1581x | +23 | +22x |
- colleaves <- collect_leaves(cinfo@tree_layout)+ lev = as.integer(indent), |
|
| 202 | -+ | ||||
| 24 | +22x |
-
+ label = row.name, |
|||
| 203 | -1581x | +25 | +22x |
- gotflist <- is.list(func)+ name = row.name,+ |
+ |
| 26 | +22x | +
+ vis = TRUE,+ |
+ |||
| 27 | +22x | +
+ table_inset = 0L |
|||
| 204 | +28 |
-
+ ) |
|||
| 205 | +29 |
- ## one set of named args to be applied to all columns+ } else {
|
|||
| 206 | -1581x | +30 | +236x |
- if (!is.null(names(splextra))) {
+ csps <- as.integer(sapply(vals, function(x) {
|
|
| 207 | -25x | +31 | +1391x |
- splextra <- list(splextra)+ attr(x, "colspan", exact = TRUE) %||% 1L |
|
| 208 | +32 |
- } else {
+ })) |
|||
| 209 | -1556x | +||||
| 33 | +
- length(splextra) <- ncol(cinfo)+ ## we have to leave the formats on the cells and NOT the row unless we were |
||||
| 210 | +34 |
- }+ ## already told to do so, because row formats get clobbered when cbinding |
|||
| 211 | +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) |
|||
| 212 | -1581x | +39 | +236x |
- if (!gotflist) {
+ DataRow( |
|
| 213 | -1068x | +40 | +236x |
- func <- list(func)+ vals = vals, lev = as.integer(indent), label = row.name, |
|
| 214 | -513x | +41 | +236x |
- } else if (length(splextra) == 1) {
+ name = row.name, ## XXX TODO |
|
| 215 | -88x | +42 | +236x |
- splextra <- rep(splextra, length.out = length(func))+ cspan = csps, |
|
| 216 | -+ | ||||
| 43 | +236x |
- }+ format = format, |
|||
| 217 | -+ | ||||
| 44 | +236x |
- ## if(length(func)) == 1 && names(spl)+ table_inset = as.integer(inset) |
|||
| 218 | +45 |
- ## splextra = list(splextra)+ ) |
|||
| 219 | +46 |
-
+ } |
|||
| 220 | +47 |
- ## we are in analyze_colvars, so we have to match+ } |
|||
| 221 | +48 |
- ## the exargs value by position for each column repeatedly+ |
|||
| 222 | +49 |
- ## across the higher level col splits.+ #' Create an `rtable` row from a vector or list of values |
|||
| 223 | -1581x | +||||
| 50 | +
- if (!is.null(datcol) && is.na(datcol)) {
+ #' |
||||
| 224 | -54x | +||||
| 51 | +
- datcol <- character(length(colleaves))+ #' @inheritParams compat_args |
||||
| 225 | -54x | +||||
| 52 | +
- exargs <- vector("list", length(colleaves))
+ #' @param ... values in vector/list form. |
||||
| 226 | -54x | +||||
| 53 | +
- for (i in seq_along(colleaves)) {
+ #' |
||||
| 227 | -228x | +||||
| 54 | +
- x <- colleaves[[i]]+ #' @inherit rrow return |
||||
| 228 | +55 |
-
+ #' |
|||
| 229 | -228x | +||||
| 56 | +
- pos <- tree_pos(x)+ #' @examples |
||||
| 230 | -228x | +||||
| 57 | +
- spls <- pos_splits(pos)+ #' rrowl("a", c(1, 2, 3), format = "xx")
|
||||
| 231 | +58 |
- ## values have the suffix but we are populating datacol+ #' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
|
|||
| 232 | +59 |
- ## so it has to match var numbers so strip the suffixes back off+ #' |
|||
| 233 | -228x | +||||
| 60 | +
- splvals <- strip_multivar_suffix(rawvalues(pos))+ #' |
||||
| 234 | -228x | +||||
| 61 | +
- n <- length(spls)+ #' rrowl("N", table(iris$Species))
|
||||
| 235 | -228x | +||||
| 62 | +
- datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
+ #' rrowl("N", table(iris$Species), format = "xx")
|
||||
| 236 | -228x | +||||
| 63 | +
- splvals[n]+ #' |
||||
| 237 | +64 |
- } else {
+ #' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE) |
|||
| 238 | -228x | +||||
| 65 | +
- NA_character_+ #' |
||||
| 239 | +66 |
- }+ #' rrow(row.name = "row 1", x) |
|||
| 240 | -228x | +||||
| 67 | +
- argpos <- match(datcol[i], spl_payload(spls[[n]]))+ #' rrow("ABC", 2, 3)
|
||||
| 241 | +68 |
- ## single bracket here because assigning NULL into a list removes+ #' |
|||
| 242 | +69 |
- ## the position entirely+ #' rrowl(row.name = "row 1", c(1, 2), c(3, 4)) |
|||
| 243 | -228x | +||||
| 70 | +
- exargs[i] <- if (argpos <= length(splextra)) {
+ #' rrow(row.name = "row 2", c(1, 2), c(3, 4)) |
||||
| 244 | -228x | +||||
| 71 | +
- splextra[argpos]+ #' |
||||
| 245 | +72 |
- } else {
+ #' @family compatibility |
|||
| 246 | -! | +||||
| 73 | +
- list(NULL)+ #' @export |
||||
| 247 | +74 |
- }+ rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) {
|
|||
| 248 | -+ | ||||
| 75 | +38x |
- }+ dots <- list(...) |
|||
| 249 | -+ | ||||
| 76 | +38x |
- ## })+ args_list <- c(list( |
|||
| 250 | -54x | +77 | +38x |
- if (all(is.na(datcol))) {
+ row.name = row.name, format = format, |
|
| 251 | -! | +||||
| 78 | +38x |
- datcol <- list(NULL)+ indent = indent, inset = inset |
|||
| 252 | -54x | +79 | +38x |
- } else if (any(is.na(datcol))) {
+ ), val = unlist(lapply(dots, as.list), recursive = FALSE)) |
|
| 253 | -! | +||||
| 80 | +38x |
- stop("mix of var and non-var columns with NA analysis rowvara")
+ do.call(rrow, args_list) |
|||
| 254 | +81 |
- }+ } |
|||
| 255 | +82 |
- } else {
+
|
|||
| 256 | -1527x | +||||
| 83 | +
- exargs <- splextra+ ## rcell moved to tt_afun_utils.R |
||||
| 257 | -1527x | +||||
| 84 | +
- if (is.null(datcol)) {
+
|
||||
| 258 | -316x | +||||
| 85 | +
- datcol <- list(NULL)+ ## inefficient trash |
||||
| 259 | +86 |
- }+ paste_em_n <- function(lst, n, sep = ".") {
|
|||
| 260 | -1527x | +87 | +9x |
- datcol <- rep(datcol, length(colexprs))+ ret <- lst[[1]] |
|
| 261 | -+ | ||||
| 88 | +9x |
- ## if(gotflist)+ if (n > 1) {
|
|||
| 262 | -+ | ||||
| 89 | +4x |
- ## length(exargs) <- length(func) ## func is a list+ for (i in 2:n) {
|
|||
| 263 | -1527x | +90 | +4x |
- exargs <- rep(exargs, length.out = length(colexprs))+ ret <- paste(ret, lst[[i]], sep = sep) |
|
| 264 | +91 |
- }- |
- |||
| 265 | -1581x | -
- allfuncs <- rep(func, length.out = length(colexprs))+ } |
|||
| 266 | +92 |
-
+ } |
|||
| 267 | -1581x | +93 | +9x |
- if (is.null(takesdf)) {
+ ret |
|
| 268 | -1122x | +||||
| 94 | +
- takesdf <- .takes_df(allfuncs)+ } |
||||
| 269 | +95 |
- }+ |
|||
| 270 | +96 |
-
+ hrows_to_colinfo <- function(rows) {
|
|||
| 271 | -1581x | +97 | +34x |
- rawvals <- mapply(gen_onerv,+ nr <- length(rows) |
|
| 272 | -1581x | +98 | +34x |
- csub = colexprs,+ stopifnot(nr > 0) |
|
| 273 | -1581x | +99 | +34x |
- col = datcol,+ cspans <- lapply(rows, row_cspans) |
|
| 274 | -1581x | +100 | +34x |
- count = colcounts,+ vals <- lapply(rows, function(x) unlist(row_values(x))) |
|
| 275 | -1581x | +101 | +34x |
- cextr = colextras,+ unqvals <- lapply(vals, unique) |
|
| 276 | -1581x | +102 | +34x |
- cpath = cpaths,+ formats <- lapply(rows, obj_format) |
|
| 277 | -1581x | +103 | +34x |
- baselinedf = baselines,+ counts <- NULL |
|
| 278 | -1581x | +104 | +34x |
- alt_dfpart = list(alt_dfpart),+ if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
|
|
| 279 | -1581x | +105 | +1x |
- func = allfuncs,+ counts <- vals[[nr]] |
|
| 280 | -1581x | +106 | +1x |
- takesdf = takesdf,+ vals <- vals[-nr] |
|
| 281 | -1581x | +107 | +1x |
- col_parent_inds = spl_context[, names(colexprs),+ cspans <- cspans[-nr] |
|
| 282 | -1581x | +108 | +1x |
- drop = FALSE+ nr <- nr - 1 |
|
| 283 | +109 |
- ],+ } |
|||
| 284 | -1581x | +||||
| 110 | +
- all_col_exprs = list(colexprs),+ ## easiest case, one header row no counts. we're done |
||||
| 285 | -1581x | +||||
| 111 | +
- all_col_counts = list(colcounts),+ ## XXX could one row but cspan ever make sense???? |
||||
| 286 | -1581x | +||||
| 112 | +
- splextra = exargs,+ ## I don't think so? |
||||
| 287 | -1581x | +113 | +34x |
- MoreArgs = list(+ if (nr == 1) { ## && all(cspans == 1L)) {
|
|
| 288 | -1581x | +114 | +29x |
- dfpart = dfpart,+ ret <- manual_cols(unlist(vals[[1]])) |
|
| 289 | -1581x | +115 | +29x |
- totcount = totcount,+ if (!is.null(counts)) {
|
|
| 290 | -1581x | +116 | +1x |
- inclNAs = inclNAs,+ col_counts(ret) <- counts |
|
| 291 | -1581x | +117 | +1x |
- spl_context = spl_context+ disp_ccounts(ret) <- TRUE |
|
| 292 | +118 |
- ),+ } |
|||
| 293 | -1581x | +119 | +29x |
- SIMPLIFY = FALSE+ return(ret) |
|
| 294 | +120 |
- )+ } |
|||
| 295 | +121 |
-
+ ## second easiest case full repeated nestin |
|||
| 296 | -1578x | +122 | +5x |
- names(rawvals) <- names(colexprs)+ repvals <- mapply(function(v, csp) rep(v, times = csp), |
|
| 297 | -1578x | +123 | +5x |
- rawvals+ v = vals, csp = cspans, SIMPLIFY = FALSE |
|
| 298 | +124 |
- }+ ) |
|||
| 299 | +125 | ||||
| 300 | +126 |
- .strip_lst_rvals <- function(lst) {
+ ## nr > 1 here |
|||
| 301 | -! | +||||
| 127 | +5x |
- lapply(lst, rawvalues)+ fullnest <- TRUE |
|||
| 302 | -+ | ||||
| 128 | +5x |
- }+ for (i in 2:nr) {
|
|||
| 303 | -+ | ||||
| 129 | +5x |
-
+ psted <- paste_em_n(repvals, i - 1) |
|||
| 304 | -+ | ||||
| 130 | +5x |
- #' @noRd+ spl <- split(repvals[[i]], psted) |
|||
| 305 | -+ | ||||
| 131 | +5x |
- #' @return A list of table rows, even when only one is generated.+ if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
|
|||
| 306 | -+ | ||||
| 132 | +4x |
- .make_tablerows <- function(dfpart,+ fullnest <- FALSE |
|||
| 307 | -+ | ||||
| 133 | +4x |
- alt_dfpart,+ break |
|||
| 308 | +134 |
- func,+ } |
|||
| 309 | +135 |
- cinfo,+ } |
|||
| 310 | +136 |
- datcol = NULL,+ |
|||
| 311 | +137 |
- lev = 1L,+ ## if its full nesting we're done, so put |
|||
| 312 | +138 |
- rvlab = NA_character_,+ ## the counts on as necessary and return. |
|||
| 313 | -+ | ||||
| 139 | +5x |
- format = NULL,+ if (fullnest) {
|
|||
| 314 | -+ | ||||
| 140 | +1x |
- defrowlabs = NULL,+ ret <- manual_cols(.lst = unqvals)+ |
+ |||
| 141 | +1x | +
+ if (!is.null(counts)) {
+ |
+ |||
| 142 | +! | +
+ col_counts(ret) <- counts+ |
+ |||
| 143 | +! | +
+ disp_ccounts(ret) <- TRUE |
|||
| 315 | +144 |
- rowconstr = DataRow,+ }+ |
+ |||
| 145 | +1x | +
+ return(ret) |
|||
| 316 | +146 |
- splextra = list(),+ } |
|||
| 317 | +147 |
- takesdf = NULL,+ |
|||
| 318 | +148 |
- baselines = replicate(+ ## booo. the fully complex case where the multiple rows |
|||
| 319 | +149 |
- length(col_exprs(cinfo)),+ ## really don't represent nesting at all, each top level |
|||
| 320 | +150 |
- list(dfpart[0, ])+ ## can have different sub labels |
|||
| 321 | +151 |
- ),+ |
|||
| 322 | +152 |
- inclNAs,+ ## we will build it up as if it were full nesting and then prune |
|||
| 323 | +153 |
- spl_context = context_df_row(cinfo = cinfo)) {
+ ## based on the columns we actually want. |
|||
| 324 | -1581x | +||||
| 154 | +
- if (is.null(datcol) && !is.na(rvlab)) {
+
|
||||
| 325 | -! | +||||
| 155 | +4x |
- stop("NULL datcol but non-na rowvar label")
+ fullcolinfo <- manual_cols(.lst = unqvals) |
|||
| 326 | -+ | ||||
| 156 | +4x |
- }+ fullbusiness <- names(collect_leaves(coltree(fullcolinfo))) |
|||
| 327 | -1581x | +157 | +4x |
- if (!is.null(datcol) && !is.na(datcol)) {
+ wanted <- paste_em_n(repvals, nr) |
|
| 328 | -1211x | +158 | +4x |
- if (!all(datcol %in% names(dfpart))) {
+ wantcols <- match(wanted, fullbusiness) |
|
| 329 | -! | +||||
| 159 | +4x |
- stop(+ stopifnot(all(!is.na(wantcols))) |
|||
| 330 | -! | +||||
| 160 | +
- "specified analysis variable (", datcol,
+
|
||||
| 331 | -! | +||||
| 161 | +4x |
- ") not present in data"+ subset_cols(fullcolinfo, wantcols) |
|||
| 332 | +162 |
- )+ } |
|||
| 333 | +163 |
- }+ |
|||
| 334 | +164 |
-
+ #' Create a header |
|||
| 335 | -1211x | +||||
| 165 | +
- rowvar <- datcol+ #' |
||||
| 336 | +166 |
- } else {
+ #' @inheritParams compat_args |
|||
| 337 | -370x | +||||
| 167 | +
- rowvar <- NA_character_+ #' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()], |
||||
| 338 | +168 |
- }+ #' [LabelRow()], etc. |
|||
| 339 | +169 |
-
+ #' |
|||
| 340 | -1581x | +||||
| 170 | +
- rawvals <- gen_rowvalues(dfpart,+ #' @return A `InstantiatedColumnInfo` object. |
||||
| 341 | -1581x | +||||
| 171 | +
- alt_dfpart = alt_dfpart,+ #' |
||||
| 342 | -1581x | +||||
| 172 | +
- datcol = datcol,+ #' @examples |
||||
| 343 | -1581x | +||||
| 173 | +
- cinfo = cinfo,+ #' h1 <- rheader(c("A", "B", "C"))
|
||||
| 344 | -1581x | +||||
| 174 | +
- func = func,+ #' h1 |
||||
| 345 | -1581x | +||||
| 175 | +
- splextra = splextra,+ #' |
||||
| 346 | -1581x | +||||
| 176 | +
- takesdf = takesdf,+ #' h2 <- rheader( |
||||
| 347 | -1581x | +||||
| 177 | +
- baselines = baselines,+ #' rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
|
||||
| 348 | -1581x | +||||
| 178 | +
- inclNAs = inclNAs,+ #' rrow(NULL, "A", "B", "A", "B") |
||||
| 349 | -1581x | +||||
| 179 | +
- spl_context = spl_context+ #' ) |
||||
| 350 | +180 |
- )+ #' h2 |
|||
| 351 | +181 |
-
+ #' |
|||
| 352 | +182 |
- ## if(is.null(rvtypes))+ #' @family compatibility |
|||
| 353 | +183 |
- ## rvtypes = rep(NA_character_, length(rawvals))+ #' @export |
|||
| 354 | -1578x | +||||
| 184 | +
- lens <- vapply(rawvals, length, NA_integer_)+ rheader <- function(..., format = "xx", .lst = NULL) {
|
||||
| 355 | -1578x | +185 | +3x |
- unqlens <- unique(lens)+ if (!is.null(.lst)) {
|
|
| 356 | -+ | ||||
| 186 | +! |
- ## length 0 returns are ok to not match cause they are+ args <- .lst |
|||
| 357 | +187 |
- ## just empty space we can fill in as needed.+ } else {
|
|||
| 358 | -1578x | +188 | +3x |
- if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
+ args <- list(...) |
|
| 359 | +189 |
- ## (0 %in% unqlens && length(unqlens) != 2)) {
+ } |
|||
| 360 | -1x | +190 | +3x |
- stop(+ rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
|
|
| 361 | -1x | +||||
| 191 | +! |
- "Number of rows generated by analysis function do not match ",+ list(rrowl(row.name = NULL, val = args[[1]], format = format)) |
|||
| 362 | -1x | +192 | +3x |
- "across all columns. ",+ } else if (are(args, "TableRow")) {
|
|
| 363 | -1x | +193 | +3x |
- if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
+ args |
|
| 364 | -! | +||||
| 194 | +
- paste(+ } |
||||
| 365 | -! | +||||
| 195 | +
- "\nPerhaps convert analysis variable", datcol,+ |
||||
| 366 | -! | +||||
| 196 | +3x |
- "to a factor?"+ hrows_to_colinfo(rrows) |
|||
| 367 | +197 |
- )+ } |
|||
| 368 | +198 |
- }+ |
|||
| 369 | +199 |
- )+ .char_to_hrows <- function(hdr) {
|
|||
| 370 | -+ | ||||
| 200 | +31x |
- }+ nlfnd <- grep("\n", hdr, fixed = TRUE)
|
|||
| 371 | -1577x | +201 | +31x |
- maxind <- match(max(unqlens), lens)+ if (length(nlfnd) == 0) {
|
|
| 372 | -+ | ||||
| 202 | +27x |
-
+ return(list(rrowl(NULL, hdr))) |
|||
| 373 | +203 |
- ## look if we got labels, if not apply the+ } |
|||
| 374 | +204 |
- ## default row labels+ |
|||
| 375 | -+ | ||||
| 205 | +4x |
- ## this is guaranteed to be a RowsVerticalSection object.+ stopifnot(length(nlfnd) == length(hdr)) |
|||
| 376 | -1577x | +206 | +4x |
- rv1col <- rawvals[[maxind]]+ raw <- strsplit(hdr, "\n", fixed = TRUE) |
|
| 377 | -+ | ||||
| 207 | +4x |
- ## nocov start+ lens <- unique(sapply(raw, length)) |
|||
| 378 | -+ | ||||
| 208 | +4x |
- if (!is(rv1col, "RowsVerticalSection")) {
+ stopifnot(length(lens) == 1L) |
|||
| 379 | -+ | ||||
| 209 | +4x |
- stop(+ lapply( |
|||
| 380 | -+ | ||||
| 210 | +4x |
- "gen_rowvalues appears to have generated something that was not ",+ seq(1, lens), |
|||
| 381 | -+ | ||||
| 211 | +4x |
- "a RowsVerticalSection object. Please contact the maintainer."+ function(i) {
|
|||
| 382 | -+ | ||||
| 212 | +8x |
- )+ rrowl(NULL, vapply(raw, `[`, NA_character_, i = i)) |
|||
| 383 | +213 |
- }+ } |
|||
| 384 | +214 |
- # nocov end+ ) |
|||
| 385 | +215 | - - | -|||
| 386 | -1577x | -
- labels <- value_labels(rv1col)+ } |
|||
| 387 | +216 | ||||
| 388 | -1577x | -
- ncrows <- max(unqlens)- |
- |||
| 389 | -1577x | -
- if (ncrows == 0) {
- |
- |||
| 390 | -! | -
- return(list())- |
- |||
| 391 | +217 |
- }- |
- |||
| 392 | -1577x | -
- stopifnot(ncrows > 0)+ #' Create a table |
|||
| 393 | +218 |
-
+ #' |
|||
| 394 | -1577x | +||||
| 219 | +
- if (is.null(labels)) {
+ #' @inheritParams compat_args |
||||
| 395 | -210x | +||||
| 220 | +
- if (length(rawvals[[maxind]]) == length(defrowlabs)) {
+ #' @inheritParams gen_args |
||||
| 396 | -202x | +||||
| 221 | +
- labels <- defrowlabs+ #' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header |
||||
| 397 | +222 |
- } else {
+ #' (column structure) of the table. This can be as row objects (legacy), character vectors, or an |
|||
| 398 | -8x | +||||
| 223 | +
- labels <- rep("", ncrows)
+ #' `InstantiatedColumnInfo` object. |
||||
| 399 | +224 |
- }+ #' @param ... rows to place in the table. |
|||
| 400 | +225 |
- }+ #' |
|||
| 401 | +226 |
-
+ #' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`). |
|||
| 402 | -1577x | +||||
| 227 | +
- rfootnotes <- rep(list(list(), length(rv1col)))+ #' |
||||
| 403 | -1577x | +||||
| 228 | +
- nms <- value_names(rv1col)+ #' @examples |
||||
| 404 | -1577x | +||||
| 229 | +
- rfootnotes <- row_footnotes(rv1col)+ #' rtable( |
||||
| 405 | +230 |
-
+ #' header = LETTERS[1:3], |
|||
| 406 | -1577x | +||||
| 231 | +
- imods <- indent_mod(rv1col) ## rv1col@indent_mods+ #' rrow("one to three", 1, 2, 3),
|
||||
| 407 | -1577x | +||||
| 232 | +
- unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE)+ #' rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
|
||||
| 408 | +233 |
-
+ #' ) |
|||
| 409 | -1577x | +||||
| 234 | +
- formatvec <- NULL+ #' |
||||
| 410 | -1577x | +||||
| 235 | +
- if (!is.null(format)) {
+ #' # Table with multirow header |
||||
| 411 | -208x | +||||
| 236 | +
- if (is.function(format)) {
+ #' |
||||
| 412 | -1x | +||||
| 237 | +
- format <- list(format)+ #' sel <- iris$Species == "setosa" |
||||
| 413 | +238 |
- }+ #' mtbl <- rtable( |
|||
| 414 | -208x | +||||
| 239 | +
- formatvec <- rep(format, length.out = ncrows)+ #' header = rheader( |
||||
| 415 | +240 |
- }+ #' rrow( |
|||
| 416 | +241 |
-
+ #' row.name = NULL, rcell("Sepal.Length", colspan = 2),
|
|||
| 417 | -1577x | +||||
| 242 | +
- trows <- lapply(1:ncrows, function(i) {
+ #' rcell("Petal.Length", colspan = 2)
|
||||
| 418 | -2550x | +||||
| 243 | +
- rowvals <- lapply(unwrapped_vals, function(colvals) {
+ #' ), |
||||
| 419 | -9137x | +||||
| 244 | +
- colvals[[i]]+ #' rrow(NULL, "mean", "median", "mean", "median") |
||||
| 420 | +245 |
- })+ #' ), |
|||
| 421 | -2550x | +||||
| 246 | +
- imod <- unique(vapply(rowvals, indent_mod, 0L))+ #' rrow( |
||||
| 422 | -2550x | +||||
| 247 | +
- if (length(imod) != 1) {
+ #' row.name = "All Species", |
||||
| 423 | -! | +||||
| 248 | +
- stop(+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
||||
| 424 | -! | +||||
| 249 | +
- "Different cells in the same row appear to have been given ",+ #' mean(iris$Petal.Length), median(iris$Petal.Length), |
||||
| 425 | -! | +||||
| 250 | +
- "different indent_mod values"+ #' format = "xx.xx" |
||||
| 426 | +251 |
- )+ #' ), |
|||
| 427 | +252 |
- }+ #' rrow( |
|||
| 428 | -2550x | +||||
| 253 | +
- rowconstr(+ #' row.name = "Setosa", |
||||
| 429 | -2550x | +||||
| 254 | +
- vals = rowvals,+ #' mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]), |
||||
| 430 | -2550x | +||||
| 255 | +
- cinfo = cinfo,+ #' mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel]) |
||||
| 431 | -2550x | +||||
| 256 | +
- lev = lev,+ #' ) |
||||
| 432 | -2550x | +||||
| 257 | +
- label = labels[i],+ #' ) |
||||
| 433 | -2550x | +||||
| 258 | +
- name = nms[i], ## labels[i], ## XXX this is probably wrong?!+ #' |
||||
| 434 | -2550x | +||||
| 259 | +
- var = rowvar,+ #' mtbl |
||||
| 435 | -2550x | +||||
| 260 | +
- format = formatvec[[i]],+ #' |
||||
| 436 | -2550x | +||||
| 261 | +
- indent_mod = imods[[i]] %||% 0L,+ #' names(mtbl) # always first row of header |
||||
| 437 | -2550x | +||||
| 262 | +
- footnotes = rfootnotes[[i]] ## one bracket so list+ #' |
||||
| 438 | +263 |
- )+ #' # Single row header |
|||
| 439 | +264 |
- })+ #' |
|||
| 440 | -1577x | +||||
| 265 | +
- trows+ #' tbl <- rtable( |
||||
| 441 | +266 |
- }+ #' header = c("Treatement\nN=100", "Comparison\nN=300"),
|
|||
| 442 | +267 |
-
+ #' format = "xx (xx.xx%)", |
|||
| 443 | +268 |
- .make_caller <- function(parent_cfun, clabelstr = "") {
+ #' rrow("A", c(104, .2), c(100, .4)),
|
|||
| 444 | -470x | +||||
| 269 | +
- formalnms <- names(formals(parent_cfun))+ #' rrow("B", c(23, .4), c(43, .5)),
|
||||
| 445 | +270 |
- ## note the <- here+ #' rrow(""),
|
|||
| 446 | -470x | +||||
| 271 | +
- if (!is.na(dotspos <- match("...", formalnms))) {
+ #' rrow("this is a very long section header"),
|
||||
| 447 | -1x | +||||
| 272 | +
- toremove <- dotspos+ #' rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
|
||||
| 448 | +273 |
- } else {
+ #' rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
|
|||
| 449 | -469x | +||||
| 274 | +
- toremove <- NULL+ #' ) |
||||
| 450 | +275 |
- }+ #' tbl |
|||
| 451 | +276 |
-
+ #' |
|||
| 452 | -470x | +||||
| 277 | +
- labelstrpos <- match("labelstr", names(formals(parent_cfun)))
+ #' row.names(tbl) |
||||
| 453 | -470x | +||||
| 278 | +
- if (is.na(labelstrpos)) {
+ #' names(tbl) |
||||
| 454 | -! | +||||
| 279 | +
- stop(+ #' |
||||
| 455 | -! | +||||
| 280 | +
- "content function does not appear to accept the labelstr",+ #' # Subsetting |
||||
| 456 | -! | +||||
| 281 | +
- "arguent"+ #' |
||||
| 457 | +282 |
- )+ #' tbl[1, ] |
|||
| 458 | +283 |
- }+ #' tbl[, 1] |
|||
| 459 | -470x | +||||
| 284 | +
- toremove <- c(toremove, labelstrpos)+ #' |
||||
| 460 | -470x | +||||
| 285 | +
- formalnms <- formalnms[-1 * toremove]+ #' tbl[1, 2] |
||||
| 461 | +286 |
-
+ #' tbl[2, 1] |
|||
| 462 | -470x | +||||
| 287 | +
- caller <- eval(parser_helper(text = paste(+ #' |
||||
| 463 | -470x | +||||
| 288 | +
- "function() { parent_cfun(",
+ #' tbl[3, 2] |
||||
| 464 | -470x | +||||
| 289 | +
- paste(formalnms, "=",+ #' tbl[5, 1] |
||||
| 465 | -470x | +||||
| 290 | +
- formalnms,+ #' tbl[5, 2] |
||||
| 466 | -470x | +||||
| 291 | +
- collapse = ", "+ #' |
||||
| 467 | +292 |
- ),+ #' # Data Structure methods |
|||
| 468 | -470x | +||||
| 293 | +
- ", labelstr = clabelstr, ...)}"+ #' |
||||
| 469 | +294 |
- )))+ #' dim(tbl) |
|||
| 470 | -470x | +||||
| 295 | +
- formals(caller) <- c(+ #' nrow(tbl) |
||||
| 471 | -470x | +||||
| 296 | +
- formals(parent_cfun)[-labelstrpos],+ #' ncol(tbl) |
||||
| 472 | -470x | +||||
| 297 | +
- alist("..." = )
+ #' names(tbl) |
||||
| 473 | -470x | +||||
| 298 | +
- ) # nolint+ #' |
||||
| 474 | -470x | +||||
| 299 | +
- caller+ #' # Colspans |
||||
| 475 | +300 |
- }+ #' |
|||
| 476 | +301 |
-
+ #' tbl2 <- rtable( |
|||
| 477 | +302 |
- # Makes content table xxx renaming+ #' c("A", "B", "C", "D", "E"),
|
|||
| 478 | +303 |
- .make_ctab <- function(df,+ #' format = "xx", |
|||
| 479 | +304 |
- lvl, ## treepos,+ #' rrow("r1", 1, 2, 3, 4, 5),
|
|||
| 480 | +305 |
- name,+ #' rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
|
|||
| 481 | +306 |
- label,+ #' ) |
|||
| 482 | +307 |
- cinfo,+ #' tbl2 |
|||
| 483 | +308 |
- parent_cfun = NULL,+ #' |
|||
| 484 | +309 |
- format = NULL,+ #' @family compatibility |
|||
| 485 | +310 |
- na_str = NA_character_,+ #' @export |
|||
| 486 | +311 |
- indent_mod = 0L,+ rtable <- function(header, ..., format = NULL, hsep = default_hsep(), |
|||
| 487 | +312 |
- cvar = NULL,+ inset = 0L) {
|
|||
| 488 | -+ | ||||
| 313 | +34x |
- inclNAs,+ if (is.character(header)) {
|
|||
| 489 | -+ | ||||
| 314 | +31x |
- alt_df,+ header <- .char_to_hrows(header) |
|||
| 490 | +315 |
- extra_args,+ } # list(rrowl(NULL, header)) |
|||
| 491 | -+ | ||||
| 316 | +34x |
- spl_context = context_df_row(cinfo = cinfo)) {
+ if (is.list(header)) {
|
|||
| 492 | -1813x | +317 | +31x |
- if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
+ if (are(header, "TableRow")) {
|
|
| 493 | -1637x | +318 | +31x |
- cvar <- NULL+ colinfo <- hrows_to_colinfo(header) |
|
| 494 | -+ | ||||
| 319 | +! |
- }+ } else if (are(header, "list")) {
|
|||
| 495 | -1813x | +||||
| 320 | +! |
- if (!is.null(parent_cfun)) {
+ colinfo <- do.call(rheader, header) |
|||
| 496 | +321 |
- ## cfunc <- .make_caller(parent_cfun, label)+ } |
|||
| 497 | -459x | +322 | +3x |
- cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label)+ } else if (is(header, "InstantiatedColumnInfo")) {
|
|
| 498 | -459x | +323 | +3x |
- contkids <- tryCatch(+ colinfo <- header |
|
| 499 | -459x | +||||
| 324 | +! |
- .make_tablerows(df,+ } else if (is(header, "TableRow")) {
|
|||
| 500 | -459x | +||||
| 325 | +! |
- lev = lvl,+ colinfo <- hrows_to_colinfo(list(header)) |
|||
| 501 | -459x | +||||
| 326 | +
- func = cfunc,+ } else {
|
||||
| 502 | -459x | +||||
| 327 | +! |
- cinfo = cinfo,+ stop("problems")
|
|||
| 503 | -459x | +||||
| 328 | +
- rowconstr = ContentRow,+ } |
||||
| 504 | -459x | +||||
| 329 | +
- datcol = cvar,+ |
||||
| 505 | -459x | +330 | +34x |
- takesdf = rep(.takes_df(cfunc),+ body <- list(...)+ |
+ |
| 331 | ++ |
+ ## XXX this shouldn't be needed. hacky |
|||
| 506 | -459x | +332 | +34x |
- length.out = ncol(cinfo)+ if (length(body) == 1 && is.list(body[[1]])) {
|
|
| 507 | -+ | ||||
| 333 | +! |
- ),+ body <- body[[1]] |
|||
| 508 | -459x | +||||
| 334 | +
- inclNAs = FALSE,+ } |
||||
| 509 | -459x | +335 | +34x |
- alt_dfpart = alt_df,+ if (are(body, "ElementaryTable") && |
|
| 510 | -459x | +336 | +34x |
- splextra = extra_args,+ all(sapply(body, function(tb) {
|
|
| 511 | -459x | +||||
| 337 | +! |
- spl_context = spl_context+ nrow(tb) == 1 && obj_name(tb) == "" |
|||
| 512 | +338 |
- ),+ }))) {
|
|||
| 513 | -459x | +339 | +1x |
- error = function(e) e+ body <- lapply(body, function(tb) tree_children(tb)[[1]]) |
|
| 514 | +340 |
- )+ } |
|||
| 515 | -459x | +||||
| 341 | +
- if (is(contkids, "error")) {
+
|
||||
| 516 | -1x | +342 | +34x |
- stop("Error in content (summary) function: ", contkids$message,
+ TableTree( |
|
| 517 | -1x | +343 | +34x |
- "\n\toccured at path: ",+ kids = body, format = format, cinfo = colinfo, |
|
| 518 | -1x | +344 | +34x |
- spl_context_to_disp_path(spl_context),+ labelrow = LabelRow(lev = 0L, label = "", vis = FALSE), |
|
| 519 | -1x | +345 | +34x |
- call. = FALSE+ hsep = hsep, inset = inset |
|
| 520 | +346 |
- )+ ) |
|||
| 521 | +347 |
- }+ } |
|||
| 522 | +348 |
- } else {
+
|
|||
| 523 | -1354x | +||||
| 349 | +
- contkids <- list()+ #' @rdname rtable |
||||
| 524 | +350 |
- }+ #' @export |
|||
| 525 | -1812x | +||||
| 351 | +
- ctab <- ElementaryTable(+ rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
|
||||
| 526 | -1812x | +352 | +1x |
- kids = contkids,+ dots <- list(...) |
|
| 527 | -1812x | +353 | +1x |
- name = paste0(name, "@content"),+ args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply( |
|
| 528 | -1812x | +354 | +1x |
- lev = lvl,+ dots, |
|
| 529 | -1812x | +355 | +1x |
- labelrow = LabelRow(),+ as.list |
|
| 530 | -1812x | +356 | +1x |
- cinfo = cinfo,+ ), recursive = FALSE)) |
|
| 531 | -1812x | +357 | +1x |
- iscontent = TRUE,+ do.call(rtable, args_list) |
|
| 532 | -1812x | +||||
| 358 | +
- format = format,+ } |
||||
| 533 | -1812x | +||||
| 359 | +
- indent_mod = indent_mod,+ |
||||
| 534 | -1812x | +||||
| 360 | +
- na_str = na_str+ # All object annotations are identical (and exist) |
||||
| 535 | +361 |
- )+ all_annots_identical <- function(all_annots) {
|
|||
| 536 | -1812x | +362 | +60x |
- ctab+ if (!is.list(all_annots)) {
|
|
| 537 | -+ | ||||
| 363 | +15x |
- }+ all_annots[1] != "" && length(unique(all_annots)) == 1 |
|||
| 538 | +364 |
-
+ } else {
|
|||
| 539 | -+ | ||||
| 365 | +45x |
- .make_analyzed_tab <- function(df,+ length(all_annots[[1]]) > 0 && Reduce(identical, all_annots) |
|||
| 540 | +366 |
- alt_df,+ } |
|||
| 541 | +367 |
- spl,+ } |
|||
| 542 | +368 |
- cinfo,+ |
|||
| 543 | +369 |
- partlabel = "",+ # Only first object has annotations |
|||
| 544 | +370 |
- dolab = TRUE,+ only_first_annot <- function(all_annots) {
|
|||
| 545 | -+ | ||||
| 371 | +56x |
- lvl,+ if (!is.list(all_annots)) {
|
|||
| 546 | -+ | ||||
| 372 | +14x |
- baselines,+ all_annots[1] != "" && all(all_annots[-1] == "") |
|||
| 547 | +373 |
- spl_context) {
+ } else {
|
|||
| 548 | -1123x | +374 | +42x |
- stopifnot(is(spl, "VAnalyzeSplit"))+ length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0) |
|
| 549 | -1123x | +||||
| 375 | +
- check_validsplit(spl, df)+ } |
||||
| 550 | -1122x | +||||
| 376 | +
- defrlabel <- spl@default_rowlabel+ } |
||||
| 551 | -1122x | +||||
| 377 | +
- if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
+
|
||||
| 552 | -! | +||||
| 378 | +
- defrlabel <- partlabel+ #' @param gap `r lifecycle::badge("deprecated")` ignored.
|
||||
| 553 | +379 |
- }+ #' @param check_headers `r lifecycle::badge("deprecated")` ignored.
|
|||
| 554 | -1122x | +||||
| 380 | +
- kids <- tryCatch(+ #' |
||||
| 555 | -1122x | +||||
| 381 | +
- .make_tablerows(df,+ #' @return A formal table object. |
||||
| 556 | -1122x | +||||
| 382 | +
- func = analysis_fun(spl),+ #' |
||||
| 557 | -1122x | +||||
| 383 | +
- defrowlabs = defrlabel, # XXX+ #' @rdname rbind |
||||
| 558 | -1122x | +||||
| 384 | +
- cinfo = cinfo,+ #' @aliases rbind |
||||
| 559 | -1122x | +||||
| 385 | +
- datcol = spl_payload(spl),+ #' @export |
||||
| 560 | -1122x | +||||
| 386 | +
- lev = lvl + 1L,+ rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
|
||||
| 561 | -1122x | +||||
| 387 | +
- format = obj_format(spl),+ ## nocov start |
||||
| 562 | -1122x | +||||
| 388 | +
- splextra = split_exargs(spl),+ if (lifecycle::is_present(gap)) {
|
||||
| 563 | -1122x | +||||
| 389 | +
- baselines = baselines,+ lifecycle::deprecate_warn( |
||||
| 564 | -1122x | +||||
| 390 | +
- alt_dfpart = alt_df,+ when = "0.3.2", |
||||
| 565 | -1122x | +||||
| 391 | +
- inclNAs = avar_inclNAs(spl),+ what = "rbindl_rtables(gap)" |
||||
| 566 | -1122x | +||||
| 392 | +
- spl_context = spl_context+ ) |
||||
| 567 | +393 |
- ),+ } |
|||
| 568 | -1122x | +||||
| 394 | +
- error = function(e) e+ if (lifecycle::is_present(check_headers)) {
|
||||
| 569 | +395 |
- )+ lifecycle::deprecate_warn( |
|||
| 570 | +396 |
-
+ when = "0.3.2", |
|||
| 571 | +397 |
- # Adding section_div for DataRows (analyze leaves)+ what = "rbindl_rtables(check_headers)" |
|||
| 572 | -1122x | +||||
| 398 | +
- kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow")+ ) |
||||
| 573 | +399 |
-
+ } |
|||
| 574 | -1122x | +||||
| 400 | +
- if (is(kids, "error")) {
+ ## nocov end |
||||
| 575 | -3x | +||||
| 401 | +
- stop("Error applying analysis function (var - ",
+
|
||||
| 576 | -3x | +402 | +16x |
- spl_payload(spl) %||% "colvars", "): ", kids$message,+ firstcols <- col_info(x[[1]]) |
|
| 577 | -3x | +403 | +16x |
- "\n\toccured at (row) path: ",+ i <- 1 |
|
| 578 | -3x | +404 | +16x |
- spl_context_to_disp_path(spl_context),+ while (no_colinfo(firstcols) && i <= length(x)) {
|
|
| 579 | -3x | +405 | +2x |
- call. = FALSE+ firstcols <- col_info(x[[i]]) |
|
| 580 | -+ | ||||
| 406 | +2x |
- )+ i <- i + 1 |
|||
| 581 | +407 |
} |
|||
| 582 | -1119x | +||||
| 408 | +
- lab <- obj_label(spl)+ |
||||
| 583 | -1119x | +409 | +16x |
- ret <- TableTree(+ lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi))) |
|
| 584 | -1119x | +||||
| 410 | +
- kids = kids,+ |
||||
| 585 | -1119x | +411 | +15x |
- name = obj_name(spl),+ rbind_annot <- list( |
|
| 586 | -1119x | +412 | +15x |
- label = lab,+ main_title = "", |
|
| 587 | -1119x | +413 | +15x |
- lev = lvl,+ subtitles = character(), |
|
| 588 | -1119x | +414 | +15x |
- cinfo = cinfo,+ main_footer = character(), |
|
| 589 | -1119x | +415 | +15x |
- format = obj_format(spl),+ prov_footer = character() |
|
| 590 | -1119x | +||||
| 416 | +
- na_str = obj_na_str(spl),+ ) |
||||
| 591 | -1119x | +||||
| 417 | +
- indent_mod = indent_mod(spl)+ |
||||
| 592 | +418 |
- )+ # Titles/footer info are (independently) retained from first object if |
|||
| 593 | +419 |
-
+ # identical or missing in all other objects |
|||
| 594 | -1119x | +420 | +15x |
- labelrow_visible(ret) <- dolab+ all_titles <- sapply(x, main_title) |
|
| 595 | -1119x | +421 | +15x |
- ret+ if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
+ |
+ |
| 422 | +2x | +
+ rbind_annot[["main_title"]] <- all_titles[[1]] |
|||
| 596 | +423 |
- }+ } |
|||
| 597 | +424 | ||||
| 598 | -+ | ||||
| 425 | +15x |
- #' @param ... all arguments to `recurse_applysplit`, methods may only use some of them.+ all_sts <- lapply(x, subtitles) |
|||
| 599 | -+ | ||||
| 426 | +15x |
- #' @return A `list` of children to place at this level.+ if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
|
|||
| 600 | -+ | ||||
| 427 | +2x |
- #'+ rbind_annot[["subtitles"]] <- all_sts[[1]] |
|||
| 601 | +428 |
- #' @noRd+ } |
|||
| 602 | +429 |
- setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
+
|
|||
| 603 | -1650x | +430 | +15x |
- standardGeneric(".make_split_kids")
+ all_ftrs <- lapply(x, main_footer) |
|
| 604 | -+ | ||||
| 431 | +15x |
- })+ if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) {
|
|||
| 605 | -+ | ||||
| 432 | +2x |
-
+ rbind_annot[["main_footer"]] <- all_ftrs[[1]] |
|||
| 606 | +433 |
- ## single AnalyzeSplit+ } |
|||
| 607 | +434 |
- setMethod(+ |
|||
| 608 | -+ | ||||
| 435 | +15x |
- ".make_split_kids", "VAnalyzeSplit",+ all_pfs <- lapply(x, prov_footer) |
|||
| 609 | -+ | ||||
| 436 | +15x |
- function(spl,+ if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
|
|||
| 610 | -+ | ||||
| 437 | +2x |
- have_controws, ## unused here+ rbind_annot[["prov_footer"]] <- all_pfs[[1]] |
|||
| 611 | +438 |
- make_lrow, ## unused here+ } |
|||
| 612 | +439 |
- ...,+ |
|||
| 613 | +440 |
- df,+ ## if we got only ElementaryTable and |
|||
| 614 | +441 |
- alt_df,+ ## TableRow objects, construct a new |
|||
| 615 | +442 |
- lvl,+ ## elementary table with all the rows |
|||
| 616 | +443 |
- name,+ ## instead of adding nesting. |
|||
| 617 | +444 |
- cinfo,+ |
|||
| 618 | +445 |
- baselines,+ ## we used to check for xi not being a lable row, why?? XXX |
|||
| 619 | -+ | ||||
| 446 | +15x |
- spl_context,+ if (all(sapply(x, function(xi) {
|
|||
| 620 | -+ | ||||
| 447 | +30x |
- nsibs = 0) {
+ (is(xi, "ElementaryTable") && !labelrow_visible(xi)) || |
|||
| 621 | -1123x | +448 | +30x |
- spvis <- labelrow_visible(spl)+ is(xi, "TableRow") |
|
| 622 | -1123x | +449 | +15x |
- if (is.na(spvis)) {
+ }))) { ## && !is(xi, "LabelRow")}))) {
|
|
| 623 | -190x | +450 | +8x |
- spvis <- nsibs > 0+ x <- unlist(lapply(x, function(xi) {
|
|
| 624 | -+ | ||||
| 451 | +16x |
- }+ if (is(xi, "TableRow")) {
+ |
+ |||
| 452 | +4x | +
+ xi |
|||
| 625 | +453 |
-
+ } else {
|
|||
| 626 | -1123x | +454 | +12x |
- ret <- .make_analyzed_tab(+ lst <- tree_children(xi) |
|
| 627 | -1123x | +455 | +12x |
- df = df,+ lapply(lst, indent, |
|
| 628 | -1123x | +456 | +12x |
- alt_df,+ by = indent_mod(xi) |
|
| 629 | -1123x | +||||
| 457 | +
- spl = spl,+ ) |
||||
| 630 | -1123x | +||||
| 458 | +
- cinfo = cinfo,+ } |
||||
| 631 | -1123x | +||||
| 459 | +
- lvl = lvl + 1L,+ })) |
||||
| 632 | -1123x | +||||
| 460 | +
- dolab = spvis,+ }+ |
+ ||||
| 461 | ++ | + | |||
| 633 | -1123x | +462 | +15x |
- partlabel = obj_label(spl),+ TableTree( |
|
| 634 | -1123x | +463 | +15x |
- baselines = baselines,+ kids = x, |
|
| 635 | -1123x | +464 | +15x |
- spl_context = spl_context+ cinfo = firstcols, |
|
| 636 | -+ | ||||
| 465 | +15x |
- )+ name = "rbind_root", |
|||
| 637 | -1119x | +466 | +15x |
- indent_mod(ret) <- indent_mod(spl)+ label = "", |
|
| 638 | -+ | ||||
| 467 | +15x |
-
+ title = rbind_annot[["main_title"]], |
|||
| 639 | -1119x | +468 | +15x |
- kids <- list(ret)+ subtitles = rbind_annot[["subtitles"]], |
|
| 640 | -1119x | +469 | +15x |
- names(kids) <- obj_name(ret)+ main_footer = rbind_annot[["main_footer"]], |
|
| 641 | -1119x | +470 | +15x |
- kids+ prov_footer = rbind_annot[["prov_footer"]] |
|
| 642 | +471 |
- }+ ) |
|||
| 643 | +472 |
- )+ } |
|||
| 644 | +473 | ||||
| 645 | +474 |
- # Adding section_divisors to TableRow+ #' Row-bind `TableTree` and related objects |
|||
| 646 | +475 |
- .set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
+ #' |
|||
| 647 | -1630x | +||||
| 476 | +
- if (!is.na(trailing_section_div_char)) {
+ #' @param deparse.level (`numeric(1)`)\cr currently ignored. |
||||
| 648 | -29x | +||||
| 477 | +
- lst <- lapply(+ #' @param ... (`ANY`)\cr elements to be stacked. |
||||
| 649 | -29x | +||||
| 478 | +
- lst,+ #' |
||||
| 650 | -29x | +||||
| 479 | +
- function(k) {
+ #' @note |
||||
| 651 | -70x | +||||
| 480 | +
- if (is(k, allowed_class)) {
+ #' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all |
||||
| 652 | -70x | +||||
| 481 | +
- trailing_section_div(k) <- trailing_section_div_char+ #' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed |
||||
| 653 | +482 |
- }+ #' and must be set for the bound table via the [main_title()], [subtitles()], [main_footer()], and [prov_footer()] |
|||
| 654 | -70x | +||||
| 483 | +
- k+ #' functions. |
||||
| 655 | +484 |
- }+ #' |
|||
| 656 | +485 |
- )+ #' @examples |
|||
| 657 | +486 |
- }+ #' mtbl <- rtable( |
|||
| 658 | -1630x | +||||
| 487 | +
- lst+ #' header = rheader( |
||||
| 659 | +488 |
- }+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
|
|||
| 660 | +489 |
-
+ #' rrow(NULL, "mean", "median", "mean", "median") |
|||
| 661 | +490 |
- ## 1 or more AnalyzeSplits+ #' ), |
|||
| 662 | +491 |
- setMethod(+ #' rrow( |
|||
| 663 | +492 |
- ".make_split_kids", "AnalyzeMultiVars",+ #' row.name = "All Species", |
|||
| 664 | +493 |
- function(spl,+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
|||
| 665 | +494 |
- have_controws,+ #' mean(iris$Petal.Length), median(iris$Petal.Length), |
|||
| 666 | +495 |
- make_lrow, ## used here+ #' format = "xx.xx" |
|||
| 667 | +496 |
- spl_context,+ #' ) |
|||
| 668 | +497 |
- ...) { ## all passed directly down to VAnalyzeSplit method
+ #' ) |
|||
| 669 | -102x | +||||
| 498 | +
- avspls <- spl_payload(spl)+ #' |
||||
| 670 | +499 |
-
+ #' mtbl2 <- with(subset(iris, Species == "setosa"), rtable( |
|||
| 671 | -102x | +||||
| 500 | +
- nspl <- length(avspls)+ #' header = rheader( |
||||
| 672 | +501 |
-
+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
|
|||
| 673 | -102x | +||||
| 502 | +
- kids <- unlist(lapply(avspls,+ #' rrow(NULL, "mean", "median", "mean", "median") |
||||
| 674 | -102x | +||||
| 503 | +
- .make_split_kids,+ #' ), |
||||
| 675 | -102x | +||||
| 504 | +
- nsibs = nspl - 1,+ #' rrow( |
||||
| 676 | -102x | +||||
| 505 | +
- have_controws = have_controws,+ #' row.name = "Setosa", |
||||
| 677 | -102x | +||||
| 506 | +
- make_lrow = make_lrow,+ #' mean(Sepal.Length), median(Sepal.Length), |
||||
| 678 | -102x | +||||
| 507 | +
- spl_context = spl_context,+ #' mean(Petal.Length), median(Petal.Length), |
||||
| 679 | +508 |
- ...+ #' format = "xx.xx" |
|||
| 680 | +509 |
- ))+ #' ) |
|||
| 681 | +510 |
-
+ #' )) |
|||
| 682 | -102x | +||||
| 511 | +
- kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree")+ #' |
||||
| 683 | +512 |
-
+ #' rbind(mtbl, mtbl2) |
|||
| 684 | +513 |
- ## XXX this seems like it should be identical not !identical+ #' rbind(mtbl, rrow(), mtbl2) |
|||
| 685 | +514 |
- ## TODO FIXME+ #' rbind(mtbl, rrow("aaa"), indent(mtbl2))
|
|||
| 686 | -102x | +||||
| 515 | +
- if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
+ #' |
||||
| 687 | +516 |
- ## we only analyzed one var so+ #' @exportMethod rbind |
|||
| 688 | +517 |
- ## we don't need an extra wrapper table+ #' @rdname rbind |
|||
| 689 | +518 |
- ## in the structure+ setMethod( |
|||
| 690 | -! | +||||
| 519 | +
- stopifnot(identical(+ "rbind", "VTableNodeInfo", |
||||
| 691 | -! | +||||
| 520 | +
- obj_name(kids[[1]]),+ function(..., deparse.level = 1) {
|
||||
| 692 | +521 | ! |
- spl_payload(spl)+ rbindl_rtables(list(...)) |
||
| 693 | +522 |
- ))+ } |
|||
| 694 | -! | +||||
| 523 | +
- return(kids[[1]])+ ) |
||||
| 695 | +524 |
- }+ |
|||
| 696 | +525 |
- ## this will be the variables+ #' @param y (`ANY`)\cr second element to be row-bound via `rbind2`. |
|||
| 697 | +526 |
- ## nms = sapply(spl_payload(spl), spl_payload)+ #' |
|||
| 698 | +527 |
-
+ #' @exportMethod rbind2 |
|||
| 699 | -102x | +||||
| 528 | +
- nms <- vapply(kids, obj_name, "")+ #' @rdname int_methods |
||||
| 700 | -102x | +||||
| 529 | +
- labs <- vapply(kids, obj_label, "")+ setMethod( |
||||
| 701 | -102x | -
- if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
- |
- |||
| 702 | -1x | -
- warning("Non-unique sibling analysis table names. Using Labels ",
- |
- |||
| 703 | -1x | -
- "instead. Use the table_names argument to analyze to avoid ",- |
- |||
| 704 | -1x | -
- "this when analyzing the same variable multiple times.",- |
- |||
| 705 | -1x | +||||
| 530 | +
- "\n\toccured at (row) path: ",+ "rbind2", c("VTableNodeInfo", "missing"),
|
||||
| 706 | -1x | +||||
| 531 | +
- spl_context_to_disp_path(spl_context),+ function(x, y) {
|
||||
| 707 | -1x | +532 | +2x |
- call. = FALSE+ TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "") |
|
| 708 | +533 |
- )+ } |
|||
| 709 | -1x | +||||
| 534 | +
- kids <- mapply(function(k, nm) {
+ ) |
||||
| 710 | -2x | +||||
| 535 | +
- obj_name(k) <- nm+ |
||||
| 711 | -2x | +||||
| 536 | +
- k+ #' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object. |
||||
| 712 | -1x | +||||
| 537 | +
- }, k = kids, nm = labs, SIMPLIFY = FALSE)+ #' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object. |
||||
| 713 | -1x | +||||
| 538 | +
- nms <- labs+ #' |
||||
| 714 | +539 |
- }+ #' @exportMethod rbind2 |
|||
| 715 | +540 |
-
+ #' @rdname rbind |
|||
| 716 | -102x | +||||
| 541 | +
- nms[is.na(nms)] <- ""+ setMethod( |
||||
| 717 | +542 |
-
+ "rbind2", "VTableNodeInfo", |
|||
| 718 | -102x | +||||
| 543 | +
- names(kids) <- nms+ function(x, y) {
|
||||
| 719 | -102x | +544 | +12x |
- kids+ rbindl_rtables(list(x, y)) |
|
| 720 | +545 |
} |
|||
| 721 | +546 |
) |
|||
| 722 | +547 | ||||
| 723 | +548 |
- setMethod(+ EmptyTreePos <- TreePos() |
|||
| 724 | +549 |
- ".make_split_kids", "Split",+ |
|||
| 725 | +550 |
- function(spl,+ ## this is painful to do right but we were doing it wrong |
|||
| 726 | +551 |
- have_controws,+ ## before and it now matters because count display information |
|||
| 727 | +552 |
- make_lrow,+ ## is in the tree which means all points in the structure |
|||
| 728 | +553 |
- ...,+ ## must be pathable, which they aren't if siblings have |
|||
| 729 | +554 |
- splvec, ## passed to recursive_applysplit+ ## identical names |
|||
| 730 | +555 |
- df, ## used to apply split+ fix_col_nm_recursive <- function(ct, newname, rename_obj = TRUE, oldnm) {
|
|||
| 731 | -+ | ||||
| 556 | +124x |
- alt_df, ## used to apply split for alternative df+ if (rename_obj) {
|
|||
| 732 | -+ | ||||
| 557 | +21x |
- lvl, ## used to calculate innerlev+ obj_name(ct) <- newname |
|||
| 733 | +558 |
- cinfo, ## used for sanity check+ } |
|||
| 734 | -+ | ||||
| 559 | +124x |
- baselines, ## used to calc new baselines+ if (is(ct, "LayoutColTree")) {
|
|||
| 735 | -+ | ||||
| 560 | +47x |
- spl_context) {
+ kids <- tree_children(ct) |
|||
| 736 | -+ | ||||
| 561 | +47x |
- ## do the core splitting of data into children for this split+ kidnms <- names(kids) |
|||
| 737 | -425x | +562 | +47x |
- rawpart <- do_split(spl, df, spl_context = spl_context)+ newkids <- lapply(kids, fix_col_nm_recursive, |
|
| 738 | -421x | +563 | +47x |
- dataspl <- rawpart[["datasplit"]]+ newname = newname, |
|
| 739 | -+ | ||||
| 564 | +47x |
- ## these are SplitValue objects+ rename_obj = FALSE, |
|||
| 740 | -421x | +565 | +47x |
- splvals <- rawpart[["values"]]+ oldnm = oldnm |
|
| 741 | -421x | +||||
| 566 | +
- partlabels <- rawpart[["labels"]]+ ) |
||||
| 742 | -421x | +567 | +47x |
- if (is.factor(partlabels)) {
+ names(newkids) <- kidnms |
|
| 743 | -! | +||||
| 568 | +47x |
- partlabels <- as.character(partlabels)+ tree_children(ct) <- newkids |
|||
| 744 | +569 |
- }+ } |
|||
| 745 | -421x | +570 | +124x |
- nms <- unlist(value_names(splvals))+ mypos <- tree_pos(ct) |
|
| 746 | -421x | -
- if (is.factor(nms)) {
- |
- |||
| 747 | -! | +571 | +124x |
- nms <- as.character(nms)+ if (!identical(mypos, EmptyTreePos)) {
|
|
| 748 | -+ | ||||
| 572 | +99x |
- }+ spls <- pos_splits(mypos) |
|||
| 749 | -+ | ||||
| 573 | +99x |
-
+ firstspl <- spls[[1]] |
|||
| 750 | -+ | ||||
| 574 | +99x |
- ## Get new baseline values+ if (obj_name(firstspl) == oldnm) {
|
|||
| 751 | -+ | ||||
| 575 | +! |
- ##+ obj_name(firstspl) <- newname |
|||
| 752 | -+ | ||||
| 576 | +! |
- ## XXX this is a lot of data churn, if it proves too slow+ spls[[1]] <- firstspl |
|||
| 753 | -+ | ||||
| 577 | +! |
- ## we can+ pos_splits(mypos) <- spls |
|||
| 754 | -+ | ||||
| 578 | +! |
- ## a) check if any of the analyses (i.e. the afuns) need the baseline in this+ tree_pos(ct) <- mypos |
|||
| 755 | +579 |
- ## splitvec and not do any of this if not, or+ } |
|||
| 756 | +580 |
- ## b) refactor row splitting to behave like column splitting+ } |
|||
| 757 | -+ | ||||
| 581 | +124x |
- ##+ if (!rename_obj) {
|
|||
| 758 | -+ | ||||
| 582 | +103x |
- ## (b) seems the better design but is a major reworking of the guts of how+ spls <- pos_splits(mypos) |
|||
| 759 | -+ | ||||
| 583 | +103x |
- ## rtables tabulation works+ splvals <- pos_splvals(mypos) |
|||
| 760 | -+ | ||||
| 584 | +103x |
- ## (a) will only help if analyses that use baseline+ pos_splits(mypos) <- c( |
|||
| 761 | -+ | ||||
| 585 | +103x |
- ## info are mixed with those who don't.+ list(AllSplit(split_name = newname)), |
|||
| 762 | -421x | +586 | +103x |
- newbl_raw <- lapply(baselines, function(dat) {
+ spls |
|
| 763 | +587 |
- # If no ref_group is specified+ ) |
|||
| 764 | -1527x | +588 | +103x |
- if (is.null(dat)) {
+ pos_splvals(mypos) <- c( |
|
| 765 | -1507x | +589 | +103x |
- return(NULL)+ list(SplitValue(NA_character_, |
|
| 766 | -+ | ||||
| 590 | +103x |
- }+ sub_expr = quote(TRUE) |
|||
| 767 | +591 |
-
+ )),+ |
+ |||
| 592 | +103x | +
+ splvals |
|||
| 768 | +593 |
- ## apply the same splitting on the+ ) |
|||
| 769 | -20x | +594 | +103x |
- bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]],+ tree_pos(ct) <- mypos+ |
+ |
| 595 | ++ |
+ } |
|||
| 770 | -20x | +596 | +124x |
- error = function(e) e+ ct |
|
| 771 | +597 |
- )+ } |
|||
| 772 | +598 | ||||
| 773 | +599 |
- # Error localization+ fix_nms <- function(ct) {
|
|||
| 774 | -20x | +600 | +134x |
- if (is(bldataspl, "error")) {
+ if (is(ct, "LayoutColLeaf")) {
|
|
| 775 | -! | +||||
| 601 | +77x |
- stop("Following error encountered in splitting .ref_group (baselines): ",
+ return(ct) |
|||
| 776 | -! | +||||
| 602 | +
- bldataspl$message,+ } |
||||
| 777 | -! | +||||
| 603 | +57x |
- call. = FALSE+ kids <- lapply(tree_children(ct), fix_nms) |
|||
| 778 | -+ | ||||
| 604 | +57x |
- )+ names(kids) <- vapply(kids, obj_name, "")+ |
+ |||
| 605 | +57x | +
+ tree_children(ct) <- kids+ |
+ |||
| 606 | +57x | +
+ ct |
|||
| 779 | +607 |
- }+ } |
|||
| 780 | +608 | ||||
| 781 | +609 |
- ## we only keep the ones corresponding with actual data splits+ make_cbind_names <- function(num, tokens) {
|
|||
| 782 | -20x | +610 | +10x |
- res <- lapply(+ cbind_tokens <- grep("^(new_)*cbind_tbl", tokens, value = TRUE)
|
|
| 783 | -20x | +611 | +10x |
- names(dataspl),+ ret <- paste0("cbind_tbl_", seq_len(num))
|
|
| 784 | -20x | +612 | +10x |
- function(nm) {
+ if (length(cbind_tokens) == 0) {
|
|
| 785 | -52x | +613 | +10x |
- if (nm %in% names(bldataspl)) {
+ return(ret) |
|
| 786 | -52x | +||||
| 614 | +
- bldataspl[[nm]]+ } |
||||
| 787 | -+ | ||||
| 615 | +! |
- } else {
+ oldprefixes <- gsub("cbind_tbl.*", "", cbind_tokens)
|
|||
| 788 | +616 | ! |
- dataspl[[1]][0, ]+ oldprefix <- oldprefixes[which.max(nchar(oldprefixes))] |
||
| 789 | -+ | ||||
| 617 | +! |
- }+ paste0("new_", oldprefix, ret)
|
|||
| 790 | +618 |
- }+ } |
|||
| 791 | +619 |
- )+ |
|||
| 792 | +620 |
-
+ combine_cinfo <- function(..., new_total = NULL, sync_count_vis) {
|
|||
| 793 | -20x | +621 | +12x |
- names(res) <- names(dataspl)+ tabs <- list(...) |
|
| 794 | -20x | +622 | +12x |
- res+ chk_cbindable_many(tabs) |
|
| 795 | -+ | ||||
| 623 | +10x |
- })+ cinfs <- lapply(tabs, col_info)+ |
+ |||
| 624 | +10x | +
+ stopifnot(are(cinfs, "InstantiatedColumnInfo")) |
|||
| 796 | +625 | ||||
| 797 | -421x | +626 | +10x |
- newbaselines <- lapply(names(dataspl), function(nm) {
+ ctrees <- lapply(cinfs, coltree) |
|
| 798 | -1245x | +627 | +10x |
- lapply(newbl_raw, function(rawdat) {
+ oldnms <- nms <- vapply(ctrees, obj_name, "") |
|
| 799 | -4502x | +628 | +10x |
- if (nm %in% names(rawdat)) {
+ path_els <- unique(unlist(lapply(ctrees, col_paths), recursive = TRUE)) |
|
| 800 | -52x | +629 | +10x |
- rawdat[[nm]]+ nms <- make_cbind_names(num = length(oldnms), tokens = path_els) |
|
| 801 | +630 |
- } else {
+
|
|||
| 802 | -4450x | +631 | +10x |
- rawdat[[1]][0, ]+ ctrees <- mapply(function(ct, nm, oldnm) {
|
|
| 803 | -+ | ||||
| 632 | +21x |
- }+ ct <- fix_col_nm_recursive(ct, nm, rename_obj = TRUE, oldnm = "") # oldnm) |
|||
| 804 | -+ | ||||
| 633 | +21x |
- })+ ct |
|||
| 805 | -+ | ||||
| 634 | +10x |
- })+ }, ct = ctrees, nm = nms, oldnm = oldnms, SIMPLIFY = FALSE)+ |
+ |||
| 635 | +10x | +
+ names(ctrees) <- nms |
|||
| 806 | +636 | ||||
| 807 | -421x | -
- if (length(newbaselines) != length(dataspl)) {
- |
- |||
| 808 | -! | +637 | +10x |
- stop(+ newctree <- LayoutColTree(kids = ctrees, colcount = NA_integer_, name = "cbind_root") |
|
| 809 | -! | +||||
| 638 | +10x |
- "Baselines (ref_group) after row split does not have",+ newctree <- fix_nms(newctree) |
|||
| 810 | -! | +||||
| 639 | +10x |
- " the same number of levels of input data split. ",+ newcounts <- unlist(lapply(cinfs, col_counts)) |
|||
| 811 | -! | +||||
| 640 | +10x |
- "Contact the maintainer."+ if (is.null(new_total)) {
|
|||
| 812 | -! | +||||
| 641 | +10x |
- ) # nocov+ new_total <- sum(newcounts) |
|||
| 813 | +642 |
- }+ } |
|||
| 814 | -421x | +643 | +10x |
- if (!(length(newbaselines) == 0 ||+ newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE) |
|
| 815 | -421x | +644 | +10x |
- identical(+ newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
|
|
| 816 | -421x | +645 | +10x |
- unique(sapply(newbaselines, length)),+ if (!sync_count_vis) {
|
|
| 817 | -421x | +646 | +1x |
- length(col_exprs(cinfo))+ newdisp <- NA |
|
| 818 | +647 |
- ))) {
- |
- |||
| 819 | -! | -
- stop(- |
- |||
| 820 | -! | -
- "Baselines (ref_group) do not have the same number of columns",- |
- |||
| 821 | -! | -
- " in each split. Contact the maintainer."+ } else {
|
|||
| 822 | -! | +||||
| 648 | +9x |
- ) # nocov+ newdisp <- any(vapply(cinfs, disp_ccounts, NA)) |
|||
| 823 | +649 |
- }+ } |
|||
| 824 | -+ | ||||
| 650 | +10x |
-
+ alltls <- lapply(cinfs, top_left) |
|||
| 825 | -+ | ||||
| 651 | +10x |
- # If params are not present do not do the calculation+ newtl <- character() |
|||
| 826 | -421x | +652 | +10x |
- acdf_param <- check_afun_cfun_params(+ if (!are(tabs, "TableRow")) {
|
|
| 827 | -421x | +653 | +10x |
- SplitVector(spl, splvec),+ alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same |
|
| 828 | -421x | +654 | +10x |
- c(".alt_df", ".alt_df_row")
+ if (length(alltls) > 0) {
|
|
| 829 | -+ | ||||
| 655 | +! |
- )+ newtl <- alltls[[1]] |
|||
| 830 | +656 |
-
+ } |
|||
| 831 | +657 |
- # Apply same split for alt_counts_df+ } |
|||
| 832 | -421x | +658 | +10x |
- if (!is.null(alt_df) && any(acdf_param)) {
+ InstantiatedColumnInfo( |
|
| 833 | -17x | +659 | +10x |
- alt_dfpart <- tryCatch(+ treelyt = newctree, |
|
| 834 | -17x | +660 | +10x |
- do_split(spl, alt_df,+ csubs = newexprs, |
|
| 835 | -17x | +661 | +10x |
- spl_context = spl_context+ extras = newexargs, |
|
| 836 | -17x | +662 | +10x |
- )[["datasplit"]],+ cnts = newcounts, |
|
| 837 | -17x | -
- error = function(e) e- |
- |||
| 838 | -- |
- )- |
- |||
| 839 | -+ | 663 | +10x |
-
+ dispcounts = newdisp, |
|
| 840 | -+ | ||||
| 664 | +10x |
- # Removing NA rows - to explore why this happens at all in a split+ countformat = colcount_format(cinfs[[1]]), |
|||
| 841 | -+ | ||||
| 665 | +10x |
- # This would be a fix but it is done in post-processing instead of pre-proc -> xxx+ total_cnt = new_total, |
|||
| 842 | -+ | ||||
| 666 | +10x |
- # x alt_dfpart <- lapply(alt_dfpart, function(data) {
+ topleft = newtl |
|||
| 843 | +667 |
- # x data[!apply(is.na(data), 1, all), ]+ ) |
|||
| 844 | +668 |
- # x })+ } |
|||
| 845 | +669 | ||||
| 846 | +670 |
- # Error localization+ nz_len_els <- function(lst) {
|
|||
| 847 | -17x | +671 | +112x |
- if (is(alt_dfpart, "error")) {
+ if (is(lst, "list")) {
|
|
| 848 | -2x | +672 | +15x |
- stop("Following error encountered in splitting alt_counts_df: ",
+ lst[vapply(lst, function(x) length(x) > 0, NA)] |
|
| 849 | -2x | +673 | +97x |
- alt_dfpart$message,+ } else if (is(lst, "character")) {
|
|
| 850 | -2x | +674 | +82x |
- call. = FALSE+ lst[nzchar(lst)] |
|
| 851 | +675 |
- )+ } else {
|
|||
| 852 | -+ | ||||
| 676 | +15x |
- }+ lst |
|||
| 853 | +677 |
- # Error if split does not have the same values in the alt_df (and order)+ } |
|||
| 854 | +678 |
- # The following breaks if there are different levels (do_split returns empty list)+ } |
|||
| 855 | +679 |
- # or if there are different number of the same levels. Added handling of NAs+ |
|||
| 856 | +680 |
- # in the values of the factor when is all only NAs+ has_one_unq <- function(x) {
|
|||
| 857 | -15x | +681 | +112x |
- is_all_na <- all(is.na(alt_df[[spl_payload(spl)]]))+ length(unique(nz_len_els(x))) <= 1 |
|
| 858 | +682 | - - | -|||
| 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 | +||||
| 683 | +
- end_part <- ""+ |
||||
| 862 | +684 |
-
+ classvec <- function(lst, enforce_one = TRUE) {
|
|||
| 863 | -5x | +685 | +28x |
- if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
+ if (enforce_one) {
|
|
| 864 | -2x | +686 | +28x |
- end_part <- paste0(+ vapply(lst, class, "") |
|
| 865 | -2x | +||||
| 687 | +
- " and following levels: ",+ } else {
|
||||
| 866 | -2x | +||||
| 688 | +! |
- paste_vec(levels(alt_df_spl_vals))+ lapply(lst, class) |
|||
| 867 | +689 |
- )+ } |
|||
| 868 | +690 |
- }+ } |
|||
| 869 | +691 | ||||
| 870 | -5x | +||||
| 692 | +
- if (is_all_na) {
+ chk_cbindable_many <- function(lst) {
|
||||
| 871 | -2x | +||||
| 693 | +
- end_part <- ". Found only NAs in alt_counts_df split"+ ## we actually want is/inherits there but no easy way |
||||
| 872 | +694 |
- }+ ## to figure out what the lowest base class is |
|||
| 873 | +695 |
-
+ ## that I can think of right now, so we do the |
|||
| 874 | -5x | +||||
| 696 | +
- stop(+ ## broken wrong thing instead :( |
||||
| 875 | -5x | -
- "alt_counts_df split variable(s) [", spl_payload(spl),+ | 697 | +17x | +
+ if (are(lst, "TableRow")) {
|
| 876 | -5x | +698 | +2x |
- "] (in split ", as.character(class(spl)),+ if (!has_one_unq(classvec(lst))) {
|
|
| 877 | -5x | +699 | +1x |
- ") does not have the same factor levels of df.\ndf has c(", '"',
+ stop("Cannot cbind different types of TableRow objects together")
|
|
| 878 | -5x | +||||
| 700 | +
- paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ",+ } |
||||
| 879 | -5x | +701 | +1x |
- ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""),+ return(TRUE) |
|
| 880 | -5x | +||||
| 702 | +
- " unique values", end_part+ } |
||||
| 881 | +703 |
- )+ ## if(!are(lst, "VTableTree") |
|||
| 882 | +704 |
- }+ ## stop("Not all elements to be bound are TableTrees or TableRows")
|
|||
| 883 | +705 |
- } else {
+
|
|||
| 884 | -404x | +706 | +15x |
- alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl))+ nrs <- vapply(lst, NROW, 1L) |
|
| 885 | -+ | ||||
| 707 | +15x |
- }+ if (!has_one_unq(nrs)) {
+ |
+ |||
| 708 | +! | +
+ stop("Not all elements to be bound have matching numbers of rows")
|
|||
| 886 | +709 |
-
+ } |
|||
| 887 | +710 | ||||
| 888 | -414x | +711 | +15x |
- innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow)+ tls <- lapply(lst, top_left) |
|
| 889 | -+ | ||||
| 712 | +15x |
- ## do full recursive_applysplit on each part of the split defined by spl+ if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
|
|||
| 890 | -414x | +713 | +2x |
- inner <- unlist(mapply(+ stop( |
|
| 891 | -414x | +714 | +2x |
- function(dfpart, alt_dfpart, nm, label, baselines, splval) {
+ "Elements to be bound have differing top-left content: ", |
|
| 892 | -1203x | +715 | +2x |
- rsplval <- context_df_row(+ paste(which(!duplicated(tls)), collapse = " ") |
|
| 893 | -1203x | +||||
| 716 | +
- split = obj_name(spl),+ ) |
||||
| 894 | -1203x | +||||
| 717 | +
- value = value_names(splval),+ }+ |
+ ||||
| 718 | ++ | + | |||
| 895 | -1203x | +719 | +13x |
- full_parent_df = list(dfpart),+ if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
|
|
| 896 | -1203x | +720 | +1x |
- cinfo = cinfo+ return(TRUE) |
|
| 897 | +721 |
- )+ } |
|||
| 898 | +722 | ||||
| 899 | -+ | ||||
| 723 | +12x |
- ## if(length(rsplval) > 0)+ rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
+ |
+ |||
| 724 | +12x | +
+ nrow = nrs[[1]] |
|||
| 900 | +725 |
- ## rsplval <- setNames(rsplval, obj_name(spl))+ ) |
|||
| 901 | -1203x | +726 | +12x |
- recursive_applysplit(+ rnsok <- apply(rns, 1, has_one_unq) |
|
| 902 | -1203x | +727 | +12x |
- df = dfpart,+ if (!all(rnsok)) {
|
|
| 903 | -1203x | +728 | +1x |
- alt_df = alt_dfpart,+ stop( |
|
| 904 | -1203x | +729 | +1x |
- name = nm,+ "Mismatching, non-empty row names detected in rows ", |
|
| 905 | -1203x | +730 | +1x |
- lvl = innerlev,+ paste(which(!rnsok), collapse = " ") |
|
| 906 | -1203x | +||||
| 731 | +
- splvec = splvec,+ ) |
||||
| 907 | -1203x | +||||
| 732 | +
- cinfo = cinfo,+ } |
||||
| 908 | -1203x | +||||
| 733 | +
- make_lrow = label_kids(spl),+ |
||||
| 909 | -1203x | +734 | +11x |
- parent_cfun = content_fun(spl),+ rws <- lapply(lst, collect_leaves, add.labrows = TRUE) |
|
| 910 | -1203x | +735 | +11x |
- cformat = content_format(spl),+ rwclsmat <- matrix(unlist(lapply(rws, classvec)), |
|
| 911 | -1203x | +736 | +11x |
- cna_str = content_na_str(spl),+ ncol = length(lst) |
|
| 912 | -1203x | +||||
| 737 | +
- partlabel = label,+ ) |
||||
| 913 | -1203x | +||||
| 738 | +
- cindent_mod = content_indent_mod(spl),+ |
||||
| 914 | -1203x | +739 | +11x |
- cvar = content_var(spl),+ rwsok <- apply(rwclsmat, 1, has_one_unq) |
|
| 915 | -1203x | +740 | +11x |
- baselines = baselines,+ if (!all(rwsok)) {
|
|
| 916 | -1203x | +||||
| 741 | +! |
- cextra_args = content_extra_args(spl),+ stop(+ |
+ |||
| 742 | +! | +
+ "Mismatching row classes found for rows: ",+ |
+ |||
| 743 | +! | +
+ paste(which(!rwsok), collapse = " ") |
|||
| 917 | +744 |
- ## splval should still be retaining its name+ )+ |
+ |||
| 745 | ++ |
+ } |
|||
| 918 | -1203x | +746 | +11x |
- spl_context = rbind(spl_context, rsplval)+ TRUE |
|
| 919 | +747 |
- )+ } |
|||
| 920 | +748 |
- },+ |
|||
| 921 | -414x | +||||
| 749 | +
- dfpart = dataspl,+ #' Column-bind two `TableTree` objects |
||||
| 922 | -414x | +||||
| 750 | +
- alt_dfpart = alt_dfpart,+ #' |
||||
| 923 | -414x | +||||
| 751 | +
- label = partlabels,+ #' @param x (`TableTree` or `TableRow`)\cr a table or row object. |
||||
| 924 | -414x | +||||
| 752 | +
- nm = nms,+ #' @param ... one or more further objects of the same class as `x`. |
||||
| 925 | -414x | +||||
| 753 | +
- baselines = newbaselines,+ #' @param sync_count_vis (`logical(1)`)\cr should column count |
||||
| 926 | -414x | +||||
| 754 | +
- splval = splvals,+ #' visibility be synced across the new and existing columns. |
||||
| 927 | -414x | +||||
| 755 | +
- SIMPLIFY = FALSE+ #' Currently defaults to `TRUE` for backwards compatibility but |
||||
| 928 | +756 |
- ))+ #' this may change in future releases. |
|||
| 929 | +757 |
-
+ #' |
|||
| 930 | +758 |
- # Setting the kids section separator if they inherits VTableTree+ #' @inherit rbindl_rtables return |
|||
| 931 | -406x | +||||
| 759 | +
- inner <- .set_kids_section_div(+ #' |
||||
| 932 | -406x | +||||
| 760 | +
- inner,+ #' @examples |
||||
| 933 | -406x | +||||
| 761 | +
- trailing_section_div_char = spl_section_div(spl),+ #' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
|
||||
| 934 | -406x | +||||
| 762 | +
- allowed_class = "VTableTree"+ #' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
|
||||
| 935 | +763 |
- )+ #' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
|
|||
| 936 | +764 |
-
+ #' |
|||
| 937 | +765 |
- ## This is where we need to build the structural tables+ #' t1 <- cbind_rtables(x, y) |
|||
| 938 | +766 |
- ## even if they are invisible because their labels are not+ #' t1 |
|||
| 939 | +767 |
- ## not shown.+ #' |
|||
| 940 | -406x | +||||
| 768 | +
- innertab <- TableTree(+ #' t2 <- cbind_rtables(x, y, z) |
||||
| 941 | -406x | +||||
| 769 | +
- kids = inner,+ #' t2 |
||||
| 942 | -406x | +||||
| 770 | +
- name = obj_name(spl),+ #' |
||||
| 943 | -406x | +||||
| 771 | +
- labelrow = LabelRow(+ #' col_paths_summary(t1) |
||||
| 944 | -406x | +||||
| 772 | +
- label = obj_label(spl),+ #' col_paths_summary(t2) |
||||
| 945 | -406x | +||||
| 773 | +
- vis = isTRUE(vis_label(spl))+ #' |
||||
| 946 | +774 |
- ),+ #' @export |
|||
| 947 | -406x | +||||
| 775 | +
- cinfo = cinfo,+ cbind_rtables <- function(x, ..., sync_count_vis = TRUE) {
|
||||
| 948 | -406x | +776 | +12x |
- iscontent = FALSE,+ lst <- list(...) |
|
| 949 | -406x | +777 | +12x |
- indent_mod = indent_mod(spl),+ newcinfo <- combine_cinfo(x, ..., sync_count_vis = sync_count_vis) |
|
| 950 | -406x | +778 | +10x |
- page_title = ptitle_prefix(spl)+ recurse_cbindl(x, cinfo = newcinfo, .list = lst) |
|
| 951 | +779 |
- )+ } |
|||
| 952 | +780 |
- ## kids = inner- |
- |||
| 953 | -406x | -
- kids <- list(innertab)+ |
|||
| 954 | -406x | +781 | +104x |
- kids+ setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))
|
|
| 955 | +782 |
- }+ |
|||
| 956 | +783 |
- )+ setMethod( |
|||
| 957 | +784 |
-
+ "recurse_cbindl", c( |
|||
| 958 | +785 |
- context_df_row <- function(split = character(),+ x = "VTableNodeInfo", |
|||
| 959 | +786 |
- value = character(),+ cinfo = "NULL" |
|||
| 960 | +787 |
- full_parent_df = list(),+ ), |
|||
| 961 | +788 |
- cinfo = NULL) {
+ function(x, cinfo, .list = NULL) {
|
|||
| 962 | -2755x | +||||
| 789 | +! |
- ret <- data.frame(+ recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list) |
|||
| 963 | -2755x | +||||
| 790 | +
- split = split,+ } |
||||
| 964 | -2755x | +||||
| 791 | +
- value = value,+ ) |
||||
| 965 | -2755x | +||||
| 792 | +
- full_parent_df = I(full_parent_df),+ |
||||
| 966 | +793 |
- # parent_cold_inds = I(parent_col_inds),+ setMethod( |
|||
| 967 | -2755x | +||||
| 794 | +
- stringsAsFactors = FALSE+ "recurse_cbindl", c( |
||||
| 968 | +795 |
- )+ x = "TableTree", |
|||
| 969 | -2755x | +||||
| 796 | +
- if (nrow(ret) > 0) {
+ cinfo = "InstantiatedColumnInfo" |
||||
| 970 | -2742x | +||||
| 797 | +
- ret$all_cols_n <- nrow(full_parent_df[[1]])+ ), |
||||
| 971 | +798 |
- } else {
+ function(x, cinfo, .list = NULL) {
|
|||
| 972 | -13x | +799 | +21x |
- ret$all_cols_n <- integer() ## should this be numeric??? This never happens+ stopifnot(are(.list, "VTableTree")) |
|
| 973 | +800 |
- }+ ## chk_cbindable(x, y) |
|||
| 974 | -+ | ||||
| 801 | +21x |
-
+ xcont <- content_table(x) |
|||
| 975 | -2755x | +802 | +21x |
- if (!is.null(cinfo)) {
+ lstconts <- lapply(.list, content_table) |
|
| 976 | -1514x | +803 | +21x |
- if (nrow(ret) > 0) {
+ lcontnrows <- vapply(lstconts, NROW, 1L) |
|
| 977 | -1505x | +804 | +21x |
- colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
+ unqnrcont <- unique(c(NROW(xcont), lcontnrows)) |
|
| 978 | -5378x | +805 | +21x |
- vals <- eval(e, envir = full_parent_df[[1]])+ if (length(unqnrcont) > 1) {
|
|
| 979 | -5378x | +||||
| 806 | +! |
- if (identical(vals, TRUE)) {
+ stop( |
|||
| 980 | -508x | +||||
| 807 | +! |
- vals <- rep(vals, length.out = nrow(full_parent_df[[1]]))+ "Got differing numbers of content rows [", |
|||
| 981 | -+ | ||||
| 808 | +! |
- }+ paste(unqnrcont, collapse = ", "), |
|||
| 982 | -5378x | +||||
| 809 | +! |
- I(list(vals))+ "]. Unable to cbind these rtables" |
|||
| 983 | +810 |
- }))+ ) |
|||
| 984 | +811 |
- } else {
- |
- |||
| 985 | -9x | -
- colcols <- as.data.frame(rep(list(logical()), ncol(cinfo)))+ } |
|||
| 986 | +812 |
- }+ |
|||
| 987 | -1514x | +813 | +21x |
- names(colcols) <- names(col_exprs(cinfo))+ if (unqnrcont == 0) {
|
|
| 988 | -1514x | +814 | +20x |
- ret <- cbind(ret, colcols)+ cont <- ElementaryTable(cinfo = cinfo) |
|
| 989 | +815 |
- }+ } else {
|
|||
| 990 | -2755x | +816 | +1x |
- ret+ cont <- recurse_cbindl(xcont, |
|
| 991 | -+ | ||||
| 817 | +1x |
- }+ .list = lstconts, |
|||
| 992 | -+ | ||||
| 818 | +1x |
-
+ cinfo = cinfo |
|||
| 993 | +819 |
- recursive_applysplit <- function(df,+ ) |
|||
| 994 | +820 |
- lvl = 0L,+ } |
|||
| 995 | +821 |
- alt_df,+ |
|||
| 996 | -+ | ||||
| 822 | +21x |
- splvec,+ kids <- lapply( |
|||
| 997 | -+ | ||||
| 823 | +21x |
- name,+ seq_along(tree_children(x)), |
|||
| 998 | -+ | ||||
| 824 | +21x |
- # label,+ function(i) {
|
|||
| 999 | -+ | ||||
| 825 | +31x |
- make_lrow = NA,+ recurse_cbindl( |
|||
| 1000 | -+ | ||||
| 826 | +31x |
- partlabel = "",+ x = tree_children(x)[[i]], |
|||
| 1001 | -+ | ||||
| 827 | +31x |
- cinfo,+ cinfo = cinfo, |
|||
| 1002 | -+ | ||||
| 828 | +31x |
- parent_cfun = NULL,+ .list = lapply(.list, function(tt) tree_children(tt)[[i]]) |
|||
| 1003 | +829 |
- cformat = NULL,+ ) |
|||
| 1004 | +830 |
- cna_str = NA_character_,+ } |
|||
| 1005 | +831 |
- cindent_mod = 0L,+ ) |
|||
| 1006 | -+ | ||||
| 832 | +21x |
- cextra_args = list(),+ names(kids) <- names(tree_children(x)) |
|||
| 1007 | -+ | ||||
| 833 | +21x |
- cvar = NULL,+ TableTree( |
|||
| 1008 | -+ | ||||
| 834 | +21x |
- baselines = lapply(+ kids = kids, labelrow = recurse_cbindl(tt_labelrow(x), |
|||
| 1009 | -+ | ||||
| 835 | +21x |
- col_extra_args(cinfo),+ cinfo = cinfo, |
|||
| 1010 | -+ | ||||
| 836 | +21x |
- function(x) x$.ref_full+ .list = lapply(.list, tt_labelrow) |
|||
| 1011 | +837 |
- ),+ ), |
|||
| 1012 | -+ | ||||
| 838 | +21x |
- spl_context = context_df_row(cinfo = cinfo),+ cont = cont, |
|||
| 1013 | -+ | ||||
| 839 | +21x |
- no_outer_tbl = FALSE,+ name = obj_name(x),+ |
+ |||
| 840 | +21x | +
+ lev = tt_level(x),+ |
+ |||
| 841 | +21x | +
+ cinfo = cinfo,+ |
+ |||
| 842 | +21x | +
+ format = obj_format(x) |
|||
| 1014 | +843 |
- parent_sect_split = NA_character_) {
+ ) |
|||
| 1015 | +844 |
- ## pre-existing table was added to the layout+ } |
|||
| 1016 | -1514x | +||||
| 845 | +
- if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
+ ) |
||||
| 1017 | -1x | +||||
| 846 | +
- return(splvec[[1]])+ |
||||
| 1018 | +847 |
- }+ setMethod( |
|||
| 1019 | +848 |
-
+ "recurse_cbindl", c( |
|||
| 1020 | +849 |
- ## the content function is the one from the PREVIOUS+ x = "ElementaryTable", |
|||
| 1021 | +850 |
- ## split, i.e. the one whose children we are now constructing+ cinfo = "InstantiatedColumnInfo" |
|||
| 1022 | +851 |
- ## this is a bit annoying but makes the semantics for+ ), |
|||
| 1023 | +852 |
- ## declaring layouts much more sane.+ function(x, cinfo, .list) {
|
|||
| 1024 | -1513x | +853 | +21x |
- ctab <- .make_ctab(df,+ stopifnot(are(.list, class(x))) |
|
| 1025 | -1513x | +||||
| 854 | +
- lvl = lvl,+ ## chk_cbindable(x,y) |
||||
| 1026 | -1513x | +855 | +21x |
- name = name,+ if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
|
|
| 1027 | -1513x | +856 | +1x |
- label = partlabel,+ col_info(x) <- cinfo |
|
| 1028 | -1513x | +857 | +1x |
- cinfo = cinfo,+ return(x) ## this needs testing... I was right, it did #136 |
|
| 1029 | -1513x | +||||
| 858 | +
- parent_cfun = parent_cfun,+ } |
||||
| 1030 | -1513x | +859 | +20x |
- format = cformat,+ kids <- lapply( |
|
| 1031 | -1513x | +860 | +20x |
- na_str = cna_str,+ seq_along(tree_children(x)), |
|
| 1032 | -1513x | +861 | +20x |
- indent_mod = cindent_mod,+ function(i) {
|
|
| 1033 | -1513x | +862 | +21x |
- cvar = cvar,+ recurse_cbindl( |
|
| 1034 | -1513x | +863 | +21x |
- alt_df = alt_df,+ x = tree_children(x)[[i]], |
|
| 1035 | -1513x | +864 | +21x |
- extra_args = cextra_args,+ cinfo = cinfo, |
|
| 1036 | -1513x | +865 | +21x |
- spl_context = spl_context+ .list = lapply(.list, function(tt) tree_children(tt)[[i]]) |
|
| 1037 | +866 |
- )+ ) |
|||
| 1038 | +867 |
-
+ }+ |
+ |||
| 868 | ++ |
+ ) |
|||
| 1039 | -1512x | +869 | +20x |
- nonroot <- lvl != 0L+ names(kids) <- names(tree_children(x)) |
|
| 1040 | +870 | ||||
| 1041 | -1512x | +871 | +20x |
- if (is.na(make_lrow)) {
+ ElementaryTable( |
|
| 1042 | -1214x | -
- make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE- |
- |||
| 1043 | -+ | 872 | +20x |
- }+ kids = kids, |
|
| 1044 | -+ | ||||
| 873 | +20x |
- ## never print an empty row label for root.+ labelrow = recurse_cbindl(tt_labelrow(x), |
|||
| 1045 | -1512x | +874 | +20x |
- if (make_lrow && partlabel == "" && !nonroot) {
+ .list = lapply(.list, tt_labelrow), |
|
| 1046 | -6x | +875 | +20x |
- make_lrow <- FALSE+ cinfo |
|
| 1047 | +876 |
- }+ ), |
|||
| 1048 | -+ | ||||
| 877 | +20x |
-
+ name = obj_name(x), |
|||
| 1049 | -1512x | +878 | +20x |
- if (length(splvec) == 0L) {
+ lev = tt_level(x), |
|
| 1050 | -79x | +879 | +20x |
- kids <- list()+ cinfo = cinfo, |
|
| 1051 | -79x | +880 | +20x |
- imod <- 0L+ format = obj_format(x), |
|
| 1052 | -79x | +881 | +20x |
- spl <- NULL+ var = obj_avar(x) |
|
| 1053 | +882 |
- } else {
+ ) |
|||
| 1054 | -1433x | +||||
| 883 | +
- spl <- splvec[[1]]+ } |
||||
| 1055 | -1433x | +||||
| 884 | +
- splvec <- splvec[-1]+ ) |
||||
| 1056 | +885 | ||||
| 1057 | +886 |
- ## we pass this everything recursive_applysplit received and+ .combine_rows <- function(x, cinfo = NULL, .list) {
|
|||
| 1058 | -+ | ||||
| 887 | +21x |
- ## it all gets passed around through ... as needed+ stopifnot(are(.list, class(x))) |
|||
| 1059 | +888 |
- ## to the various methods of .make_split_kids+ |
|||
| 1060 | -1433x | +889 | +21x |
- kids <- .make_split_kids(+ avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE)) |
|
| 1061 | -1433x | +890 | +21x |
- spl = spl,+ avars <- avars[!is.na(avars)] |
|
| 1062 | -1433x | +||||
| 891 | +
- df = df,+ |
||||
| 1063 | -1433x | +892 | +21x |
- alt_df = alt_df,+ if (length(unique(avars)) > 1) {
|
|
| 1064 | -1433x | +||||
| 893 | +! |
- lvl = lvl,+ stop("Got rows that don't analyze the same variable")
|
|||
| 1065 | -1433x | +||||
| 894 | +
- splvec = splvec,+ } |
||||
| 1066 | -1433x | +||||
| 895 | +
- name = name,+ |
||||
| 1067 | -1433x | +896 | +21x |
- make_lrow = make_lrow,+ xlst <- c(list(x), .list) |
|
| 1068 | -1433x | +||||
| 897 | +
- partlabel = partlabel,+ |
||||
| 1069 | -1433x | +898 | +21x |
- cinfo = cinfo,+ ncols <- vapply(xlst, ncol, 1L) |
|
| 1070 | -1433x | +899 | +21x |
- parent_cfun = parent_cfun,+ totcols <- sum(ncols) |
|
| 1071 | -1433x | +900 | +21x |
- cformat = cformat,+ cumncols <- cumsum(ncols) |
|
| 1072 | -1433x | +901 | +21x |
- cindent_mod = cindent_mod,+ strtncols <- c(0L, head(cumncols, -1)) + 1L |
|
| 1073 | -1433x | +902 | +21x |
- cextra_args = cextra_args, cvar = cvar,+ vals <- vector("list", totcols)
|
|
| 1074 | -1433x | +903 | +21x |
- baselines = baselines,+ cspans <- integer(totcols) |
|
| 1075 | -1433x | +||||
| 904 | +
- spl_context = spl_context,+ ## vals[1:ncol(x)] <- row_values(x) |
||||
| 1076 | -1433x | +||||
| 905 | +
- have_controws = nrow(ctab) > 0+ ## cpans[1:ncol(x)] <- row_cspans(x) |
||||
| 1077 | +906 |
- )+ |
|||
| 1078 | -1410x | +907 | +21x |
- imod <- 0L+ for (i in seq_along(xlst)) {
|
|
| 1079 | -+ | ||||
| 908 | +43x |
- } ## end length(splvec)+ strt <- strtncols[i]+ |
+ |||
| 909 | +43x | +
+ end <- cumncols[i] |
|||
| 1080 | +910 |
-
+ ## full vars are here for debugging purposes |
|||
| 1081 | -1489x | +911 | +43x |
- if (is.na(make_lrow)) {
+ fullvy <- vy <- row_cells(xlst[[i]]) # nolint |
|
| 1082 | -! | +||||
| 912 | +43x |
- make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE+ fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint |
|||
| 1083 | +913 |
- }+ |
|||
| 1084 | +914 |
- ## never print an empty row label for root.+ if ( |
|||
| 1085 | -1489x | +915 | +43x |
- if (make_lrow && partlabel == "" && !nonroot) {
+ i > 1 && |
|
| 1086 | -! | +||||
| 916 | +43x |
- make_lrow <- FALSE+ identical(rawvalues(vy[[1]]), rawvalues(lastval)) && |
|||
| 1087 | +917 |
- }+ ## cspy[1] == lastspn && |
|||
| 1088 | -+ | ||||
| 918 | +43x |
-
+ lastspn > 1 |
|||
| 1089 | +919 |
- ## this is only true when called from build_table and the first split+ ) {
|
|||
| 1090 | -+ | ||||
| 920 | +! |
- ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split.+ vy <- vy[-1] |
|||
| 1091 | -+ | ||||
| 921 | +! |
- ## in that case we would be "double creating" the structural+ cspans[strt - 1L] <- lastspn + cspy[1]+ |
+ |||
| 922 | +! | +
+ cspy <- cspy[-1]+ |
+ |||
| 923 | +! | +
+ strt <- strt + 1L |
|||
| 1092 | +924 |
- ## subtable+ } |
|||
| 1093 | -1489x | +925 | +43x |
- if (no_outer_tbl) {
+ if (length(vy) > 0) {
|
|
| 1094 | -269x | +926 | +43x |
- ret <- kids[[1]]+ vals[strt:end] <- vy |
|
| 1095 | -269x | +927 | +43x |
- indent_mod(ret) <- indent_mod(spl)+ cspans[strt:end] <- cspy |
|
| 1096 | -1220x | +928 | +43x |
- } else if (nrow(ctab) > 0L || length(kids) > 0L) {
+ lastval <- vy[[length(vy)]] |
|
| 1097 | -+ | ||||
| 929 | +43x |
- ## previously we checked if the child had an identical label+ lastspn <- cspy[[length(cspy)]] |
|||
| 1098 | +930 |
- ## but I don't think thats needed anymore.+ } else {
|
|||
| 1099 | -1220x | +||||
| 931 | +
- tlabel <- partlabel+ ## lastval stays the same |
||||
| 1100 | -1220x | +||||
| 932 | +! |
- ret <- TableTree(+ lastspn <- cspans[strtncols[i] - 1] ## already updated |
|||
| 1101 | -1220x | +||||
| 933 | +
- cont = ctab,+ } |
||||
| 1102 | -1220x | +||||
| 934 | +
- kids = kids,+ } |
||||
| 1103 | -1220x | +||||
| 935 | +
- name = name,+ |
||||
| 1104 | -1220x | +||||
| 936 | +
- label = tlabel, # partlabel,+ ## Could be DataRow or ContentRow |
||||
| 1105 | -1220x | +||||
| 937 | +
- lev = lvl,+ ## This is ok because LabelRow is special cased |
||||
| 1106 | -1220x | +938 | +21x |
- iscontent = FALSE,+ constr_fun <- get(class(x), mode = "function") |
|
| 1107 | -1220x | +939 | +21x |
- labelrow = LabelRow(+ constr_fun( |
|
| 1108 | -1220x | +940 | +21x |
- lev = lvl,+ vals = vals, |
|
| 1109 | -1220x | +941 | +21x |
- label = tlabel,+ cspan = cspans, |
|
| 1110 | -1220x | +942 | +21x |
- cinfo = cinfo,+ cinfo = cinfo, |
|
| 1111 | -1220x | +943 | +21x |
- vis = make_lrow+ var = obj_avar(x), |
|
| 1112 | -+ | ||||
| 944 | +21x |
- ),+ format = obj_format(x), |
|||
| 1113 | -1220x | +945 | +21x |
- cinfo = cinfo,+ name = obj_name(x), |
|
| 1114 | -1220x | +946 | +21x |
- indent_mod = imod+ label = obj_label(x) |
|
| 1115 | +947 |
- )+ ) |
|||
| 1116 | +948 |
- } else {
- |
- |||
| 1117 | -! | -
- ret <- NULL+ } |
|||
| 1118 | +949 |
- }+ |
|||
| 1119 | +950 |
-
+ setMethod( |
|||
| 1120 | +951 |
- ## if(!is.null(spl) && !is.na(spl_section_sep(spl)))+ "recurse_cbindl", c( |
|||
| 1121 | +952 |
- ## ret <- apply_kids_section_sep(ret, spl_section_sep(spl))+ "TableRow", |
|||
| 1122 | +953 |
- ## ## message(sprintf("indent modifier: %d", indentmod))
+ "InstantiatedColumnInfo" |
|||
| 1123 | +954 |
- ## if(!is.null(ret))+ ), |
|||
| 1124 | +955 |
- ## indent_mod(ret) = indentmod+ function(x, cinfo = NULL, .list) {
|
|||
| 1125 | -1489x | +956 | +21x |
- ret+ .combine_rows(x, cinfo, .list) |
|
| 1126 | +957 |
- }+ } |
|||
| 1127 | +958 |
-
+ ) |
|||
| 1128 | +959 |
- #' Create a table from a layout and data+ |
|||
| 1129 | +960 |
- #'+ setMethod( |
|||
| 1130 | +961 |
- #' Layouts are used to describe a table pre-data. `build_table` is used to create a table+ "recurse_cbindl", c( |
|||
| 1131 | +962 |
- #' using a layout and a dataset.+ x = "LabelRow", |
|||
| 1132 | +963 |
- #'+ cinfo = "InstantiatedColumnInfo" |
|||
| 1133 | +964 |
- #' @inheritParams gen_args+ ), |
|||
| 1134 | +965 |
- #' @inheritParams lyt_args+ function(x, cinfo = NULL, .list) {
|
|||
| 1135 | -+ | ||||
| 966 | +41x |
- #' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
+ col_info(x) <- cinfo |
|||
| 1136 | -+ | ||||
| 967 | +41x |
- #' which override those calculated automatically during tabulation. Must specify "counts" for *all*+ x |
|||
| 1137 | +968 |
- #' resulting columns if non-`NULL`. `NA` elements will be replaced with the automatically calculated counts.+ } |
|||
| 1138 | +969 |
- #' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`.+ ) |
|||
| 1139 | +970 |
- #' @param ... ignored.+ |
|||
| 1140 | +971 |
- #'+ ## we don't care about the following discrepencies: |
|||
| 1141 | +972 |
- #' @details+ ## - ci2 having NA counts when ci1 doesn't |
|||
| 1142 | +973 |
- #' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting+ ## - mismatching display_ccounts values |
|||
| 1143 | +974 |
- #' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and+ ## - mismatching colcount formats |
|||
| 1144 | +975 |
- #' counting the observations in each resulting subset.+ ## |
|||
| 1145 | +976 |
- #'+ |
|||
| 1146 | +977 |
- #' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have+ # chk_compat_cinfos <- function(ci1, ci2) {
|
|||
| 1147 | +978 |
- #' been calculated based on `df` and simply re-used for the count calculation.+ chk_compat_cinfos <- function(tt1, tt2) {
|
|||
| 1148 | -+ | ||||
| 979 | +41x |
- #'+ nc1 <- ncol(tt1) |
|||
| 1149 | -+ | ||||
| 980 | +41x |
- #' @note+ nc2 <- ncol(tt2) |
|||
| 1150 | -+ | ||||
| 981 | +41x |
- #' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called+ if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
|
|||
| 1151 | -+ | ||||
| 982 | +1x |
- #' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation+ stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
|
|||
| 1152 | +983 |
- #' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the+ } |
|||
| 1153 | -+ | ||||
| 984 | +40x |
- #' only way to ensure overridden counts are fully respected.+ if (no_colinfo(tt1) || no_colinfo(tt2)) {
|
|||
| 1154 | -+ | ||||
| 985 | +10x |
- #'+ return(TRUE) |
|||
| 1155 | +986 |
- #' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations+ } |
|||
| 1156 | -+ | ||||
| 987 | +30x |
- #' declared in `lyt` to the data `df`.+ ci1 <- col_info(tt1) |
|||
| 1157 | -+ | ||||
| 988 | +30x |
- #'+ ci2 <- col_info(tt2) |
|||
| 1158 | +989 |
- #' @examples+ ## this will enforce same length and |
|||
| 1159 | +990 |
- #' lyt <- basic_table() %>%+ ## same names, in addition to same |
|||
| 1160 | +991 |
- #' split_cols_by("Species") %>%
+ ## expressions so we dont need |
|||
| 1161 | +992 |
- #' analyze("Sepal.Length", afun = function(x) {
+ ## to check those separateley |
|||
| 1162 | -+ | ||||
| 993 | +30x |
- #' list(+ if (!identical(col_exprs(ci1), col_exprs(ci2))) {
|
|||
| 1163 | -+ | ||||
| 994 | +! |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ stop("Column structures not compatible: subset expression lists not identical")
|
|||
| 1164 | +995 |
- #' "range" = diff(range(x))+ } |
|||
| 1165 | +996 |
- #' )+ |
|||
| 1166 | -+ | ||||
| 997 | +30x |
- #' })+ if (any(!is.na(col_counts(ci2))) && |
|||
| 1167 | -+ | ||||
| 998 | +30x |
- #' lyt+ !identical( |
|||
| 1168 | -+ | ||||
| 999 | +30x |
- #'+ col_counts(ci1), |
|||
| 1169 | -+ | ||||
| 1000 | +30x |
- #' tbl <- build_table(lyt, iris)+ col_counts(ci2) |
|||
| 1170 | +1001 |
- #' tbl+ )) {
|
|||
| 1171 | -+ | ||||
| 1002 | +! |
- #'+ stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
|
|||
| 1172 | +1003 |
- #' # analyze multiple variables+ } |
|||
| 1173 | +1004 |
- #' lyt2 <- basic_table() %>%+ |
|||
| 1174 | -+ | ||||
| 1005 | +30x |
- #' split_cols_by("Species") %>%
+ if (any(sapply( |
|||
| 1175 | -+ | ||||
| 1006 | +30x |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
+ col_extra_args(ci2), |
|||
| 1176 | -+ | ||||
| 1007 | +30x |
- #' list(+ function(x) length(x) > 0 |
|||
| 1177 | +1008 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ )) && |
|||
| 1178 | -+ | ||||
| 1009 | +30x |
- #' "range" = diff(range(x))+ !identical( |
|||
| 1179 | -+ | ||||
| 1010 | +30x |
- #' )+ col_extra_args(ci1), |
|||
| 1180 | -+ | ||||
| 1011 | +30x |
- #' })+ col_extra_args(ci2) |
|||
| 1181 | +1012 |
- #'+ )) {
|
|||
| 1182 | -+ | ||||
| 1013 | +! |
- #' tbl2 <- build_table(lyt2, iris)+ stop( |
|||
| 1183 | -+ | ||||
| 1014 | +! |
- #' tbl2+ "Column structures not compatible: 2nd column structure has ", |
|||
| 1184 | -+ | ||||
| 1015 | +! |
- #'+ "non-matching, non-null extra args" |
|||
| 1185 | +1016 |
- #' # an example more relevant for clinical trials with column counts+ ) |
|||
| 1186 | +1017 |
- #' lyt3 <- basic_table(show_colcounts = TRUE) %>%+ } |
|||
| 1187 | +1018 |
- #' split_cols_by("ARM") %>%
+
|
|||
| 1188 | -+ | ||||
| 1019 | +30x |
- #' analyze("AGE", afun = function(x) {
+ if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
|
|||
| 1189 | -+ | ||||
| 1020 | +1x |
- #' setNames(as.list(fivenum(x)), c(+ stop( |
|||
| 1190 | -+ | ||||
| 1021 | +1x |
- #' "minimum", "lower-hinge", "median",+ "Top-left materials not compatible: Got non-empty, non-matching ", |
|||
| 1191 | -+ | ||||
| 1022 | +1x |
- #' "upper-hinge", "maximum"+ "top-left materials. Clear them using top_left(x)<-character() ", |
|||
| 1192 | -+ | ||||
| 1023 | +1x |
- #' ))+ "before binding to force compatibility." |
|||
| 1193 | +1024 |
- #' })+ ) |
|||
| 1194 | +1025 |
- #'+ } |
|||
| 1195 | -+ | ||||
| 1026 | +29x |
- #' tbl3 <- build_table(lyt3, DM)+ TRUE |
|||
| 1196 | +1027 |
- #' tbl3+ } |
|||
| 1197 | +1028 |
- #'+ |
|||
| 1198 | +1029 |
- #' tbl4 <- build_table(lyt3, subset(DM, AGE > 40))+ |
|||
| 1199 | +1030 |
- #' tbl4+ #' Insert `rrow`s at (before) a specific location |
|||
| 1200 | +1031 |
#' |
|||
| 1201 | +1032 |
- #' # with column counts calculated based on different data+ #' `r lifecycle::badge("deprecated")`
|
|||
| 1202 | +1033 |
- #' miniDM <- DM[sample(1:NROW(DM), 100), ]+ #' |
|||
| 1203 | +1034 |
- #' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM)+ #' This function is deprecated and will be removed in a future release of `rtables`. Please use |
|||
| 1204 | +1035 |
- #' tbl5+ #' [insert_row_at_path()] or [label_at_path()] instead. |
|||
| 1205 | +1036 |
#' |
|||
| 1206 | +1037 |
- #' tbl6 <- build_table(lyt3, DM, col_counts = 1:3)+ #' @param tbl (`VTableTree`)\cr a `rtable` object. |
|||
| 1207 | +1038 |
- #' tbl6+ #' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`. |
|||
| 1208 | +1039 |
- #'+ #' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1). |
|||
| 1209 | +1040 |
- #' @author Gabriel Becker+ #' @param ascontent (`flag`)\cr currently ignored. |
|||
| 1210 | +1041 |
- #' @export+ #' |
|||
| 1211 | +1042 |
- build_table <- function(lyt, df,+ #' @return A `TableTree` of the same specific class as `tbl`. |
|||
| 1212 | +1043 |
- alt_counts_df = NULL,+ #' |
|||
| 1213 | +1044 |
- col_counts = NULL,+ #' @note |
|||
| 1214 | +1045 |
- col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df),+ #' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do |
|||
| 1215 | +1046 |
- topleft = NULL,+ #' not already contain a label row when there is a non-trivial nested row structure in `tbl`. |
|||
| 1216 | +1047 |
- hsep = default_hsep(),+ #' |
|||
| 1217 | +1048 |
- ...) {
- |
- |||
| 1218 | -320x | -
- if (!is(lyt, "PreDataTableLayouts")) {
- |
- |||
| 1219 | -! | -
- stop(+ #' @examples |
|||
| 1220 | -! | +||||
| 1049 | +
- "lyt must be a PreDataTableLayouts object. Got object of class ",+ #' o <- options(warn = 0) |
||||
| 1221 | -! | +||||
| 1050 | +
- class(lyt)+ #' lyt <- basic_table() %>% |
||||
| 1222 | +1051 |
- )+ #' split_cols_by("Species") %>%
|
|||
| 1223 | +1052 |
- }+ #' analyze("Sepal.Length")
|
|||
| 1224 | +1053 |
-
+ #' |
|||
| 1225 | +1054 |
- ## if no columns are defined (e.g. because lyt is NULL)+ #' tbl <- build_table(lyt, iris) |
|||
| 1226 | +1055 |
- ## add a single overall column as the "most basic"+ #' |
|||
| 1227 | +1056 |
- ## table column structure that makes sense+ #' insert_rrow(tbl, rrow("Hello World"))
|
|||
| 1228 | -320x | +||||
| 1057 | +
- clyt <- clayout(lyt)+ #' insert_rrow(tbl, rrow("Hello World"), at = 2)
|
||||
| 1229 | -320x | +||||
| 1058 | +
- if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
+ #' |
||||
| 1230 | -93x | +||||
| 1059 | +
- clyt[[1]] <- add_overall_col(clyt[[1]], "")+ #' lyt2 <- basic_table() %>% |
||||
| 1231 | -93x | +||||
| 1060 | +
- clayout(lyt) <- clyt+ #' split_cols_by("Species") %>%
|
||||
| 1232 | +1061 |
- }+ #' split_rows_by("Species") %>%
|
|||
| 1233 | +1062 |
-
+ #' analyze("Sepal.Length")
|
|||
| 1234 | +1063 |
- ## do checks and defensive programming now that we have the data+ #' |
|||
| 1235 | -320x | +||||
| 1064 | +
- lyt <- fix_dyncuts(lyt, df)+ #' tbl2 <- build_table(lyt2, iris) |
||||
| 1236 | -320x | +||||
| 1065 | +
- lyt <- set_def_child_ord(lyt, df)+ #' |
||||
| 1237 | -319x | +||||
| 1066 | +
- lyt <- fix_analyze_vis(lyt)+ #' insert_rrow(tbl2, rrow("Hello World"))
|
||||
| 1238 | -319x | +||||
| 1067 | +
- df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts))+ #' insert_rrow(tbl2, rrow("Hello World"), at = 2)
|
||||
| 1239 | -310x | +||||
| 1068 | +
- alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
+ #' insert_rrow(tbl2, rrow("Hello World"), at = 4)
|
||||
| 1240 | -310x | +||||
| 1069 | +
- if (any(alt_params) && is.null(alt_counts_df)) {
+ #' |
||||
| 1241 | -2x | +||||
| 1070 | +
- stop(+ #' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
|
||||
| 1242 | -2x | +||||
| 1071 | +
- "Layout contains afun/cfun functions that have optional parameters ",+ #' |
||||
| 1243 | -2x | +||||
| 1072 | +
- ".alt_df and/or .alt_df_row, but no alt_count_df was provided in ",+ #' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
|
||||
| 1244 | -2x | +||||
| 1073 | +
- "build_table()."+ #' |
||||
| 1245 | +1074 |
- )+ #' options(o) |
|||
| 1246 | +1075 |
- }+ #' |
|||
| 1247 | +1076 |
-
+ #' @export |
|||
| 1248 | -308x | +||||
| 1077 | +
- rtpos <- TreePos()+ insert_rrow <- function(tbl, rrow, at = 1, |
||||
| 1249 | -308x | +||||
| 1078 | +
- cinfo <- create_colinfo(lyt, df, rtpos,+ ascontent = FALSE) {
|
||||
| 1250 | -308x | +1079 | +9x |
- counts = col_counts,+ lifecycle::deprecate_warn( |
|
| 1251 | -308x | +1080 | +9x |
- alt_counts_df = alt_counts_df,+ when = "0.4.0", |
|
| 1252 | -308x | +1081 | +9x |
- total = col_total,+ what = "insert_rrow()", |
|
| 1253 | -308x | +1082 | +9x |
- topleft+ with = I("insert_row_at_path() or label_at_path()")
|
|
| 1254 | +1083 |
) |
|||
| 1255 | -300x | -
- if (!is.null(col_counts)) {
- |
- |||
| 1256 | -1x | -
- disp_ccounts(cinfo) <- TRUE- |
- |||
| 1257 | -+ | 1084 | +9x |
- }+ stopifnot( |
|
| 1258 | -300x | +1085 | +9x |
- rlyt <- rlayout(lyt)+ is(tbl, "VTableTree"), |
|
| 1259 | -300x | +1086 | +9x |
- rtspl <- root_spl(rlyt)+ is(rrow, "TableRow"), |
|
| 1260 | -300x | +1087 | +9x |
- ctab <- .make_ctab(df, 0L,+ at >= 1 && at <= nrow(tbl) + 1 |
|
| 1261 | -300x | +||||
| 1088 | +
- alt_df = NULL,+ ) |
||||
| 1262 | -300x | +1089 | +9x |
- name = "root",+ chk_compat_cinfos(tbl, rrow) |
|
| 1263 | -300x | +1090 | +8x |
- label = "",+ if (no_colinfo(rrow)) {
|
|
| 1264 | -300x | +1091 | +8x |
- cinfo = cinfo, ## cexprs, ctree,+ col_info(rrow) <- col_info(tbl) |
|
| 1265 | -300x | +||||
| 1092 | +
- parent_cfun = content_fun(rtspl),+ } |
||||
| 1266 | -300x | +||||
| 1093 | +
- format = content_format(rtspl),+ |
||||
| 1267 | -300x | +1094 | +8x |
- na_str = content_na_str(rtspl),+ if (at == 1) {
|
|
| 1268 | -300x | +1095 | +4x |
- indent_mod = 0L,+ return(rbindl_rtables(list(rrow, tbl))) |
|
| 1269 | -300x | +1096 | +4x |
- cvar = content_var(rtspl),+ } else if (at == nrow(tbl) + 1) {
|
|
| 1270 | -300x | +1097 | +1x |
- extra_args = content_extra_args(rtspl)+ return(rbind2(tbl, rrow)) |
|
| 1271 | +1098 |
- )+ } |
|||
| 1272 | +1099 | ||||
| 1273 | -300x | +1100 | +3x |
- kids <- lapply(seq_along(rlyt), function(i) {
+ ret <- recurse_insert(tbl, rrow, |
|
| 1274 | -325x | +1101 | +3x |
- splvec <- rlyt[[i]]+ at = at, |
|
| 1275 | -325x | +1102 | +3x |
- if (length(splvec) == 0) {
+ pos = 0, |
|
| 1276 | -14x | +1103 | +3x |
- return(NULL)+ ascontent = ascontent |
|
| 1277 | +1104 |
- }+ ) |
|||
| 1278 | -311x | +1105 | +3x |
- firstspl <- splvec[[1]]+ ret |
|
| 1279 | -311x | +||||
| 1106 | +
- nm <- obj_name(firstspl)+ } |
||||
| 1280 | +1107 |
- ## XXX unused, probably shouldn't be?+ |
|||
| 1281 | +1108 |
- ## this seems to be covered by grabbing the partlabel+ .insert_helper <- function(tt, row, at, pos, |
|||
| 1282 | +1109 |
- ## TODO confirm this+ ascontent = FALSE) {
|
|||
| 1283 | -+ | ||||
| 1110 | +9x |
- ## lab <- obj_label(firstspl)+ islab <- is(row, "LabelRow") |
|||
| 1284 | -311x | +1111 | +9x |
- recursive_applysplit(+ kids <- tree_children(tt) |
|
| 1285 | -311x | +1112 | +9x |
- df = df, lvl = 0L,+ numkids <- length(kids) |
|
| 1286 | -311x | +1113 | +9x |
- alt_df = alt_counts_df,+ kidnrs <- sapply(kids, nrow) |
|
| 1287 | -311x | +1114 | +9x |
- name = nm,+ cumpos <- pos + cumsum(kidnrs) |
|
| 1288 | -311x | +1115 | +9x |
- splvec = splvec,+ contnr <- if (is(tt, "TableTree")) {
|
|
| 1289 | -311x | +1116 | +6x |
- cinfo = cinfo,+ nrow(content_table(tt)) |
|
| 1290 | +1117 |
- ## XXX are these ALWAYS right?+ } else {
|
|||
| 1291 | -311x | +1118 | +3x |
- make_lrow = label_kids(firstspl),+ 0 |
|
| 1292 | -311x | +||||
| 1119 | +
- parent_cfun = NULL,+ } |
||||
| 1293 | -311x | +1120 | +9x |
- cformat = content_format(firstspl),+ contnr <- contnr + as.numeric(labelrow_visible(tt)) |
|
| 1294 | -311x | +||||
| 1121 | +
- cna_str = content_na_str(firstspl),+ |
||||
| 1295 | -311x | +1122 | +9x |
- cvar = content_var(firstspl),+ totnr <- nrow(tt) |
|
| 1296 | -311x | +1123 | +9x |
- cextra_args = content_extra_args(firstspl),+ endpos <- pos + totnr |
|
| 1297 | -311x | +1124 | +9x |
- spl_context = context_df_row(+ atend <- !islab && endpos == at - 1 |
|
| 1298 | -311x | +1125 | +9x |
- split = "root", value = "root",+ if (at == pos + 1 && islab) {
|
|
| 1299 | -311x | +1126 | +2x |
- full_parent_df = list(df),+ if (labelrow_visible(tt)) {
|
|
| 1300 | -311x | +||||
| 1127 | +! |
- cinfo = cinfo+ stop("Inserting a label row at a position that already has a label row is not currently supported")
|
|||
| 1301 | +1128 |
- ),+ }+ |
+ |||
| 1129 | +2x | +
+ tt_labelrow(tt) <- row+ |
+ |||
| 1130 | +2x | +
+ return(tt) |
|||
| 1302 | +1131 |
- ## we DO want the 'outer table' if the first+ } |
|||
| 1303 | +1132 |
- ## one is a multi-analyze+ |
|||
| 1304 | -311x | +1133 | +7x |
- no_outer_tbl = !is(firstspl, "AnalyzeMultiVars")+ if (numkids == 0) {
|
|
| 1305 | -+ | ||||
| 1134 | +! |
- )+ kids <- list(row) |
|||
| 1306 | -+ | ||||
| 1135 | +7x |
- })+ } else if (atend) {
|
|||
| 1307 | -284x | +1136 | +2x |
- kids <- kids[!sapply(kids, is.null)]+ if (are(kids, "TableRow")) {
|
|
| 1308 | -270x | +1137 | +1x |
- if (length(kids) > 0) names(kids) <- sapply(kids, obj_name)+ kids <- c(kids, list(row)) |
|
| 1309 | +1138 |
-
+ } else {
|
|||
| 1310 | -+ | ||||
| 1139 | +1x |
- # top level divisor+ kids[[numkids]] <- recurse_insert( |
|||
| 1311 | -284x | +1140 | +1x |
- if (!is.na(top_level_section_div(lyt))) {
+ kids[[numkids]], |
|
| 1312 | -2x | +1141 | +1x |
- kids <- lapply(kids, function(first_level_kids) {
+ row = row, |
|
| 1313 | -4x | +1142 | +1x |
- trailing_section_div(first_level_kids) <- top_level_section_div(lyt)+ at = at, |
|
| 1314 | -4x | +1143 | +1x |
- first_level_kids+ pos = pos + contnr + sum(kidnrs[-numkids]), |
|
| 1315 | -+ | ||||
| 1144 | +1x |
- })+ ascontent = ascontent |
|||
| 1316 | +1145 |
- }+ ) |
|||
| 1317 | +1146 |
-
+ } |
|||
| 1318 | -284x | +||||
| 1147 | +
- if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
+ } else { # have >0 kids
|
||||
| 1319 | -239x | +1148 | +5x |
- tab <- kids[[1]]+ kidnrs <- sapply(kids, nrow) |
|
| 1320 | -239x | +1149 | +5x |
- main_title(tab) <- main_title(lyt)+ cumpos <- pos + cumsum(kidnrs) |
|
| 1321 | -239x | +||||
| 1150 | +
- subtitles(tab) <- subtitles(lyt)+ |
||||
| 1322 | -239x | +||||
| 1151 | +
- main_footer(tab) <- main_footer(lyt)+ ## data rows go in the end of the |
||||
| 1323 | -239x | +||||
| 1152 | +
- prov_footer(tab) <- prov_footer(lyt)+ ## preceding subtable (if applicable) |
||||
| 1324 | -239x | +||||
| 1153 | +
- header_section_div(tab) <- header_section_div(lyt)+ ## label rows go in the beginning of |
||||
| 1325 | +1154 |
- } else {
+ ## one at at |
|||
| 1326 | -45x | +1155 | +5x |
- tab <- TableTree(+ ind <- min( |
|
| 1327 | -45x | +1156 | +5x |
- cont = ctab,+ which((cumpos + !islab) >= at), |
|
| 1328 | -45x | +1157 | +5x |
- kids = kids,+ numkids |
|
| 1329 | -45x | +||||
| 1158 | +
- lev = 0L,+ ) |
||||
| 1330 | -45x | +1159 | +5x |
- name = "root",+ thekid <- kids[[ind]] |
|
| 1331 | -45x | +||||
| 1160 | +
- label = "",+ |
||||
| 1332 | -45x | +1161 | +5x |
- iscontent = FALSE,+ if (is(thekid, "TableRow")) {
|
|
| 1333 | -45x | +||||
| 1162 | +! |
- cinfo = cinfo,+ tt_level(row) <- tt_level(thekid) |
|||
| 1334 | -45x | +||||
| 1163 | +! |
- format = obj_format(rtspl),+ if (ind == 1) {
|
|||
| 1335 | -45x | +||||
| 1164 | +! |
- na_str = obj_na_str(rtspl),+ bef <- integer() |
|||
| 1336 | -45x | +||||
| 1165 | +! |
- title = main_title(lyt),+ aft <- 1:numkids |
|||
| 1337 | -45x | +||||
| 1166 | +! |
- subtitles = subtitles(lyt),+ } else if (ind == numkids) {
|
|||
| 1338 | -45x | +||||
| 1167 | +! |
- main_footer = main_footer(lyt),+ bef <- 1:(ind - 1) |
|||
| 1339 | -45x | +||||
| 1168 | +! |
- prov_footer = prov_footer(lyt),+ aft <- ind |
|||
| 1340 | -45x | +||||
| 1169 | +
- header_section_div = header_section_div(lyt)+ } else {
|
||||
| 1341 | -+ | ||||
| 1170 | +! |
- )+ bef <- 1:ind |
|||
| 1342 | -+ | ||||
| 1171 | +! |
- }+ aft <- (ind + 1):numkids |
|||
| 1343 | +1172 |
-
+ } |
|||
| 1344 | -+ | ||||
| 1173 | +! |
- ## This seems to be unneeded, not clear what 'top_left' check it refers to+ kids <- c( |
|||
| 1345 | -+ | ||||
| 1174 | +! |
- ## but both top_left taller than column headers and very long topleft are now+ kids[bef], list(row), |
|||
| 1346 | -+ | ||||
| 1175 | +! |
- ## allowed, so this is just wasted computation.+ kids[aft] |
|||
| 1347 | +1176 |
-
+ ) |
|||
| 1348 | +1177 |
- ## ## this is where the top_left check lives right now. refactor later maybe+ } else { # kid is not a table row
+ |
+ |||
| 1178 | +5x | +
+ newpos <- if (ind == 1) {
+ |
+ |||
| 1179 | +4x | +
+ pos + contnr |
|||
| 1349 | +1180 |
- ## ## but now just call it so the error gets thrown when I want it to+ } else {
+ |
+ |||
| 1181 | +1x | +
+ cumpos[ind - 1] |
|||
| 1350 | +1182 |
- ## unused <- matrix_form(tab)+ } |
|||
| 1351 | -284x | +||||
| 1183 | +
- tab <- update_ref_indexing(tab)+ |
||||
| 1352 | -284x | +1184 | +5x |
- horizontal_sep(tab) <- hsep+ kids[[ind]] <- recurse_insert(thekid, |
|
| 1353 | -284x | +1185 | +5x |
- if (table_inset(lyt) > 0) {
+ row, |
|
| 1354 | -1x | +1186 | +5x |
- table_inset(tab) <- table_inset(lyt)+ at, |
|
| 1355 | -+ | ||||
| 1187 | +5x |
- }+ pos = newpos, |
|||
| 1356 | -284x | +1188 | +5x |
- tab+ ascontent = ascontent |
|
| 1357 | +1189 |
- }+ ) |
|||
| 1358 | +1190 |
-
+ } # end kid is not table row |
|||
| 1359 | +1191 |
- # fix_split_vars ----+ } |
|||
| 1360 | -+ | ||||
| 1192 | +7x |
- # These checks guarantee that all the split variables are present in the data.+ tree_children(tt) <- kids |
|||
| 1361 | -+ | ||||
| 1193 | +7x |
- # No generic is needed because it is not dependent on the input layout but+ tt |
|||
| 1362 | +1194 |
- # on the df.+ } |
|||
| 1363 | +1195 |
- fix_one_split_var <- function(spl, df, char_ok = TRUE) {
- |
- |||
| 1364 | -525x | -
- var <- spl_payload(spl)+ |
|||
| 1365 | -525x | +1196 | +9x |
- if (!(var %in% names(df))) {
+ setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))
|
|
| 1366 | -2x | +||||
| 1197 | +
- stop("Split variable [", var, "] not found in data being tabulated.")
+
|
||||
| 1367 | +1198 |
- }+ setMethod( |
|||
| 1368 | -523x | +||||
| 1199 | +
- varvec <- df[[var]]+ "recurse_insert", "TableTree", |
||||
| 1369 | -523x | +||||
| 1200 | +
- if (!is(varvec, "character") && !is.factor(varvec)) {
+ function(tt, row, at, pos, ascontent = FALSE) {
|
||||
| 1370 | -1x | +1201 | +6x |
- message(sprintf(+ ctab <- content_table(tt) |
|
| 1371 | -1x | +1202 | +6x |
- paste(+ contnr <- nrow(ctab) |
|
| 1372 | -1x | +1203 | +6x |
- "Split var [%s] was not character or factor.",+ contpos <- pos + contnr |
|
| 1373 | -1x | +1204 | +6x |
- "Converting to factor"+ islab <- is(row, "LabelRow") |
|
| 1374 | +1205 |
- ),+ ## this will NOT insert it as |
|||
| 1375 | -1x | +1206 | +6x |
- var+ if ((contnr > 0 || islab) && contpos > at) {
|
|
| 1376 | -- |
- ))- |
- |||
| 1377 | -1x | +||||
| 1207 | +! |
- varvec <- factor(varvec)+ content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE) |
|||
| 1378 | -1x | +||||
| 1208 | +! |
- df[[var]] <- varvec+ return(tt) |
|||
| 1379 | -522x | +||||
| 1209 | +
- } else if (is(varvec, "character") && !char_ok) {
+ } |
||||
| 1380 | -1x | +||||
| 1210 | +
- stop(+ |
||||
| 1381 | -1x | +1211 | +6x |
- "Overriding column counts is not supported when splitting on ",+ .insert_helper(tt, row, |
|
| 1382 | -1x | +1212 | +6x |
- "character variables.\n Please convert all column split variables to ",+ at = at, pos = pos + contnr, |
|
| 1383 | -1x | +1213 | +6x |
- "factors."+ ascontent = ascontent |
|
| 1384 | +1214 |
) |
|||
| 1385 | +1215 |
} |
|||
| 1386 | +1216 | - - | -|||
| 1387 | -522x | -
- if (is.factor(varvec)) {
- |
- |||
| 1388 | -363x | -
- levs <- levels(varvec)+ ) |
|||
| 1389 | +1217 |
- } else {
- |
- |||
| 1390 | -159x | -
- levs <- unique(varvec)+ |
|||
| 1391 | +1218 |
- }+ setMethod( |
|||
| 1392 | -522x | +||||
| 1219 | +
- if (!all(nzchar(levs))) {
+ "recurse_insert", "ElementaryTable", |
||||
| 1393 | -4x | +||||
| 1220 | +
- stop(+ function(tt, row, at, pos, ascontent = FALSE) {
|
||||
| 1394 | -4x | +1221 | +3x |
- "Got empty string level in splitting variable ", var,+ .insert_helper(tt, row, |
|
| 1395 | -4x | +1222 | +3x |
- " This is not supported.\nIf display as an empty level is ",+ at = at, pos = pos, |
|
| 1396 | -4x | +1223 | +3x |
- "desired use a value-labeling variable."+ ascontent = FALSE |
|
| 1397 | +1224 |
) |
|||
| 1398 | +1225 |
} |
|||
| 1399 | +1226 |
-
+ ) |
| 1400 | +1 |
- ## handle label var+ ## Split types ----------------------------------------------------------------- |
||
| 1401 | -518x | +|||
| 2 | +
- lblvar <- spl_label_var(spl)+ ## variable: split on distinct values of a variable |
|||
| 1402 | -518x | +|||
| 3 | +
- have_lblvar <- !identical(var, lblvar)+ ## all: include all observations (root 'split') |
|||
| 1403 | -518x | +|||
| 4 | +
- if (have_lblvar) {
+ ## rawcut: cut on static values of a variable |
|||
| 1404 | -88x | +|||
| 5 | +
- if (!(lblvar %in% names(df))) {
+ ## quantilecut: cut on quantiles of observed values for a variable |
|||
| 1405 | -1x | +|||
| 6 | +
- stop(+ ## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group?? |
|||
| 1406 | -1x | +|||
| 7 | +
- "Value label variable [", lblvar,+ ## multicolumn: each child analyzes a different column |
|||
| 1407 | -1x | +|||
| 8 | +
- "] not found in data being tabulated."+ ## arbitrary: children are not related to each other in any systematic fashion. |
|||
| 1408 | +9 |
- )+ |
||
| 1409 | +10 |
- }+ ## null is ok here. |
||
| 1410 | -87x | +|||
| 11 | +
- lblvec <- df[[lblvar]]+ check_ok_label <- function(lbl, multi_ok = FALSE) {
|
|||
| 1411 | -87x | -
- tab <- table(varvec, lblvec)- |
- ||
| 1412 | -+ | 12 | +48758x |
-
+ if (length(lbl) == 0) {
|
| 1413 | -87x | +13 | +11263x |
- if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
+ return(TRUE) |
| 1414 | -1x | +|||
| 14 | +
- stop(sprintf(+ } |
|||
| 1415 | -1x | +|||
| 15 | +
- paste(+ |
|||
| 1416 | -1x | +16 | +37495x |
- "There does not appear to be a 1-1",+ if (length(lbl) > 1) {
|
| 1417 | -1x | +17 | +1811x |
- "correspondence between values in split var",+ if (multi_ok) {
|
| 1418 | -1x | +18 | +1811x |
- "[%s] and label var [%s]"+ return(all(vapply(lbl, check_ok_label, TRUE))) |
| 1419 | +19 |
- ),- |
- ||
| 1420 | -1x | -
- var, lblvar+ } |
||
| 1421 | -+ | |||
| 20 | +! |
- ))+ stop("got a label of length > 1")
|
||
| 1422 | +21 |
- }+ } |
||
| 1423 | +22 | |||
| 1424 | -86x | -
- if (!is(lblvec, "character") && !is.factor(lblvec)) {
- |
- ||
| 1425 | -! | -
- message(sprintf(- |
- ||
| 1426 | -! | -
- paste(- |
- ||
| 1427 | -! | +23 | +35684x |
- "Split label var [%s] was not character or",+ if (grepl("([{}])", lbl)) {
|
| 1428 | -! | +|||
| 24 | +1x |
- "factor. Converting to factor"+ stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
|
||
| 1429 | +25 |
- ),+ } |
||
| 1430 | -! | +|||
| 26 | +35683x |
- var+ invisible(TRUE) |
||
| 1431 | +27 |
- ))- |
- ||
| 1432 | -! | -
- lblvec <- factor(lblvec)+ } |
||
| 1433 | -! | +|||
| 28 | +
- df[[lblvar]] <- lblvec+ |
|||
| 1434 | +29 |
- }+ valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
|
||
| 1435 | +30 |
- }+ .labelkids_helper <- function(charval) {
|
||
| 1436 | -+ | |||
| 31 | +2427x |
-
+ ret <- switch(charval, |
||
| 1437 | -516x | +32 | +2427x |
- df+ "default" = NA, |
| 1438 | -+ | |||
| 33 | +2427x |
- }+ "visible" = TRUE, |
||
| 1439 | -+ | |||
| 34 | +2427x |
-
+ "hidden" = FALSE, |
||
| 1440 | -+ | |||
| 35 | +2427x |
- fix_split_vars <- function(lyt, df, char_ok) {
+ "topleft" = FALSE, |
||
| 1441 | -319x | +36 | +2427x |
- df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok)+ stop( |
| 1442 | -315x | +37 | +2427x |
- df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE)+ "unrecognized charval in .labelkids_helper. ", |
| 1443 | -310x | +38 | +2427x |
- df+ "this shouldn't ever happen" |
| 1444 | +39 |
-
+ ) |
||
| 1445 | +40 |
- ## clyt <- clayout(lyt)+ ) |
||
| 1446 | -+ | |||
| 41 | +2427x |
- ## rlyt <- rlayout(lyt)+ ret |
||
| 1447 | +42 |
-
+ } |
||
| 1448 | +43 |
- ## allspls <- unlist(list(clyt, rlyt))+ |
||
| 1449 | +44 |
- ## VarLevelSplit includes sublclass VarLevWBaselineSplit+ setOldClass("expression")
|
||
| 1450 | +45 |
- }+ setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric"))
|
||
| 1451 | +46 | |||
| 1452 | +47 |
- fix_split_vars_inner <- function(lyt, df, char_ok) {
- |
- ||
| 1453 | -634x | -
- stopifnot(is(lyt, "PreDataAxisLayout"))- |
- ||
| 1454 | -634x | -
- allspls <- unlist(lyt)- |
- ||
| 1455 | -634x | -
- varspls <- allspls[sapply(allspls, is, "VarLevelSplit")]- |
- ||
| 1456 | -634x | -
- unqvarinds <- !duplicated(sapply(varspls, spl_payload))+ setClassUnion("integerOrNULL", c("NULL", "integer"))
|
||
| 1457 | -634x | +|||
| 48 | +
- unqvarspls <- varspls[unqvarinds]+ setClassUnion("characterOrNULL", c("NULL", "character"))
|
|||
| 1458 | -525x | +|||
| 49 | +
- for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok)+ |
|||
| 1459 | +50 |
-
+ ## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame? |
||
| 1460 | -625x | +|||
| 51 | +
- df+ setClass("TreePos", representation(
|
|||
| 1461 | +52 |
- }+ splits = "list", |
||
| 1462 | +53 |
-
+ s_values = "list", |
||
| 1463 | +54 |
- # set_def_child_ord ----+ sval_labels = "character", |
||
| 1464 | +55 |
- ## the table is built by recursively splitting the data and doing things to each+ subset = "SubsetDef" |
||
| 1465 | +56 |
- ## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to+ ), |
||
| 1466 | +57 |
- ## be the same in all the different partitions. This addresses that.+ validity = function(object) {
|
||
| 1467 | +58 |
- setGeneric(+ nspl <- length(object@splits) |
||
| 1468 | +59 |
- "set_def_child_ord",+ length(object@s_values) == nspl && length(object@sval_labels) == nspl |
||
| 1469 | -3621x | +|||
| 60 | +
- function(lyt, df) standardGeneric("set_def_child_ord")
+ } |
|||
| 1470 | +61 |
) |
||
| 1471 | +62 | |||
| 1472 | +63 |
- setMethod(+ setClassUnion("functionOrNULL", c("NULL", "function"))
|
||
| 1473 | +64 |
- "set_def_child_ord", "PreDataTableLayouts",+ setClassUnion("listOrNULL", c("NULL", "list"))
|
||
| 1474 | +65 |
- function(lyt, df) {
- |
- ||
| 1475 | -320x | -
- clayout(lyt) <- set_def_child_ord(clayout(lyt), df)- |
- ||
| 1476 | -319x | -
- rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df)- |
- ||
| 1477 | -319x | -
- lyt+ ## TODO (?) make "list" more specific, e.g FormatList, or FunctionList? |
||
| 1478 | +66 |
- }+ setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
|
||
| 1479 | +67 |
- )+ setClassUnion("ExprOrNULL", c("NULL", "expression"))
|
||
| 1480 | +68 | |||
| 1481 | +69 |
- setMethod(+ setClass("ValueWrapper", representation(
|
||
| 1482 | +70 |
- "set_def_child_ord", "PreDataAxisLayout",+ value = "ANY", |
||
| 1483 | +71 |
- function(lyt, df) {
+ label = "characterOrNULL", |
||
| 1484 | -949x | +|||
| 72 | +
- lyt@.Data <- lapply(lyt, set_def_child_ord, df = df)+ subset_expression = "ExprOrNULL" |
|||
| 1485 | -948x | +|||
| 73 | +
- lyt+ ), |
|||
| 1486 | +74 |
- }+ contains = "VIRTUAL" |
||
| 1487 | +75 |
) |
||
| 1488 | +76 |
-
+ ## heavier-weight than I'd like but I think we need |
||
| 1489 | +77 |
- setMethod(+ ## this to carry around thee subsets for |
||
| 1490 | +78 |
- "set_def_child_ord", "SplitVector",+ ## comparison-based splits |
||
| 1491 | +79 |
- function(lyt, df) {
+
|
||
| 1492 | -985x | +|||
| 80 | +
- lyt[] <- lapply(lyt, set_def_child_ord, df = df)+ setClass("SplitValue",
|
|||
| 1493 | -984x | +|||
| 81 | +
- lyt+ contains = "ValueWrapper", |
|||
| 1494 | +82 |
- }+ representation(extra = "list") |
||
| 1495 | +83 |
) |
||
| 1496 | +84 | |||
| 1497 | +85 |
- ## for most split types, don't do anything+ SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
|
||
| 1498 | -+ | |||
| 86 | +4825x |
- ## becuause their ordering already isn't data-based+ if (is(val, "SplitValue")) {
|
||
| 1499 | -+ | |||
| 87 | +2026x |
- setMethod(+ if (length(splv_extra(val)) > 0) {
+ |
+ ||
| 88 | +29x | +
+ extr <- c(splv_extra(val), extr) |
||
| 1500 | +89 |
- "set_def_child_ord", "ANY",+ } |
||
| 1501 | -582x | +90 | +2026x |
- function(lyt, df) lyt+ splv_extra(val) <- extr |
| 1502 | -+ | |||
| 91 | +2026x |
- )+ return(val) |
||
| 1503 | +92 |
-
+ } |
||
| 1504 | -+ | |||
| 93 | +2799x |
- setMethod(+ if (!is(extr, "list")) {
|
||
| 1505 | -+ | |||
| 94 | +! |
- "set_def_child_ord", "VarLevelSplit",+ extr <- list(extr) |
||
| 1506 | +95 |
- function(lyt, df) {
+ } |
||
| 1507 | -768x | +96 | +2799x |
- if (!is.null(spl_child_order(lyt))) {
+ if (!is(label, "character")) {
|
| 1508 | -246x | +|||
| 97 | +! |
- return(lyt)+ label <- as.character(label) |
||
| 1509 | +98 |
- }+ } |
||
| 1510 | +99 | |||
| 1511 | -522x | +100 | +2799x |
- vec <- df[[spl_payload(lyt)]]+ if (!is.null(sub_expr) && !is.expression(sub_expr)) {
|
| 1512 | -522x | +101 | +107x |
- vals <- if (is.factor(vec)) {
+ sub_expr <- as.expression(sub_expr)+ |
+
| 102 | ++ |
+ } ## sometimes they will be "call" objects, etc |
||
| 1513 | -361x | +103 | +2799x |
- levels(vec)+ check_ok_label(label) |
| 1514 | -+ | |||
| 104 | +2799x |
- } else {
+ new("SplitValue",
|
||
| 1515 | -161x | +105 | +2799x |
- unique(vec)+ value = val, |
| 1516 | -+ | |||
| 106 | +2799x |
- }+ extra = extr, |
||
| 1517 | -522x | +107 | +2799x |
- spl_child_order(lyt) <- vals+ label = label, |
| 1518 | -522x | +108 | +2799x |
- lyt+ subset_expression = sub_expr |
| 1519 | +109 |
- }+ ) |
||
| 1520 | +110 |
- )+ } |
||
| 1521 | +111 | |||
| 1522 | +112 |
- setMethod(+ setClass("LevelComboSplitValue",
|
||
| 1523 | +113 |
- "set_def_child_ord", "VarLevWBaselineSplit",+ contains = "SplitValue", |
||
| 1524 | +114 |
- function(lyt, df) {
- |
- ||
| 1525 | -17x | -
- bline <- spl_ref_group(lyt)+ representation(combolevels = "character") |
||
| 1526 | -17x | +|||
| 115 | +
- if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
+ ) |
|||
| 1527 | -6x | +|||
| 116 | +
- return(lyt)+ |
|||
| 1528 | +117 |
- }+ ## wrapped in user-facing `add_combo_facet` |
||
| 1529 | +118 |
-
+ LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
|
||
| 1530 | -11x | -
- if (!is.null(split_fun(lyt))) {
- |
- ||
| 1531 | -+ | 119 | +28x |
- ## expensive but sadly necessary, I think+ check_ok_label(label) |
| 1532 | -3x | +120 | +28x |
- pinfo <- do_split(lyt, df, spl_context = context_df_row())+ new("LevelComboSplitValue",
|
| 1533 | -3x | +121 | +28x |
- vals <- sort(unlist(value_names(pinfo$values)))+ value = val, |
| 1534 | -+ | |||
| 122 | +28x |
- } else {
+ extra = extr, |
||
| 1535 | -8x | +123 | +28x |
- vec <- df[[spl_payload(lyt)]]+ combolevels = combolevels, |
| 1536 | -8x | +124 | +28x |
- vals <- if (is.factor(vec)) {
+ label = label, |
| 1537 | -5x | +125 | +28x |
- levels(vec)+ subset_expression = sub_expr |
| 1538 | +126 |
- } else {
+ ) |
||
| 1539 | -3x | +|||
| 127 | +
- unique(vec)+ } |
|||
| 1540 | +128 |
- }+ |
||
| 1541 | +129 |
- }+ setClass("Split",
|
||
| 1542 | -11x | +|||
| 130 | +
- if (!bline %in% vals) {
+ contains = "VIRTUAL", |
|||
| 1543 | -1x | +|||
| 131 | +
- stop(paste0(+ representation( |
|||
| 1544 | -1x | +|||
| 132 | +
- 'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data."+ payload = "ANY", |
|||
| 1545 | +133 |
- ))+ name = "character", |
||
| 1546 | +134 |
- }+ split_label = "character", |
||
| 1547 | -10x | +|||
| 135 | +
- spl_child_order(lyt) <- vals+ split_format = "FormatSpec", |
|||
| 1548 | -10x | +|||
| 136 | +
- lyt+ split_na_str = "character", |
|||
| 1549 | +137 |
- }+ split_label_position = "character", |
||
| 1550 | +138 |
- )+ ## NB this is the function which is applied to |
||
| 1551 | +139 |
-
+ ## get the content rows for the CHILDREN of this |
||
| 1552 | +140 |
- splitvec_to_coltree <- function(df, splvec, pos = NULL,+ ## split!!! |
||
| 1553 | +141 |
- lvl = 1L, label = "",+ content_fun = "listOrNULL", ## functionOrNULL", |
||
| 1554 | +142 |
- spl_context = context_df_row(cinfo = NULL)) {
+ content_format = "FormatSpec", |
||
| 1555 | -1592x | +|||
| 143 | +
- stopifnot(+ content_na_str = "character", |
|||
| 1556 | -1592x | +|||
| 144 | +
- lvl <= length(splvec) + 1L,+ content_var = "character", |
|||
| 1557 | -1592x | +|||
| 145 | +
- is(splvec, "SplitVector")+ label_children = "logical", |
|||
| 1558 | +146 |
- )+ extra_args = "list", |
||
| 1559 | +147 |
-
+ indent_modifier = "integer", |
||
| 1560 | +148 |
-
+ content_indent_modifier = "integer", |
||
| 1561 | -1592x | +|||
| 149 | +
- if (lvl == length(splvec) + 1L) {
+ content_extra_args = "list", |
|||
| 1562 | +150 |
- ## XXX this should be a LayoutColree I Think.+ page_title_prefix = "character", |
||
| 1563 | -1047x | +|||
| 151 | +
- nm <- unlist(tail(value_names(pos), 1)) %||% ""+ child_section_div = "character", |
|||
| 1564 | -1047x | +|||
| 152 | +
- LayoutColLeaf(+ child_show_colcounts = "logical", |
|||
| 1565 | -1047x | +|||
| 153 | +
- lev = lvl - 1L,+ child_colcount_format = "FormatSpec" |
|||
| 1566 | -1047x | +|||
| 154 | +
- label = label,+ ) |
|||
| 1567 | -1047x | +|||
| 155 | +
- tpos = pos,+ ) |
|||
| 1568 | -1047x | +|||
| 156 | +
- name = nm+ |
|||
| 1569 | +157 |
- )+ setClass("CustomizableSplit",
|
||
| 1570 | +158 |
- } else {
+ contains = "Split", |
||
| 1571 | -545x | +|||
| 159 | +
- spl <- splvec[[lvl]]+ representation(split_fun = "functionOrNULL") |
|||
| 1572 | -545x | +|||
| 160 | +
- nm <- if (is.null(pos)) {
+ ) |
|||
| 1573 | -! | +|||
| 161 | +
- obj_name(spl)+ |
|||
| 1574 | +162 |
- } else {
+ #' @author Gabriel Becker |
||
| 1575 | -545x | +|||
| 163 | +
- unlist(tail(+ #' @exportClass VarLevelSplit |
|||
| 1576 | -545x | +|||
| 164 | +
- value_names(pos),+ #' @rdname VarLevelSplit |
|||
| 1577 | -545x | +|||
| 165 | +
- 1+ setClass("VarLevelSplit",
|
|||
| 1578 | +166 |
- ))+ contains = "CustomizableSplit", |
||
| 1579 | +167 |
- }+ representation( |
||
| 1580 | -545x | +|||
| 168 | +
- rawpart <- do_split(spl, df,+ value_label_var = "character", |
|||
| 1581 | -545x | +|||
| 169 | +
- trim = FALSE,+ value_order = "ANY" |
|||
| 1582 | -545x | +|||
| 170 | +
- spl_context = spl_context+ ) |
|||
| 1583 | +171 |
- )+ ) |
||
| 1584 | -542x | +|||
| 172 | +
- datparts <- rawpart[["datasplit"]]+ #' Split on levels within a variable |
|||
| 1585 | -542x | +|||
| 173 | +
- vals <- rawpart[["values"]]+ #' |
|||
| 1586 | -542x | +|||
| 174 | +
- labs <- rawpart[["labels"]]+ #' @inheritParams lyt_args |
|||
| 1587 | +175 |
-
+ #' @inheritParams constr_args |
||
| 1588 | +176 |
-
+ #' |
||
| 1589 | -542x | +|||
| 177 | +
- kids <- mapply(+ #' @return a `VarLevelSplit` object. |
|||
| 1590 | -542x | +|||
| 178 | +
- function(dfpart, value, partlab) {
+ #' |
|||
| 1591 | +179 |
- ## we could pass subset expression in here but the spec+ #' @export |
||
| 1592 | +180 |
- ## currently doesn't call for it in column space+ VarLevelSplit <- function(var, |
||
| 1593 | -1237x | +|||
| 181 | +
- newprev <- context_df_row(+ split_label, |
|||
| 1594 | -1237x | +|||
| 182 | +
- split = obj_name(spl),+ labels_var = NULL, |
|||
| 1595 | -1237x | +|||
| 183 | +
- value = value_names(value),+ cfun = NULL, |
|||
| 1596 | -1237x | +|||
| 184 | +
- full_parent_df = list(dfpart),+ cformat = NULL, |
|||
| 1597 | -1237x | +|||
| 185 | +
- cinfo = NULL+ cna_str = NA_character_, |
|||
| 1598 | +186 |
- )+ split_fun = NULL, |
||
| 1599 | +187 |
- ## subset expressions handled inside make_child_pos,+ split_format = NULL, |
||
| 1600 | +188 |
- ## value is (optionally, for the moment) carrying it around+ split_na_str = NA_character_, |
||
| 1601 | -1237x | +|||
| 189 | +
- newpos <- make_child_pos(pos, spl, value, partlab)+ valorder = NULL, |
|||
| 1602 | -1237x | +|||
| 190 | +
- splitvec_to_coltree(dfpart, splvec, newpos,+ split_name = var, |
|||
| 1603 | -1237x | +|||
| 191 | +
- lvl + 1L, partlab,+ child_labels = c("default", "visible", "hidden"),
|
|||
| 1604 | -1237x | +|||
| 192 | +
- spl_context = rbind(spl_context, newprev)+ extra_args = list(), |
|||
| 1605 | +193 |
- )+ indent_mod = 0L, |
||
| 1606 | +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) {
|
||
| 1607 | -542x | +202 | +517x |
- dfpart = datparts, value = vals,+ child_labels <- match.arg(child_labels) |
| 1608 | -542x | +203 | +517x |
- partlab = labs, SIMPLIFY = FALSE+ if (is.null(labels_var)) {
+ |
+
| 204 | +1x | +
+ labels_var <- var |
||
| 1609 | +205 |
- )+ } |
||
| 1610 | -541x | +206 | +517x |
- names(kids) <- value_names(vals)+ check_ok_label(split_label) |
| 1611 | -541x | +207 | +517x |
- LayoutColTree(+ new("VarLevelSplit",
|
| 1612 | -541x | +208 | +517x |
- lev = lvl, label = label,+ payload = var, |
| 1613 | -541x | +209 | +517x |
- spl = spl,+ split_label = split_label, |
| 1614 | -541x | +210 | +517x |
- kids = kids, tpos = pos,+ name = split_name, |
| 1615 | -541x | +211 | +517x |
- name = nm,+ value_label_var = labels_var, |
| 1616 | -541x | +212 | +517x |
- summary_function = content_fun(spl)+ content_fun = cfun, |
| 1617 | -+ | |||
| 213 | +517x |
- )+ content_format = cformat, |
||
| 1618 | -+ | |||
| 214 | +517x |
- }+ content_na_str = cna_str, |
||
| 1619 | -+ | |||
| 215 | +517x |
- }+ split_fun = split_fun, |
||
| 1620 | -+ | |||
| 216 | +517x |
-
+ split_format = split_format, |
||
| 1621 | -+ | |||
| 217 | +517x |
- # fix_analyze_vis ----+ split_na_str = split_na_str, |
||
| 1622 | -+ | |||
| 218 | +517x |
- ## now that we know for sure the number of siblings+ value_order = NULL, |
||
| 1623 | -+ | |||
| 219 | +517x |
- ## collaplse NAs to TRUE/FALSE for whether+ label_children = .labelkids_helper(child_labels), |
||
| 1624 | -+ | |||
| 220 | +517x |
- ## labelrows should be visible for ElementaryTables+ extra_args = extra_args, |
||
| 1625 | -+ | |||
| 221 | +517x |
- ## generatead from analyzing a single variable+ indent_modifier = as.integer(indent_mod), |
||
| 1626 | -982x | +222 | +517x |
- setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))
+ content_indent_modifier = as.integer(cindent_mod), |
| 1627 | -+ | |||
| 223 | +517x |
-
+ content_var = cvar, |
||
| 1628 | -+ | |||
| 224 | +517x |
- setMethod(+ split_label_position = label_pos, |
||
| 1629 | -+ | |||
| 225 | +517x |
- "fix_analyze_vis", "PreDataTableLayouts",+ content_extra_args = cextra_args, |
||
| 1630 | -+ | |||
| 226 | +517x |
- function(lyt) {
+ page_title_prefix = page_prefix, |
||
| 1631 | -319x | +227 | +517x |
- rlayout(lyt) <- fix_analyze_vis(rlayout(lyt))+ child_section_div = section_div, |
| 1632 | -319x | +228 | +517x |
- lyt+ child_show_colcounts = show_colcounts,+ |
+
| 229 | +517x | +
+ child_colcount_format = colcount_format |
||
| 1633 | +230 |
- }+ ) |
||
| 1634 | +231 |
- )+ } |
||
| 1635 | +232 | |||
| 1636 | +233 |
- setMethod(+ setClass("AllSplit", contains = "Split")
|
||
| 1637 | +234 |
- "fix_analyze_vis", "PreDataRowLayout",+ |
||
| 1638 | +235 |
- function(lyt) {
+ AllSplit <- function(split_label = "", |
||
| 1639 | -319x | +|||
| 236 | +
- splvecs <- lapply(lyt, fix_analyze_vis)+ cfun = NULL, |
|||
| 1640 | -319x | +|||
| 237 | +
- PreDataRowLayout(+ cformat = NULL, |
|||
| 1641 | -319x | +|||
| 238 | +
- root = root_spl(lyt),+ cna_str = NA_character_, |
|||
| 1642 | -319x | +|||
| 239 | +
- lst = splvecs+ split_format = NULL, |
|||
| 1643 | +240 |
- )+ split_na_str = NA_character_, |
||
| 1644 | +241 |
- }+ split_name = NULL, |
||
| 1645 | +242 |
- )+ extra_args = list(), |
||
| 1646 | +243 |
-
+ indent_mod = 0L, |
||
| 1647 | +244 |
- setMethod(+ cindent_mod = 0L, |
||
| 1648 | +245 |
- "fix_analyze_vis", "SplitVector",+ cvar = "", |
||
| 1649 | +246 |
- function(lyt) {
+ cextra_args = list(), |
||
| 1650 | -344x | +|||
| 247 | +
- len <- length(lyt)+ show_colcounts = FALSE, |
|||
| 1651 | -344x | +|||
| 248 | +
- if (len == 0) {
+ colcount_format = NULL, |
|||
| 1652 | -14x | +|||
| 249 | +
- return(lyt)+ ...) {
|
|||
| 1653 | -+ | |||
| 250 | +203x |
- }+ if (is.null(split_name)) {
|
||
| 1654 | -330x | +251 | +100x |
- lastspl <- lyt[[len]]+ if (nzchar(split_label)) {
|
| 1655 | -330x | +252 | +7x |
- if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
+ split_name <- split_label+ |
+
| 253 | ++ |
+ } else {
|
||
| 1656 | -62x | +254 | +93x |
- return(lyt)+ split_name <- "all obs" |
| 1657 | +255 |
} |
||
| 1658 | +256 |
-
+ } |
||
| 1659 | -268x | +257 | +203x |
- if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
+ check_ok_label(split_label) |
| 1660 | -+ | |||
| 258 | +203x |
- ## labelrow_visible(lastspl) = FALSE+ new("AllSplit",
|
||
| 1661 | -262x | +259 | +203x |
- labelrow_visible(lastspl) <- "hidden"+ split_label = split_label, |
| 1662 | -6x | +260 | +203x |
- } else if (is(lastspl, "AnalyzeMultiVar")) {
+ content_fun = cfun, |
| 1663 | -! | +|||
| 261 | +203x |
- pld <- spl_payload(lastspl)+ content_format = cformat, |
||
| 1664 | -! | +|||
| 262 | +203x |
- newpld <- lapply(pld, function(sp, havesibs) {
+ content_na_str = cna_str, |
||
| 1665 | -! | +|||
| 263 | +203x |
- if (is.na(labelrow_visible(sp))) {
+ split_format = split_format, |
||
| 1666 | -! | +|||
| 264 | +203x |
- labelrow_visible(sp) <- havesibs+ split_na_str = split_na_str, |
||
| 1667 | -+ | |||
| 265 | +203x |
- }+ name = split_name, |
||
| 1668 | -! | +|||
| 266 | +203x |
- }, havesibs = len > 1)+ label_children = FALSE, |
||
| 1669 | -! | +|||
| 267 | +203x |
- spl_payload(lastspl) <- newpld+ extra_args = extra_args, |
||
| 1670 | -+ | |||
| 268 | +203x |
- ## pretty sure this isn't needed...+ indent_modifier = as.integer(indent_mod), |
||
| 1671 | -! | +|||
| 269 | +203x |
- if (is.na(label_kids(lastspl))) {
+ content_indent_modifier = as.integer(cindent_mod), |
||
| 1672 | -! | +|||
| 270 | +203x |
- label_kids(lastspl) <- len > 1+ content_var = cvar, |
||
| 1673 | -+ | |||
| 271 | +203x |
- }+ split_label_position = "hidden", |
||
| 1674 | -+ | |||
| 272 | +203x |
- }+ content_extra_args = cextra_args, |
||
| 1675 | -268x | +273 | +203x |
- lyt[[len]] <- lastspl+ page_title_prefix = NA_character_, |
| 1676 | -268x | +274 | +203x |
- lyt+ child_section_div = NA_character_,+ |
+
| 275 | +203x | +
+ child_show_colcounts = show_colcounts,+ |
+ ||
| 276 | +203x | +
+ child_colcount_format = colcount_format |
||
| 1677 | +277 |
- }+ ) |
||
| 1678 | +278 |
- )+ } |
||
| 1679 | +279 | |||
| 1680 | +280 |
- # check_afun_cfun_params ----+ setClass("RootSplit", contains = "AllSplit")
|
||
| 1681 | +281 | |||
| 1682 | +282 |
- # This checks if the input params are used anywhere in cfun/afun+ RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "", |
||
| 1683 | +283 |
- setGeneric("check_afun_cfun_params", function(lyt, params) {
+ split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
|
||
| 1684 | -3143x | +284 | +632x |
- standardGeneric("check_afun_cfun_params")
+ check_ok_label(split_label) |
| 1685 | -+ | |||
| 285 | +632x |
- })+ new("RootSplit",
|
||
| 1686 | -+ | |||
| 286 | +632x |
-
+ split_label = split_label, |
||
| 1687 | -+ | |||
| 287 | +632x |
- setMethod(+ content_fun = cfun, |
||
| 1688 | -+ | |||
| 288 | +632x |
- "check_afun_cfun_params", "PreDataTableLayouts",+ content_format = cformat, |
||
| 1689 | -+ | |||
| 289 | +632x |
- function(lyt, params) {
+ content_na_str = cna_str, |
||
| 1690 | -+ | |||
| 290 | +632x |
- # clayout does not have analysis functions+ split_format = split_format, |
||
| 1691 | -310x | +291 | +632x |
- check_afun_cfun_params(rlayout(lyt), params)+ split_na_str = split_na_str, |
| 1692 | -+ | |||
| 292 | +632x |
- }+ name = "root", |
||
| 1693 | -+ | |||
| 293 | +632x |
- )+ label_children = FALSE, |
||
| 1694 | -+ | |||
| 294 | +632x |
-
+ indent_modifier = 0L, |
||
| 1695 | -+ | |||
| 295 | +632x |
- setMethod(+ content_indent_modifier = 0L, |
||
| 1696 | -+ | |||
| 296 | +632x |
- "check_afun_cfun_params", "PreDataRowLayout",+ content_var = cvar, |
||
| 1697 | -+ | |||
| 297 | +632x |
- function(lyt, params) {
+ split_label_position = "hidden", |
||
| 1698 | -310x | +298 | +632x |
- ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params)+ content_extra_args = cextra_args, |
| 1699 | -310x | +299 | +632x |
- r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params)+ child_section_div = NA_character_, |
| 1700 | -310x | +300 | +632x |
- Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l))+ child_show_colcounts = FALSE, |
| 1701 | -+ | |||
| 301 | +632x |
- }+ child_colcount_format = "(N=xx)" |
||
| 1702 | +302 |
- )+ ) |
||
| 1703 | +303 |
-
+ } |
||
| 1704 | +304 |
- # Main function for checking parameters+ |
||
| 1705 | +305 |
- setMethod(+ setClass("ManualSplit",
|
||
| 1706 | +306 |
- "check_afun_cfun_params", "SplitVector",+ contains = "AllSplit", |
||
| 1707 | +307 |
- function(lyt, params) {
- |
- ||
| 1708 | -756x | -
- param_l <- lapply(lyt, check_afun_cfun_params, params = params)+ representation(levels = "character") |
||
| 1709 | -756x | +|||
| 308 | +
- Reduce(`|`, param_l)+ ) |
|||
| 1710 | +309 |
- }+ |
||
| 1711 | +310 |
- )+ #' Manually defined split |
||
| 1712 | +311 |
-
+ #' |
||
| 1713 | +312 |
- # Helper function for check_afun_cfun_params+ #' @inheritParams lyt_args |
||
| 1714 | +313 |
- .afun_cfun_switch <- function(spl_i) {
+ #' @inheritParams constr_args |
||
| 1715 | -1766x | +|||
| 314 | +
- if (is(spl_i, "VAnalyzeSplit")) {
+ #' @inheritParams gen_args |
|||
| 1716 | -598x | +|||
| 315 | +
- analysis_fun(spl_i)+ #' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split). |
|||
| 1717 | +316 |
- } else {
+ #' |
||
| 1718 | -1168x | +|||
| 317 | +
- content_fun(spl_i)+ #' @return A `ManualSplit` object. |
|||
| 1719 | +318 |
- }+ #' |
||
| 1720 | +319 |
- }+ #' @author Gabriel Becker |
||
| 1721 | +320 |
-
+ #' @export |
||
| 1722 | +321 |
- # Extreme case that happens only when using add_existing_table+ ManualSplit <- function(levels, label, name = "manual", |
||
| 1723 | +322 |
- setMethod(+ extra_args = list(), |
||
| 1724 | +323 |
- "check_afun_cfun_params", "VTableTree",+ indent_mod = 0L, |
||
| 1725 | +324 |
- function(lyt, params) {
+ cindent_mod = 0L, |
||
| 1726 | -1x | +|||
| 325 | +
- setNames(logical(length(params)), params) # All FALSE+ cvar = "", |
|||
| 1727 | +326 |
- }+ cextra_args = list(), |
||
| 1728 | +327 |
- )+ label_pos = "visible", |
||
| 1729 | +328 |
-
+ page_prefix = NA_character_, |
||
| 1730 | +329 |
- setMethod(+ section_div = NA_character_) {
|
||
| 1731 | -+ | |||
| 330 | +47x |
- "check_afun_cfun_params", "Split",+ label_pos <- match.arg(label_pos, label_pos_values) |
||
| 1732 | -+ | |||
| 331 | +47x |
- function(lyt, params) {
+ check_ok_label(label, multi_ok = TRUE) |
||
| 1733 | -+ | |||
| 332 | +47x |
- # Extract function in the split+ new("ManualSplit",
|
||
| 1734 | -1766x | +333 | +47x |
- fnc <- .afun_cfun_switch(lyt)+ split_label = label, |
| 1735 | -+ | |||
| 334 | +47x |
-
+ levels = levels, |
||
| 1736 | -+ | |||
| 335 | +47x |
- # For each parameter, check if it is called+ name = name, |
||
| 1737 | -1766x | +336 | +47x |
- sapply(params, function(pai) any(unlist(func_takes(fnc, pai))))+ label_children = FALSE, |
| 1738 | -+ | |||
| 337 | +47x |
- }+ extra_args = extra_args, |
||
| 1739 | -+ | |||
| 338 | +47x |
- )+ indent_modifier = 0L, |
||
| 1740 | -+ | |||
| 339 | +47x |
-
+ content_indent_modifier = as.integer(cindent_mod), |
||
| 1741 | -+ | |||
| 340 | +47x |
- # Helper functions ----+ content_var = cvar, |
||
| 1742 | -+ | |||
| 341 | +47x |
-
+ split_format = NULL, |
||
| 1743 | -231x | +342 | +47x |
- count <- function(df, ...) NROW(df)+ 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)" |
||
| 1744 | +348 |
-
+ ) |
||
| 1745 | +349 |
- guess_format <- function(val) {
+ } |
||
| 1746 | -1054x | +|||
| 350 | +
- if (length(val) == 1) {
+
|
|||
| 1747 | -1042x | +|||
| 351 | +
- if (is.integer(val) || !is.numeric(val)) {
+ ## splits across which variables are being analynzed |
|||
| 1748 | -226x | +|||
| 352 | +
- "xx"+ setClass("MultiVarSplit",
|
|||
| 1749 | +353 |
- } else {
+ contains = "CustomizableSplit", ## "Split", |
||
| 1750 | -816x | +|||
| 354 | +
- "xx.xx"+ representation( |
|||
| 1751 | +355 |
- }+ var_labels = "character", |
||
| 1752 | -12x | +|||
| 356 | +
- } else if (length(val) == 2) {
+ var_names = "character" |
|||
| 1753 | -12x | +|||
| 357 | +
- "xx.x / xx.x"+ ), |
|||
| 1754 | -! | +|||
| 358 | +
- } else if (length(val) == 3) {
+ validity = function(object) {
|
|||
| 1755 | -! | +|||
| 359 | +
- "xx.x (xx.x - xx.x)"+ length(object@payload) >= 1 && |
|||
| 1756 | +360 |
- } else {
+ all(!is.na(object@payload)) && |
||
| 1757 | -! | +|||
| 361 | +
- stop("got value of length > 3")
+ (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels)) |
|||
| 1758 | +362 |
} |
||
| 1759 | +363 |
- }+ ) |
||
| 1760 | +364 | |||
| 1761 | +365 |
- .quick_afun <- function(afun, lbls) {
+ .make_suffix_vec <- function(n) {
|
||
| 1762 | -14x | +366 | +3x |
- if (.takes_df(afun)) {
+ c(+ |
+
| 367 | ++ |
+ "", |
||
| 1763 | -5x | +368 | +3x |
- function(df, .spl_context, ...) {
+ sprintf( |
| 1764 | -226x | +369 | +3x |
- if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
+ "._[[%d]]_.", |
| 1765 | -222x | +370 | +3x |
- lbls <- tail(.spl_context$value, 1)+ seq_len(n - 1) + 1L |
| 1766 | +371 |
- }+ ) |
||
| 1767 | -226x | +|||
| 372 | +
- if (".spl_context" %in% names(formals(afun))) {
+ ) |
|||
| 1768 | -! | +|||
| 373 | +
- res <- afun(df = df, .spl_context = .spl_context, ...)+ } |
|||
| 1769 | +374 |
- } else {
+
|
||
| 1770 | -226x | +|||
| 375 | +
- res <- afun(df = df, ...)+ .make_multivar_names <- function(vars) {
|
|||
| 1771 | -+ | |||
| 376 | +28x |
- }+ dups <- duplicated(vars) |
||
| 1772 | -226x | +377 | +28x |
- if (is(res, "RowsVerticalSection")) {
+ if (!any(dups)) {
|
| 1773 | -! | +|||
| 378 | +25x |
- ret <- res+ return(vars) |
||
| 1774 | +379 |
- } else {
+ } |
||
| 1775 | -226x | +380 | +3x |
- if (!is.list(res)) {
+ dupvars <- unique(vars[dups]) |
| 1776 | -226x | +381 | +3x |
- ret <- rcell(res, label = lbls, format = guess_format(res))+ ret <- vars |
| 1777 | -+ | |||
| 382 | +3x |
- } else {
+ for (v in dupvars) {
|
||
| 1778 | -! | +|||
| 383 | +3x |
- if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ pos <- which(ret == v) |
||
| 1779 | -! | +|||
| 384 | +3x |
- names(res) <- lbls+ ret[pos] <- paste0( |
||
| 1780 | -+ | |||
| 385 | +3x |
- }+ ret[pos], |
||
| 1781 | -! | +|||
| 386 | +3x |
- ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))+ .make_suffix_vec(length(pos)) |
||
| 1782 | +387 |
- }+ ) |
||
| 1783 | +388 |
- }+ } |
||
| 1784 | -226x | +389 | +3x |
- ret+ ret |
| 1785 | +390 |
- }+ } |
||
| 1786 | +391 |
- } else {
+
|
||
| 1787 | -9x | +|||
| 392 | +
- function(x, .spl_context, ...) {
+ #' Split between two or more different variables |
|||
| 1788 | -387x | +|||
| 393 | +
- if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
+ #' |
|||
| 1789 | -225x | +|||
| 394 | +
- lbls <- tail(.spl_context$value, 1)+ #' @inheritParams lyt_args |
|||
| 1790 | +395 |
- }+ #' @inheritParams constr_args |
||
| 1791 | -387x | +|||
| 396 | +
- if (".spl_context" %in% names(formals(afun))) {
+ #' |
|||
| 1792 | -! | +|||
| 397 | +
- res <- afun(x = x, .spl_context = .spl_context, ...)+ #' @return A `MultiVarSplit` object. |
|||
| 1793 | +398 |
- } else {
+ #' |
||
| 1794 | -387x | +|||
| 399 | +
- res <- afun(x = x, ...)+ #' @author Gabriel Becker |
|||
| 1795 | +400 |
- }+ #' @export |
||
| 1796 | -387x | +|||
| 401 | +
- if (is(res, "RowsVerticalSection")) {
+ MultiVarSplit <- function(vars, |
|||
| 1797 | -! | +|||
| 402 | +
- ret <- res+ split_label = "", |
|||
| 1798 | +403 |
- } else {
+ varlabels = NULL, |
||
| 1799 | -387x | +|||
| 404 | +
- if (!is.list(res)) {
+ varnames = NULL, |
|||
| 1800 | -297x | +|||
| 405 | +
- ret <- rcell(res, label = lbls, format = guess_format(res))+ cfun = NULL, |
|||
| 1801 | +406 |
- } else {
+ cformat = NULL, |
||
| 1802 | -90x | +|||
| 407 | +
- if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ cna_str = NA_character_, |
|||
| 1803 | -9x | +|||
| 408 | +
- names(res) <- lbls+ split_format = NULL, |
|||
| 1804 | +409 |
- }+ split_na_str = NA_character_, |
||
| 1805 | -90x | +|||
| 410 | +
- ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))+ split_name = "multivars", |
|||
| 1806 | +411 |
- }+ child_labels = c("default", "visible", "hidden"),
|
||
| 1807 | +412 |
- }+ extra_args = list(), |
||
| 1808 | -387x | +|||
| 413 | +
- ret+ indent_mod = 0L, |
|||
| 1809 | +414 |
- }+ cindent_mod = 0L, |
||
| 1810 | +415 |
- }+ cvar = "", |
||
| 1811 | +416 |
- }+ cextra_args = list(), |
||
| 1812 | +417 |
-
+ label_pos = "visible", |
||
| 1813 | +418 |
- # qtable ----+ split_fun = NULL, |
||
| 1814 | +419 |
-
+ page_prefix = NA_character_, |
||
| 1815 | +420 |
- n_cells_res <- function(res) {
+ section_div = NA_character_,+ |
+ ||
| 421 | ++ |
+ show_colcounts = FALSE,+ |
+ ||
| 422 | ++ |
+ colcount_format = NULL) {
|
||
| 1816 | -8x | +423 | +28x |
- ans <- 1L+ check_ok_label(split_label)+ |
+
| 424 | ++ |
+ ## no topleft allowed |
||
| 1817 | -8x | +425 | +28x |
- if (is.list(res)) {
+ label_pos <- match.arg(label_pos, label_pos_values[-3]) |
| 1818 | -4x | +426 | +28x |
- ans <- length(res)+ child_labels <- match.arg(child_labels) |
| 1819 | -4x | +427 | +28x |
- } else if (is(res, "RowsVerticalSection")) {
+ if (length(vars) == 1 && grepl(":", vars)) {
|
| 1820 | +428 | ! |
- ans <- length(res$values)+ vars <- strsplit(vars, ":")[[1]] |
|
| 1821 | +429 |
- } # XXX penetrating the abstraction+ } |
||
| 1822 | -8x | +430 | +28x |
- ans+ if (length(varlabels) == 0) { ## covers NULL and character()
|
| 1823 | -+ | |||
| 431 | +1x |
- }+ varlabels <- vars |
||
| 1824 | +432 |
-
+ } |
||
| 1825 | -+ | |||
| 433 | +28x |
- #' Generalized frequency table+ vnames <- varnames %||% .make_multivar_names(vars) |
||
| 1826 | -+ | |||
| 434 | +28x |
- #'+ stopifnot(length(vnames) == length(vars)) |
||
| 1827 | -+ | |||
| 435 | +28x |
- #' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and+ new("MultiVarSplit",
|
||
| 1828 | -+ | |||
| 436 | +28x |
- #' column space can be facetted by variables, and an analysis function can be specified. The function then builds a+ payload = vars, |
||
| 1829 | -+ | |||
| 437 | +28x |
- #' layout with the specified layout and applies it to the data provided.+ split_label = split_label, |
||
| 1830 | -+ | |||
| 438 | +28x |
- #'+ var_labels = varlabels, |
||
| 1831 | -+ | |||
| 439 | +28x |
- #' @inheritParams constr_args+ var_names = vnames, |
||
| 1832 | -+ | |||
| 440 | +28x |
- #' @inheritParams basic_table+ content_fun = cfun, |
||
| 1833 | -+ | |||
| 441 | +28x |
- #' @param row_vars (`character`)\cr the names of variables to be used in row facetting.+ content_format = cformat, |
||
| 1834 | -+ | |||
| 442 | +28x |
- #' @param col_vars (`character`)\cr the names of variables to be used in column facetting.+ content_na_str = cna_str, |
||
| 1835 | -+ | |||
| 443 | +28x |
- #' @param data (`data.frame`)\cr the data to tabulate.+ split_format = split_format, |
||
| 1836 | -+ | |||
| 444 | +28x |
- #' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`.+ split_na_str = split_na_str, |
||
| 1837 | -+ | |||
| 445 | +28x |
- #' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must+ label_children = .labelkids_helper(child_labels), |
||
| 1838 | -+ | |||
| 446 | +28x |
- #' match the number of rows generated by `afun`.+ name = split_name, |
||
| 1839 | -+ | |||
| 447 | +28x |
- #' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis+ extra_args = extra_args, |
||
| 1840 | -+ | |||
| 448 | +28x |
- #' function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas+ indent_modifier = as.integer(indent_mod), |
||
| 1841 | -+ | |||
| 449 | +28x |
- #' lists are interpreted as multiple cells.+ content_indent_modifier = as.integer(cindent_mod), |
||
| 1842 | -+ | |||
| 450 | +28x |
- #' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to+ content_var = cvar, |
||
| 1843 | -+ | |||
| 451 | +28x |
- #' `TRUE`.+ split_label_position = label_pos, |
||
| 1844 | -+ | |||
| 452 | +28x |
- #' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to+ content_extra_args = cextra_args, |
||
| 1845 | -+ | |||
| 453 | +28x |
- #' `FALSE`.+ split_fun = split_fun, |
||
| 1846 | -+ | |||
| 454 | +28x |
- #' @param ... additional arguments passed to `afun`.+ page_title_prefix = page_prefix, |
||
| 1847 | -+ | |||
| 455 | +28x |
- #' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users.+ child_section_div = section_div, |
||
| 1848 | -+ | |||
| 456 | +28x |
- #'+ child_show_colcounts = show_colcounts, |
||
| 1849 | -+ | |||
| 457 | +28x |
- #' @details+ child_colcount_format = colcount_format |
||
| 1850 | +458 |
- #' This function creates a table with a single top-level structure in both row and column dimensions involving faceting+ ) |
||
| 1851 | +459 |
- #' by 0 or more variables in each dimension.+ } |
||
| 1852 | +460 |
- #'+ |
||
| 1853 | +461 |
- #' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a+ #' Splits for cutting by values of a numeric variable |
||
| 1854 | +462 |
- #' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row+ #' |
||
| 1855 | +463 |
- #' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun`+ #' @inheritParams lyt_args |
||
| 1856 | +464 |
- #' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row+ #' @inheritParams constr_args |
||
| 1857 | +465 |
- #' labels and the deepest-nested facet row labels will be visible.+ #' |
||
| 1858 | +466 |
- #'+ #' @exportClass VarStaticCutSplit |
||
| 1859 | +467 |
- #' The table will be annotated in the top-left area with an informative label displaying the analysis variable+ #' @rdname cutsplits |
||
| 1860 | +468 |
- #' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception+ setClass("VarStaticCutSplit",
|
||
| 1861 | +469 |
- #' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and+ contains = "Split", |
||
| 1862 | +470 |
- #' an `afun` which returns a single row.+ representation( |
||
| 1863 | +471 |
- #'+ cuts = "numeric", |
||
| 1864 | +472 |
- #' @return+ cut_labels = "character" |
||
| 1865 | +473 |
- #' * `qtable` returns a built `TableTree` object representing the desired table+ ) |
||
| 1866 | +474 |
- #' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for+ ) |
||
| 1867 | +475 |
- #' passing to [build_table()].+ |
||
| 1868 | +476 |
- #'+ .is_cut_lab_lst <- function(cuts) {
|
||
| 1869 | -+ | |||
| 477 | +12x |
- #' @examples+ is.list(cuts) && is.numeric(cuts[[1]]) && |
||
| 1870 | -+ | |||
| 478 | +12x |
- #' qtable(ex_adsl)+ is.character(cuts[[2]]) && |
||
| 1871 | -+ | |||
| 479 | +12x |
- #' qtable(ex_adsl, row_vars = "ARM")+ length(cuts[[1]]) == length(cuts[[2]]) |
||
| 1872 | +480 |
- #' qtable(ex_adsl, col_vars = "ARM")+ } |
||
| 1873 | +481 |
- #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM")+ |
||
| 1874 | +482 |
- #' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
+ #' Create static cut or static cumulative cut split |
||
| 1875 | +483 |
- #' qtable(ex_adsl,+ #' |
||
| 1876 | +484 |
- #' row_vars = c("COUNTRY", "SEX"),
+ #' @inheritParams lyt_args |
||
| 1877 | +485 |
- #' col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
+ #' @inheritParams constr_args |
||
| 1878 | +486 |
- #' )+ #' |
||
| 1879 | +487 |
- #' summary_list <- function(x, ...) as.list(summary(x))+ #' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit` |
||
| 1880 | +488 |
- #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list)+ #' object for [VarDynCutSplit()]. |
||
| 1881 | +489 |
- #' suppressWarnings(qtable(ex_adsl,+ #' |
||
| 1882 | +490 |
- #' row_vars = "SEX",+ #' @rdname cutsplits |
||
| 1883 | +491 |
- #' col_vars = "ARM", avar = "AGE", afun = range+ make_static_cut_split <- function(var, |
||
| 1884 | +492 |
- #' ))+ split_label, |
||
| 1885 | +493 |
- #'+ cuts, |
||
| 1886 | +494 |
- #' @export+ cutlabels = NULL, |
||
| 1887 | +495 |
- qtable_layout <- function(data,+ cfun = NULL, |
||
| 1888 | +496 |
- row_vars = character(),+ cformat = NULL, |
||
| 1889 | +497 |
- col_vars = character(),+ cna_str = NA_character_, |
||
| 1890 | +498 |
- avar = NULL,+ split_format = NULL, |
||
| 1891 | +499 |
- row_labels = NULL,+ split_na_str = NA_character_, |
||
| 1892 | +500 |
- afun = NULL,+ split_name = var, |
||
| 1893 | +501 |
- summarize_groups = FALSE,+ child_labels = c("default", "visible", "hidden"),
|
||
| 1894 | -- |
- title = "",- |
- ||
| 1895 | -- |
- subtitles = character(),- |
- ||
| 1896 | +502 |
- main_footer = character(),+ extra_args = list(), |
||
| 1897 | +503 |
- prov_footer = character(),+ indent_mod = 0L, |
||
| 1898 | +504 |
- show_colcounts = TRUE,+ cindent_mod = 0L, |
||
| 1899 | +505 |
- drop_levels = TRUE,+ cvar = "", |
||
| 1900 | +506 |
- ...,+ cextra_args = list(), |
||
| 1901 | +507 |
- .default_rlabel = NULL) {
- |
- ||
| 1902 | -16x | -
- subafun <- substitute(afun)- |
- ||
| 1903 | -16x | -
- if (!is.null(.default_rlabel)) {
- |
- ||
| 1904 | -16x | -
- dflt_row_lbl <- .default_rlabel+ label_pos = "visible", |
||
| 1905 | +508 |
- } else if (- |
- ||
| 1906 | -! | -
- is.name(subafun) &&- |
- ||
| 1907 | -! | -
- is.function(afun) &&+ cumulative = FALSE, |
||
| 1908 | +509 |
- ## this is gross. basically testing+ page_prefix = NA_character_, |
||
| 1909 | +510 |
- ## if the symbol we have corresponds+ section_div = NA_character_, |
||
| 1910 | +511 |
- ## in some meaningful way to the function+ show_colcounts = FALSE, |
||
| 1911 | +512 |
- ## we will be calling.- |
- ||
| 1912 | -! | -
- identical(+ colcount_format = NULL) {
|
||
| 1913 | -! | +|||
| 513 | +12x |
- mget(+ cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit" |
||
| 1914 | -! | +|||
| 514 | +12x |
- as.character(subafun),+ check_ok_label(split_label) |
||
| 1915 | -! | +|||
| 515 | +
- mode = "function",+ |
|||
| 1916 | -! | +|||
| 516 | +12x |
- envir = parent.frame(1),+ label_pos <- match.arg(label_pos, label_pos_values) |
||
| 1917 | -! | +|||
| 517 | +12x |
- ifnotfound = list(NULL),+ child_labels <- match.arg(child_labels) |
||
| 1918 | -! | +|||
| 518 | +12x |
- inherits = TRUE+ if (.is_cut_lab_lst(cuts)) {
|
||
| 1919 | +519 | ! |
- )[[1]],+ cutlabels <- cuts[[2]] |
|
| 1920 | +520 | ! |
- afun- |
- |
| 1921 | -- |
- )+ cuts <- cuts[[1]] |
||
| 1922 | +521 |
- ) {
- |
- ||
| 1923 | -! | -
- dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")+ } |
||
| 1924 | -+ | |||
| 522 | +12x |
- } else {
+ if (is.unsorted(cuts, strictly = TRUE)) {
|
||
| 1925 | +523 | ! |
- dflt_row_lbl <- if (is.null(avar)) "count" else avar+ stop("invalid cuts vector. not sorted unique values.")
|
|
| 1926 | +524 |
} |
||
| 1927 | +525 | |||
| 1928 | -16x | +526 | +12x |
- if (is.null(afun)) {
+ if (is.null(cutlabels) && !is.null(names(cuts))) {
|
| 1929 | -5x | +527 | +1x |
- afun <- count+ cutlabels <- names(cuts)[-1] |
| 1930 | +528 |
- }+ } ## XXX is this always right? |
||
| 1931 | +529 | |||
| 1932 | -16x | +530 | +12x |
- if (is.null(avar)) {
+ new(cls, |
| 1933 | -5x | -
- avar <- names(data)[1]- |
- ||
| 1934 | -+ | 531 | +12x |
- }+ payload = var, |
| 1935 | -16x | +532 | +12x |
- fakeres <- afun(data[[avar]], ...)+ split_label = split_label, |
| 1936 | -16x | -
- multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups- |
- ||
| 1937 | -- |
- ## this is before we plug in the default so if not specified by the user- |
- ||
| 1938 | -+ | 533 | +12x |
- ## explicitly, row_labels is NULL at this point.+ cuts = cuts, |
| 1939 | -16x | +534 | +12x |
- if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
+ cut_labels = cutlabels, |
| 1940 | -2x | +535 | +12x |
- stop(+ content_fun = cfun, |
| 1941 | -2x | +536 | +12x |
- "Length of row_labels (",
+ content_format = cformat, |
| 1942 | -2x | +537 | +12x |
- length(row_labels),+ content_na_str = cna_str, |
| 1943 | -2x | +538 | +12x |
- ") does not agree with number of rows generated by analysis function (",
+ split_format = split_format, |
| 1944 | -2x | -
- n_cells_res(fakeres),- |
- ||
| 1945 | -- |
- ")."- |
- ||
| 1946 | -+ | 539 | +12x |
- )+ split_na_str = split_na_str, |
| 1947 | -+ | |||
| 540 | +12x |
- }+ name = split_name, |
||
| 1948 | -+ | |||
| 541 | +12x |
-
+ label_children = .labelkids_helper(child_labels), |
||
| 1949 | -14x | +542 | +12x |
- if (is.null(row_labels)) {
+ extra_args = extra_args, |
| 1950 | -10x | +543 | +12x |
- row_labels <- dflt_row_lbl+ indent_modifier = as.integer(indent_mod), |
| 1951 | -+ | |||
| 544 | +12x |
- }+ content_indent_modifier = as.integer(cindent_mod), |
||
| 1952 | -+ | |||
| 545 | +12x |
-
+ content_var = cvar, |
||
| 1953 | -14x | +546 | +12x |
- lyt <- basic_table(+ split_label_position = label_pos, |
| 1954 | -14x | +547 | +12x |
- title = title,+ content_extra_args = cextra_args, |
| 1955 | -14x | +548 | +12x |
- subtitles = subtitles,+ page_title_prefix = page_prefix, |
| 1956 | -14x | +549 | +12x |
- main_footer = main_footer,+ child_section_div = section_div, |
| 1957 | -14x | +550 | +12x |
- prov_footer = prov_footer,+ child_show_colcounts = show_colcounts, |
| 1958 | -14x | +551 | +12x |
- show_colcounts = show_colcounts+ child_colcount_format = colcount_format |
| 1959 | +552 |
) |
||
| 1960 | +553 | - - | -||
| 1961 | -14x | -
- for (var in col_vars) lyt <- split_cols_by(lyt, var)+ } |
||
| 1962 | +554 | |||
| 1963 | -14x | -
- for (var in head(row_vars, -1)) {
- |
- ||
| 1964 | -4x | -
- lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL)- |
- ||
| 1965 | -4x | -
- if (summarize_groups) {
- |
- ||
| 1966 | -2x | +|||
| 555 | +
- lyt <- summarize_row_groups(lyt)+ #' @exportClass CumulativeCutSplit |
|||
| 1967 | +556 |
- }+ #' @rdname cutsplits |
||
| 1968 | +557 |
- }+ setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")
|
||
| 1969 | +558 | |||
| 1970 | -14x | -
- tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character()- |
- ||
| 1971 | -14x | -
- if (length(row_vars) > 0) {
- |
- ||
| 1972 | -10x | -
- if (!multirow) {
- |
- ||
| 1973 | +559 |
- ## in the single row in splitting case, we use the row label as the topleft+ ## make_static_cut_split with cumulative=TRUE is the constructor |
||
| 1974 | +560 |
- ## and the split values as the row labels for a more compact apeparance- |
- ||
| 1975 | -6x | -
- tleft <- row_labels- |
- ||
| 1976 | -6x | -
- row_labels <- NA_character_+ ## for CumulativeCutSplit |
||
| 1977 | -6x | +|||
| 561 | +
- lyt <- split_rows_by(+ |
|||
| 1978 | -6x | +|||
| 562 | +
- lyt, tail(row_vars, 1),+ ## do we want this to be a CustomizableSplit instead of |
|||
| 1979 | -6x | +|||
| 563 | +
- split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden"+ ## taking cut_fun? |
|||
| 1980 | +564 |
- )+ ## cut_funct must take avector and no other arguments |
||
| 1981 | +565 |
- } else {
+ ## and return a named vector of cut points |
||
| 1982 | -4x | +|||
| 566 | +
- lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL)+ #' @exportClass VarDynCutSplit |
|||
| 1983 | +567 |
- }+ #' @rdname cutsplits |
||
| 1984 | -10x | +|||
| 568 | +
- if (summarize_groups) {
+ setClass("VarDynCutSplit",
|
|||
| 1985 | -2x | +|||
| 569 | +
- lyt <- summarize_row_groups(lyt)+ contains = "Split", |
|||
| 1986 | +570 |
- }+ representation( |
||
| 1987 | +571 |
- }+ cut_fun = "function", |
||
| 1988 | -14x | +|||
| 572 | +
- inner_afun <- .quick_afun(afun, row_labels)+ cut_label_fun = "function", |
|||
| 1989 | -14x | +|||
| 573 | +
- lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...))+ cumulative_cuts = "logical" |
|||
| 1990 | -14x | +|||
| 574 | +
- lyt <- append_topleft(lyt, tleft)+ ) |
|||
| 1991 | +575 |
- }+ ) |
||
| 1992 | +576 | |||
| 1993 | +577 |
- #' @rdname qtable_layout+ #' @export |
||
| 1994 | +578 |
- #' @export+ #' @rdname cutsplits |
||
| 1995 | +579 |
- qtable <- function(data,+ VarDynCutSplit <- function(var, |
||
| 1996 | +580 |
- row_vars = character(),+ split_label, |
||
| 1997 | +581 |
- col_vars = character(),+ cutfun, |
||
| 1998 | +582 |
- avar = NULL,+ cutlabelfun = function(x) NULL, |
||
| 1999 | +583 |
- row_labels = NULL,+ cfun = NULL, |
||
| 2000 | +584 |
- afun = NULL,+ cformat = NULL, |
||
| 2001 | +585 |
- summarize_groups = FALSE,+ cna_str = NA_character_, |
||
| 2002 | +586 |
- title = "",+ split_format = NULL, |
||
| 2003 | +587 |
- subtitles = character(),+ split_na_str = NA_character_, |
||
| 2004 | +588 |
- main_footer = character(),+ split_name = var, |
||
| 2005 | +589 |
- prov_footer = character(),+ child_labels = c("default", "visible", "hidden"),
|
||
| 2006 | +590 |
- show_colcounts = TRUE,+ extra_args = list(), |
||
| 2007 | +591 |
- drop_levels = TRUE,+ cumulative = FALSE, |
||
| 2008 | +592 |
- ...) {
+ indent_mod = 0L, |
||
| 2009 | +593 |
- ## this involves substitution so it needs to appear in both functions. Gross but true.+ cindent_mod = 0L, |
||
| 2010 | -16x | +|||
| 594 | +
- subafun <- substitute(afun)+ cvar = "", |
|||
| 2011 | +595 |
- if (+ cextra_args = list(), |
||
| 2012 | -16x | +|||
| 596 | +
- is.name(subafun) && is.function(afun) &&+ label_pos = "visible", |
|||
| 2013 | +597 |
- ## this is gross. basically testing+ page_prefix = NA_character_, |
||
| 2014 | +598 |
- ## if the symbol we have corresponds+ section_div = NA_character_, |
||
| 2015 | +599 |
- ## in some meaningful way to the function+ show_colcounts = FALSE, |
||
| 2016 | +600 |
- ## we will be calling.+ colcount_format = NULL) {
|
||
| 2017 | -16x | +601 | +6x |
- identical(+ check_ok_label(split_label) |
| 2018 | -16x | +602 | +6x |
- mget(+ label_pos <- match.arg(label_pos, label_pos_values) |
| 2019 | -16x | +603 | +6x |
- as.character(subafun),+ child_labels <- match.arg(child_labels) |
| 2020 | -16x | +604 | +6x |
- mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE+ new("VarDynCutSplit",
|
| 2021 | -16x | +605 | +6x |
- )[[1]],+ payload = var, |
| 2022 | -16x | -
- afun- |
- ||
| 2023 | -+ | 606 | +6x |
- )+ split_label = split_label, |
| 2024 | -+ | |||
| 607 | +6x |
- ) {
+ cut_fun = cutfun, |
||
| 2025 | -11x | +608 | +6x |
- dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")+ cumulative_cuts = cumulative, |
| 2026 | -+ | |||
| 609 | +6x |
- } else {
+ cut_label_fun = cutlabelfun, |
||
| 2027 | -5x | +610 | +6x |
- dflt_row_lbl <- if (is.null(avar)) "count" else avar+ content_fun = cfun, |
| 2028 | -+ | |||
| 611 | +6x |
- }+ content_format = cformat, |
||
| 2029 | -+ | |||
| 612 | +6x |
-
+ content_na_str = cna_str, |
||
| 2030 | -16x | +613 | +6x |
- lyt <- qtable_layout(+ split_format = split_format, |
| 2031 | -16x | +614 | +6x |
- data = data,+ split_na_str = split_na_str, |
| 2032 | -16x | +615 | +6x |
- row_vars = row_vars,+ name = split_name, |
| 2033 | -16x | +616 | +6x |
- col_vars = col_vars,+ label_children = .labelkids_helper(child_labels), |
| 2034 | -16x | +617 | +6x |
- avar = avar,+ extra_args = extra_args, |
| 2035 | -16x | +618 | +6x |
- row_labels = row_labels,+ indent_modifier = as.integer(indent_mod), |
| 2036 | -16x | +619 | +6x |
- afun = afun,+ content_indent_modifier = as.integer(cindent_mod), |
| 2037 | -16x | +620 | +6x |
- summarize_groups = summarize_groups,+ content_var = cvar, |
| 2038 | -16x | +621 | +6x |
- title = title,+ split_label_position = label_pos, |
| 2039 | -16x | +622 | +6x |
- subtitles = subtitles,+ content_extra_args = cextra_args, |
| 2040 | -16x | +623 | +6x |
- main_footer = main_footer,+ page_title_prefix = page_prefix, |
| 2041 | -16x | +624 | +6x |
- prov_footer = prov_footer,+ child_section_div = section_div, |
| 2042 | -16x | +625 | +6x |
- show_colcounts = show_colcounts,+ child_show_colcounts = show_colcounts, |
| 2043 | -16x | +626 | +6x |
- drop_levels = drop_levels,+ child_colcount_format = colcount_format |
| 2044 | +627 |
- ...,+ ) |
||
| 2045 | -16x | +|||
| 628 | +
- .default_rlabel = dflt_row_lbl+ } |
|||
| 2046 | +629 |
- )+ |
||
| 2047 | -14x | +|||
| 630 | +
- build_table(lyt, data)+ ## NB analyze splits can't have content-related things |
|||
| 2048 | +631 |
- }+ setClass("VAnalyzeSplit",
|
| 1 | +632 |
- #' Cell value constructors+ contains = "Split", |
||
| 2 | +633 |
- #'+ representation( |
||
| 3 | +634 |
- #' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.+ default_rowlabel = "character", |
||
| 4 | +635 |
- #'+ include_NAs = "logical", |
||
| 5 | +636 |
- #' @inheritParams compat_args+ var_label_position = "character" |
||
| 6 | +637 |
- #' @inheritParams lyt_args+ ) |
||
| 7 | +638 |
- #' @param x (`ANY`)\cr cell value.+ ) |
||
| 8 | +639 |
- #' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.+ |
||
| 9 | +640 |
- #' See [formatters::list_valid_format_labels()] for currently supported format labels.+ setClass("AnalyzeVarSplit",
|
||
| 10 | +641 |
- #' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.+ contains = "VAnalyzeSplit", |
||
| 11 | +642 |
- #' @param colspan (`integer(1)`)\cr column span value.+ representation(analysis_fun = "function") |
||
| 12 | +643 |
- #' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.+ ) |
||
| 13 | +644 |
- #'+ |
||
| 14 | +645 |
- #' @inherit CellValue return+ setClass("AnalyzeColVarSplit",
|
||
| 15 | +646 |
- #'+ contains = "VAnalyzeSplit", |
||
| 16 | +647 |
- #' @note Currently column spanning is only supported for defining header structure.+ representation(analysis_fun = "list") |
||
| 17 | +648 |
- #'+ ) |
||
| 18 | +649 |
- #' @rdname rcell+ |
||
| 19 | +650 |
- #' @export+ #' Define a subset tabulation/analysis |
||
| 20 | +651 |
- rcell <- function(x,+ #' |
||
| 21 | +652 |
- format = NULL,+ #' @inheritParams lyt_args |
||
| 22 | +653 |
- colspan = 1L,+ #' @inheritParams constr_args |
||
| 23 | +654 |
- label = NULL,+ #' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`. |
||
| 24 | +655 |
- indent_mod = NULL,+ #' |
||
| 25 | +656 |
- footnotes = NULL,+ #' @return An `AnalyzeVarSplit` object. |
||
| 26 | +657 |
- align = NULL,+ #' |
||
| 27 | +658 |
- format_na_str = NULL) {
+ #' @author Gabriel Becker |
||
| 28 | -31318x | +|||
| 659 | +
- if (!is.null(align)) {
+ #' @export |
|||
| 29 | -56x | +|||
| 660 | +
- check_aligns(align)+ #' @rdname avarspl |
|||
| 30 | +661 |
- }+ AnalyzeVarSplit <- function(var, |
||
| 31 | -31318x | +|||
| 662 | +
- if (is(x, "CellValue")) {
+ split_label = var, |
|||
| 32 | -18978x | +|||
| 663 | +
- if (!is.null(label)) {
+ afun, |
|||
| 33 | -1x | +|||
| 664 | +
- obj_label(x) <- label+ defrowlab = "", |
|||
| 34 | +665 |
- }+ cfun = NULL, |
||
| 35 | -18978x | +|||
| 666 | +
- if (colspan != 1L) {
+ cformat = NULL, |
|||
| 36 | -1x | +|||
| 667 | +
- cell_cspan(x) <- colspan+ split_format = NULL, |
|||
| 37 | +668 |
- }+ split_na_str = NA_character_, |
||
| 38 | -18978x | +|||
| 669 | +
- if (!is.null(indent_mod)) {
+ inclNAs = FALSE, |
|||
| 39 | -1x | +|||
| 670 | +
- indent_mod(x) <- indent_mod+ split_name = var, |
|||
| 40 | +671 |
- }+ extra_args = list(), |
||
| 41 | -18978x | +|||
| 672 | +
- if (!is.null(format)) {
+ indent_mod = 0L, |
|||
| 42 | -1x | +|||
| 673 | +
- obj_format(x) <- format+ label_pos = "default", |
|||
| 43 | +674 |
- }+ cvar = "",+ |
+ ||
| 675 | ++ |
+ section_div = NA_character_) {
|
||
| 44 | -18978x | +676 | +337x |
- if (!is.null(footnotes)) {
+ check_ok_label(split_label) |
| 45 | -357x | +677 | +337x |
- cell_footnotes(x) <- lapply(footnotes, RefFootnote)+ label_pos <- match.arg(label_pos, c("default", label_pos_values))
|
| 46 | -+ | |||
| 678 | +337x |
- }+ if (!any(nzchar(defrowlab))) {
|
||
| 47 | -18978x | +679 | +1x |
- if (!is.null(format_na_str)) {
+ defrowlab <- as.character(substitute(afun))+ |
+
| 680 | +1x | +
+ if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
|
||
| 48 | +681 | ! |
- obj_na_str(x) <- format_na_str+ defrowlab <- "" |
|
| 49 | +682 |
} |
||
| 683 | ++ |
+ }+ |
+ ||
| 50 | -18978x | +684 | +337x |
- ret <- x+ new("AnalyzeVarSplit",
|
| 51 | -+ | |||
| 685 | +337x |
- } else {
+ payload = var, |
||
| 52 | -12340x | +686 | +337x |
- if (is.null(label)) {
+ split_label = split_label, |
| 53 | -9413x | +687 | +337x |
- label <- obj_label(x)+ content_fun = cfun, |
| 54 | -+ | |||
| 688 | +337x |
- }+ analysis_fun = afun, |
||
| 55 | -12340x | +689 | +337x |
- if (is.null(format)) {
+ content_format = cformat, |
| 56 | -6806x | +690 | +337x |
- format <- obj_format(x)+ split_format = split_format, |
| 57 | -+ | |||
| 691 | +337x |
- }+ split_na_str = split_na_str, |
||
| 58 | -12340x | +692 | +337x |
- if (is.null(indent_mod)) {
+ default_rowlabel = defrowlab, |
| 59 | -12340x | +693 | +337x |
- indent_mod <- indent_mod(x)+ include_NAs = inclNAs, |
| 60 | -+ | |||
| 694 | +337x |
- }+ name = split_name, |
||
| 61 | -12340x | +695 | +337x |
- footnotes <- lapply(footnotes, RefFootnote)+ label_children = FALSE, |
| 62 | -12340x | +696 | +337x |
- ret <- CellValue(+ extra_args = extra_args, |
| 63 | -12340x | +697 | +337x |
- val = x,+ indent_modifier = as.integer(indent_mod), |
| 64 | -12340x | +698 | +337x |
- format = format,+ content_indent_modifier = 0L, |
| 65 | -12340x | +699 | +337x |
- colspan = colspan,+ var_label_position = label_pos, |
| 66 | -12340x | +700 | +337x |
- label = label,+ content_var = cvar, |
| 67 | -12340x | +701 | +337x |
- indent_mod = indent_mod,+ page_title_prefix = NA_character_, |
| 68 | -12340x | +702 | +337x |
- footnotes = footnotes,+ child_section_div = section_div, |
| 69 | -12340x | +703 | +337x |
- format_na_str = format_na_str+ child_show_colcounts = FALSE, |
| 70 | -12340x | +704 | +337x |
- ) # RefFootnote(footnote))+ child_colcount_format = NA_character_+ |
+
| 705 | +337x | +
+ ) ## no content_extra_args |
||
| 71 | +706 |
- }+ } |
||
| 72 | -31318x | +|||
| 707 | +
- if (!is.null(align)) {
+
|
|||
| 73 | -56x | +|||
| 708 | +
- cell_align(ret) <- align+ #' Define a subset tabulation/analysis |
|||
| 74 | +709 |
- }+ #' |
||
| 75 | -31318x | +|||
| 710 | +
- ret+ #' @inheritParams lyt_args |
|||
| 76 | +711 |
- }+ #' @inheritParams constr_args |
||
| 77 | +712 |
-
+ #' |
||
| 78 | +713 |
- #' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be+ #' @author Gabriel Becker |
||
| 79 | +714 |
- #' passed to this argument).+ #' @export |
||
| 80 | +715 |
- #' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.+ #' @rdname avarspl |
||
| 81 | +716 |
- #'+ AnalyzeColVarSplit <- function(afun, |
||
| 82 | +717 |
- #' @details+ defrowlab = "", |
||
| 83 | +718 |
- #' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should+ cfun = NULL, |
||
| 84 | +719 |
- #' be passed the value of `.in_ref_col` when it is used.+ cformat = NULL, |
||
| 85 | +720 |
- #'+ split_format = NULL, |
||
| 86 | +721 |
- #' @rdname rcell+ split_na_str = NA_character_, |
||
| 87 | +722 |
- #' @export+ inclNAs = FALSE, |
||
| 88 | +723 |
- non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,+ split_name = "", |
||
| 89 | +724 |
- label = NULL, indent_mod = NULL,+ extra_args = list(), |
||
| 90 | +725 |
- refval = NULL,+ indent_mod = 0L, |
||
| 91 | +726 |
- align = "center",+ label_pos = "default", |
||
| 92 | +727 |
- format_na_str = NULL) {
+ cvar = "",+ |
+ ||
| 728 | ++ |
+ section_div = NA_character_) {
|
||
| 93 | -2x | +729 | +23x |
- val <- if (is_ref) refval else x+ label_pos <- match.arg(label_pos, c("default", label_pos_values))
|
| 94 | -2x | +730 | +23x |
- rcell(val,+ new("AnalyzeColVarSplit",
|
| 95 | -2x | +731 | +23x |
- format = format, colspan = colspan, label = label,+ payload = NA_character_, |
| 96 | -2x | +732 | +23x |
- indent_mod = indent_mod, align = align,+ split_label = "", |
| 97 | -2x | +733 | +23x |
- format_na_str = format_na_str+ content_fun = cfun, |
| 98 | -+ | |||
| 734 | +23x |
- )+ analysis_fun = afun, |
||
| 99 | -+ | |||
| 735 | +23x |
- }+ content_format = cformat, |
||
| 100 | -+ | |||
| 736 | +23x |
-
+ split_format = split_format, |
||
| 101 | -+ | |||
| 737 | +23x |
- #' Create multiple rows in analysis or summary functions+ split_na_str = split_na_str, |
||
| 102 | -+ | |||
| 738 | +23x |
- #'+ default_rowlabel = defrowlab, |
||
| 103 | -+ | |||
| 739 | +23x |
- #' Define the cells that get placed into multiple rows in `afun`.+ include_NAs = inclNAs, |
||
| 104 | -+ | |||
| 740 | +23x |
- #'+ name = split_name, |
||
| 105 | -+ | |||
| 741 | +23x |
- #' @param ... single row defining expressions.+ label_children = FALSE, |
||
| 106 | -+ | |||
| 742 | +23x |
- #' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.+ extra_args = extra_args, |
||
| 107 | -+ | |||
| 743 | +23x |
- #' @param .names (`character` or `NULL`)\cr names of the returned list/structure.+ indent_modifier = as.integer(indent_mod), |
||
| 108 | -+ | |||
| 744 | +23x |
- #' @param .labels (`character` or `NULL`)\cr labels for the defined rows.+ content_indent_modifier = 0L, |
||
| 109 | -+ | |||
| 745 | +23x |
- #' @param .formats (`character` or `NULL`)\cr formats for the values.+ var_label_position = label_pos, |
||
| 110 | -+ | |||
| 746 | +23x |
- #' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.+ content_var = cvar, |
||
| 111 | -+ | |||
| 747 | +23x |
- #' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*.+ page_title_prefix = NA_character_, |
||
| 112 | -+ | |||
| 748 | +23x |
- #' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*.+ child_section_div = section_div, |
||
| 113 | -+ | |||
| 749 | +23x |
- #' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.+ child_show_colcounts = FALSE, |
||
| 114 | -+ | |||
| 750 | +23x |
- #' See [formatters::list_valid_aligns()] for currently supported alignments.+ child_colcount_format = NA_character_ |
||
| 115 | -+ | |||
| 751 | +23x |
- #' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.+ ) ## no content_extra_args |
||
| 116 | +752 |
- #'+ } |
||
| 117 | +753 |
- #' @note In post-processing, referential footnotes can also be added using row and column+ |
||
| 118 | +754 |
- #' paths with [`fnotes_at_path<-`].+ setClass("CompoundSplit",
|
||
| 119 | +755 |
- #'+ contains = "Split", |
||
| 120 | +756 |
- #' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an+ validity = function(object) are(object@payload, "Split") |
||
| 121 | +757 |
- #' internal implementation detail.+ ) |
||
| 122 | +758 |
- #'+ |
||
| 123 | +759 |
- #' @seealso [analyze()]+ setClass("AnalyzeMultiVars", contains = "CompoundSplit")
|
||
| 124 | +760 |
- #'+ |
||
| 125 | +761 |
- #' @examples+ .repoutlst <- function(x, nv) {
|
||
| 126 | -+ | |||
| 762 | +1854x |
- #' in_rows(1, 2, 3, .names = c("a", "b", "c"))
+ if (!is.function(x) && length(x) == nv) {
|
||
| 127 | -+ | |||
| 763 | +891x |
- #' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
+ return(x) |
||
| 128 | +764 |
- #' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
+ } |
||
| 129 | -+ | |||
| 765 | +963x |
- #'+ if (!is(x, "list")) {
|
||
| 130 | -+ | |||
| 766 | +963x |
- #' in_rows(.list = list(a = 1, b = 2, c = 3))+ x <- list(x) |
||
| 131 | +767 |
- #' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
+ } |
||
| 132 | -+ | |||
| 768 | +963x |
- #'+ rep(x, length.out = nv) |
||
| 133 | +769 |
- #' lyt <- basic_table() %>%+ } |
||
| 134 | +770 |
- #' split_cols_by("ARM") %>%
+
|
||
| 135 | +771 |
- #' analyze("AGE", afun = function(x) {
+ .uncompound <- function(csplit) {
|
||
| 136 | -+ | |||
| 772 | +63x |
- #' in_rows(+ if (is(csplit, "list")) {
|
||
| 137 | -+ | |||
| 773 | +3x |
- #' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ return(unlist(lapply(csplit, .uncompound))) |
||
| 138 | +774 |
- #' "Range" = rcell(range(x), format = "xx.xx - xx.xx")+ } |
||
| 139 | +775 |
- #' )+ |
||
| 140 | -+ | |||
| 776 | +60x |
- #' })+ if (!is(csplit, "CompoundSplit")) {
|
||
| 141 | -+ | |||
| 777 | +59x |
- #'+ return(csplit) |
||
| 142 | +778 |
- #' tbl <- build_table(lyt, ex_adsl)+ } |
||
| 143 | +779 |
- #' tbl+ |
||
| 144 | -+ | |||
| 780 | +1x |
- #'+ pld <- spl_payload(csplit) |
||
| 145 | -+ | |||
| 781 | +1x |
- #' @export+ done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit")) |
||
| 146 | -+ | |||
| 782 | +1x |
- in_rows <- function(..., .list = NULL, .names = NULL,+ if (done) {
|
||
| 147 | -+ | |||
| 783 | +1x |
- .labels = NULL,+ pld |
||
| 148 | +784 |
- .formats = NULL,+ } else {
|
||
| 149 | -+ | |||
| 785 | +! |
- .indent_mods = NULL,+ unlist(lapply(pld, .uncompound)) |
||
| 150 | +786 |
- .cell_footnotes = list(NULL),+ } |
||
| 151 | +787 |
- .row_footnotes = list(NULL),+ } |
||
| 152 | +788 |
- .aligns = NULL,+ |
||
| 153 | +789 |
- .format_na_strs = NULL) {
+ strip_compound_name <- function(obj) {
|
||
| 154 | -5819x | +790 | +11x |
- if (is.function(.formats)) {
+ nm <- obj_name(obj) |
| 155 | -! | +|||
| 791 | +11x |
- .formats <- list(.formats)+ gsub("^ma_", "", nm)
|
||
| 156 | +792 |
- }+ } |
||
| 157 | +793 | |||
| 158 | -5819x | +|||
| 794 | +
- l <- c(list(...), .list)+ make_ma_name <- function(spl, pld = spl_payload(spl)) {
|
|||
| 159 | -+ | |||
| 795 | +3x |
-
+ paste( |
||
| 160 | -5819x | +796 | +3x |
- if (missing(.names) && missing(.labels)) {
+ c( |
| 161 | -1755x | +797 | +3x |
- if (length(l) > 0 && is.null(names(l))) {
+ "ma", |
| 162 | -! | +|||
| 798 | +3x |
- stop("need a named list")
+ vapply(pld, strip_compound_name, "") |
||
| 163 | +799 |
- } else {
+ ), |
||
| 164 | -1755x | +800 | +3x |
- .names <- names(l)+ collapse = "_" |
| 165 | +801 |
- }+ ) |
||
| 166 | -1755x | +|||
| 802 | +
- stopifnot(!anyNA(.names))+ } |
|||
| 167 | +803 |
- }+ |
||
| 168 | +804 |
-
+ #' @param .payload (`list`)\cr used internally, not intended to be set by end users. |
||
| 169 | -5819x | +|||
| 805 | +
- if (length(l) == 0) {
+ #' |
|||
| 170 | +806 |
- if (+ #' @return An `AnalyzeMultiVars` split object. |
||
| 171 | -! | +|||
| 807 | +
- length(.labels) > 0 ||+ #' |
|||
| 172 | -! | +|||
| 808 | +
- length(.formats) > 0 ||+ #' @export |
|||
| 173 | -! | +|||
| 809 | +
- length(.names) > 0 ||+ #' @rdname avarspl |
|||
| 174 | -! | +|||
| 810 | +
- length(.indent_mods) > 0 ||+ AnalyzeMultiVars <- function(var, |
|||
| 175 | -! | +|||
| 811 | +
- length(.format_na_strs) > 0+ split_label = "", |
|||
| 176 | +812 |
- ) {
+ afun, |
||
| 177 | -! | +|||
| 813 | +
- stop(+ defrowlab = "", |
|||
| 178 | -! | +|||
| 814 | +
- "in_rows got 0 rows but length >0 of at least one of ",+ cfun = NULL, |
|||
| 179 | -! | +|||
| 815 | +
- ".labels, .formats, .names, .indent_mods, .format_na_strs. ",+ cformat = NULL, |
|||
| 180 | -! | +|||
| 816 | +
- "Does your analysis/summary function handle the 0 row ",+ split_format = NULL, |
|||
| 181 | -! | +|||
| 817 | +
- "df/length 0 x case?"+ split_na_str = NA_character_, |
|||
| 182 | +818 |
- )+ inclNAs = FALSE, |
||
| 183 | +819 |
- }+ .payload = NULL, |
||
| 184 | -! | +|||
| 820 | +
- l2 <- list()+ split_name = NULL, |
|||
| 185 | +821 |
- } else {
+ extra_args = list(), |
||
| 186 | -5819x | +|||
| 822 | +
- if (is.null(.formats)) {
+ indent_mod = 0L, |
|||
| 187 | -5359x | +|||
| 823 | +
- .formats <- list(NULL)+ child_labels = c("default", "topleft", "visible", "hidden"),
|
|||
| 188 | +824 |
- }+ child_names = var, |
||
| 189 | -5819x | +|||
| 825 | +
- stopifnot(is.list(.cell_footnotes))+ cvar = "", |
|||
| 190 | -5819x | +|||
| 826 | +
- if (length(.cell_footnotes) != length(l)) {
+ section_div = NA_character_) {
|
|||
| 191 | -1234x | +|||
| 827 | +
- .cell_footnotes <- c(+ ## NB we used to resolve to strict TRUE/FALSE for label visibillity |
|||
| 192 | -1234x | +|||
| 828 | +
- .cell_footnotes,+ ## in this function but that was too greedy for repeated |
|||
| 193 | -1234x | +|||
| 829 | +
- setNames(+ ## analyze calls, so that now occurs in the tabulation machinery |
|||
| 194 | -1234x | +|||
| 830 | +
- rep(list(character()),+ ## when the table is actually being built.+ |
+ |||
| 831 | ++ |
+ ## show_kidlabs = .labelkids_helper(match.arg(child_labels)) |
||
| 195 | -1234x | +832 | +334x |
- length.out = length(setdiff(+ child_labels <- match.arg(child_labels) |
| 196 | -1234x | +833 | +334x |
- names(l),+ show_kidlabs <- child_labels |
| 197 | -1234x | +834 | +334x |
- names(.cell_footnotes)+ if (is.null(.payload)) {
|
| 198 | -+ | |||
| 835 | +309x |
- ))+ nv <- length(var) |
||
| 199 | -+ | |||
| 836 | +309x |
- ),+ defrowlab <- .repoutlst(defrowlab, nv) |
||
| 200 | -1234x | +837 | +309x |
- setdiff(+ afun <- .repoutlst(afun, nv) |
| 201 | -1234x | +838 | +309x |
- names(l),+ split_label <- .repoutlst(split_label, nv) |
| 202 | -1234x | +839 | +309x |
- names(.cell_footnotes)+ check_ok_label(split_label, multi_ok = TRUE) |
| 203 | -+ | |||
| 840 | +309x |
- )+ cfun <- .repoutlst(cfun, nv) |
||
| 204 | -+ | |||
| 841 | +309x |
- )+ cformat <- .repoutlst(cformat, nv) |
||
| 205 | +842 |
- )+ ## split_format = .repoutlst(split_format, nv) |
||
| 206 | -1234x | +843 | +309x |
- .cell_footnotes <- .cell_footnotes[names(l)]+ inclNAs <- .repoutlst(inclNAs, nv) |
| 207 | -+ | |||
| 844 | +309x |
- }+ section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div |
||
| 208 | -5819x | +845 | +309x |
- if (is.null(.aligns)) {
+ pld <- mapply(AnalyzeVarSplit, |
| 209 | -5816x | +846 | +309x |
- .aligns <- list(NULL)+ var = var, |
| 210 | -+ | |||
| 847 | +309x |
- }+ split_name = child_names, |
||
| 211 | -5819x | +848 | +309x |
- l2 <- mapply(rcell,+ split_label = split_label, |
| 212 | -5819x | +849 | +309x |
- x = l, format = .formats,+ afun = afun, |
| 213 | -5819x | +850 | +309x |
- footnotes = .cell_footnotes %||% list(NULL),+ defrowlab = defrowlab, |
| 214 | -5819x | +851 | +309x |
- align = .aligns,+ cfun = cfun, |
| 215 | -5819x | +852 | +309x |
- format_na_str = .format_na_strs %||% list(NULL),+ cformat = cformat,+ |
+
| 853 | ++ |
+ ## split_format = split_format, |
||
| 216 | -5819x | +854 | +309x |
- SIMPLIFY = FALSE+ inclNAs = inclNAs, |
| 217 | -+ | |||
| 855 | +309x |
- )+ MoreArgs = list( |
||
| 218 | -+ | |||
| 856 | +309x |
- }+ extra_args = extra_args, |
||
| 219 | -5819x | +857 | +309x |
- if (is.null(.labels)) {
+ indent_mod = indent_mod, |
| 220 | -2619x | +858 | +309x |
- objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "")+ label_pos = show_kidlabs, |
| 221 | -2619x | +859 | +309x |
- if (any(nzchar(objlabs))) {
+ split_format = split_format, |
| 222 | -69x | +860 | +309x |
- .labels <- objlabs+ split_na_str = split_na_str,+ |
+
| 861 | +309x | +
+ section_div = section_div_if_multivar+ |
+ ||
| 862 | +309x | +
+ ), ## rvis),+ |
+ ||
| 863 | +309x | +
+ SIMPLIFY = FALSE |
||
| 223 | +864 |
- }+ ) |
||
| 224 | +865 |
- }+ } else {
|
||
| 225 | +866 |
-
+ ## we're combining existing splits here |
||
| 226 | -5819x | +867 | +25x |
- if (is.null(.names) && !is.null(names(l))) {
+ pld <- unlist(lapply(.payload, .uncompound)) |
| 227 | -97x | +|||
| 868 | +
- .names <- names(l)+ |
|||
| 228 | +869 |
- }+ ## only override the childen being combined if the constructor |
||
| 229 | -5819x | +|||
| 870 | +
- stopifnot(is.list(.row_footnotes))+ ## was passed a non-default value for child_labels |
|||
| 230 | -5819x | +|||
| 871 | +
- if (length(.row_footnotes) != length(l2)) {
+ ## and the child was at NA before |
|||
| 231 | -1234x | +872 | +25x |
- tmp <- .row_footnotes+ pld <- lapply( |
| 232 | -1234x | +873 | +25x |
- .row_footnotes <- vector("list", length(l2))
+ pld, |
| 233 | -1234x | +874 | +25x |
- pos <- match(names(tmp), .names)+ function(x) {
|
| 234 | -1234x | +875 | +50x |
- nonna <- which(!is.na(pos))+ rvis <- label_position(x) ## labelrow_visible(x) |
| 235 | -1234x | +876 | +50x |
- .row_footnotes[pos] <- tmp[nonna]+ if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
+ |
+
| 877 | +! | +
+ if (identical(rvis, "default")) { ## ois.na(rvis))
+ |
+ ||
| 878 | +! | +
+ rvis <- show_kidlabs |
||
| 236 | +879 |
- # length(.row_footnotes) <- length(l2)+ } |
||
| 237 | +880 |
- }+ } |
||
| 238 | -5819x | +881 | +50x |
- ret <- RowsVerticalSection(l2,+ label_position(x) <- rvis |
| 239 | -5819x | +882 | +50x |
- names = .names,+ x+ |
+
| 883 | ++ |
+ }+ |
+ ||
| 884 | ++ |
+ )+ |
+ ||
| 885 | ++ |
+ } |
||
| 240 | -5819x | +886 | +334x |
- labels = .labels,+ if (length(pld) == 1) {
|
| 241 | -5819x | +887 | +286x |
- indent_mods = .indent_mods,+ ret <- pld[[1]]+ |
+
| 888 | ++ |
+ } else {
|
||
| 242 | -5819x | +889 | +48x |
- formats = .formats,+ if (is.null(split_name)) {
|
| 243 | -5819x | +890 | +48x |
- footnotes = .row_footnotes,+ split_name <- paste(c("ma", vapply(pld, obj_name, "")),
|
| 244 | -5819x | +891 | +48x |
- format_na_strs = .format_na_strs+ collapse = "_" |
| 245 | +892 |
- )+ ) |
||
| 246 | +893 |
- ## if(!is.null(.names))+ } |
||
| 247 | -+ | |||
| 894 | +48x |
- ## names(l2) <- .names+ ret <- new("AnalyzeMultiVars",
|
||
| 248 | -+ | |||
| 895 | +48x |
- ## else+ payload = pld, |
||
| 249 | -+ | |||
| 896 | +48x |
- ## names(l2) <- names(l)+ split_label = "", |
||
| 250 | -! | +|||
| 897 | +48x |
- if (length(ret) == 0) NULL else ret+ split_format = NULL, |
||
| 251 | -+ | |||
| 898 | +48x |
-
+ split_na_str = split_na_str, |
||
| 252 | -+ | |||
| 899 | +48x |
- ## if (length(l) == 0) NULL else l+ content_fun = NULL,+ |
+ ||
| 900 | +48x | +
+ content_format = NULL, |
||
| 253 | +901 |
- }+ ## I beleive this is superfluous now |
||
| 254 | +902 |
-
+ ## the payloads carry aroudn the real instructions |
||
| 255 | +903 |
- .validate_nms <- function(vals, .stats, arg) {
+ ## XXX |
||
| 256 | -268x | +904 | +48x |
- if (!is.null(arg)) {
+ label_children = .labelkids_helper(show_kidlabs), |
| 257 | -112x | +905 | +48x |
- if (is.null(names(arg))) {
+ split_label_position = "hidden", ## XXX is this right? |
| 258 | -! | +|||
| 906 | +48x |
- stopifnot(length(arg) == length(.stats))+ name = split_name, |
||
| 259 | -! | +|||
| 907 | +48x |
- names(arg) <- names(vals)+ extra_args = extra_args, |
||
| 260 | +908 |
- } else {
+ ## modifier applied on splits in payload |
||
| 261 | -112x | +909 | +48x |
- lblpos <- match(names(arg), names(vals))+ indent_modifier = 0L, |
| 262 | -112x | +910 | +48x |
- stopifnot(!anyNA(lblpos))+ content_indent_modifier = 0L,+ |
+
| 911 | +48x | +
+ content_var = cvar,+ |
+ ||
| 912 | +48x | +
+ page_title_prefix = NA_character_,+ |
+ ||
| 913 | +48x | +
+ child_section_div = section_div |
||
| 263 | +914 |
- }+ ) |
||
| 264 | +915 |
} |
||
| 265 | -268x | +916 | +334x |
- arg+ ret |
| 266 | +917 |
} |
||
| 267 | +918 | |||
| 268 | +919 |
- #' Create a custom analysis function wrapping an existing function+ setClass("VarLevWBaselineSplit",
|
||
| 269 | +920 |
- #'+ contains = "VarLevelSplit", |
||
| 270 | +921 |
- #' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.+ representation( |
||
| 271 | +922 |
- #' `fun` should return a named `list`.+ var = "character", |
||
| 272 | +923 |
- #' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.+ ref_group_value = "character" |
||
| 273 | +924 |
- #' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.+ ) |
||
| 274 | +925 |
- #' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.+ ) |
||
| 275 | +926 |
- #' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.+ |
||
| 276 | +927 |
- #' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.+ #' @rdname VarLevelSplit |
||
| 277 | +928 |
- #' @param ... additional arguments to `fun` which effectively become new defaults. These can still be+ #' @export |
||
| 278 | +929 |
- #' overridden by `extra_args` within a split.+ VarLevWBaselineSplit <- function(var, |
||
| 279 | +930 |
- #' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the+ ref_group, |
||
| 280 | +931 |
- #' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note+ labels_var = var, |
||
| 281 | +932 |
- #' this argument occurs after `...` so it must be *fully* specified by name when set.+ split_label, |
||
| 282 | +933 |
- #' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.+ split_fun = NULL, |
||
| 283 | +934 |
- #'+ label_fstr = "%s - %s", |
||
| 284 | +935 |
- #' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling+ ## not needed I Think... |
||
| 285 | +936 |
- #' performed automatically.+ cfun = NULL, |
||
| 286 | +937 |
- #'+ cformat = NULL, |
||
| 287 | +938 |
- #' @note+ cna_str = NA_character_, |
||
| 288 | +939 |
- #' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than+ cvar = "", |
||
| 289 | +940 |
- #' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that+ split_format = NULL, |
||
| 290 | +941 |
- #' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,+ split_na_str = NA_character_, |
||
| 291 | +942 |
- #' *not* the original structure returned by `fun`. See the final pair of examples below.+ valorder = NULL, |
||
| 292 | +943 |
- #'+ split_name = var, |
||
| 293 | +944 |
- #' @seealso [analyze()]+ extra_args = list(), |
||
| 294 | +945 |
- #'+ show_colcounts = FALSE, |
||
| 295 | +946 |
- #' @examples+ colcount_format = NULL) {
|
||
| 296 | -+ | |||
| 947 | +10x |
- #' s_summary <- function(x) {
+ check_ok_label(split_label) |
||
| 297 | -+ | |||
| 948 | +10x |
- #' stopifnot(is.numeric(x))+ new("VarLevWBaselineSplit",
|
||
| 298 | -+ | |||
| 949 | +10x |
- #'+ payload = var, |
||
| 299 | -+ | |||
| 950 | +10x |
- #' list(+ ref_group_value = ref_group, |
||
| 300 | +951 |
- #' n = sum(!is.na(x)),+ ## This will occur at the row level not on the column split, for now |
||
| 301 | +952 |
- #' mean_sd = c(mean = mean(x), sd = sd(x)),+ ## TODO revisit this to confirm its right |
||
| 302 | +953 |
- #' min_max = range(x)+ ## comparison_func = comparison, |
||
| 303 | +954 |
- #' )+ # label_format = label_fstr, |
||
| 304 | -+ | |||
| 955 | +10x |
- #' }+ value_label_var = labels_var, |
||
| 305 | -+ | |||
| 956 | +10x |
- #'+ split_label = split_label, |
||
| 306 | -+ | |||
| 957 | +10x |
- #' s_summary(iris$Sepal.Length)+ content_fun = cfun, |
||
| 307 | -+ | |||
| 958 | +10x |
- #'+ content_format = cformat, |
||
| 308 | -+ | |||
| 959 | +10x |
- #' a_summary <- make_afun(+ content_na_str = cna_str, |
||
| 309 | -+ | |||
| 960 | +10x |
- #' fun = s_summary,+ split_format = split_format, |
||
| 310 | -+ | |||
| 961 | +10x |
- #' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),+ split_na_str = split_na_str, |
||
| 311 | -+ | |||
| 962 | +10x |
- #' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")+ split_fun = split_fun, |
||
| 312 | -+ | |||
| 963 | +10x |
- #' )+ name = split_name, |
||
| 313 | -+ | |||
| 964 | +10x |
- #'+ label_children = FALSE, |
||
| 314 | -+ | |||
| 965 | +10x |
- #' a_summary(x = iris$Sepal.Length)+ extra_args = extra_args, |
||
| 315 | +966 |
- #'+ ## this is always a column split |
||
| 316 | -+ | |||
| 967 | +10x |
- #' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
+ indent_modifier = 0L, |
||
| 317 | -+ | |||
| 968 | +10x |
- #'+ content_indent_modifier = 0L, |
||
| 318 | -+ | |||
| 969 | +10x |
- #' a_summary2(x = iris$Sepal.Length)+ content_var = cvar, |
||
| 319 | +970 |
- #'+ ## so long as this is columnspace only |
||
| 320 | -+ | |||
| 971 | +10x |
- #' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))+ page_title_prefix = NA_character_, |
||
| 321 | -+ | |||
| 972 | +10x |
- #'+ child_section_div = NA_character_, |
||
| 322 | -+ | |||
| 973 | +10x |
- #' s_foo <- function(df, .N_col, a = 1, b = 2) {
+ child_show_colcounts = show_colcounts, |
||
| 323 | -+ | |||
| 974 | +10x |
- #' list(+ child_colcount_format = colcount_format |
||
| 324 | +975 |
- #' nrow_df = nrow(df),+ ) |
||
| 325 | +976 |
- #' .N_col = .N_col,+ } |
||
| 326 | +977 |
- #' a = a,+ |
||
| 327 | +978 |
- #' b = b+ .chkname <- function(nm) {
|
||
| 328 | -+ | |||
| 979 | +19152x |
- #' )+ if (is.null(nm)) {
|
||
| 329 | -+ | |||
| 980 | +! |
- #' }+ nm <- "" |
||
| 330 | +981 |
- #'+ } |
||
| 331 | -+ | |||
| 982 | +19152x |
- #' s_foo(iris, 40)+ if (length(nm) != 1) {
|
||
| 332 | -+ | |||
| 983 | +! |
- #'+ stop("name is not of length one")
|
||
| 333 | -+ | |||
| 984 | +19152x |
- #' a_foo <- make_afun(s_foo,+ } else if (is.na(nm)) {
|
||
| 334 | -+ | |||
| 985 | +! |
- #' b = 4,+ warning("Got missing value for name, converting to characters '<NA>'")
|
||
| 335 | -+ | |||
| 986 | +! |
- #' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),+ nm <- "<NA>" |
||
| 336 | +987 |
- #' .labels = c(+ } |
||
| 337 | -+ | |||
| 988 | +19152x |
- #' nrow_df = "Nrow df",+ nm |
||
| 338 | +989 |
- #' ".N_col" = "n in cols", a = "a value", b = "b value"+ } |
||
| 339 | +990 |
- #' ),+ |
||
| 340 | +991 |
- #' .indent_mods = c(nrow_df = 2L, a = 1L)+ ### Tree Position Representation |
||
| 341 | +992 |
- #' )+ ### |
||
| 342 | +993 |
- #'+ ### Class(es) that represent position with in a |
||
| 343 | +994 |
- #' a_foo(iris, .N_col = 40)+ ### tree as parallel vectors of Split objects and |
||
| 344 | +995 |
- #' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))+ ### values chosen at that split, plus labeling info |
||
| 345 | +996 |
- #' a_foo2(iris, .N_col = 40)+ TreePos <- function(spls = list(), |
||
| 346 | +997 |
- #'+ svals = list(), |
||
| 347 | +998 |
- #' # grouping and further customization+ svlabels = character(), |
||
| 348 | +999 |
- #' s_grp <- function(df, .N_col, a = 1, b = 2) {
+ sub = NULL) {
|
||
| 349 | -+ | |||
| 1000 | +1745x |
- #' list(+ check_ok_label(svlabels, multi_ok = TRUE) |
||
| 350 | -+ | |||
| 1001 | +1745x |
- #' nrow_df = nrow(df),+ svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr)) |
||
| 351 | -+ | |||
| 1002 | +1745x |
- #' .N_col = .N_col,+ if (is.null(sub)) {
|
||
| 352 | -+ | |||
| 1003 | +369x |
- #' letters = list(+ if (length(spls) > 0) {
|
||
| 353 | -+ | |||
| 1004 | +! |
- #' a = a,+ sub <- make_pos_subset( |
||
| 354 | -+ | |||
| 1005 | +! |
- #' b = b+ spls = spls, |
||
| 355 | -+ | |||
| 1006 | +! |
- #' )+ svals = svals |
||
| 356 | +1007 |
- #' )+ ) |
||
| 357 | +1008 |
- #' }+ } else {
|
||
| 358 | -+ | |||
| 1009 | +369x |
- #' a_grp <- make_afun(s_grp,+ sub <- expression(TRUE) |
||
| 359 | +1010 |
- #' b = 3,+ } |
||
| 360 | +1011 |
- #' .labels = c(+ } |
||
| 361 | -+ | |||
| 1012 | +1745x |
- #' nrow_df = "row count",+ new("TreePos",
|
||
| 362 | -+ | |||
| 1013 | +1745x |
- #' .N_col = "count in column"+ splits = spls, s_values = svals, |
||
| 363 | -+ | |||
| 1014 | +1745x |
- #' ),+ sval_labels = svlabels, |
||
| 364 | -+ | |||
| 1015 | +1745x |
- #' .formats = c(nrow_df = "xx.", .N_col = "xx."),+ subset = sub |
||
| 365 | +1016 |
- #' .indent_mods = c(letters = 1L),+ ) |
||
| 366 | +1017 |
- #' .ungroup_stats = "letters"+ } |
||
| 367 | +1018 |
- #' )+ |
||
| 368 | +1019 |
- #' a_grp(iris, 40)+ ## Tree position convenience functions |
||
| 369 | +1020 |
- #' a_aftergrp <- make_afun(a_grp,+ ## |
||
| 370 | +1021 |
- #' .stats = c("nrow_df", "b"),
+ make_child_pos <- function(parpos, |
||
| 371 | +1022 |
- #' .formats = c(b = "xx.")+ newspl, |
||
| 372 | +1023 |
- #' )+ newval, |
||
| 373 | +1024 |
- #' a_aftergrp(iris, 40)+ newlab = newval, |
||
| 374 | +1025 |
- #'+ newextra = list()) {
|
||
| 375 | -- |
- #' s_ref <- function(x, .in_ref_col, .ref_group) {
+ | ||
| 1026 | +1376x | +
+ if (!is(newval, "SplitValue")) {
|
||
| 376 | -+ | |||
| 1027 | +! |
- #' list(+ nsplitval <- SplitValue(newval, extr = newextra, label = newlab) |
||
| 377 | +1028 |
- #' mean_diff = mean(x) - mean(.ref_group)+ } else {
|
||
| 378 | -+ | |||
| 1029 | +1376x |
- #' )+ nsplitval <- newval |
||
| 379 | +1030 |
- #' }+ } |
||
| 380 | -+ | |||
| 1031 | +1376x |
- #'+ check_ok_label(newlab) |
||
| 381 | -+ | |||
| 1032 | +1376x |
- #' a_ref <- make_afun(s_ref,+ newpos <- TreePos( |
||
| 382 | -+ | |||
| 1033 | +1376x |
- #' .labels = c(mean_diff = "Mean Difference from Ref")+ spls = c(pos_splits(parpos), newspl), |
||
| 383 | -+ | |||
| 1034 | +1376x |
- #' )+ svals = c(pos_splvals(parpos), nsplitval),+ |
+ ||
| 1035 | +1376x | +
+ svlabels = c(pos_splval_labels(parpos), newlab),+ |
+ ||
| 1036 | +1376x | +
+ sub = .combine_subset_exprs(+ |
+ ||
| 1037 | +1376x | +
+ pos_subset(parpos), |
||
| 384 | +1038 |
- #' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)+ ## this will grab the value's custom subset expression if present+ |
+ ||
| 1039 | +1376x | +
+ make_subset_expr(newspl, nsplitval) |
||
| 385 | +1040 |
- #' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)+ ) |
||
| 386 | +1041 |
- #'+ )+ |
+ ||
| 1042 | +1376x | +
+ newpos |
||
| 387 | +1043 |
- #' @export+ } |
||
| 388 | +1044 |
- make_afun <- function(fun,+ |
||
| 389 | +1045 |
- .stats = NULL,+ ## Virtual Classes for Tree Nodes and Layouts ================================= |
||
| 390 | +1046 |
- .formats = NULL,+ ## |
||
| 391 | +1047 |
- .labels = NULL,+ ## Virtual class hiearchy for the various types of trees in use in the S4 |
||
| 392 | +1048 |
- .indent_mods = NULL,+ ## implementation of the TableTree machinery |
||
| 393 | +1049 |
- .ungroup_stats = NULL,+ |
||
| 394 | +1050 |
- .format_na_strs = NULL,+ ## core basics |
||
| 395 | +1051 |
- ...,+ setClass("VNodeInfo",
|
||
| 396 | +1052 |
- .null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
+ contains = "VIRTUAL", |
||
| 397 | +1053 |
- ## there is a LOT more computing-on-the-language hackery in here that I+ representation( |
||
| 398 | +1054 |
- ## would prefer, but currently this is the way I see to do everything we+ level = "integer", |
||
| 399 | +1055 |
- ## want to do.+ name = "character" ## , |
||
| 400 | +1056 |
-
+ ## label = "character" |
||
| 401 | +1057 |
- ## too clever by three-quarters (because half wasn't enough)+ ) |
||
| 402 | +1058 |
- ## gross scope hackery+ ) |
||
| 403 | -23x | +|||
| 1059 | +
- fun_args <- force(list(...))+ |
|||
| 404 | -23x | +|||
| 1060 | +
- fun_fnames <- names(formals(fun))+ setClass("VTree",
|
|||
| 405 | +1061 |
-
+ contains = c("VIRTUAL", "VNodeInfo"),
|
||
| 406 | +1062 |
- ## force EVERYTHING otherwise calling this within loops is the stuff of+ representation(children = "list") |
||
| 407 | +1063 |
- ## nightmares+ ) |
||
| 408 | -23x | +|||
| 1064 | +
- force(.stats)+ |
|||
| 409 | -23x | +|||
| 1065 | +
- force(.formats)+ setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))
|
|||
| 410 | -23x | +|||
| 1066 | +
- force(.format_na_strs)+ |
|||
| 411 | -23x | +|||
| 1067 | +
- force(.labels)+ ## Layout trees ================================= |
|||
| 412 | -23x | +|||
| 1068 | +
- force(.indent_mods)+ |
|||
| 413 | -23x | +|||
| 1069 | +
- force(.ungroup_stats)+ # setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))
|
|||
| 414 | -23x | +|||
| 1070 | +
- force(.null_ref_cells) ## this one probably isn't needed?+ |
|||
| 415 | +1071 |
-
+ setClass("VLayoutLeaf",
|
||
| 416 | -23x | +|||
| 1072 | +
- ret <- function(x, ...) { ## remember formals get clobbered here
+ contains = c("VIRTUAL", "VLeaf"),
|
|||
| 417 | +1073 |
-
+ representation( |
||
| 418 | +1074 |
- ## this helper will grab the value and wrap it in a named list if+ pos_in_tree = "TreePos", |
||
| 419 | +1075 |
- ## we need the variable and return list() otherwise.+ label = "character" |
||
| 420 | +1076 |
- ## We define it in here so that the scoping hackery works correctly+ ) |
||
| 421 | -66x | +|||
| 1077 | +
- .if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
+ ) |
|||
| 422 | -660x | +|||
| 1078 | +
- val <- if (nm %in% fun_fnames) get(nm) else ifnot+ |
|||
| 423 | -660x | +|||
| 1079 | +
- if (named_lwrap && !identical(val, ifnot)) {
+ setClass("VLayoutTree",
|
|||
| 424 | -78x | +|||
| 1080 | +
- setNames(list(val), nm)+ contains = c("VIRTUAL", "VTree"),
|
|||
| 425 | +1081 |
- } else {
+ representation( |
||
| 426 | -582x | +|||
| 1082 | +
- val+ split = "Split", |
|||
| 427 | +1083 |
- }+ pos_in_tree = "TreePos", |
||
| 428 | +1084 |
- }+ label = "character" |
||
| 429 | +1085 |
-
+ ) |
||
| 430 | -66x | +|||
| 1086 | +
- custargs <- fun_args+ ) |
|||
| 431 | +1087 | |||
| 432 | +1088 |
- ## special handling cause I need it at the bottom as well+ setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))
|
||
| 433 | -66x | +|||
| 1089 | +
- in_rc_argl <- .if_in_formals(".in_ref_col")
+
|
|||
| 434 | -66x | +|||
| 1090 | +
- .in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE+ ## LayoutAxisTree classes ================================= |
|||
| 435 | +1091 | |||
| 436 | -66x | +|||
| 1092 | +
- sfunargs <- c(+ setOldClass("function")
|
|||
| 437 | +1093 |
- ## these are either named lists containing the arg, or list()+ setOldClass("NULL")
|
||
| 438 | +1094 |
- ## depending on whether fun accept the argument or not+ setClassUnion("FunctionOrNULL", c("function", "NULL"))
|
||
| 439 | -66x | +|||
| 1095 | +
- .if_in_formals("x"),
+
|
|||
| 440 | -66x | +|||
| 1096 | +
- .if_in_formals("df"),
+ setClass("LayoutAxisTree",
|
|||
| 441 | -66x | +|||
| 1097 | +
- .if_in_formals(".N_col"),
+ contains = "VLayoutTree", |
|||
| 442 | -66x | +|||
| 1098 | +
- .if_in_formals(".N_total"),
+ representation(summary_func = "FunctionOrNULL"), |
|||
| 443 | -66x | +|||
| 1099 | +
- .if_in_formals(".N_row"),
+ validity = function(object) {
|
|||
| 444 | -66x | +|||
| 1100 | +
- .if_in_formals(".ref_group"),
+ all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf"))) |
|||
| 445 | -66x | +|||
| 1101 | +
- in_rc_argl,+ } |
|||
| 446 | -66x | +|||
| 1102 | +
- .if_in_formals(".df_row"),
+ ) |
|||
| 447 | -66x | +|||
| 1103 | +
- .if_in_formals(".var"),
+
|
|||
| 448 | -66x | +|||
| 1104 | +
- .if_in_formals(".ref_full")
+ ## this is only used for columns!!!! |
|||
| 449 | +1105 |
- )+ setClass("LayoutAxisLeaf",
|
||
| 450 | +1106 |
-
+ contains = "VLayoutLeaf", ## "VNodeInfo", |
||
| 451 | -66x | +|||
| 1107 | +
- allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
+ representation( |
|||
| 452 | +1108 |
- ## values int he actual call to this function override customization+ func = "function", |
||
| 453 | +1109 |
- ## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE+ display_columncounts = "logical", |
||
| 454 | -66x | +|||
| 1110 | +
- if ("..." %in% fun_fnames) {
+ columncount_format = "FormatSpec", # character", |
|||
| 455 | -5x | +|||
| 1111 | +
- exargs <- eval(parser_helper(text = "list(...)"))+ col_footnotes = "list", |
|||
| 456 | -5x | +|||
| 1112 | +
- custargs[names(exargs)] <- exargs+ column_count = "integer" |
|||
| 457 | -5x | +|||
| 1113 | +
- allvars <- unique(c(allvars, names(custargs)))+ ) |
|||
| 458 | +1114 |
- }+ ) |
||
| 459 | +1115 | |||
| 460 | -66x | +|||
| 1116 | +
- for (var in allvars) {
+ setClass("LayoutColTree",
|
|||
| 461 | +1117 |
- ## not missing, i.e. specified in the direct call, takes precedence+ contains = "LayoutAxisTree", |
||
| 462 | -22x | +|||
| 1118 | +
- if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
+ representation( |
|||
| 463 | -5x | +|||
| 1119 | +
- sfunargs[[var]] <- get(var)+ display_columncounts = "logical", |
|||
| 464 | -17x | +|||
| 1120 | +
- } else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
+ columncount_format = "FormatSpec", # "character", |
|||
| 465 | -4x | +|||
| 1121 | +
- sfunargs[[var]] <- custargs[[var]]+ col_footnotes = "list", |
|||
| 466 | +1122 |
- }+ column_count = "integer" |
||
| 467 | +1123 |
- ## else left out so we hit the original default we inherited from fun+ ) |
||
| 468 | +1124 |
- }+ ) |
||
| 469 | +1125 | |||
| 470 | -66x | +|||
| 1126 | +
- rawvals <- do.call(fun, sfunargs)+ setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
|
|||
| 471 | +1127 |
-
+ LayoutColTree <- function(lev = 0L, |
||
| 472 | +1128 |
- ## note single brackets here so its a list+ name = obj_name(spl), |
||
| 473 | +1129 |
- ## no matter what. thats important!+ label = obj_label(spl), |
||
| 474 | -66x | +|||
| 1130 | +
- final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]+ kids = list(), |
|||
| 475 | +1131 |
-
+ spl = EmptyAllSplit, |
||
| 476 | -66x | +|||
| 1132 | +
- if (!is.list(rawvals)) {
+ tpos = TreePos(), |
|||
| 477 | -! | +|||
| 1133 | +
- stop("make_afun expects a function fun that always returns a list")
+ summary_function = NULL, |
|||
| 478 | +1134 |
- }+ disp_ccounts = FALSE, |
||
| 479 | -66x | +|||
| 1135 | +
- if (!is.null(.stats)) {
+ colcount_format = NULL, |
|||
| 480 | -10x | +|||
| 1136 | +
- stopifnot(all(.stats %in% names(rawvals)))+ footnotes = list(), |
|||
| 481 | +1137 |
- } else {
+ colcount) { ## ,
|
||
| 482 | -56x | +|||
| 1138 | +
- .stats <- names(rawvals)+ ## sub = expression(TRUE), |
|||
| 483 | +1139 |
- }+ ## svar = NA_character_,+ |
+ ||
| 1140 | ++ |
+ ## slab = NA_character_) {
|
||
| 484 | -66x | +1141 | +608x |
- if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
+ if (is.null(spl)) {
|
| 485 | +1142 | ! |
- stop(+ stop( |
|
| 486 | +1143 | ! |
- "Stats specified for ungrouping not included in non-null .stats list: ",+ "LayoutColTree constructor got NULL for spl. ", # nocov |
|
| 487 | +1144 | ! |
- setdiff(.ungroup_stats, .stats)+ "This should never happen. Please contact the maintainer." |
|
| 488 | +1145 |
- )+ ) |
||
| 489 | +1146 |
- }+ } # nocov |
||
| 490 | -+ | |||
| 1147 | +608x |
-
+ footnotes <- make_ref_value(footnotes) |
||
| 491 | -66x | +1148 | +608x |
- .labels <- .validate_nms(final_vals, .stats, .labels)+ check_ok_label(label) |
| 492 | -66x | +1149 | +608x |
- .formats <- .validate_nms(final_vals, .stats, .formats)+ new("LayoutColTree",
|
| 493 | -66x | +1150 | +608x |
- .indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)+ level = lev, children = kids, |
| 494 | -66x | +1151 | +608x |
- .format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)+ name = .chkname(name), |
| 495 | -+ | |||
| 1152 | +608x |
-
+ summary_func = summary_function, |
||
| 496 | -66x | +1153 | +608x |
- final_labels <- value_labels(final_vals)+ pos_in_tree = tpos, |
| 497 | -66x | +1154 | +608x |
- final_labels[names(.labels)] <- .labels+ split = spl, |
| 498 | +1155 |
-
+ ## subset = sub,+ |
+ ||
| 1156 | ++ |
+ ## splitvar = svar, |
||
| 499 | -66x | +1157 | +608x |
- final_formats <- lapply(final_vals, obj_format)+ label = label, |
| 500 | -66x | +1158 | +608x |
- final_formats[names(.formats)] <- .formats+ display_columncounts = disp_ccounts, |
| 501 | -+ | |||
| 1159 | +608x |
-
+ columncount_format = colcount_format, |
||
| 502 | -66x | +1160 | +608x |
- final_format_na_strs <- lapply(final_vals, obj_na_str)+ col_footnotes = footnotes, |
| 503 | -66x | +1161 | +608x |
- final_format_na_strs[names(.format_na_strs)] <- .format_na_strs+ column_count = colcount |
| 504 | +1162 |
-
+ ) |
||
| 505 | -66x | +|||
| 1163 | +
- if (is(final_vals, "RowsVerticalSection")) {
+ } |
|||
| 506 | -20x | +|||
| 1164 | +
- final_imods <- indent_mod(final_vals)+ |
|||
| 507 | +1165 |
- } else {
+ LayoutColLeaf <- function(lev = 0L, |
||
| 508 | -46x | +|||
| 1166 | +
- final_imods <- vapply(final_vals, indent_mod, 1L)+ name = label, |
|||
| 509 | +1167 |
- }+ label = "", |
||
| 510 | -66x | +|||
| 1168 | +
- final_imods[names(.indent_mods)] <- .indent_mods+ tpos = TreePos(), |
|||
| 511 | +1169 |
-
+ colcount, |
||
| 512 | -66x | +|||
| 1170 | +
- if (!is.null(.ungroup_stats)) {
+ disp_ccounts = FALSE,+ |
+ |||
| 1171 | ++ |
+ colcount_format = NULL) {
|
||
| 513 | -2x | +1172 | +1139x |
- for (nm in .ungroup_stats) {
+ check_ok_label(label) |
| 514 | -3x | +1173 | +1139x |
- tmp <- final_vals[[nm]]+ new("LayoutColLeaf",
|
| 515 | -3x | +1174 | +1139x |
- if (is(tmp, "CellValue")) {
+ level = lev, name = .chkname(name), label = label, |
| 516 | -1x | +1175 | +1139x |
- tmp <- tmp[[1]]+ pos_in_tree = tpos, |
| 517 | -23x | +1176 | +1139x |
- } ## unwrap it+ column_count = colcount, |
| 518 | -3x | +1177 | +1139x |
- final_vals <- insert_replace(final_vals, nm, tmp)+ display_columncounts = disp_ccounts, |
| 519 | -3x | +1178 | +1139x |
- stopifnot(all(nzchar(names(final_vals))))+ columncount_format = colcount_format |
| 520 | +1179 |
-
+ ) |
||
| 521 | -3x | +|||
| 1180 | +
- final_labels <- insert_replace(+ } |
|||
| 522 | -3x | +|||
| 1181 | +
- final_labels,+ |
|||
| 523 | -3x | +|||
| 1182 | +
- nm,+ ## Instantiated column info class ============================================== |
|||
| 524 | -3x | +|||
| 1183 | +
- setNames(+ ## |
|||
| 525 | -3x | +|||
| 1184 | +
- value_labels(tmp),+ ## This is so we don't need multiple arguments |
|||
| 526 | -3x | +|||
| 1185 | +
- names(tmp)+ ## in the recursive functions that track |
|||
| 527 | +1186 |
- )+ ## various aspects of the column layout |
||
| 528 | +1187 |
- )+ ## once its applied to the data. |
||
| 529 | -3x | +|||
| 1188 | +
- final_formats <- insert_replace(+ |
|||
| 530 | -3x | +|||
| 1189 | +
- final_formats,+ #' Instantiated column info |
|||
| 531 | -3x | +|||
| 1190 | +
- nm,+ #' |
|||
| 532 | -3x | +|||
| 1191 | +
- setNames(+ #' @inheritParams gen_args |
|||
| 533 | -3x | +|||
| 1192 | +
- rep(final_formats[nm],+ #' |
|||
| 534 | -3x | +|||
| 1193 | +
- length.out = length(tmp)+ #' @exportClass InstantiatedColumnInfo |
|||
| 535 | +1194 |
- ),+ #' @rdname cinfo |
||
| 536 | -3x | +|||
| 1195 | +
- names(tmp)+ setClass( |
|||
| 537 | +1196 |
- )+ "InstantiatedColumnInfo", |
||
| 538 | +1197 |
- )+ representation( |
||
| 539 | -3x | +|||
| 1198 | +
- final_format_na_strs <- insert_replace(+ tree_layout = "VLayoutNode", ## LayoutColTree", |
|||
| 540 | -3x | +|||
| 1199 | +
- final_format_na_strs,+ subset_exprs = "list", |
|||
| 541 | -3x | +|||
| 1200 | +
- nm,+ cextra_args = "list", |
|||
| 542 | -3x | +|||
| 1201 | +
- setNames(+ counts = "integer", |
|||
| 543 | -3x | +|||
| 1202 | +
- rep(final_format_na_strs[nm],- |
- |||
| 544 | -3x | -
- length.out = length(tmp)+ total_count = "integer", |
||
| 545 | +1203 |
- ),+ display_columncounts = "logical", |
||
| 546 | -3x | +|||
| 1204 | +
- names(tmp)+ columncount_format = "FormatSpec", |
|||
| 547 | +1205 |
- )+ columncount_na_str = "character", |
||
| 548 | +1206 |
- )+ top_left = "character" |
||
| 549 | -3x | +|||
| 1207 | +
- final_imods <- insert_replace(+ ) |
|||
| 550 | -3x | +|||
| 1208 | +
- final_imods,+ ) |
|||
| 551 | -3x | +|||
| 1209 | +
- nm,+ |
|||
| 552 | -3x | +|||
| 1210 | +
- setNames(+ #' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object. |
|||
| 553 | -3x | +|||
| 1211 | +
- rep(final_imods[nm],+ #' @param csubs (`list`)\cr a list of subsetting expressions. |
|||
| 554 | -3x | +|||
| 1212 | +
- length.out = length(tmp)+ #' @param extras (`list`)\cr extra arguments associated with the columns. |
|||
| 555 | +1213 |
- ),+ #' @param cnts (`integer`)\cr counts. |
||
| 556 | -3x | +|||
| 1214 | +
- names(tmp)+ #' @param total_cnt (`integer(1)`)\cr total observations represented across all columns. |
|||
| 557 | +1215 |
- )+ #' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated |
||
| 558 | +1216 |
- )+ #' table is printed. |
||
| 559 | +1217 |
- }+ #' @param countformat (`string`)\cr format for the counts if they are displayed. |
||
| 560 | +1218 |
- }+ #' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults |
||
| 561 | -66x | +|||
| 1219 | +
- rcells <- mapply(+ #' to `""`. |
|||
| 562 | -66x | +|||
| 1220 | +
- function(x, f, l, na_str) {
+ #' |
|||
| 563 | -197x | +|||
| 1221 | +
- if (is(x, "CellValue")) {
+ #' @return An `InstantiateadColumnInfo` object. |
|||
| 564 | -65x | +|||
| 1222 | +
- obj_label(x) <- l+ #' |
|||
| 565 | -65x | +|||
| 1223 | +
- obj_format(x) <- f+ #' @export |
|||
| 566 | -65x | +|||
| 1224 | +
- obj_na_str(x) <- na_str+ #' @rdname cinfo |
|||
| 567 | +1225 |
- # indent_mod(x) <- im+ InstantiatedColumnInfo <- function(treelyt = LayoutColTree(colcount = total_cnt), |
||
| 568 | -65x | +|||
| 1226 | +
- x+ csubs = list(expression(TRUE)), |
|||
| 569 | -132x | +|||
| 1227 | +
- } else if (.null_ref_cells) {
+ extras = list(list()), |
|||
| 570 | -! | +|||
| 1228 | +
- non_ref_rcell(x,+ cnts = NA_integer_, |
|||
| 571 | -! | +|||
| 1229 | +
- is_ref = .in_ref_col,+ total_cnt = NA_integer_, |
|||
| 572 | -! | +|||
| 1230 | +
- format = f, label = l,+ dispcounts = FALSE, |
|||
| 573 | -! | +|||
| 1231 | +
- format_na_str = na_str+ countformat = "(N=xx)", |
|||
| 574 | -! | +|||
| 1232 | +
- ) # , indent_mod = im)+ count_na_str = "", |
|||
| 575 | +1233 |
- } else {
+ topleft = character()) {
|
||
| 576 | -132x | -
- rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)- |
- ||
| 577 | -+ | 1234 | +637x |
- }+ leaves <- collect_leaves(treelyt) |
| 578 | -+ | |||
| 1235 | +637x |
- },+ nl <- length(leaves) |
||
| 579 | -66x | +1236 | +637x |
- f = final_formats, x = final_vals,+ extras <- rep(extras, length.out = nl) |
| 580 | -66x | +1237 | +637x |
- l = final_labels,+ cnts <- rep(cnts, length.out = nl) |
| 581 | -66x | +1238 | +637x |
- na_str = final_format_na_strs,+ csubs <- rep(csubs, length.out = nl) |
| 582 | +1239 |
- # im = final_imods,+ |
||
| 583 | -66x | +1240 | +637x |
- SIMPLIFY = FALSE+ nleaves <- length(leaves) |
| 584 | -+ | |||
| 1241 | +637x |
- )+ snas <- sum(is.na(cnts)) |
||
| 585 | -66x | +1242 | +637x |
- in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)+ if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
|
| 586 | -+ | |||
| 1243 | +! |
- }+ stop( |
||
| 587 | -23x | +|||
| 1244 | +! |
- formals(ret) <- formals(fun)+ "Mismatching number of columns indicated by: csubs [", |
||
| 588 | -23x | +|||
| 1245 | +! |
- ret+ length(csubs), "], ", |
||
| 589 | -+ | |||
| 1246 | +! |
- }+ "treelyt [", nl, "], extras [", length(extras),+ |
+ ||
| 1247 | +! | +
+ "] and counts [", cnts, "]." |
||
| 590 | +1248 |
-
+ ) |
||
| 591 | +1249 |
- insert_replace <- function(x, nm, newvals = x[[nm]]) {
+ } |
||
| 592 | -15x | +1250 | +637x |
- i <- match(nm, names(x))+ if (snas != 0 && snas != nleaves) {
|
| 593 | -15x | +1251 | +2x |
- if (is.na(i)) {
+ warning( |
| 594 | -! | +|||
| 1252 | +2x |
- stop("name not found")
+ "Mixture of missing and non-missing column counts when ",+ |
+ ||
| 1253 | +2x | +
+ "creating column info." |
||
| 595 | +1254 |
- }+ ) |
||
| 596 | -15x | +|||
| 1255 | +
- bef <- if (i > 1) 1:(i - 1) else numeric()+ } |
|||
| 597 | -15x | +|||
| 1256 | +
- aft <- if (i < length(x)) (i + 1):length(x) else numeric()+ |
|||
| 598 | -15x | +1257 | +637x |
- ret <- c(x[bef], newvals, x[aft])+ if (!is.na(dispcounts)) {
|
| 599 | -15x | +1258 | +410x |
- names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])+ pths <- col_paths(treelyt) |
| 600 | -15x | +1259 | +410x |
- ret+ for (path in pths) {
|
| 601 | -+ | |||
| 1260 | +917x |
- }+ colcount_visible(treelyt, path) <- dispcounts |
||
| 602 | +1261 |
-
+ } |
||
| 603 | +1262 |
- parser_helper <- function(text, envir = parent.frame(2)) {
+ } else { ## na leaves the children as they are and dispcols goes to whether any of them are displayed for the leaves
|
||
| 604 | -495x | +1263 | +227x |
- parse(text = text, keep.source = FALSE)+ dispcounts <- any(vapply(leaves, disp_ccounts, NA)) |
| 605 | +1264 |
- }+ } |
||
| 606 | +1265 | |||
| 607 | -+ | |||
| 1266 | +637x |
- length_w_name <- function(x, .parent_splval) {
+ new("InstantiatedColumnInfo",
|
||
| 608 | -! | +|||
| 1267 | +637x |
- in_rows(length(x),+ tree_layout = treelyt, |
||
| 609 | -! | +|||
| 1268 | +637x |
- .names = value_labels(.parent_splval)+ subset_exprs = csubs, |
||
| 610 | -+ | |||
| 1269 | +637x |
- )+ cextra_args = extras, |
||
| 611 | -+ | |||
| 1270 | +637x |
- }+ counts = cnts, |
| 1 | -+ | |||
| 1271 | +637x |
- ## Generics and how they are used directly+ total_count = total_cnt, |
||
| 2 | -+ | |||
| 1272 | +637x |
-
+ display_columncounts = dispcounts, |
||
| 3 | -+ | |||
| 1273 | +637x |
- ## check_validsplit - Check if the split is valid for the data, error if not+ columncount_format = countformat, |
||
| 4 | -+ | |||
| 1274 | +637x |
-
+ columncount_na_str = count_na_str,+ |
+ ||
| 1275 | +637x | +
+ top_left = topleft |
||
| 5 | +1276 |
- ## .apply_spl_extras - Generate Extras+ ) |
||
| 6 | +1277 |
-
+ } |
||
| 7 | +1278 |
- ## .apply_spl_datapart - generate data partition+ |
||
| 8 | +1279 |
-
+ ## TableTrees and row classes ================================================== |
||
| 9 | +1280 |
- ## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values+ ## XXX Rowspans as implemented dont really work |
||
| 10 | +1281 |
-
+ ## they're aren't attached to the right data structures |
||
| 11 | +1282 |
- setGeneric(+ ## during conversions. |
||
| 12 | +1283 |
- ".applysplit_rawvals",+ |
||
| 13 | -929x | +|||
| 1284 | +
- function(spl, df) standardGeneric(".applysplit_rawvals")
+ ## FIXME: if we ever actually need row spanning |
|||
| 14 | +1285 |
- )+ setClass("VTableNodeInfo",
|
||
| 15 | +1286 |
-
+ contains = c("VNodeInfo", "VIRTUAL"),
|
||
| 16 | +1287 |
- setGeneric(+ representation( |
||
| 17 | +1288 |
- ".applysplit_datapart",+ ## col_layout = "VLayoutNode", |
||
| 18 | -1003x | +|||
| 1289 | +
- function(spl, df, vals) standardGeneric(".applysplit_datapart")
+ col_info = "InstantiatedColumnInfo", |
|||
| 19 | +1290 |
- )+ format = "FormatSpec", |
||
| 20 | +1291 |
-
+ na_str = "character", |
||
| 21 | +1292 |
- setGeneric(+ indent_modifier = "integer", |
||
| 22 | +1293 |
- ".applysplit_extras",+ table_inset = "integer" |
||
| 23 | -1003x | +|||
| 1294 | +
- function(spl, df, vals) standardGeneric(".applysplit_extras")
+ ) |
|||
| 24 | +1295 |
) |
||
| 25 | +1296 | |||
| 26 | +1297 |
- setGeneric(+ setClass("TableRow",
|
||
| 27 | +1298 |
- ".applysplit_partlabels",+ contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
|
||
| 28 | -1002x | +|||
| 1299 | +
- function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
+ representation( |
|||
| 29 | +1300 |
- )+ leaf_value = "ANY", |
||
| 30 | +1301 |
-
+ var_analyzed = "character", |
||
| 31 | +1302 |
- setGeneric(+ ## var_label = "character", |
||
| 32 | +1303 |
- "check_validsplit",+ label = "character", |
||
| 33 | -2146x | +|||
| 1304 | +
- function(spl, df) standardGeneric("check_validsplit")
+ row_footnotes = "list", |
|||
| 34 | +1305 |
- )+ trailing_section_div = "character" |
||
| 35 | +1306 |
-
+ ) |
||
| 36 | +1307 |
- setGeneric(+ ) |
||
| 37 | +1308 |
- ".applysplit_ref_vals",+ |
||
| 38 | -17x | +|||
| 1309 | +
- function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
+ ## TableTree Core Non-Virtual Classes ============== |
|||
| 39 | +1310 |
- )+ ## |
||
| 40 | +1311 |
-
+ #' Row classes and constructors |
||
| 41 | +1312 |
- #' Custom split functions+ #' |
||
| 42 | +1313 |
- #'+ #' @inheritParams constr_args |
||
| 43 | +1314 |
- #' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set+ #' @inheritParams lyt_args |
||
| 44 | +1315 |
- #' of incoming data and a split object, and return "splits" of that data.+ #' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only). |
||
| 45 | +1316 |
#' |
||
| 46 | +1317 |
- #' @section Custom Splitting Function Details:+ #' @return A formal object representing a table row of the constructed type. |
||
| 47 | +1318 |
#' |
||
| 48 | +1319 |
- #' User-defined custom split functions can perform any type of computation on the incoming data provided that they+ #' @author Gabriel Becker |
||
| 49 | +1320 |
- #' meet the requirements for generating "splits" of the incoming data based on the split object.+ #' @export |
||
| 50 | +1321 |
- #'+ #' @rdname rowclasses |
||
| 51 | +1322 |
- #' Split functions are functions that accept:+ LabelRow <- function(lev = 1L, |
||
| 52 | +1323 |
- #' \describe{
+ label = "", |
||
| 53 | +1324 |
- #' \item{df}{a `data.frame` of incoming data to be split.}
+ name = label, |
||
| 54 | +1325 |
- #' \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
+ vis = !is.na(label) && nzchar(label), |
||
| 55 | +1326 |
- #' but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting+ cinfo = EmptyColInfo, |
||
| 56 | +1327 |
- #' table.}+ indent_mod = 0L, |
||
| 57 | +1328 |
- #' \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
+ table_inset = 0L, |
||
| 58 | +1329 |
- #' Should be `NULL` in most cases and can usually be ignored.}+ trailing_section_div = NA_character_) {
|
||
| 59 | -+ | |||
| 1330 | +4760x |
- #' \item{labels}{any pre-calculated value labels. Same as above for `values`.}
+ check_ok_label(label) |
||
| 60 | -+ | |||
| 1331 | +4760x |
- #' \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
+ new("LabelRow",
|
||
| 61 | -+ | |||
| 1332 | +4760x |
- #' \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
+ leaf_value = list(), |
||
| 62 | -+ | |||
| 1333 | +4760x |
- #' arrived at `df`.}+ level = lev, |
||
| 63 | -+ | |||
| 1334 | +4760x |
- #' }+ label = label, |
||
| 64 | +1335 |
- #'+ ## XXX this means that a label row and its talbe can have the same name.... |
||
| 65 | +1336 |
- #' The function must then output a named `list` with the following elements:+ ## XXX that is bad but how bad remains to be seen |
||
| 66 | +1337 |
- #'+ ## XXX |
||
| 67 | -+ | |||
| 1338 | +4760x |
- #' \describe{
+ name = .chkname(name), |
||
| 68 | -+ | |||
| 1339 | +4760x |
- #' \item{values}{the vector of all values corresponding to the splits of `df`.}
+ col_info = cinfo, |
||
| 69 | -+ | |||
| 1340 | +4760x |
- #' \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
+ visible = vis, |
||
| 70 | -+ | |||
| 1341 | +4760x |
- #' \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
+ indent_modifier = as.integer(indent_mod), |
||
| 71 | -+ | |||
| 1342 | +4760x |
- #' \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
+ table_inset = as.integer(table_inset),+ |
+ ||
| 1343 | +4760x | +
+ trailing_section_div = trailing_section_div |
||
| 72 | +1344 |
- #' whenever they are executed on the corresponding element of `datasplit` or a subset thereof.}+ ) |
||
| 73 | +1345 |
- #' }+ } |
||
| 74 | +1346 |
- #'+ |
||
| 75 | +1347 |
- #' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming+ #' Row constructors and classes |
||
| 76 | +1348 |
- #' data before they are called or their outputs.+ #' |
||
| 77 | +1349 |
- #'+ #' @rdname rowclasses |
||
| 78 | +1350 |
- #' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of+ #' @exportClass DataRow |
||
| 79 | +1351 |
- #' pre-defined split functions.+ setClass("DataRow",
|
||
| 80 | +1352 |
- #'+ contains = "TableRow", |
||
| 81 | +1353 |
- #' @examples+ representation(colspans = "integer") ## , |
||
| 82 | +1354 |
- #' # Example of a picky split function. The number of values in the column variable+ ## pos_in_tree = "TableRowPos"), |
||
| 83 | +1355 |
- #' # var decrees if we are going to print also the column with all observation+ ## validity = function(object) {
|
||
| 84 | +1356 |
- #' # or not.+ ## lcsp = length(object@colspans) |
||
| 85 | +1357 |
- #'+ ## length(lcsp == 0) || lcsp == length(object@leaf_value) |
||
| 86 | +1358 |
- #' picky_splitter <- function(var) {
+ ## } |
||
| 87 | +1359 |
- #' # Main layout function+ ) |
||
| 88 | +1360 |
- #' function(df, spl, vals, labels, trim) {
+
|
||
| 89 | +1361 |
- #' orig_vals <- vals+ #' @rdname rowclasses |
||
| 90 | +1362 |
- #'+ #' @exportClass ContentRow |
||
| 91 | +1363 |
- #' # Check for number of levels if all are selected+ setClass("ContentRow",
|
||
| 92 | +1364 |
- #' if (is.null(vals)) {
+ contains = "TableRow", |
||
| 93 | +1365 |
- #' vec <- df[[var]]+ representation(colspans = "integer") ## , |
||
| 94 | +1366 |
- #' vals <- unique(vec)+ ## pos_in_tree = "TableRowPos"), |
||
| 95 | +1367 |
- #' }+ ## validity = function(object) {
|
||
| 96 | +1368 |
- #'+ ## lcsp = length(object@colspans) |
||
| 97 | +1369 |
- #' # Do a split with or without All obs+ ## length(lcsp == 0) || lcsp == length(object@leaf_value) |
||
| 98 | +1370 |
- #' if (length(vals) == 1) {
+ ## } |
||
| 99 | +1371 |
- #' do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim)+ ) |
||
| 100 | +1372 |
- #' } else {
+
|
||
| 101 | +1373 |
- #' fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
+ #' @rdname rowclasses |
||
| 102 | +1374 |
- #' fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim)+ #' @exportClass LabelRow |
||
| 103 | +1375 |
- #' }+ setClass("LabelRow",
|
||
| 104 | +1376 |
- #' }+ contains = "TableRow", |
||
| 105 | +1377 |
- #' }+ representation(visible = "logical") |
||
| 106 | +1378 |
- #'+ ) |
||
| 107 | +1379 |
- #' # Data sub-set+ |
||
| 108 | +1380 |
- #' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F"))+ #' @param klass (`character`)\cr internal detail. |
||
| 109 | +1381 |
- #' d1 <- subset(d1, SEX %in% c("M", "F"))
+ #' |
||
| 110 | +1382 |
- #' d1$SEX <- factor(d1$SEX)+ #' @export |
||
| 111 | +1383 |
- #'+ #' @rdname rowclasses |
||
| 112 | +1384 |
- #' # This table uses the number of values in the SEX column to add the overall col or not+ .tablerow <- function(vals = list(), |
||
| 113 | +1385 |
- #' lyt <- basic_table() %>%+ name = "", |
||
| 114 | +1386 |
- #' split_cols_by("ARM", split_fun = drop_split_levels) %>%
+ lev = 1L, |
||
| 115 | +1387 |
- #' split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
+ label = name, |
||
| 116 | +1388 |
- #' analyze("AGE", show_labels = "visible")
+ cspan = rep(1L, length(vals)), |
||
| 117 | +1389 |
- #' tbl <- build_table(lyt, d1)+ cinfo = EmptyColInfo, |
||
| 118 | +1390 |
- #' tbl+ var = NA_character_, |
||
| 119 | +1391 |
- #'+ format = NULL, |
||
| 120 | +1392 |
- #' @name custom_split_funs+ na_str = NA_character_, |
||
| 121 | +1393 |
- NULL+ klass, |
||
| 122 | +1394 |
-
+ indent_mod = 0L, |
||
| 123 | +1395 |
- ## do various cleaning, and naming, plus+ footnotes = list(), |
||
| 124 | +1396 |
- ## ensure partinfo$values contains SplitValue objects only+ table_inset = 0L, |
||
| 125 | +1397 |
- .fixupvals <- function(partinfo) {
+ trailing_section_div = NA_character_) {
|
||
| 126 | -1030x | +1398 | +3342x |
- if (is.factor(partinfo$labels)) {
+ if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
|
| 127 | -! | +|||
| 1399 | +261x |
- partinfo$labels <- as.character(partinfo$labels)+ name <- label |
||
| 128 | +1400 |
} |
||
| 129 | -+ | |||
| 1401 | +3342x |
-
+ vals <- lapply(vals, rcell) |
||
| 130 | -1030x | +1402 | +3342x |
- vals <- partinfo$values+ rlabels <- unique(unlist(lapply(vals, obj_label))) |
| 131 | -1030x | +1403 | +3342x |
- if (is.factor(vals)) {
+ if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
|
| 132 | +1404 | ! |
- vals <- levels(vals)[vals]+ label <- rlabels[nzchar(rlabels)] |
|
| 133 | +1405 |
} |
||
| 134 | -1030x | +1406 | +3342x |
- extr <- partinfo$extras+ if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
|
| 135 | -1030x | +1407 | +3081x |
- dpart <- partinfo$datasplit+ cspan <- vapply(vals, cell_cspan, 0L)+ |
+
| 1408 | ++ |
+ }+ |
+ ||
| 1409 | ++ | + | ||
| 136 | -1030x | +1410 | +3342x |
- labels <- partinfo$labels+ check_ok_label(label) |
| 137 | -1030x | +1411 | +3342x |
- if (is.null(labels)) {
+ rw <- new(klass, |
| 138 | -! | +|||
| 1412 | +3342x |
- if (!is.null(names(vals))) {
+ leaf_value = vals, |
||
| 139 | -! | +|||
| 1413 | +3342x |
- labels <- names(vals)+ name = .chkname(name), |
||
| 140 | -! | +|||
| 1414 | +3342x |
- } else if (!is.null(names(dpart))) {
+ level = lev, |
||
| 141 | -! | +|||
| 1415 | +3342x |
- labels <- names(dpart)+ label = .chkname(label), |
||
| 142 | -! | +|||
| 1416 | +3342x |
- } else if (!is.null(names(extr))) {
+ colspans = cspan, |
||
| 143 | -! | +|||
| 1417 | +3342x |
- labels <- names(extr)+ col_info = cinfo, |
||
| 144 | -+ | |||
| 1418 | +3342x |
- }+ var_analyzed = var, |
||
| 145 | +1419 |
- }+ ## these are set in set_format_recursive below+ |
+ ||
| 1420 | +3342x | +
+ format = NULL,+ |
+ ||
| 1421 | +3342x | +
+ na_str = NA_character_,+ |
+ ||
| 1422 | +3342x | +
+ indent_modifier = indent_mod,+ |
+ ||
| 1423 | +3342x | +
+ row_footnotes = footnotes,+ |
+ ||
| 1424 | +3342x | +
+ table_inset = table_inset,+ |
+ ||
| 1425 | +3342x | +
+ trailing_section_div = trailing_section_div |
||
| 146 | +1426 |
-
+ ) |
||
| 147 | -1030x | +1427 | +3342x |
- subsets <- partinfo$subset_exprs+ rw <- set_format_recursive(rw, format, na_str, FALSE) |
| 148 | -1030x | +1428 | +3342x |
- if (is.null(subsets)) {
+ rw |
| 149 | -1014x | +|||
| 1429 | +
- subsets <- vector(mode = "list", length = length(vals))+ } |
|||
| 150 | +1430 |
- ## use labels here cause we already did all that work+ |
||
| 151 | +1431 |
- ## to get the names on the labels vector right+ #' @param ... additional parameters passed to shared constructor (`.tablerow`). |
||
| 152 | -1014x | +|||
| 1432 | +
- names(subsets) <- names(labels)+ #' |
|||
| 153 | +1433 |
- }+ #' @export |
||
| 154 | +1434 |
-
+ #' @rdname rowclasses |
||
| 155 | -1030x | +1435 | +2827x |
- if (is.null(vals) && !is.null(extr)) {
+ DataRow <- function(...) .tablerow(..., klass = "DataRow") |
| 156 | -! | +|||
| 1436 | +
- vals <- seq_along(extr)+ |
|||
| 157 | +1437 |
- }+ #' @export |
||
| 158 | +1438 |
-
+ #' @rdname rowclasses |
||
| 159 | -1030x | +1439 | +515x |
- if (length(vals) == 0) {
+ ContentRow <- function(...) .tablerow(..., klass = "ContentRow") |
| 160 | -13x | +|||
| 1440 | +
- stopifnot(length(extr) == 0)+ |
|||
| 161 | -13x | +|||
| 1441 | +
- return(partinfo)+ setClass("VTitleFooter",
|
|||
| 162 | +1442 |
- }+ contains = "VIRTUAL", |
||
| 163 | +1443 |
- ## length(vals) > 0 from here down+ representation( |
||
| 164 | +1444 |
-
+ main_title = "character", |
||
| 165 | -1017x | +|||
| 1445 | +
- if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
+ subtitles = "character", |
|||
| 166 | -22x | +|||
| 1446 | +
- if (!is.null(extr)) {
+ main_footer = "character", |
|||
| 167 | +1447 |
- ## in_ref_cols is in here for some reason even though its already in the SplitValue object.+ provenance_footer = "character" |
||
| 168 | +1448 |
- ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598+ ) |
||
| 169 | +1449 |
- ## the if is a bandaid.+ ) |
||
| 170 | +1450 |
- ## XXX FIXME RIGHT+ |
||
| 171 | -3x | +|||
| 1451 | +
- sq <- seq_along(vals)+ setClass("VTableTree",
|
|||
| 172 | -3x | +|||
| 1452 | +
- if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
+ contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
|
|||
| 173 | -! | +|||
| 1453 | +
- warning(+ representation( |
|||
| 174 | -! | +|||
| 1454 | +
- "Got a partinfo list with values that are ",+ children = "list", |
|||
| 175 | -! | +|||
| 1455 | +
- "already SplitValue objects and non-null extras ",+ rowspans = "data.frame", |
|||
| 176 | -! | +|||
| 1456 | +
- "element. This shouldn't happen"+ labelrow = "LabelRow", |
|||
| 177 | +1457 |
- )+ page_titles = "character", |
||
| 178 | +1458 |
- }+ horizontal_sep = "character", |
||
| 179 | +1459 |
- }+ header_section_div = "character", |
||
| 180 | +1460 |
- } else {
+ trailing_section_div = "character" |
||
| 181 | -995x | +|||
| 1461 | +
- if (is.null(extr)) {
+ ) |
|||
| 182 | -6x | +|||
| 1462 | +
- extr <- rep(list(list()), length(vals))+ ) |
|||
| 183 | +1463 |
- }+ |
||
| 184 | -995x | +|||
| 1464 | +
- vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets)+ setClassUnion("IntegerOrNull", c("integer", "NULL"))
|
|||
| 185 | +1465 |
- }+ ## covered because it's ElementaryTable's validity method but covr misses it |
||
| 186 | +1466 |
- ## we're done with this so take it off+ ## nocov start |
||
| 187 | -1017x | +|||
| 1467 | +
- partinfo$extras <- NULL+ etable_validity <- function(object) {
|
|||
| 188 | +1468 |
-
+ kids <- tree_children(object) |
||
| 189 | -1017x | +|||
| 1469 | +
- vnames <- value_names(vals)+ all(sapply( |
|||
| 190 | -1017x | +|||
| 1470 | +
- names(vals) <- vnames+ kids, |
|||
| 191 | -1017x | +|||
| 1471 | +
- partinfo$values <- vals+ function(k) {
|
|||
| 192 | +1472 |
-
+ (is(k, "DataRow") || is(k, "ContentRow")) |
||
| 193 | -1017x | +|||
| 1473 | +
- if (!identical(names(dpart), vnames)) {
+ } |
|||
| 194 | -1017x | +|||
| 1474 | +
- names(dpart) <- vnames+ )) ### && |
|||
| 195 | -1017x | +|||
| 1475 | +
- partinfo$datasplit <- dpart+ } |
|||
| 196 | +1476 |
- }+ ## nocov end |
||
| 197 | +1477 | |||
| 198 | -1017x | +|||
| 1478 | +
- partinfo$labels <- labels+ #' `TableTree` classes |
|||
| 199 | +1479 |
-
+ #' |
||
| 200 | -1017x | +|||
| 1480 | +
- stopifnot(length(unique(sapply(partinfo, NROW))) == 1)+ #' @return A formal object representing a populated table. |
|||
| 201 | -1017x | +|||
| 1481 | +
- partinfo+ #' |
|||
| 202 | +1482 |
- }+ #' @author Gabriel Becker |
||
| 203 | +1483 |
-
+ #' @exportClass ElementaryTable |
||
| 204 | +1484 |
- .add_ref_extras <- function(spl, df, partinfo) {
+ #' @rdname tabclasses |
||
| 205 | +1485 |
- ## this is only the .in_ref_col booleans+ setClass("ElementaryTable",
|
||
| 206 | -17x | +|||
| 1486 | +
- refvals <- .applysplit_ref_vals(spl, df, partinfo$values)+ contains = "VTableTree", |
|||
| 207 | -17x | +|||
| 1487 | +
- ref_ind <- which(unlist(refvals))+ representation(var_analyzed = "character"), |
|||
| 208 | -17x | +|||
| 1488 | +
- stopifnot(length(ref_ind) == 1)+ validity = etable_validity ## function(object) {
|
|||
| 209 | +1489 | ++ |
+ )+ |
+ |
| 1490 | ||||
| 210 | -17x | +|||
| 1491 | +
- vnames <- value_names(partinfo$values)+ .enforce_valid_kids <- function(lst, colinfo) {
|
|||
| 211 | -17x | +|||
| 1492 | +
- if (is.null(partinfo$extras)) {
+ ## colinfo |
|||
| 212 | -3x | +1493 | +5961x |
- names(refvals) <- vnames+ if (!no_colinfo(colinfo)) {
|
| 213 | -3x | +1494 | +5961x |
- partinfo$extras <- refvals+ lst <- lapply( |
| 214 | -+ | |||
| 1495 | +5961x |
- } else {
+ lst, |
||
| 215 | -14x | +1496 | +5961x |
- newextras <- mapply(+ function(x) {
|
| 216 | -14x | +1497 | +7443x |
- function(old, incol, ref_full) {
+ if (no_colinfo(x)) {
|
| 217 | -37x | +1498 | +208x |
- c(old, list(+ col_info(x) <- colinfo |
| 218 | -37x | +1499 | +7235x |
- .in_ref_col = incol,+ } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
|
| 219 | -37x | +|||
| 1500 | +
- .ref_full = ref_full+ ## split functions from function factories (e.g. add_combo_levels) |
|||
| 220 | +1501 |
- ))+ ## have different environments so we can't use identical here |
||
| 221 | +1502 |
- },+ ## all.equal requires the **values within the closures** to be the |
||
| 222 | -14x | +|||
| 1503 | +
- old = partinfo$extras,+ ## same but not the actual enclosing environments. |
|||
| 223 | -14x | +|||
| 1504 | +! |
- incol = unlist(refvals),+ stop( |
||
| 224 | -14x | +|||
| 1505 | +! |
- MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]),+ "attempted to add child with non-matching, non-empty ", |
||
| 225 | -14x | +|||
| 1506 | +! |
- SIMPLIFY = FALSE+ "column info to an existing table" |
||
| 226 | +1507 |
- )+ ) |
||
| 227 | -14x | +|||
| 1508 | +
- names(newextras) <- vnames+ } |
|||
| 228 | -14x | +1509 | +7443x |
- partinfo$extras <- newextras+ x |
| 229 | +1510 |
- }+ } |
||
| 230 | -17x | +|||
| 1511 | +
- partinfo+ ) |
|||
| 231 | +1512 |
- }+ } |
||
| 232 | +1513 | |||
| 233 | -+ | |||
| 1514 | +5961x |
- #' Apply basic split (for use in custom split functions)+ if (are(lst, "ElementaryTable") && |
||
| 234 | -+ | |||
| 1515 | +5961x |
- #'+ all(sapply(lst, function(tb) {
|
||
| 235 | -+ | |||
| 1516 | +1042x |
- #' This function is intended for use inside custom split functions. It applies the current split *as if it had no+ nrow(tb) <= 1 && identical(obj_name(tb), "") |
||
| 236 | +1517 |
- #' custom splitting function* so that those default splits can be further manipulated.+ }))) {
|
||
| 237 | -+ | |||
| 1518 | +1552x |
- #'+ lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]])) |
||
| 238 | +1519 |
- #' @inheritParams gen_args+ } |
||
| 239 | -+ | |||
| 1520 | +5961x |
- #' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`.+ if (length(lst) == 0) {
|
||
| 240 | -+ | |||
| 1521 | +1552x |
- #' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should+ return(list()) |
||
| 241 | +1522 |
- #' almost always be the case.+ } |
||
| 242 | +1523 |
- #' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to+ ## names |
||
| 243 | -+ | |||
| 1524 | +4409x |
- #' `FALSE`.+ realnames <- sapply(lst, obj_name) |
||
| 244 | -+ | |||
| 1525 | +4409x |
- #'+ lstnames <- names(lst) |
||
| 245 | -+ | |||
| 1526 | +4409x |
- #' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs].+ if (is.null(lstnames)) {
|
||
| 246 | -+ | |||
| 1527 | +1877x |
- #'+ names(lst) <- realnames |
||
| 247 | -+ | |||
| 1528 | +2532x |
- #' @examples+ } else if (!identical(realnames, lstnames)) {
|
||
| 248 | -+ | |||
| 1529 | +2532x |
- #' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ names(lst) <- realnames |
||
| 249 | +1530 |
- #' ret <- do_base_split(spl, df, vals, labels, trim)+ } |
||
| 250 | +1531 |
- #' if (NROW(df) == 0) {
+
|
||
| 251 | -+ | |||
| 1532 | +4409x |
- #' ret <- lapply(ret, function(x) x[1])+ lst |
||
| 252 | +1533 |
- #' }+ } |
||
| 253 | +1534 |
- #' ret+ |
||
| 254 | +1535 |
- #' }+ #' Table constructors and classes |
||
| 255 | +1536 |
#' |
||
| 256 | +1537 |
- #' lyt <- basic_table() %>%+ #' @inheritParams constr_args |
||
| 257 | +1538 |
- #' split_cols_by("ARM") %>%
+ #' @inheritParams gen_args |
||
| 258 | +1539 |
- #' split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
+ #' @inheritParams lyt_args |
||
| 259 | +1540 |
- #' varlabels = c("N", "E", "BMR1"),
+ #' @param rspans (`data.frame`)\cr currently stored but otherwise ignored. |
||
| 260 | +1541 |
- #' split_fun = uneven_splfun+ #' |
||
| 261 | +1542 |
- #' ) %>%+ #' @author Gabriel Becker |
||
| 262 | +1543 |
- #' analyze_colvars(list(+ #' @export |
||
| 263 | +1544 |
- #' USUBJID = function(x, ...) length(unique(x)),+ #' @rdname tabclasses |
||
| 264 | +1545 |
- #' AESEQ = max,+ ElementaryTable <- function(kids = list(), |
||
| 265 | +1546 |
- #' BMRKR1 = mean+ name = "", |
||
| 266 | +1547 |
- #' ))+ lev = 1L, |
||
| 267 | +1548 |
- #'+ label = "", |
||
| 268 | +1549 |
- #' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2))+ labelrow = LabelRow( |
||
| 269 | +1550 |
- #' tbl+ lev = lev, |
||
| 270 | +1551 |
- #'+ label = label, |
||
| 271 | +1552 |
- #' @export+ vis = !isTRUE(iscontent) && |
||
| 272 | +1553 |
- do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
+ !is.na(label) && |
||
| 273 | -13x | +|||
| 1554 | +
- spl2 <- spl+ nzchar(label) |
|||
| 274 | -13x | +|||
| 1555 | +
- split_fun(spl2) <- NULL+ ), |
|||
| 275 | -13x | +|||
| 1556 | +
- do_split(spl2,+ rspans = data.frame(), |
|||
| 276 | -13x | +|||
| 1557 | +
- df = df, vals = vals, labels = labels, trim = trim,+ cinfo = NULL, |
|||
| 277 | -13x | +|||
| 1558 | +
- spl_context = NULL+ iscontent = NA, |
|||
| 278 | +1559 |
- )+ var = NA_character_, |
||
| 279 | +1560 |
- }+ format = NULL, |
||
| 280 | +1561 |
-
+ na_str = NA_character_, |
||
| 281 | +1562 |
- ### NB This is called at EACH level of recursive splitting+ indent_mod = 0L, |
||
| 282 | +1563 |
- do_split <- function(spl,+ title = "", |
||
| 283 | +1564 |
- df,+ subtitles = character(), |
||
| 284 | +1565 |
- vals = NULL,+ main_footer = character(), |
||
| 285 | +1566 |
- labels = NULL,+ prov_footer = character(), |
||
| 286 | +1567 |
- trim = FALSE,+ header_section_div = NA_character_, |
||
| 287 | +1568 |
- spl_context) {
+ hsep = default_hsep(), |
||
| 288 | +1569 |
- ## this will error if, e.g., df doesn't have columns+ trailing_section_div = NA_character_, |
||
| 289 | +1570 |
- ## required by spl, or generally any time the spl+ inset = 0L) {
|
||
| 290 | -+ | |||
| 1571 | +3083x |
- ## can't be applied to df+ check_ok_label(label) |
||
| 291 | -1023x | +1572 | +3083x |
- check_validsplit(spl, df)+ if (is.null(cinfo)) {
+ |
+
| 1573 | +! | +
+ if (length(kids) > 0) {
+ |
+ ||
| 1574 | +! | +
+ cinfo <- col_info(kids[[1]]) |
||
| 292 | +1575 |
- ## note the <- here!!!+ } else {
|
||
| 293 | -1022x | +|||
| 1576 | +! |
- if (!is.null(splfun <- split_fun(spl))) {
+ cinfo <- EmptyColInfo |
||
| 294 | +1577 |
- ## Currently the contract is that split_functions take df, vals, labels and+ } |
||
| 295 | +1578 |
- ## return list(values=., datasplit=., labels = .), optionally with+ } |
||
| 296 | +1579 |
- ## an additional extras element+ |
||
| 297 | -339x | +1580 | +3083x |
- if (func_takes(splfun, ".spl_context")) {
+ if (no_colinfo(labelrow)) {
|
| 298 | -23x | +1581 | +1881x |
- ret <- tryCatch(+ col_info(labelrow) <- cinfo |
| 299 | -23x | +|||
| 1582 | +
- splfun(df, spl, vals, labels,+ } |
|||
| 300 | -23x | +1583 | +3083x |
- trim = trim,+ kids <- .enforce_valid_kids(kids, cinfo) |
| 301 | -23x | +1584 | +3083x |
- .spl_context = spl_context+ tab <- new("ElementaryTable",
|
| 302 | -+ | |||
| 1585 | +3083x |
- ),+ children = kids, |
||
| 303 | -23x | +1586 | +3083x |
- error = function(e) e+ name = .chkname(name), |
| 304 | -23x | +1587 | +3083x |
- ) ## rawvalues(spl_context ))+ level = lev, |
| 305 | -+ | |||
| 1588 | +3083x |
- } else {
+ labelrow = labelrow, |
||
| 306 | -316x | +1589 | +3083x |
- ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim),+ rowspans = rspans, |
| 307 | -316x | +1590 | +3083x |
- error = function(e) e+ col_info = cinfo,+ |
+
| 1591 | +3083x | +
+ var_analyzed = var, |
||
| 308 | +1592 |
- )+ ## XXX these are hardcoded, because they both get set during |
||
| 309 | +1593 |
- }+ ## set_format_recursive anyway |
||
| 310 | -339x | +1594 | +3083x |
- if (is(ret, "error")) {
+ format = NULL, |
| 311 | -5x | +1595 | +3083x |
- stop(+ na_str = NA_character_, |
| 312 | -5x | +1596 | +3083x |
- "Error applying custom split function: ", ret$message, "\n\tsplit: ",+ table_inset = 0L, |
| 313 | -5x | +1597 | +3083x |
- class(spl), " (", payloadmsg(spl), ")\n",
+ indent_modifier = as.integer(indent_mod), |
| 314 | -5x | +1598 | +3083x |
- "\toccured at path: ",+ main_title = title, |
| 315 | -5x | +1599 | +3083x |
- spl_context_to_disp_path(spl_context), "\n"+ subtitles = subtitles, |
| 316 | -+ | |||
| 1600 | +3083x |
- )+ main_footer = main_footer, |
||
| 317 | -+ | |||
| 1601 | +3083x |
- }+ provenance_footer = prov_footer, |
||
| 318 | -+ | |||
| 1602 | +3083x |
- } else {
+ horizontal_sep = hsep, |
||
| 319 | -683x | +1603 | +3083x |
- ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim)+ header_section_div = header_section_div, |
| 320 | -+ | |||
| 1604 | +3083x |
- }+ trailing_section_div = trailing_section_div |
||
| 321 | +1605 |
-
+ ) |
||
| 322 | -+ | |||
| 1606 | +3083x |
- ## this adds .ref_full and .in_ref_col+ tab <- set_format_recursive(tab, format, na_str, FALSE) |
||
| 323 | -1017x | +1607 | +3083x |
- if (is(spl, "VarLevWBaselineSplit")) {
+ table_inset(tab) <- as.integer(inset) |
| 324 | -17x | +1608 | +3083x |
- ret <- .add_ref_extras(spl, df, ret)+ tab |
| 325 | +1609 |
- }+ } |
||
| 326 | +1610 | |||
| 327 | +1611 |
- ## this:+ ttable_validity <- function(object) {
|
||
| 328 | -+ | |||
| 1612 | +! |
- ## - guarantees that ret$values contains SplitValue objects+ all(sapply( |
||
| 329 | -+ | |||
| 1613 | +! |
- ## - removes the extras element since its redundant after the above+ tree_children(object), |
||
| 330 | -+ | |||
| 1614 | +! |
- ## - Ensures datasplit and values lists are named according to labels+ function(x) is(x, "VTableTree") || is(x, "TableRow") |
||
| 331 | +1615 |
- ## - ensures labels are character not factor+ )) |
||
| 332 | -1017x | +|||
| 1616 | +
- ret <- .fixupvals(ret)+ } |
|||
| 333 | +1617 |
- ## we didn't put this in .fixupvals because that get called withint he split functions+ |
||
| 334 | +1618 |
- ## created by make_split_fun and its not clear this check should be happening then.+ .calc_cinfo <- function(cinfo, cont, kids) {
|
||
| 335 | -1017x | +1619 | +2878x |
- if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
+ if (!is.null(cinfo)) {
|
| 336 | -3x | +1620 | +2878x |
- stop(+ cinfo |
| 337 | -3x | +|||
| 1621 | +! |
- "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ",+ } else if (!is.null(cont)) {
|
||
| 338 | -3x | +|||
| 1622 | +! |
- class(spl), " (", payloadmsg(spl), ")\n",
+ col_info(cont) |
||
| 339 | -3x | +|||
| 1623 | +! |
- "\toccured at path: ",+ } else if (length(kids) >= 1) {
|
||
| 340 | -3x | +|||
| 1624 | +! |
- spl_context_to_disp_path(spl_context), "\n"+ col_info(kids[[1]]) |
||
| 341 | +1625 |
- )+ } else {
|
||
| 342 | -+ | |||
| 1626 | +! |
- }+ EmptyColInfo |
||
| 343 | -1014x | +|||
| 1627 | +
- ret+ } |
|||
| 344 | +1628 |
} |
||
| 345 | +1629 | |||
| 346 | +1630 |
- .apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
+ ## under this model, non-leaf nodes can have a content table where rollup |
||
| 347 | -1003x | +|||
| 1631 | +
- if (is.null(vals)) {
+ ## analyses live |
|||
| 348 | -929x | +|||
| 1632 | +
- vals <- .applysplit_rawvals(spl, df)+ #' @exportClass TableTree |
|||
| 349 | +1633 |
- }+ #' @rdname tabclasses |
||
| 350 | -1003x | +|||
| 1634 | +
- extr <- .applysplit_extras(spl, df, vals)+ setClass("TableTree",
|
|||
| 351 | +1635 |
-
+ contains = c("VTableTree"),
|
||
| 352 | -1003x | +|||
| 1636 | +
- if (is.null(vals)) {
+ representation( |
|||
| 353 | -! | +|||
| 1637 | +
- return(list(+ content = "ElementaryTable", |
|||
| 354 | -! | +|||
| 1638 | +
- values = list(),+ page_title_prefix = "character" |
|||
| 355 | -! | +|||
| 1639 | +
- datasplit = list(),+ ), |
|||
| 356 | -! | +|||
| 1640 | +
- labels = list(),+ validity = ttable_validity |
|||
| 357 | -! | +|||
| 1641 | +
- extras = list()+ ) |
|||
| 358 | +1642 |
- ))+ |
||
| 359 | +1643 |
- }+ #' @export |
||
| 360 | +1644 |
-
+ #' @rdname tabclasses |
||
| 361 | -1003x | +|||
| 1645 | +
- dpart <- .applysplit_datapart(spl, df, vals)+ TableTree <- function(kids = list(), |
|||
| 362 | +1646 |
-
+ name = if (!is.na(var)) var else "", |
||
| 363 | -1003x | +|||
| 1647 | +
- if (is.null(labels)) {
+ cont = EmptyElTable, |
|||
| 364 | -1002x | +|||
| 1648 | +
- labels <- .applysplit_partlabels(spl, df, vals, labels)+ lev = 1L, |
|||
| 365 | +1649 |
- } else {
+ label = name, |
||
| 366 | -1x | +|||
| 1650 | +
- stopifnot(names(labels) == names(vals))+ labelrow = LabelRow( |
|||
| 367 | +1651 |
- }+ lev = lev, |
||
| 368 | +1652 |
- ## get rid of columns that would not have any+ label = label, |
||
| 369 | +1653 |
- ## observations.+ vis = nrow(cont) == 0 && !is.na(label) && |
||
| 370 | +1654 |
- ##+ nzchar(label) |
||
| 371 | +1655 |
- ## But only if there were any rows to start with+ ), |
||
| 372 | +1656 |
- ## if not we're in a manually constructed table+ rspans = data.frame(), |
||
| 373 | +1657 |
- ## column tree+ iscontent = NA, |
||
| 374 | -1003x | +|||
| 1658 | +
- if (trim) {
+ var = NA_character_, |
|||
| 375 | -! | +|||
| 1659 | +
- hasdata <- sapply(dpart, function(x) nrow(x) > 0)+ cinfo = NULL, |
|||
| 376 | -! | +|||
| 1660 | +
- if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
+ format = NULL, |
|||
| 377 | -! | +|||
| 1661 | +
- dpart <- dpart[hasdata]+ na_str = NA_character_, |
|||
| 378 | -! | +|||
| 1662 | +
- vals <- vals[hasdata]+ indent_mod = 0L, |
|||
| 379 | -! | +|||
| 1663 | +
- extr <- extr[hasdata]+ title = "", |
|||
| 380 | -! | +|||
| 1664 | +
- labels <- labels[hasdata]+ subtitles = character(), |
|||
| 381 | +1665 |
- }+ main_footer = character(), |
||
| 382 | +1666 |
- }+ prov_footer = character(), |
||
| 383 | +1667 |
-
+ page_title = NA_character_, |
||
| 384 | -1003x | +|||
| 1668 | +
- if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
+ hsep = default_hsep(), |
|||
| 385 | -150x | +|||
| 1669 | +
- vord <- seq_along(vals)+ header_section_div = NA_character_, |
|||
| 386 | +1670 |
- } else {
+ trailing_section_div = NA_character_, |
||
| 387 | -853x | +|||
| 1671 | +
- vord <- match(+ inset = 0L) {
|
|||
| 388 | -853x | +1672 | +2878x |
- spl_child_order(spl),+ check_ok_label(label) |
| 389 | -853x | +1673 | +2878x |
- vals+ cinfo <- .calc_cinfo(cinfo, cont, kids) |
| 390 | +1674 |
- )+ |
||
| 391 | -853x | +1675 | +2878x |
- vord <- vord[!is.na(vord)]+ kids <- .enforce_valid_kids(kids, cinfo) |
| 392 | -+ | |||
| 1676 | +2878x |
- }+ if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
|
||
| 393 | -+ | |||
| 1677 | +! |
-
+ stop("Got table tree with content table and content position")
|
||
| 394 | +1678 |
- ## FIXME: should be an S4 object, not a list+ } |
||
| 395 | -1003x | +1679 | +2878x |
- ret <- list(+ if (no_colinfo(labelrow)) {
|
| 396 | -1003x | +1680 | +1637x |
- values = vals[vord],+ col_info(labelrow) <- cinfo |
| 397 | -1003x | +|||
| 1681 | +
- datasplit = dpart[vord],+ } |
|||
| 398 | -1003x | +1682 | +2878x |
- labels = labels[vord],+ if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
|
| 399 | -1003x | +1683 | +1182x |
- extras = extr[vord]+ if (!is.na(page_title)) {
+ |
+
| 1684 | +! | +
+ stop("Got a page title prefix for an Elementary Table")
|
||
| 400 | +1685 |
- )+ }+ |
+ ||
| 1686 | ++ |
+ ## constructor takes care of recursive format application |
||
| 401 | -1003x | +1687 | +1182x |
- ret+ ElementaryTable( |
| 402 | -+ | |||
| 1688 | +1182x |
- }+ kids = kids, |
||
| 403 | -+ | |||
| 1689 | +1182x |
-
+ name = .chkname(name), |
||
| 404 | -+ | |||
| 1690 | +1182x |
- .checkvarsok <- function(spl, df) {
+ lev = lev, |
||
| 405 | -1922x | +1691 | +1182x |
- vars <- spl_payload(spl)+ labelrow = labelrow, |
| 406 | -+ | |||
| 1692 | +1182x |
- ## could be multiple vars in the future?+ rspans = rspans, |
||
| 407 | -+ | |||
| 1693 | +1182x |
- ## no reason not to make that work here now.+ cinfo = cinfo, |
||
| 408 | -1922x | +1694 | +1182x |
- if (!all(vars %in% names(df))) {
+ var = var, |
| 409 | -2x | +1695 | +1182x |
- stop(+ format = format, |
| 410 | -2x | +1696 | +1182x |
- " variable(s) [",+ na_str = na_str, |
| 411 | -2x | +1697 | +1182x |
- paste(setdiff(vars, names(df)),+ indent_mod = indent_mod, |
| 412 | -2x | +1698 | +1182x |
- collapse = ", "+ title = title, |
| 413 | -+ | |||
| 1699 | +1182x |
- ),+ subtitles = subtitles, |
||
| 414 | -2x | +1700 | +1182x |
- "] not present in data. (",
+ main_footer = main_footer, |
| 415 | -2x | +1701 | +1182x |
- class(spl), ")"+ prov_footer = prov_footer, |
| 416 | -+ | |||
| 1702 | +1182x |
- )+ hsep = hsep, |
||
| 417 | -+ | |||
| 1703 | +1182x |
- }+ header_section_div = header_section_div, |
||
| 418 | -1920x | +1704 | +1182x |
- invisible(NULL)+ trailing_section_div = trailing_section_div, |
| 419 | -+ | |||
| 1705 | +1182x |
- }+ inset = inset |
||
| 420 | +1706 |
-
+ ) |
||
| 421 | +1707 |
- ### Methods to verify a split appears to be valid, applicable+ } else {
|
||
| 422 | -+ | |||
| 1708 | +1696x |
- ### to the ***current subset*** of the df.+ tab <- new("TableTree",
|
||
| 423 | -+ | |||
| 1709 | +1696x |
- ###+ content = cont, |
||
| 424 | -+ | |||
| 1710 | +1696x |
- ### This is called at each level of recursive splitting so+ children = kids, |
||
| 425 | -+ | |||
| 1711 | +1696x |
- ### do NOT make it check, e.g., if the ref_group level of+ name = .chkname(name), |
||
| 426 | -+ | |||
| 1712 | +1696x |
- ### a factor is present in the data, because it may not be.+ level = lev, |
||
| 427 | -+ | |||
| 1713 | +1696x |
-
+ labelrow = labelrow, |
||
| 428 | -+ | |||
| 1714 | +1696x |
- setMethod(+ rowspans = rspans, |
||
| 429 | -+ | |||
| 1715 | +1696x |
- "check_validsplit", "VarLevelSplit",+ col_info = cinfo, |
||
| 430 | -+ | |||
| 1716 | +1696x |
- function(spl, df) {
+ format = NULL, |
||
| 431 | -798x | +1717 | +1696x |
- .checkvarsok(spl, df)+ na_str = na_str, |
| 432 | -+ | |||
| 1718 | +1696x |
- }+ table_inset = 0L, |
||
| 433 | -+ | |||
| 1719 | +1696x |
- )+ indent_modifier = as.integer(indent_mod), |
||
| 434 | -+ | |||
| 1720 | +1696x |
-
+ main_title = title, |
||
| 435 | -+ | |||
| 1721 | +1696x |
- setMethod(+ subtitles = subtitles, |
||
| 436 | -+ | |||
| 1722 | +1696x |
- "check_validsplit", "MultiVarSplit",+ main_footer = main_footer, |
||
| 437 | -+ | |||
| 1723 | +1696x |
- function(spl, df) {
+ provenance_footer = prov_footer, |
||
| 438 | -55x | +1724 | +1696x |
- .checkvarsok(spl, df)+ page_title_prefix = page_title, |
| 439 | -+ | |||
| 1725 | +1696x |
- }+ horizontal_sep = "-", |
||
| 440 | -+ | |||
| 1726 | +1696x |
- )+ header_section_div = header_section_div,+ |
+ ||
| 1727 | +1696x | +
+ trailing_section_div = trailing_section_div+ |
+ ||
| 1728 | +1696x | +
+ ) ## this is overridden below to get recursiveness+ |
+ ||
| 1729 | +1696x | +
+ tab <- set_format_recursive(tab, format, na_str, FALSE) |
||
| 441 | +1730 | |||
| 442 | +1731 |
- setMethod(+ ## these is recursive |
||
| 443 | +1732 |
- "check_validsplit", "VAnalyzeSplit",+ ## XXX combine these probably |
||
| 444 | -+ | |||
| 1733 | +1696x |
- function(spl, df) {
+ horizontal_sep(tab) <- hsep |
||
| 445 | -1123x | +1734 | +1696x |
- if (!is.na(spl_payload(spl))) {
+ table_inset(tab) <- as.integer(inset) |
| 446 | -1069x | +1735 | +1696x |
- .checkvarsok(spl, df)+ tab |
| 447 | +1736 |
- } else {
+ } |
||
| 448 | -54x | +|||
| 1737 | +
- TRUE+ } |
|||
| 449 | +1738 |
- }+ |
||
| 450 | +1739 |
- }+ ### Pre-Data Layout Declaration Classes |
||
| 451 | +1740 |
- )+ ### |
||
| 452 | +1741 |
-
+ ### Notably these are NOT represented as trees |
||
| 453 | +1742 |
- setMethod(+ ### because without data we cannot know what the |
||
| 454 | +1743 |
- "check_validsplit", "CompoundSplit",+ ### children should be. |
||
| 455 | +1744 |
- function(spl, df) {
+
|
||
| 456 | -! | +|||
| 1745 | +
- all(sapply(spl_payload(spl), df))+ ## Vector (ordered list) of splits. |
|||
| 457 | +1746 |
- }+ ## |
||
| 458 | +1747 |
- )+ ## This is a vector (ordered list) of splits to be |
||
| 459 | +1748 |
-
+ ## applied recursively to the data when provided. |
||
| 460 | +1749 |
- ## default does nothing, add methods as they become+ ## |
||
| 461 | +1750 |
- ## required+ ## For convenience, if this is length 1, it can contain |
||
| 462 | +1751 |
- setMethod(+ ## a pre-existing TableTree/ElementaryTable. |
||
| 463 | +1752 |
- "check_validsplit", "Split",+ ## This is used for add_existing_table in colby_constructors.R |
||
| 464 | -119x | +|||
| 1753 | +
- function(spl, df) invisible(NULL)+ |
|||
| 465 | +1754 |
- )+ setClass("SplitVector",
|
||
| 466 | +1755 |
-
+ contains = "list", |
||
| 467 | +1756 |
- setMethod(+ validity = function(object) {
|
||
| 468 | +1757 |
- ".applysplit_rawvals", "VarLevelSplit",+ if (length(object) >= 1) {
|
||
| 469 | +1758 |
- function(spl, df) {
+ lst <- tail(object, 1)[[1]] |
||
| 470 | -711x | +|||
| 1759 | +
- varvec <- df[[spl_payload(spl)]]+ } else {
|
|||
| 471 | -711x | -
- if (is.factor(varvec)) {
- |
- ||
| 472 | -511x | +|||
| 1760 | +
- levels(varvec)+ lst <- NULL |
|||
| 473 | +1761 |
- } else {
+ } |
||
| 474 | -200x | +|||
| 1762 | +
- unique(varvec)+ all(sapply(head(object, -1), is, "Split")) && |
|||
| 475 | +1763 |
- }+ (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo")) |
||
| 476 | +1764 |
} |
||
| 477 | +1765 |
) |
||
| 478 | +1766 | |||
| 479 | +1767 |
- setMethod(+ SplitVector <- function(x = NULL, |
||
| 480 | +1768 |
- ".applysplit_rawvals", "MultiVarSplit",+ ..., |
||
| 481 | +1769 |
- function(spl, df) {
+ lst = list(...)) {
|
||
| 482 | -+ | |||
| 1770 | +2443x |
- ## spl_payload(spl)+ if (!is.null(x)) {
|
||
| 483 | -48x | +1771 | +456x |
- spl_varnames(spl)+ lst <- unlist(c(list(x), lst), recursive = FALSE) |
| 484 | +1772 |
} |
||
| 1773 | +2443x | +
+ new("SplitVector", lst)
+ |
+ ||
| 485 | +1774 |
- )+ } |
||
| 486 | +1775 | |||
| 487 | +1776 |
- setMethod(+ avar_noneorlast <- function(vec) {
+ |
+ ||
| 1777 | +977x | +
+ if (!is(vec, "SplitVector")) {
+ |
+ ||
| 1778 | +! | +
+ return(FALSE) |
||
| 488 | +1779 |
- ".applysplit_rawvals", "AllSplit",+ } |
||
| 489 | -97x | +1780 | +977x |
- function(spl, df) obj_name(spl)+ if (length(vec) == 0) {
+ |
+
| 1781 | +634x | +
+ return(TRUE) |
||
| 490 | +1782 |
- ) # "all obs")+ }+ |
+ ||
| 1783 | +343x | +
+ isavar <- which(sapply(vec, is, "AnalyzeVarSplit"))+ |
+ ||
| 1784 | +343x | +
+ (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec)) |
||
| 491 | +1785 | ++ |
+ }+ |
+ |
| 1786 | ||||
| 492 | +1787 |
- setMethod(+ setClass("PreDataAxisLayout",
|
||
| 493 | +1788 |
- ".applysplit_rawvals", "ManualSplit",+ contains = "list", |
||
| 494 | -51x | +|||
| 1789 | +
- function(spl, df) spl@levels+ representation(root_split = "ANY"), |
|||
| 495 | +1790 |
- )+ validity = function(object) {
|
||
| 496 | +1791 |
-
+ allleafs <- unlist(object, recursive = TRUE) |
||
| 497 | +1792 |
- ## setMethod(".applysplit_rawvals", "NULLSplit",
+ all(sapply(object, avar_noneorlast)) && |
||
| 498 | +1793 |
- ## function(spl, df) "")+ all(sapply( |
||
| 499 | +1794 |
-
+ allleafs, |
||
| 500 | +1795 |
- setMethod(+ ## remember existing table trees can be added to layouts |
||
| 501 | +1796 |
- ".applysplit_rawvals", "VAnalyzeSplit",+ ## for now... |
||
| 502 | -! | +|||
| 1797 | +
- function(spl, df) spl_payload(spl)+ function(x) is(x, "Split") || is(x, "VTableTree") |
|||
| 503 | +1798 |
- )+ )) |
||
| 504 | +1799 |
-
+ } |
||
| 505 | +1800 |
- ## formfactor here is gross we're gonna have ot do this+ ) |
||
| 506 | +1801 |
- ## all again in tthe data split part :-/+ |
||
| 507 | +1802 |
- setMethod(+ setClass("PreDataColLayout",
|
||
| 508 | +1803 |
- ".applysplit_rawvals", "VarStaticCutSplit",+ contains = "PreDataAxisLayout", |
||
| 509 | +1804 |
- function(spl, df) {
+ representation( |
||
| 510 | -22x | +|||
| 1805 | +
- spl_cutlabels(spl)+ display_columncounts = "logical", |
|||
| 511 | +1806 |
- }+ columncount_format = "FormatSpec" # "character" |
||
| 512 | +1807 |
- )+ ) |
||
| 513 | +1808 |
-
+ ) |
||
| 514 | +1809 |
- setMethod(+ |
||
| 515 | +1810 |
- ".applysplit_datapart", "VarLevelSplit",+ setClass("PreDataRowLayout", contains = "PreDataAxisLayout")
|
||
| 516 | +1811 |
- function(spl, df, vals) {
+
|
||
| 517 | -785x | +|||
| 1812 | +
- if (!(spl_payload(spl) %in% names(df))) {
+ PreDataColLayout <- function(x = SplitVector(), |
|||
| 518 | -! | +|||
| 1813 | +
- stop(+ rtsp = RootSplit(), |
|||
| 519 | -! | +|||
| 1814 | +
- "Attempted to split on values of column (", spl_payload(spl),
+ ..., |
|||
| 520 | -! | +|||
| 1815 | +
- ") not present in the data"+ lst = list(x, ...), |
|||
| 521 | +1816 |
- )+ disp_colcounts = NA, |
||
| 522 | +1817 |
- }+ colcount_format = "(N=xx)") {
|
||
| 523 | -785x | +1818 | +312x |
- ret <- lapply(seq_along(vals), function(i) {
+ ret <- new("PreDataColLayout", lst,
|
| 524 | -2143x | +1819 | +312x |
- spl_col <- df[[spl_payload(spl)]]+ display_columncounts = disp_colcounts, |
| 525 | -2143x | +1820 | +312x |
- df[!is.na(spl_col) & spl_col == vals[[i]], ]+ columncount_format = colcount_format |
| 526 | +1821 |
- })+ ) |
||
| 527 | -785x | +1822 | +312x |
- names(ret) <- as.character(vals)+ ret@root_split <- rtsp |
| 528 | -785x | +1823 | +312x |
- ret+ ret |
| 529 | +1824 |
- }+ } |
||
| 530 | +1825 |
- )+ |
||
| 531 | +1826 |
-
+ PreDataRowLayout <- function(x = SplitVector(), |
||
| 532 | +1827 |
- setMethod(+ root = RootSplit(), |
||
| 533 | +1828 |
- ".applysplit_datapart", "MultiVarSplit",+ ..., |
||
| 534 | +1829 |
- function(spl, df, vals) {
- |
- ||
| 535 | -48x | -
- allvnms <- spl_varnames(spl)+ lst = list(x, ...)) {
|
||
| 536 | -48x | -
- if (!is.null(vals) && !identical(allvnms, vals)) {
- |
- ||
| 537 | -! | +1830 | +640x |
- incl <- match(vals, allvnms)+ new("PreDataRowLayout", lst, root_split = root)
|
| 538 | +1831 |
- } else {
+ } |
||
| 539 | -48x | +|||
| 1832 | +
- incl <- seq_along(allvnms)+ |
|||
| 540 | +1833 |
- }+ setClass("PreDataTableLayouts",
|
||
| 541 | -48x | +|||
| 1834 | +
- vars <- spl_payload(spl)[incl]+ contains = "VTitleFooter", |
|||
| 542 | +1835 |
- ## don't remove nas+ representation( |
||
| 543 | +1836 |
- ## ret = lapply(vars, function(cl) {
+ row_layout = "PreDataRowLayout", |
||
| 544 | +1837 |
- ## df[!is.na(df[[cl]]),]+ col_layout = "PreDataColLayout", |
||
| 545 | +1838 |
- ## })+ top_left = "character", |
||
| 546 | -48x | +|||
| 1839 | +
- ret <- rep(list(df), length(vars))+ header_section_div = "character", |
|||
| 547 | -48x | +|||
| 1840 | +
- names(ret) <- vals+ top_level_section_div = "character", |
|||
| 548 | -48x | +|||
| 1841 | +
- ret+ table_inset = "integer" |
|||
| 549 | +1842 |
- }+ ) |
||
| 550 | +1843 |
) |
||
| 551 | +1844 | |||
| 552 | +1845 |
- setMethod(+ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), |
||
| 553 | +1846 |
- ".applysplit_datapart", "AllSplit",- |
- ||
| 554 | -97x | -
- function(spl, df, vals) list(df)+ clayout = PreDataColLayout(), |
||
| 555 | +1847 |
- )+ topleft = character(), |
||
| 556 | +1848 |
-
+ title = "", |
||
| 557 | +1849 |
- ## ## not sure I need this+ subtitles = character(), |
||
| 558 | +1850 |
- setMethod(+ main_footer = character(), |
||
| 559 | +1851 |
- ".applysplit_datapart", "ManualSplit",- |
- ||
| 560 | -51x | -
- function(spl, df, vals) rep(list(df), times = length(vals))+ prov_footer = character(), |
||
| 561 | +1852 |
- )+ header_section_div = NA_character_, |
||
| 562 | +1853 |
-
+ top_level_section_div = NA_character_, |
||
| 563 | +1854 |
- ## setMethod(".applysplit_datapart", "NULLSplit",
+ table_inset = 0L) {
|
||
| 564 | -+ | |||
| 1855 | +312x |
- ## function(spl, df, vals) list(df[FALSE,]))+ new("PreDataTableLayouts",
|
||
| 565 | -+ | |||
| 1856 | +312x |
-
+ row_layout = rlayout, |
||
| 566 | -+ | |||
| 1857 | +312x |
- setMethod(+ col_layout = clayout, |
||
| 567 | -+ | |||
| 1858 | +312x |
- ".applysplit_datapart", "VarStaticCutSplit",+ top_left = topleft, |
||
| 568 | -+ | |||
| 1859 | +312x |
- function(spl, df, vals) {
+ main_title = title, |
||
| 569 | -+ | |||
| 1860 | +312x |
- # lbs = spl_cutlabels(spl)+ subtitles = subtitles, |
||
| 570 | -14x | +1861 | +312x |
- var <- spl_payload(spl)+ main_footer = main_footer, |
| 571 | -14x | +1862 | +312x |
- varvec <- df[[var]]+ provenance_footer = prov_footer, |
| 572 | -14x | +1863 | +312x |
- cts <- spl_cuts(spl)+ header_section_div = header_section_div, |
| 573 | -14x | +1864 | +312x |
- cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ top_level_section_div = top_level_section_div, |
| 574 | -14x | +1865 | +312x |
- split(df, cfct, drop = FALSE)+ table_inset = table_inset |
| 575 | +1866 |
- }+ ) |
||
| 576 | +1867 |
- )+ } |
||
| 577 | +1868 | |||
| 578 | +1869 |
- setMethod(+ ## setClass("CellValue", contains = "ValueWrapper",
|
||
| 579 | +1870 |
- ".applysplit_datapart", "CumulativeCutSplit",+ ## representation(format = "FormatSpec", |
||
| 580 | +1871 |
- function(spl, df, vals) {
+ ## colspan = "integerOrNULL", |
||
| 581 | +1872 |
- # lbs = spl_cutlabels(spl)+ ## label = "characterOrNULL"), |
||
| 582 | -8x | +|||
| 1873 | +
- var <- spl_payload(spl)+ ## prototype = list(label ="", colspan = NULL, format = NULL)) |
|||
| 583 | -8x | +|||
| 1874 | +
- varvec <- df[[var]]+ |
|||
| 584 | -8x | +|||
| 1875 | +
- cts <- spl_cuts(spl)+ setOldClass("CellValue")
|
|||
| 585 | -8x | +|||
| 1876 | +
- cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ |
|||
| 586 | -8x | +|||
| 1877 | +
- ret <- lapply(+ #' Length of a Cell value |
|||
| 587 | -8x | +|||
| 1878 | +
- seq_len(length(levels(cfct))),+ #' |
|||
| 588 | -8x | +|||
| 1879 | +
- function(i) df[as.integer(cfct) <= i, ]+ #' @param x (`CellValue`)\cr a `CellValue` object. |
|||
| 589 | +1880 |
- )+ #' |
||
| 590 | -8x | +|||
| 1881 | +
- names(ret) <- levels(cfct)+ #' @return Always returns `1L`. |
|||
| 591 | -8x | +|||
| 1882 | +
- ret+ #' |
|||
| 592 | +1883 |
- }+ #' @exportMethod length |
||
| 593 | +1884 |
- )+ setMethod( |
||
| 594 | +1885 |
-
+ "length", "CellValue", |
||
| 595 | -+ | |||
| 1886 | +! |
- ## XXX TODO *CutSplit Methods+ function(x) 1L |
||
| 596 | +1887 |
-
+ ) |
||
| 597 | +1888 |
- setClass("NullSentinel", contains = "NULL")
+
|
||
| 598 | +1889 |
- nullsentinel <- new("NullSentinel")
+ setClass("RefFootnote", representation(
|
||
| 599 | -! | +|||
| 1890 | +
- noarg <- function() nullsentinel+ value = "character", |
|||
| 600 | +1891 |
-
+ index = "integer", |
||
| 601 | +1892 |
- ## Extras generation methods+ symbol = "character" |
||
| 602 | +1893 |
- setMethod(+ )) |
||
| 603 | +1894 |
- ".applysplit_extras", "Split",+ |
||
| 604 | +1895 |
- function(spl, df, vals) {
+ RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
|
||
| 605 | -952x | +1896 | +168x |
- splex <- split_exargs(spl)+ if (is(note, "RefFootnote")) {
|
| 606 | -952x | +1897 | +66x |
- nvals <- length(vals)+ return(note) |
| 607 | -952x | +1898 | +102x |
- lapply(seq_len(nvals), function(vpos) {
+ } else if (length(note) == 0) {
|
| 608 | -2432x | +|||
| 1899 | +! |
- one_ex <- lapply(splex, function(arg) {
+ return(NULL) |
||
| 609 | -! | +|||
| 1900 | +
- if (length(arg) >= vpos) {
+ }+ |
+ |||
| 1901 | +102x | +
+ if (length(symbol) != 1L) {
|
||
| 610 | +1902 | ! |
- arg[[vpos]]+ stop( |
|
| 611 | -+ | |||
| 1903 | +! |
- } else {
+ "Referential footnote can only have a single string as its index.", |
||
| 612 | +1904 | ! |
- noarg()+ " Got char vector of length ", length(index) |
|
| 613 | +1905 |
- }+ ) |
||
| 614 | +1906 |
- })+ } |
||
| 615 | -2432x | +1907 | +102x |
- names(one_ex) <- names(splex)+ if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) {
|
| 616 | -2432x | +|||
| 1908 | +! |
- one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")]+ stop( |
||
| 617 | -2432x | +|||
| 1909 | +! |
- one_ex+ "The string 'NA' and strings containing '{' or '}' cannot be used as ",
|
||
| 618 | -+ | |||
| 1910 | +! |
- })+ "referential footnote index symbols. Got string '", index, "'." |
||
| 619 | +1911 |
- }+ ) |
||
| 620 | +1912 |
- )+ } |
||
| 621 | +1913 | |||
| 622 | -+ | |||
| 1914 | +102x |
- setMethod(+ new("RefFootnote", value = note, index = index, symbol = symbol)
|
||
| 623 | +1915 |
- ".applysplit_ref_vals", "Split",- |
- ||
| 624 | -! | -
- function(spl, df, vals) rep(list(NULL), length(vals))+ } |
||
| 625 | +1916 |
- )+ |
||
| 626 | +1917 |
-
+ #' Constructor for Cell Value |
||
| 627 | +1918 |
- setMethod(+ #' |
||
| 628 | +1919 |
- ".applysplit_ref_vals", "VarLevWBaselineSplit",+ #' @inheritParams lyt_args |
||
| 629 | +1920 |
- 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) {
+ #' @inheritParams rcell |
||
| 633 | -46x | +|||
| 1921 | +
- list(.in_ref_col = vl == bl_level)+ #' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted. |
|||
| 634 | +1922 |
- })+ #' |
||
| 635 | -17x | +|||
| 1923 | +
- names(ret) <- vnames+ #' @return An object representing the value within a single cell within a populated table. The underlying structure |
|||
| 636 | -17x | +|||
| 1924 | +
- ret+ #' of this object is an implementation detail and should not be relied upon beyond calling accessors for the class. |
|||
| 637 | +1925 |
- }+ #' |
||
| 638 | +1926 |
- )+ #' @export |
||
| 639 | +1927 | |||
| 640 | +1928 |
- ## XXX TODO FIXME+ ## Class definition |
||
| 641 | +1929 |
- setMethod(+ ## [[1]] list: cell value |
||
| 642 | +1930 |
- ".applysplit_partlabels", "Split",+ ## format : format for cell |
||
| 643 | -119x | +|||
| 1931 | +
- function(spl, df, vals, labels) as.character(vals)+ ## colspan: column span info for cell |
|||
| 644 | +1932 |
- )+ ## label: row label to be used for parent row |
||
| 645 | +1933 |
-
+ ## indent_mod: indent modifier to be used for parent row |
||
| 646 | +1934 |
- setMethod(+ CellValue <- function(val, format = NULL, colspan = 1L, label = NULL, |
||
| 647 | +1935 |
- ".applysplit_partlabels", "VarLevelSplit",+ indent_mod = NULL, footnotes = NULL, |
||
| 648 | +1936 |
- function(spl, df, vals, labels) {
+ align = NULL, format_na_str = NULL) {
|
||
| 649 | -784x | +1937 | +13046x |
- varname <- spl_payload(spl)+ if (is.null(colspan)) {
+ |
+
| 1938 | +! | +
+ colspan <- 1L+ |
+ ||
| 1939 | ++ |
+ } |
||
| 650 | -784x | +1940 | +13046x |
- vlabelname <- spl_labelvar(spl)+ if (!is.null(colspan) && !is(colspan, "integer")) {
|
| 651 | -784x | +1941 | +10x |
- varvec <- df[[varname]]+ colspan <- as.integer(colspan) |
| 652 | +1942 |
- ## we used to check if vals was NULL but+ } |
||
| 653 | +1943 |
- ## this is called after a short-circuit return in .apply_split_inner in that+ ## if we're not given a label but the value has one associated with |
||
| 654 | +1944 |
- ## case+ ## it we use that. |
||
| 655 | +1945 |
- ## so vals is guaranteed to be non-null here+ ## NB: we need to be able to override a non-empty label with an empty one |
||
| 656 | -784x | +|||
| 1946 | +
- if (is.null(labels)) {
+ ## so we can't have "" mean "not given a label" here |
|||
| 657 | -784x | +1947 | +13046x |
- if (varname == vlabelname) {
+ if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
|
| 658 | -649x | +1948 | +2x |
- labels <- vals+ label <- obj_label(val) |
| 659 | +1949 |
- } else {
+ } |
||
| 660 | -135x | +1950 | +13046x |
- labfact <- is.factor(df[[vlabelname]])+ if (!is.list(footnotes)) {
|
| 661 | -135x | +1951 | +9x |
- lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL+ footnotes <- lapply(footnotes, RefFootnote) |
| 662 | -135x | +|||
| 1952 | +
- labels <- sapply(vals, function(v) {
+ } |
|||
| 663 | -272x | +1953 | +13046x |
- vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE])+ check_ok_label(label) |
| 664 | -+ | |||
| 1954 | +13046x |
- ## TODO remove this once 1-to-1 value-label map is enforced+ ret <- structure(list(val), |
||
| 665 | -+ | |||
| 1955 | +13046x |
- ## elsewhere.+ format = format, colspan = colspan, |
||
| 666 | -272x | +1956 | +13046x |
- stopifnot(length(vlabel) < 2)+ label = label, |
| 667 | -272x | +1957 | +13046x |
- if (length(vlabel) == 0) {
+ indent_mod = indent_mod, footnotes = footnotes, |
| 668 | -! | +|||
| 1958 | +13046x |
- vlabel <- ""+ align = align, |
||
| 669 | -272x | +1959 | +13046x |
- } else if (labfact) {
+ format_na_str = format_na_str, |
| 670 | -6x | +1960 | +13046x |
- vlabel <- lablevs[vlabel]+ class = "CellValue" |
| 671 | +1961 |
- }+ ) |
||
| 672 | -272x | -
- vlabel- |
- ||
| 673 | -+ | 1962 | +13046x |
- })+ ret |
| 674 | +1963 |
- }+ } |
||
| 675 | +1964 |
- }- |
- ||
| 676 | -784x | -
- names(labels) <- as.character(vals)- |
- ||
| 677 | -784x | -
- labels+ |
||
| 678 | +1965 |
- }+ #' @method print CellValue |
||
| 679 | +1966 |
- )+ #' |
||
| 680 | +1967 |
-
+ #' @export |
||
| 681 | +1968 |
- setMethod(+ print.CellValue <- function(x, ...) {
|
||
| 682 | -+ | |||
| 1969 | +! |
- ".applysplit_partlabels", "MultiVarSplit",+ cat(paste("rcell:", format_rcell(x), "\n"))
|
||
| 683 | -48x | +|||
| 1970 | +! |
- function(spl, df, vals, labels) value_labels(spl)+ invisible(x) |
||
| 684 | +1971 |
- )+ } |
||
| 685 | +1972 | |||
| 686 | +1973 |
- make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals,+ ## too slow |
||
| 687 | +1974 |
- subset_exprs) {
- |
- ||
| 688 | -2590x | -
- if (length(vals) == 0) {
- |
- ||
| 689 | -358x | -
- return(vals)+ # setClass("RowsVerticalSection", contains = "list",
|
||
| 690 | +1975 |
- }+ # representation = list(row_names = "characterOrNULL", |
||
| 691 | +1976 | - - | -||
| 692 | -2232x | -
- if (is(extrs, "AsIs")) {
- |
- ||
| 693 | -! | -
- extrs <- unclass(extrs)+ # row_labels = "characterOrNULL", |
||
| 694 | +1977 |
- }+ # row_formats = "ANY", |
||
| 695 | +1978 |
- ## if(are(vals, "SplitValue")) {
+ # indent_mods = "integerOrNULL")) |
||
| 696 | +1979 | |||
| 697 | +1980 |
- ## return(vals)+ setOldClass("RowsVerticalSection")
|
||
| 698 | +1981 |
- ## }+ RowsVerticalSection <- function(values, |
||
| 699 | +1982 | - - | -||
| 700 | -2232x | -
- mapply(SplitValue,- |
- ||
| 701 | -2232x | -
- val = vals, extr = extrs,- |
- ||
| 702 | -2232x | -
- label = labels,+ names = names(values), |
||
| 703 | -2232x | +|||
| 1983 | +
- sub_expr = subset_exprs,+ labels = NULL, |
|||
| 704 | -2232x | +|||
| 1984 | +
- SIMPLIFY = FALSE+ indent_mods = NULL, |
|||
| 705 | +1985 |
- )+ formats = NULL, |
||
| 706 | +1986 |
- }+ footnotes = NULL, |
||
| 707 | +1987 |
-
+ format_na_strs = NULL) {
|
||
| 708 | -+ | |||
| 1988 | +5922x |
- #' Split functions+ stopifnot(is(values, "list")) |
||
| 709 | +1989 |
- #'+ ## innernms <- value_names(values) |
||
| 710 | +1990 |
- #' @inheritParams sf_args+ |
||
| 711 | -+ | |||
| 1991 | +5922x |
- #' @inheritParams gen_args+ if (is.null(labels)) {
|
||
| 712 | -+ | |||
| 1992 | +2653x |
- #' @param vals (`ANY`)\cr for internal use only.+ labels <- names(values) |
||
| 713 | +1993 |
- #' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones.+ } |
||
| 714 | -+ | |||
| 1994 | +5922x |
- #' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure+ if (is.null(names) && all(nzchar(labels))) {
|
||
| 715 | -+ | |||
| 1995 | +3318x |
- #' regardless of presence in the data).+ names <- labels |
||
| 716 | -+ | |||
| 1996 | +2604x |
- #'+ } else if (is.null(labels) && !is.null(names)) {
|
||
| 717 | -+ | |||
| 1997 | +15x |
- #' @inheritSection custom_split_funs Custom Splitting Function Details+ labels <- names |
||
| 718 | +1998 |
- #'+ } |
||
| 719 | +1999 |
- #' @inherit add_overall_level return+ |
||
| 720 | -+ | |||
| 2000 | +5922x |
- #'+ if (!is.null(indent_mods)) {
|
||
| 721 | -+ | |||
| 2001 | +68x |
- #' @name split_funcs+ indent_mods <- as.integer(indent_mods) |
||
| 722 | +2002 |
- NULL+ } |
||
| 723 | -+ | |||
| 2003 | +5922x |
-
+ check_ok_label(labels, multi_ok = TRUE) |
||
| 724 | -+ | |||
| 2004 | +5921x |
-
+ structure(values, |
||
| 725 | -+ | |||
| 2005 | +5921x |
- #' @examples+ class = "RowsVerticalSection", row_names = names, |
||
| 726 | -+ | |||
| 2006 | +5921x |
- #' lyt <- basic_table() %>%+ row_labels = labels, indent_mods = indent_mods, |
||
| 727 | -+ | |||
| 2007 | +5921x |
- #' split_cols_by("ARM") %>%
+ row_formats = formats, |
||
| 728 | -+ | |||
| 2008 | +5921x |
- #' split_rows_by("COUNTRY",
+ row_na_strs = format_na_strs, |
||
| 729 | -+ | |||
| 2009 | +5921x |
- #' split_fun = remove_split_levels(c(+ row_footnotes = lapply( |
||
| 730 | -+ | |||
| 2010 | +5921x |
- #' "USA", "CAN",+ footnotes, |
||
| 731 | +2011 |
- #' "CHE", "BRA"+ ## cause each row needs to accept |
||
| 732 | +2012 |
- #' ))+ ## a *list* of row footnotes |
||
| 733 | -+ | |||
| 2013 | +5921x |
- #' ) %>%+ function(fns) lapply(fns, RefFootnote) |
||
| 734 | +2014 |
- #' analyze("AGE")
+ ) |
||
| 735 | +2015 |
- #'+ ) |
||
| 736 | +2016 |
- #' tbl <- build_table(lyt, DM)+ } |
||
| 737 | +2017 |
- #' tbl+ |
||
| 738 | +2018 |
- #'+ #' @method print RowsVerticalSection |
||
| 739 | +2019 |
- #' @rdname split_funcs+ #' |
||
| 740 | +2020 |
#' @export |
||
| 741 | +2021 |
- remove_split_levels <- function(excl) {
+ print.RowsVerticalSection <- function(x, ...) {
|
||
| 742 | -28x | +2022 | +1x |
- stopifnot(is.character(excl))+ cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
|
| 743 | -28x | +2023 | +1x |
- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ "---------\n", |
| 744 | -56x | +2024 | +1x |
- var <- spl_payload(spl)+ sep = "" |
| 745 | -56x | +|||
| 2025 | +
- df2 <- df[!(df[[var]] %in% excl), ]+ ) |
|||
| 746 | -56x | +2026 | +1x |
- if (is.factor(df2[[var]])) {
+ print(data.frame( |
| 747 | +2027 | 1x |
- levels <- levels(df2[[var]])+ row_name = attr(x, "row_names", exact = TRUE), |
|
| 748 | +2028 | 1x |
- levels <- levels[!(levels %in% excl)]+ formatted_cell = vapply(x, format_rcell, character(1)), |
|
| 749 | +2029 | 1x |
- df2[[var]] <- factor(df2[[var]], levels = levels)- |
- |
| 750 | -- |
- }+ indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)), |
||
| 751 | -56x | +2030 | +1x |
- .apply_split_inner(spl, df2,+ row_label = attr(x, "row_labels", exact = TRUE), |
| 752 | -56x | +2031 | +1x |
- vals = vals,+ stringsAsFactors = FALSE, |
| 753 | -56x | +2032 | +1x |
- labels = labels,+ row.names = NULL |
| 754 | -56x | -
- trim = trim- |
- ||
| 755 | -+ | 2033 | +1x |
- )+ ), row.names = TRUE) |
| 756 | -+ | |||
| 2034 | +1x |
- }+ invisible(x) |
||
| 757 | +2035 |
} |
||
| 758 | +2036 | |||
| 759 | +2037 |
- #' @param only (`character`)\cr levels to retain (all others will be dropped).+ #### Empty default objects to avoid repeated calls |
||
| 760 | +2038 |
- #' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the+ ## EmptyColInfo <- InstantiatedColumnInfo() |
||
| 761 | +2039 |
- #' split. Defaults to `TRUE`.+ ## EmptyElTable <- ElementaryTable() |
||
| 762 | +2040 |
- #'+ ## EmptyRootSplit <- RootSplit() |
||
| 763 | +2041 |
- #' @examples+ ## EmptyAllSplit <- AllSplit() |
| 764 | +1 |
- #' lyt <- basic_table() %>%+ treestruct <- function(obj, ind = 0L) {
|
||
| 765 | -+ | |||
| 2 | +19x |
- #' split_cols_by("ARM") %>%
+ nc <- ncol(obj) |
||
| 766 | -+ | |||
| 3 | +19x |
- #' split_rows_by("COUNTRY",
+ cat(rep(" ", times = ind),
|
||
| 767 | -+ | |||
| 4 | +19x |
- #' split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
+ sprintf("[%s] %s", class(obj), obj_name(obj)),
|
||
| 768 | -+ | |||
| 5 | +19x |
- #' ) %>%+ sep = "" |
||
| 769 | +6 |
- #' analyze("AGE")
+ ) |
||
| 770 | -+ | |||
| 7 | +19x |
- #'+ if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
|
||
| 771 | -+ | |||
| 8 | +6x |
- #' tbl <- build_table(lyt, DM)+ crows <- nrow(content_table(obj)) |
||
| 772 | -+ | |||
| 9 | +6x |
- #' tbl+ ccols <- if (crows == 0) 0 else nc |
||
| 773 | -+ | |||
| 10 | +6x |
- #'+ cat(sprintf( |
||
| 774 | -+ | |||
| 11 | +6x |
- #' @rdname split_funcs+ " [cont: %d x %d]", |
||
| 775 | -+ | |||
| 12 | +6x |
- #' @export+ crows, ccols |
||
| 776 | +13 |
- keep_split_levels <- function(only, reorder = TRUE) {
+ )) |
||
| 777 | -40x | +|||
| 14 | +
- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ } |
|||
| 778 | -74x | +15 | +19x |
- var <- spl_payload(spl)+ if (is(obj, "VTableTree") && length(tree_children(obj))) {
|
| 779 | -74x | +16 | +19x |
- varvec <- df[[var]]+ kids <- tree_children(obj) |
| 780 | -74x | +17 | +19x |
- if (is.factor(varvec) && !all(only %in% levels(varvec))) {
+ if (are(kids, "TableRow")) {
|
| 781 | -1x | +18 | +9x |
- stop(+ cat(sprintf( |
| 782 | -1x | +19 | +9x |
- "Attempted to keep invalid factor level(s) in split ",+ " (%d x %d)\n", |
| 783 | -1x | +20 | +9x |
- setdiff(only, levels(varvec))+ length(kids), nc |
| 784 | +21 |
- )+ )) |
||
| 785 | +22 |
- }- |
- ||
| 786 | -73x | -
- df2 <- df[df[[var]] %in% only, ]+ } else {
|
||
| 787 | -73x | +23 | +10x |
- if (reorder) {
+ cat("\n")
|
| 788 | -73x | +24 | +10x |
- df2[[var]] <- factor(df2[[var]], levels = only)+ lapply(kids, treestruct, ind = ind + 1) |
| 789 | +25 |
} |
||
| 790 | -73x | +|||
| 26 | +
- spl_child_order(spl) <- only+ } |
|||
| 791 | -73x | +27 | +19x |
- .apply_split_inner(spl, df2,+ invisible(NULL) |
| 792 | -73x | +|||
| 28 | +
- vals = only,+ } |
|||
| 793 | -73x | +|||
| 29 | +
- labels = labels,+ |
|||
| 794 | -73x | +|||
| 30 | +
- trim = trim+ setGeneric( |
|||
| 795 | +31 |
- )+ "ploads_to_str", |
||
| 796 | -+ | |||
| 32 | +103x |
- }+ function(x, collapse = ":") standardGeneric("ploads_to_str")
|
||
| 797 | +33 |
- }+ ) |
||
| 798 | +34 | |||
| 799 | +35 |
- #' @examples+ setMethod( |
||
| 800 | +36 |
- #' lyt <- basic_table() %>%+ "ploads_to_str", "Split", |
||
| 801 | +37 |
- #' split_cols_by("ARM") %>%
+ function(x, collapse = ":") {
|
||
| 802 | -+ | |||
| 38 | +52x |
- #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ paste(sapply(spl_payload(x), ploads_to_str), |
||
| 803 | -+ | |||
| 39 | +52x |
- #' analyze("AGE")
+ collapse = collapse |
||
| 804 | +40 |
- #'+ ) |
||
| 805 | +41 |
- #' tbl <- build_table(lyt, DM)+ } |
||
| 806 | +42 |
- #' tbl+ ) |
||
| 807 | +43 |
- #'+ |
||
| 808 | +44 |
- #' @rdname split_funcs+ setMethod( |
||
| 809 | +45 |
- #' @export+ "ploads_to_str", "CompoundSplit", |
||
| 810 | +46 |
- drop_split_levels <- function(df,+ function(x, collapse = ":") {
|
||
| 811 | -+ | |||
| 47 | +6x |
- spl,+ paste(sapply(spl_payload(x), ploads_to_str),+ |
+ ||
| 48 | +6x | +
+ collapse = collapse |
||
| 812 | +49 |
- vals = NULL,+ ) |
||
| 813 | +50 |
- labels = NULL,+ } |
||
| 814 | +51 |
- trim = FALSE) {
+ ) |
||
| 815 | -165x | +|||
| 52 | +
- var <- spl_payload(spl)+ |
|||
| 816 | -165x | +|||
| 53 | +
- df2 <- df+ setMethod( |
|||
| 817 | -165x | +|||
| 54 | +
- df2[[var]] <- factor(df[[var]])+ "ploads_to_str", "list", |
|||
| 818 | -165x | +|||
| 55 | +
- lblvar <- spl_label_var(spl)+ function(x, collapse = ":") {
|
|||
| 819 | -165x | +|||
| 56 | +! |
- if (!is.null(lblvar)) {
+ stop("Please contact the maintainer")
|
||
| 820 | -165x | +|||
| 57 | +
- df2[[lblvar]] <- factor(df[[lblvar]])+ } |
|||
| 821 | +58 |
- }+ ) |
||
| 822 | +59 | |||
| 823 | -165x | +|||
| 60 | +
- .apply_split_inner(spl, df2,+ setMethod( |
|||
| 824 | -165x | +|||
| 61 | +
- vals = vals,+ "ploads_to_str", "SplitVector", |
|||
| 825 | -165x | +|||
| 62 | +
- labels = labels,+ function(x, collapse = ":") {
|
|||
| 826 | -165x | +63 | +8x |
- trim = trim+ sapply(x, ploads_to_str) |
| 827 | +64 |
- )+ } |
||
| 828 | +65 |
- }+ ) |
||
| 829 | +66 | |||
| 830 | +67 |
- #' @examples+ setMethod( |
||
| 831 | +68 |
- #' lyt <- basic_table() %>%+ "ploads_to_str", "ANY", |
||
| 832 | +69 |
- #' split_cols_by("ARM") %>%
+ function(x, collapse = ":") {
|
||
| 833 | -+ | |||
| 70 | +37x |
- #' split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
+ paste(x) |
||
| 834 | +71 |
- #' analyze("AGE")
+ } |
||
| 835 | +72 |
- #'+ ) |
||
| 836 | +73 |
- #' tbl <- build_table(lyt, DM)+ |
||
| 837 | -+ | |||
| 74 | +40x |
- #' tbl+ setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
|
||
| 838 | +75 |
- #'+ |
||
| 839 | +76 |
- #' @rdname split_funcs+ setMethod( |
||
| 840 | +77 |
- #' @export+ "payloadmsg", "VarLevelSplit", |
||
| 841 | +78 |
- drop_and_remove_levels <- function(excl) {
+ function(spl) {
|
||
| 842 | -4x | +79 | +39x |
- stopifnot(is.character(excl))+ spl_payload(spl) |
| 843 | -4x | +|||
| 80 | +
- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ } |
|||
| 844 | -13x | +|||
| 81 | +
- var <- spl_payload(spl)+ ) |
|||
| 845 | -13x | +|||
| 82 | +
- df2 <- df[!(df[[var]] %in% excl), ]+ |
|||
| 846 | -13x | +|||
| 83 | +
- df2[[var]] <- factor(df2[[var]])+ setMethod( |
|||
| 847 | -13x | +|||
| 84 | +
- .apply_split_inner(+ "payloadmsg", "MultiVarSplit", |
|||
| 848 | -13x | +85 | +1x |
- spl,+ function(spl) "var" |
| 849 | -13x | +|||
| 86 | +
- df2,+ ) |
|||
| 850 | -13x | +|||
| 87 | +
- vals = vals,+ |
|||
| 851 | -13x | +|||
| 88 | +
- labels = labels,+ setMethod( |
|||
| 852 | -13x | +|||
| 89 | +
- trim = trim+ "payloadmsg", "VarLevWBaselineSplit", |
|||
| 853 | +90 |
- )+ function(spl) {
|
||
| 854 | -+ | |||
| 91 | +! |
- }+ paste0( |
||
| 855 | -+ | |||
| 92 | +! |
- }+ spl_payload(spl), "[bsl ", |
||
| 856 | -+ | |||
| 93 | +! |
-
+ spl@ref_group_value, # XXX XXX |
||
| 857 | +94 |
- #' @param neworder (`character`)\cr new order of factor levels.+ "]" |
||
| 858 | +95 |
- #' @param newlabels (`character`)\cr labels for (new order of) factor levels.+ ) |
||
| 859 | +96 |
- #' @param drlevels (`flag`)\cr whether levels in the data which do not appear in `neworder` should be dropped.+ } |
||
| 860 | +97 |
- #' Defaults to `TRUE`.+ ) |
||
| 861 | +98 |
- #'+ |
||
| 862 | +99 |
- #' @rdname split_funcs+ setMethod( |
||
| 863 | +100 |
- #' @export+ "payloadmsg", "ManualSplit",+ |
+ ||
| 101 | +! | +
+ function(spl) "mnl" |
||
| 864 | +102 |
- reorder_split_levels <- function(neworder,+ ) |
||
| 865 | +103 |
- newlabels = neworder,+ |
||
| 866 | +104 |
- drlevels = TRUE) {
+ setMethod( |
||
| 867 | -1x | +|||
| 105 | +
- if (length(neworder) != length(newlabels)) {
+ "payloadmsg", "AllSplit", |
|||
| 868 | +106 | ! |
- stop("Got mismatching lengths for neworder and newlabels.")
+ function(spl) "all" |
|
| 869 | +107 |
- }+ ) |
||
| 870 | -1x | +|||
| 108 | +
- function(df, spl, trim, ...) {
+
|
|||
| 871 | -1x | +|||
| 109 | +
- df2 <- df+ setMethod( |
|||
| 872 | -1x | +|||
| 110 | +
- valvec <- df2[[spl_payload(spl)]]+ "payloadmsg", "ANY", |
|||
| 873 | -1x | +|||
| 111 | +
- vals <- if (is.factor(valvec)) levels(valvec) else unique(valvec)+ function(spl) {
|
|||
| 874 | -1x | +|||
| 112 | +! |
- if (!drlevels) {
+ warning("don't know how to make payload print message for Split of class", class(spl))
|
||
| 875 | +113 | ! |
- neworder <- c(neworder, setdiff(vals, neworder))+ "XXX" |
|
| 876 | +114 |
- }+ } |
||
| 877 | -1x | +|||
| 115 | +
- df2[[spl_payload(spl)]] <- factor(valvec, levels = neworder)+ ) |
|||
| 878 | -1x | +|||
| 116 | +
- if (drlevels) {
+
+ |
+ |||
| 117 | ++ |
+ spldesc <- function(spl, value = "") {
|
||
| 879 | -1x | +118 | +32x |
- orig_order <- neworder+ value <- rawvalues(value) |
| 880 | -1x | +119 | +32x |
- df2[[spl_payload(spl)]] <- droplevels(df2[[spl_payload(spl)]])+ payloadmsg <- payloadmsg(spl) |
| 881 | -1x | +120 | +32x |
- neworder <- levels(df2[[spl_payload(spl)]])+ format <- "%s (%s)" |
| 882 | -1x | +121 | +32x |
- newlabels <- newlabels[orig_order %in% neworder]+ sprintf( |
| 883 | -+ | |||
| 122 | +32x |
- }+ format, |
||
| 884 | -1x | +123 | +32x |
- spl_child_order(spl) <- neworder+ value, |
| 885 | -1x | +124 | +32x |
- .apply_split_inner(spl, df2, vals = neworder, labels = newlabels, trim = trim)+ payloadmsg |
| 886 | +125 |
- }+ ) |
||
| 887 | +126 |
} |
||
| 888 | +127 | |||
| 889 | +128 |
- #' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped)+ layoutmsg <- function(obj) {
|
||
| 890 | +129 |
- #' *separately within each grouping defined at this point in the structure*.+ ## if(!is(obj, "VLayoutNode")) |
||
| 891 | +130 |
- #' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer"+ ## stop("how did a non layoutnode object get in docatlayout??")
|
||
| 892 | +131 |
- #' variable, not `innervar`) should be dropped. Defaults to `TRUE`.+ |
||
| 893 | -+ | |||
| 132 | +28x |
- #'+ pos <- tree_pos(obj) |
||
| 894 | -+ | |||
| 133 | +28x |
- #' @rdname split_funcs+ 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))) |
||
| 895 | +138 |
- #' @export+ } |
||
| 896 | +139 |
- trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
+
|
||
| 897 | -3x | +140 | +16x |
- myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ msg <- paste( |
| 898 | -3x | +141 | +16x |
- if (!drop_outlevs) {
+ collapse = " -> ", |
| 899 | -! | +|||
| 142 | +16x |
- ret <- .apply_split_inner(spl, df,+ mapply(spldesc, |
||
| 900 | -! | +|||
| 143 | +16x |
- vals = vals,+ spl = spllst, |
||
| 901 | -! | +|||
| 144 | +16x |
- labels = labels, trim = trim+ value = spvallst |
||
| 902 | +145 |
- )+ ) |
||
| 903 | +146 |
- } else {
+ ) |
||
| 904 | -3x | +147 | +16x |
- ret <- drop_split_levels(+ msg |
| 905 | -3x | +|||
| 148 | +
- df = df, spl = spl, vals = vals,+ } |
|||
| 906 | -3x | +|||
| 149 | +
- labels = labels, trim = trim+ |
|||
| 907 | +150 |
- )+ setMethod( |
||
| 908 | +151 |
- }+ "show", "LayoutAxisTree", |
||
| 909 | +152 |
-
+ function(object) {
|
||
| 910 | -3x | +153 | +2x |
- ret$datasplit <- lapply(ret$datasplit, function(x) {
+ msg <- layoutmsg(object) |
| 911 | -8x | +154 | +2x |
- coldat <- x[[innervar]]+ cat(msg, "\n") |
| 912 | -8x | +155 | +2x |
- if (is(coldat, "character")) {
+ invisible(object) |
| 913 | -! | +|||
| 156 | +
- if (!is.null(vals)) {
+ } |
|||
| 914 | -! | +|||
| 157 | +
- lvs <- vals+ ) |
|||
| 915 | +158 |
- } else {
+
|
||
| 916 | -! | +|||
| 159 | +
- lvs <- unique(coldat)+ |
|||
| 917 | +160 |
- }+ #' Display column tree structure |
||
| 918 | -! | +|||
| 161 | +
- coldat <- factor(coldat, levels = lvs) ## otherwise+ #' |
|||
| 919 | +162 |
- } else {
+ #' Displays the tree structure of the columns of a |
||
| 920 | -8x | +|||
| 163 | +
- coldat <- droplevels(coldat)+ #' table or column structure object. |
|||
| 921 | +164 |
- }+ #' |
||
| 922 | -8x | +|||
| 165 | +
- x[[innervar]] <- coldat+ #' @inheritParams gen_args |
|||
| 923 | -8x | +|||
| 166 | +
- x+ #' |
|||
| 924 | +167 |
- })+ #' @return Nothing, called for its side effect of displaying |
||
| 925 | -3x | +|||
| 168 | +
- ret$labels <- as.character(ret$labels) # TODO+ #' a summary to the terminal. |
|||
| 926 | -3x | +|||
| 169 | +
- ret+ #' |
|||
| 927 | +170 |
- }+ #' @examples |
||
| 928 | -3x | +|||
| 171 | +
- myfun+ #' lyt <- basic_table() %>% |
|||
| 929 | +172 |
- }+ #' split_cols_by("ARM") %>%
|
||
| 930 | +173 |
-
+ #' split_cols_by("STRATA1") %>%
|
||
| 931 | +174 |
- .add_combo_part_info <- function(part,+ #' split_cols_by("SEX", nested = FALSE) %>%
|
||
| 932 | +175 |
- df,+ #' analyze("AGE")
|
||
| 933 | +176 |
- valuename,+ #' |
||
| 934 | +177 |
- levels,+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 935 | +178 |
- label,+ #' coltree_structure(tbl) |
||
| 936 | +179 |
- extras,+ #' @export |
||
| 937 | +180 |
- first = TRUE) {
+ coltree_structure <- function(obj) {
|
||
| 938 | -18x | +181 | +1x |
- value <- LevelComboSplitValue(valuename, extras,+ ctree <- coltree(obj) |
| 939 | -18x | +182 | +1x |
- combolevels = levels,+ cat(layoutmsg2(ctree)) |
| 940 | -18x | +|||
| 183 | +
- label = label+ } |
|||
| 941 | +184 |
- )+ |
||
| 942 | -18x | +|||
| 185 | +
- newdat <- setNames(list(df), valuename)+ lastposmsg <- function(pos) {
|
|||
| 943 | -18x | +186 | +6x |
- newval <- setNames(list(value), valuename)+ spls <- pos_splits(pos) |
| 944 | -18x | +187 | +6x |
- newextra <- setNames(list(extras), valuename)+ splvals <- value_names(pos_splvals(pos)) |
| 945 | -18x | +188 | +6x |
- if (first) {
+ indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "), |
| 946 | +189 | 6x |
- part$datasplit <- c(newdat, part$datasplit)+ spl = spls, |
|
| 947 | +190 | 6x |
- part$values <- c(newval, part$values)+ valnm = splvals, |
|
| 948 | +191 | 6x |
- part$labels <- c(setNames(label, valuename), part$labels)+ SIMPLIFY = FALSE+ |
+ |
| 192 | ++ |
+ )) |
||
| 949 | +193 | 6x |
- part$extras <- c(newextra, part$extras)+ paste(indiv_msgs, collapse = " -> ") |
|
| 950 | +194 |
- } else {
+ } |
||
| 951 | -12x | +|||
| 195 | +
- part$datasplit <- c(part$datasplit, newdat)+ |
|||
| 952 | -12x | +|||
| 196 | +
- part$values <- c(part$values, newval)+ layoutmsg2 <- function(obj, level = 1) {
|
|||
| 953 | -12x | +197 | +7x |
- part$labels <- c(part$labels, setNames(label, valuename))+ nm <- obj_name(obj) |
| 954 | -12x | +198 | +7x |
- part$extras <- c(part$extras, newextra)+ pos <- tree_pos(obj) |
| 955 | -+ | |||
| 199 | +7x |
- }+ nopos <- identical(pos, EmptyTreePos) |
||
| 956 | +200 |
- ## not needed even in custom split function case.+ |
||
| 957 | -+ | |||
| 201 | +7x |
- ## part = .fixupvals(part)+ msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
|
||
| 958 | -18x | +202 | +7x |
- part+ if (is(obj, "LayoutAxisTree")) {
|
| 959 | -+ | |||
| 203 | +3x |
- }+ kids <- tree_children(obj) |
||
| 960 | -+ | |||
| 204 | +3x |
-
+ msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1))) |
||
| 961 | +205 |
- #' Add a virtual "overall" level to split+ } |
||
| 962 | -+ | |||
| 206 | +7x |
- #'+ msg |
||
| 963 | +207 |
- #' @inheritParams lyt_args+ } |
||
| 964 | +208 |
- #' @inheritParams sf_args+ |
||
| 965 | -+ | |||
| 209 | +46x |
- #' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to+ setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
|
||
| 966 | +210 |
- #' `"Overall"`.+ |
||
| 967 | +211 |
- #' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults+ setMethod( |
||
| 968 | +212 |
- #' to `TRUE`.+ "spltype_abbrev", "VarLevelSplit", |
||
| 969 | -+ | |||
| 213 | +4x |
- #'+ function(obj) "lvls" |
||
| 970 | +214 |
- #' @return A closure suitable for use as a splitting function (`splfun`) when creating a table layout.+ ) |
||
| 971 | +215 |
- #'+ |
||
| 972 | +216 |
- #' @examples+ setMethod( |
||
| 973 | +217 |
- #' lyt <- basic_table() %>%+ "spltype_abbrev", "VarLevWBaselineSplit", |
||
| 974 | -+ | |||
| 218 | +5x |
- #' split_cols_by("ARM", split_fun = add_overall_level("All Patients",
+ function(obj) paste("ref_group", obj@ref_group_value)
|
||
| 975 | +219 |
- #' first = FALSE+ ) |
||
| 976 | +220 |
- #' )) %>%+ |
||
| 977 | +221 |
- #' analyze("AGE")
+ setMethod( |
||
| 978 | +222 |
- #'+ "spltype_abbrev", "MultiVarSplit", |
||
| 979 | -+ | |||
| 223 | +! |
- #' tbl <- build_table(lyt, DM)+ function(obj) "vars" |
||
| 980 | +224 |
- #' tbl+ ) |
||
| 981 | +225 |
- #'+ |
||
| 982 | +226 |
- #' lyt2 <- basic_table() %>%+ setMethod( |
||
| 983 | +227 |
- #' split_cols_by("ARM") %>%
+ "spltype_abbrev", "VarStaticCutSplit", |
||
| 984 | -+ | |||
| 228 | +10x |
- #' split_rows_by("RACE",
+ function(obj) "scut" |
||
| 985 | +229 |
- #' split_fun = add_overall_level("All Ethnicities")
+ ) |
||
| 986 | +230 |
- #' ) %>%+ |
||
| 987 | +231 |
- #' summarize_row_groups(label_fstr = "%s (n)") %>%+ setMethod( |
||
| 988 | +232 |
- #' analyze("AGE")
+ "spltype_abbrev", "VarDynCutSplit", |
||
| 989 | -+ | |||
| 233 | +5x |
- #' lyt2+ function(obj) "dcut" |
||
| 990 | +234 |
- #'+ ) |
||
| 991 | +235 |
- #' tbl2 <- build_table(lyt2, DM)+ setMethod( |
||
| 992 | +236 |
- #' tbl2+ "spltype_abbrev", "AllSplit", |
||
| 993 | -+ | |||
| 237 | +15x |
- #'+ function(obj) "all obs" |
||
| 994 | +238 |
- #' @export+ ) |
||
| 995 | +239 |
- add_overall_level <- function(valname = "Overall",+ ## setMethod("spltype_abbrev", "NULLSplit",
|
||
| 996 | +240 |
- label = valname,+ ## function(obj) "no obs") |
||
| 997 | +241 |
- extra_args = list(),+ |
||
| 998 | +242 |
- first = TRUE,+ setMethod( |
||
| 999 | +243 |
- trim = FALSE) {
- |
- ||
| 1000 | -5x | -
- combodf <- data.frame(- |
- ||
| 1001 | -5x | -
- valname = valname,- |
- ||
| 1002 | -5x | -
- label = label,+ "spltype_abbrev", "AnalyzeVarSplit", |
||
| 1003 | -5x | +244 | +1x |
- levelcombo = I(list(select_all_levels)),+ function(obj) "** analysis **" |
| 1004 | -5x | +|||
| 245 | +
- exargs = I(list(extra_args)),+ ) |
|||
| 1005 | -5x | +|||
| 246 | +
- stringsAsFactors = FALSE+ |
|||
| 1006 | +247 |
- )+ setMethod( |
||
| 1007 | -5x | +|||
| 248 | +
- add_combo_levels(combodf,+ "spltype_abbrev", "CompoundSplit", |
|||
| 1008 | -5x | +|||
| 249 | +! |
- trim = trim, first = first+ function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
|
||
| 1009 | +250 |
- )+ ) |
||
| 1010 | +251 |
- }+ |
||
| 1011 | +252 |
-
+ setMethod( |
||
| 1012 | +253 |
- setClass("AllLevelsSentinel", contains = "character")
+ "spltype_abbrev", "AnalyzeMultiVars", |
||
| 1013 | -+ | |||
| 254 | +6x |
-
+ function(obj) "** multivar analysis **" |
||
| 1014 | +255 |
- # nocov start+ ) |
||
| 1015 | +256 |
- #' @rdname add_combo_levels+ setMethod( |
||
| 1016 | +257 |
- #' @export+ "spltype_abbrev", "AnalyzeColVarSplit", |
||
| 1017 | -+ | |||
| 258 | +! |
- select_all_levels <- new("AllLevelsSentinel")
+ function(obj) "** col-var analysis **" |
||
| 1018 | +259 |
- # nocov end+ ) |
||
| 1019 | +260 | |||
| 1020 | +261 |
- #' Add combination levels to split+ docat_splitvec <- function(object, indent = 0) {
|
||
| 1021 | -+ | |||
| 262 | +8x |
- #'+ if (indent > 0) {
|
||
| 1022 | -+ | |||
| 263 | +! |
- #' @inheritParams sf_args+ cat(rep(" ", times = indent), sep = "")
|
||
| 1023 | +264 |
- #' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and+ } |
||
| 1024 | -+ | |||
| 265 | +8x |
- #' `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in+ if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
|
||
| 1025 | -+ | |||
| 266 | +! |
- #' `comblevels` column indicates that an overall/all-observations level should be created.+ tab <- object[[1]] |
||
| 1026 | -+ | |||
| 267 | +! |
- #' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and+ msg <- sprintf( |
||
| 1027 | -+ | |||
| 268 | +! |
- #' individual levels.+ "A Pre-Existing Table [%d x %d]", |
||
| 1028 | -+ | |||
| 269 | +! |
- #'+ nrow(tab), ncol(tab) |
||
| 1029 | +270 |
- #' @inherit add_overall_level return+ ) |
||
| 1030 | +271 |
- #'+ } else {
|
||
| 1031 | -+ | |||
| 272 | +8x |
- #' @note+ plds <- ploads_to_str(object) ## lapply(object, spl_payload)) |
||
| 1032 | +273 |
- #' Analysis or summary functions for which the order matters should never be used within the tabulation framework.+ |
||
| 1033 | -+ | |||
| 274 | +8x |
- #'+ tabbrev <- sapply(object, spltype_abbrev) |
||
| 1034 | -+ | |||
| 275 | +8x |
- #' @examples+ msg <- paste( |
||
| 1035 | -+ | |||
| 276 | +8x |
- #' library(tibble)+ collapse = " -> ", |
||
| 1036 | -+ | |||
| 277 | +8x |
- #' combodf <- tribble(+ paste0(plds, " (", tabbrev, ")")
|
||
| 1037 | +278 |
- #' ~valname, ~label, ~levelcombo, ~exargs,+ ) |
||
| 1038 | +279 |
- #' "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
+ } |
||
| 1039 | -+ | |||
| 280 | +8x |
- #' "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
+ cat(msg, "\n") |
||
| 1040 | +281 |
- #' )+ } |
||
| 1041 | +282 |
- #'+ |
||
| 1042 | +283 |
- #' lyt <- basic_table(show_colcounts = TRUE) %>%+ setMethod( |
||
| 1043 | +284 |
- #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
+ "show", "SplitVector", |
||
| 1044 | +285 |
- #' analyze("AGE")
+ function(object) {
|
||
| 1045 | -+ | |||
| 286 | +1x |
- #'+ cat("A SplitVector Pre-defining a Tree Structure\n\n")
|
||
| 1046 | -+ | |||
| 287 | +1x |
- #' tbl <- build_table(lyt, DM)+ docat_splitvec(object) |
||
| 1047 | -+ | |||
| 288 | +1x |
- #' tbl+ cat("\n")
|
||
| 1048 | -+ | |||
| 289 | +1x |
- #'+ invisible(object) |
||
| 1049 | +290 |
- #' lyt1 <- basic_table(show_colcounts = TRUE) %>%+ } |
||
| 1050 | +291 |
- #' split_cols_by("ARM",
+ ) |
||
| 1051 | +292 |
- #' split_fun = add_combo_levels(combodf,+ |
||
| 1052 | +293 |
- #' keep_levels = c(+ docat_predataxis <- function(object, indent = 0) {
|
||
| 1053 | -+ | |||
| 294 | +6x |
- #' "A_B",+ lapply(object, docat_splitvec) |
||
| 1054 | +295 |
- #' "A_C"+ } |
||
| 1055 | +296 |
- #' )+ |
||
| 1056 | +297 |
- #' )+ setMethod( |
||
| 1057 | +298 |
- #' ) %>%+ "show", "PreDataColLayout", |
||
| 1058 | +299 |
- #' analyze("AGE")
+ function(object) {
|
||
| 1059 | -+ | |||
| 300 | +1x |
- #'+ cat("A Pre-data Column Layout Object\n\n")
|
||
| 1060 | -+ | |||
| 301 | +1x |
- #' tbl1 <- build_table(lyt1, DM)+ docat_predataxis(object) |
||
| 1061 | -+ | |||
| 302 | +1x |
- #' tbl1+ invisible(object) |
||
| 1062 | +303 |
- #'+ } |
||
| 1063 | +304 |
- #' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
+ ) |
||
| 1064 | +305 |
- #' grepl("^(A|B)", ARM)))
+
|
||
| 1065 | +306 |
- #' lyt2 <- basic_table(show_colcounts = TRUE) %>%+ setMethod( |
||
| 1066 | +307 |
- #' split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
+ "show", "PreDataRowLayout", |
||
| 1067 | +308 |
- #' split_cols_by("SEX",
+ function(object) {
|
||
| 1068 | -+ | |||
| 309 | +1x |
- #' split_fun = add_overall_level("SEX_ALL", "All Genders")
+ cat("A Pre-data Row Layout Object\n\n")
|
||
| 1069 | -+ | |||
| 310 | +1x |
- #' ) %>%+ docat_predataxis(object) |
||
| 1070 | -+ | |||
| 311 | +1x |
- #' analyze("AGE")
+ invisible(object) |
||
| 1071 | +312 |
- #'+ } |
||
| 1072 | +313 |
- #' lyt3 <- basic_table(show_colcounts = TRUE) %>%+ ) |
||
| 1073 | +314 |
- #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
+
|
||
| 1074 | +315 |
- #' split_rows_by("SEX",
+ setMethod( |
||
| 1075 | +316 |
- #' split_fun = add_overall_level("SEX_ALL", "All Genders")
+ "show", "PreDataTableLayouts", |
||
| 1076 | +317 |
- #' ) %>%+ function(object) {
|
||
| 1077 | -+ | |||
| 318 | +2x |
- #' summarize_row_groups() %>%+ cat("A Pre-data Table Layout\n")
|
||
| 1078 | -+ | |||
| 319 | +2x |
- #' analyze("AGE")
+ cat("\nColumn-Split Structure:\n")
|
||
| 1079 | -+ | |||
| 320 | +2x |
- #'+ docat_predataxis(object@col_layout) |
||
| 1080 | -+ | |||
| 321 | +2x |
- #' tbl3 <- build_table(lyt3, smallerDM)+ cat("\nRow-Split Structure:\n")
|
||
| 1081 | -+ | |||
| 322 | +2x |
- #' tbl3+ docat_predataxis(object@row_layout)+ |
+ ||
| 323 | +2x | +
+ cat("\n")
+ |
+ ||
| 324 | +2x | +
+ invisible(object) |
||
| 1082 | +325 |
- #'+ } |
||
| 1083 | +326 |
- #' @export+ ) |
||
| 1084 | +327 |
- add_combo_levels <- function(combosdf,+ |
||
| 1085 | +328 |
- trim = FALSE,+ setMethod( |
||
| 1086 | +329 |
- first = FALSE,+ "show", "InstantiatedColumnInfo", |
||
| 1087 | +330 |
- keep_levels = NULL) {
+ function(object) {
|
||
| 1088 | -10x | +331 | +2x |
- myfun <- function(df, spl, vals = NULL, labels = NULL, ...) {
+ layoutmsg <- layoutmsg(coltree(object)) |
| 1089 | -12x | +332 | +2x |
- if (is(spl, "MultiVarSplit")) {
+ cat("An InstantiatedColumnInfo object",
|
| 1090 | -! | +|||
| 333 | +2x |
- stop("Combining levels of a MultiVarSplit does not make sense.",
+ "Columns:", |
||
| 1091 | -! | +|||
| 334 | +2x |
- call. = FALSE+ layoutmsg, |
||
| 1092 | -+ | |||
| 335 | +2x |
- )+ if (disp_ccounts(object)) {
|
||
| 1093 | -10x | +336 | +2x |
- } # nocov+ paste( |
| 1094 | -12x | +337 | +2x |
- ret <- .apply_split_inner(spl, df,+ "ColumnCounts:\n", |
| 1095 | -12x | +338 | +2x |
- vals = vals,+ paste(col_counts(object), |
| 1096 | -12x | +339 | +2x |
- labels = labels, trim = trim+ collapse = ", " |
| 1097 | +340 |
- )- |
- ||
| 1098 | -12x | -
- for (i in seq_len(nrow(combosdf))) {
- |
- ||
| 1099 | -18x | -
- lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]]+ ) |
||
| 1100 | -18x | +|||
| 341 | +
- spld <- spl_payload(spl)+ ) |
|||
| 1101 | -18x | +|||
| 342 | +
- if (is(lcombo, "AllLevelsSentinel")) {
+ }, |
|||
| 1102 | -6x | +|||
| 343 | +
- subdf <- df+ "", |
|||
| 1103 | -12x | +344 | +2x |
- } else if (is(spl, "VarLevelSplit")) {
+ sep = "\n" |
| 1104 | -12x | +|||
| 345 | +
- subdf <- df[df[[spld]] %in% lcombo, ]+ ) |
|||
| 1105 | -10x | -
- } else { ## this covers non-var splits, e.g. Cut-based splits
- |
- ||
| 1106 | -! | +346 | +2x |
- stopifnot(all(lcombo %in% c(ret$labels, ret$vals)))+ invisible(object) |
| 1107 | -! | +|||
| 347 | +
- subdf <- do.call(+ } |
|||
| 1108 | -! | +|||
| 348 | +
- rbind,+ ) |
|||
| 1109 | -! | +|||
| 349 | +
- ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo]+ |
|||
| 1110 | +350 |
- )+ #' @rdname int_methods |
||
| 1111 | +351 |
- }+ setMethod("print", "VTableTree", function(x, ...) {
|
||
| 1112 | -18x | +352 | +5x |
- ret <- .add_combo_part_info(+ msg <- toString(x, ...) |
| 1113 | -18x | +353 | +4x |
- ret, subdf,+ cat(msg) |
| 1114 | -18x | +354 | +4x |
- combosdf[i, "valname", drop = TRUE],+ invisible(x) |
| 1115 | -18x | +|||
| 355 | +
- lcombo,+ }) |
|||
| 1116 | -18x | +|||
| 356 | +
- combosdf[i, "label", drop = TRUE],+ |
|||
| 1117 | -18x | +|||
| 357 | +
- combosdf[i, "exargs", drop = TRUE][[1]],+ #' @rdname int_methods |
|||
| 1118 | -18x | +|||
| 358 | +
- first+ setMethod("show", "VTableTree", function(object) {
+ |
+ |||
| 359 | +! | +
+ cat(toString(object))+ |
+ ||
| 360 | +! | +
+ invisible(object) |
||
| 1119 | +361 |
- )+ }) |
||
| 1120 | +362 |
- }+ |
||
| 1121 | -12x | +|||
| 363 | +
- if (!is.null(keep_levels)) {
+ setMethod("show", "TableRow", function(object) {
|
|||
| 1122 | -3x | +364 | +1x |
- keep_inds <- value_names(ret$values) %in% keep_levels+ cat(sprintf( |
| 1123 | -3x | +365 | +1x |
- ret <- lapply(ret, function(x) x[keep_inds])+ "[%s indent_mod %d]: %s %s\n", |
| 1124 | -+ | |||
| 366 | +1x |
- }+ class(object), |
||
| 1125 | -+ | |||
| 367 | +1x |
-
+ indent_mod(object), |
||
| 1126 | -12x | +368 | +1x |
- ret+ obj_label(object), |
| 1127 | -+ | |||
| 369 | +1x |
- }+ paste(as.vector(get_formatted_cells(object)), |
||
| 1128 | -10x | +370 | +1x |
- myfun+ collapse = " " |
| 1129 | +371 |
- }+ ) |
||
| 1130 | +372 |
-
+ ))+ |
+ ||
| 373 | +1x | +
+ invisible(object) |
||
| 1131 | +374 |
- #' Trim levels to map+ }) |
| 1132 | +1 |
- #'+ label_pos_values <- c("hidden", "visible", "topleft")
|
||
| 1133 | +2 |
- #' This split function constructor creates a split function which trims levels of a variable to reflect restrictions+ |
||
| 1134 | +3 |
- #' on the possible combinations of two or more variables which the data is split by (along the same axis) within a+ #' @name internal_methods |
||
| 1135 | +4 |
- #' layout.+ #' @rdname int_methods |
||
| 1136 | +5 |
- #'+ NULL |
||
| 1137 | +6 |
- #' @param map data.frame. A data.frame defining allowed combinations of+ |
||
| 1138 | +7 |
- #' variables. Any combination at the level of this split not present in the+ #' Combine `SplitVector` objects |
||
| 1139 | +8 |
- #' map will be removed from the data, both for the variable being split and+ #' |
||
| 1140 | +9 |
- #' those present in the data but not associated with this split or any parents+ #' @param x (`SplitVector`)\cr a `SplitVector` object. |
||
| 1141 | +10 |
- #' of it.+ #' @param ... splits or `SplitVector` objects. |
||
| 1142 | +11 |
#' |
||
| 1143 | +12 |
- #' @details+ #' @return Various, but should be considered implementation details. |
||
| 1144 | +13 |
- #' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the+ #' |
||
| 1145 | +14 |
- #' variable being split are then pruned to only those still present within this subset of the map representing the+ #' @rdname int_methods |
||
| 1146 | +15 |
- #' current hierarchical splitting context.+ #' @exportMethod c |
||
| 1147 | +16 |
- #'+ setMethod("c", "SplitVector", function(x, ...) {
|
||
| 1148 | -+ | |||
| 17 | +401x |
- #' Splitting is then performed via the [keep_split_levels()] split function.+ arglst <- list(...) |
||
| 1149 | -+ | |||
| 18 | +401x |
- #'+ stopifnot(all(sapply(arglst, is, "Split"))) |
||
| 1150 | -+ | |||
| 19 | +401x |
- #' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables+ tmp <- c(unclass(x), arglst) |
||
| 1151 | -+ | |||
| 20 | +401x |
- #' specified in the map to those values allowed under the combination of the previous and current split.+ SplitVector(lst = tmp) |
||
| 1152 | +21 |
- #'+ }) |
||
| 1153 | +22 |
- #' @return A function that can be used as a split function.+ |
||
| 1154 | +23 |
- #'+ ## split_rows and split_cols are "recursive method stacks" which follow |
||
| 1155 | +24 |
- #' @seealso [trim_levels_in_group()]+ ## the general pattern of accept object -> call add_*_split on slot of object -> |
||
| 1156 | +25 |
- #'+ ## update object with value returned from slot method, return object. |
||
| 1157 | +26 |
- #' @examples+ ## |
||
| 1158 | +27 |
- #' map <- data.frame(+ ## Thus each of the methods is idempotent, returning an updated object of the |
||
| 1159 | +28 |
- #' LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
+ ## same class it was passed. The exception for idempotency is the NULL method |
||
| 1160 | +29 |
- #' PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
+ ## which constructs a PreDataTableLayouts object with the specified split in the |
||
| 1161 | +30 |
- #' ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
+ ## correct place. |
||
| 1162 | +31 |
- #' stringsAsFactors = FALSE+ |
||
| 1163 | +32 |
- #' )+ ## The cascading (by class) in this case is as follows for the row case: |
||
| 1164 | +33 |
- #'+ ## PreDataTableLayouts -> PreDataRowLayout -> SplitVector |
||
| 1165 | +34 |
- #' lyt <- basic_table() %>%+ #' @param cmpnd_fun (`function`)\cr intended for internal use. |
||
| 1166 | +35 |
- #' split_rows_by("LBCAT") %>%
+ #' @param pos (`numeric(1)`)\cr intended for internal use. |
||
| 1167 | +36 |
- #' split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
+ #' @param spl (`Split`)\cr the split. |
||
| 1168 | +37 |
- #' analyze("ANRIND")
+ #' |
||
| 1169 | +38 |
- #' tbl <- build_table(lyt, ex_adlb)+ #' @rdname int_methods |
||
| 1170 | +39 |
- #'+ setGeneric( |
||
| 1171 | +40 |
- #' @export+ "split_rows", |
||
| 1172 | +41 |
- trim_levels_to_map <- function(map = NULL) {
+ function(lyt = NULL, spl, pos, |
||
| 1173 | -7x | +|||
| 42 | +
- if (is.null(map) || any(sapply(map, class) != "character")) {
+ cmpnd_fun = AnalyzeMultiVars) {
|
|||
| 1174 | -! | +|||
| 43 | +1628x |
- stop(+ standardGeneric("split_rows")
|
||
| 1175 | -! | +|||
| 44 | +
- "No map dataframe was provided or not all of the columns are of ",+ } |
|||
| 1176 | -! | +|||
| 45 | +
- "type character."+ ) |
|||
| 1177 | +46 |
- )+ |
||
| 1178 | +47 |
- }+ #' @rdname int_methods |
||
| 1179 | +48 |
-
+ setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
|
||
| 1180 | -7x | +49 | +1x |
- myfun <- function(df,+ lifecycle::deprecate_warn( |
| 1181 | -7x | +50 | +1x |
- spl,+ when = "0.3.8", |
| 1182 | -7x | +51 | +1x |
- vals = NULL,+ what = I("split_rows(NULL)"),
|
| 1183 | -7x | +52 | +1x |
- labels = NULL,+ with = "basic_table()", |
| 1184 | -7x | +53 | +1x |
- trim = FALSE,+ details = "Initializing layouts via `NULL` is no longer supported."+ |
+
| 54 | ++ |
+ ) |
||
| 1185 | -7x | +55 | +1x |
- .spl_context) {
+ rl <- PreDataRowLayout(SplitVector(spl)) |
| 1186 | -12x | +56 | +1x |
- allvars <- colnames(map)+ cl <- PreDataColLayout() |
| 1187 | -12x | +57 | +1x |
- splvar <- spl_payload(spl)+ PreDataTableLayouts(rlayout = rl, clayout = cl) |
| 1188 | +58 | ++ |
+ })+ |
+ |
| 59 | ||||
| 1189 | -12x | +|||
| 60 | +
- allvmatches <- match(.spl_context$split, allvars)+ #' @rdname int_methods |
|||
| 1190 | -12x | +|||
| 61 | +
- outvars <- allvars[na.omit(allvmatches)]+ setMethod( |
|||
| 1191 | +62 |
- ## invars are variables present in data, but not in+ "split_rows", "PreDataRowLayout", |
||
| 1192 | +63 |
- ## previous or current splits+ function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
|
||
| 1193 | -12x | +64 | +551x |
- invars <- intersect(+ stopifnot(pos > 0 && pos <= length(lyt) + 1) |
| 1194 | -12x | +65 | +551x |
- setdiff(allvars, c(outvars, splvar)),+ tmp <- if (pos <= length(lyt)) {
|
| 1195 | -12x | +66 | +525x |
- names(df)+ split_rows(lyt[[pos]], spl, pos, cmpnd_fun) |
| 1196 | +67 |
- )+ } else {
|
||
| 1197 | -+ | |||
| 68 | +26x |
- ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits+ if (pos != 1 && has_force_pag(spl)) {
|
||
| 1198 | -+ | |||
| 69 | +1x |
- ## which(allvars == splvar), ## this split+ stop("page_by splits cannot have top-level siblings",
|
||
| 1199 | -+ | |||
| 70 | +1x |
- ## allvars[-1*na.omit(allvmatches)]) ## "outvars"+ call. = FALSE |
||
| 1200 | +71 |
-
+ ) |
||
| 1201 | +72 |
- ## allvars <- allvars[allvarord]+ }+ |
+ ||
| 73 | +25x | +
+ SplitVector(spl) |
||
| 1202 | +74 |
- ## outvars <- allvars[-(which(allvars == splvar):length(allvars))]+ } |
||
| 1203 | -12x | +75 | +549x |
- if (length(outvars) > 0) {
+ lyt[[pos]] <- tmp |
| 1204 | -10x | +76 | +549x |
- indfilters <- vapply(outvars, function(ivar) {
+ lyt |
| 1205 | -12x | +|||
| 77 | +
- obsval <- .spl_context$value[match(ivar, .spl_context$split)]+ } |
|||
| 1206 | -12x | +|||
| 78 | +
- sprintf("%s == '%s'", ivar, obsval)
+ ) |
|||
| 1207 | +79 |
- }, "")+ |
||
| 1208 | +80 | ++ |
+ is_analysis_spl <- function(spl) {
+ |
+ |
| 81 | +! | +
+ is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars")+ |
+ ||
| 82 | ++ |
+ }+ |
+ ||
| 83 | ||||
| 1209 | -10x | +|||
| 84 | +
- allfilters <- paste(indfilters, collapse = " & ")+ ## note "pos" is ignored here because it is for which nest-chain |
|||
| 1210 | -10x | +|||
| 85 | +
- map <- map[eval(parse(text = allfilters), envir = map), ]+ ## spl should be placed in, NOIT for where in that chain it should go |
|||
| 1211 | +86 |
- }+ #' @rdname int_methods |
||
| 1212 | -12x | +|||
| 87 | +
- map_splvarpos <- which(names(map) == splvar)+ setMethod( |
|||
| 1213 | -12x | +|||
| 88 | +
- nondup <- !duplicated(map[[splvar]])+ "split_rows", "SplitVector", |
|||
| 1214 | -12x | +|||
| 89 | +
- ksl_fun <- keep_split_levels(+ function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
|
|||
| 1215 | -12x | +|||
| 90 | +
- only = map[[splvar]][nondup],+ ## if(is_analysis_spl(spl) && |
|||
| 1216 | -12x | +|||
| 91 | +
- reorder = TRUE+ ## is_analysis_spl(last_rowsplit(lyt))) {
|
|||
| 1217 | +92 |
- )+ ## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun)) |
||
| 1218 | -12x | +|||
| 93 | +
- ret <- ksl_fun(df, spl, vals, labels, trim = trim)+ ## } |
|||
| 1219 | +94 | |||
| 1220 | -12x | +95 | +525x |
- if (length(ret$datasplit) == 0) {
+ if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
|
| 1221 | +96 | 1x |
- msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
+ stop("page_by splits cannot be nested within non-page_by splits",
|
|
| 1222 | +97 | 1x |
- collapse = "->"+ call. = FALSE |
|
| 1223 | +98 |
) |
||
| 1224 | -1x | +|||
| 99 | +
- stop(+ } |
|||
| 1225 | -1x | +100 | +524x |
- "map does not allow any values present in data for split ",+ tmp <- c(unclass(lyt), spl) |
| 1226 | -1x | +101 | +524x |
- "variable ", splvar,+ SplitVector(lst = tmp) |
| 1227 | -1x | +|||
| 102 | +
- " under the following parent splits:\n\t", msg+ } |
|||
| 1228 | +103 |
- )+ ) |
||
| 1229 | +104 |
- }+ |
||
| 1230 | +105 |
-
+ #' @rdname int_methods |
||
| 1231 | +106 |
- ## keep non-split (inner) variables levels+ setMethod( |
||
| 1232 | -11x | +|||
| 107 | +
- ret$datasplit <- lapply(ret$values, function(splvar_lev) {
+ "split_rows", "PreDataTableLayouts", |
|||
| 1233 | -19x | +|||
| 108 | +
- df3 <- ret$datasplit[[splvar_lev]]+ function(lyt, spl, pos) {
|
|||
| 1234 | -19x | +109 | +551x |
- curmap <- map[map[[map_splvarpos]] == splvar_lev, ]+ rlyt <- rlayout(lyt) |
| 1235 | -+ | |||
| 110 | +551x |
- ## loop through inner variables+ addtl <- FALSE |
||
| 1236 | -19x | +111 | +551x |
- for (iv in invars) { ## setdiff(colnames(map), splvar)) {
+ split_label <- obj_label(spl) |
| 1237 | -19x | +|||
| 112 | +
- iv_lev <- df3[[iv]]+ if ( |
|||
| 1238 | -19x | +113 | +551x |
- levkeep <- as.character(unique(curmap[[iv]]))+ is(spl, "Split") && ## exclude existing tables that are being tacked in |
| 1239 | -19x | +114 | +551x |
- if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) {
+ identical(label_position(spl), "topleft") && |
| 1240 | -! | +|||
| 115 | +551x |
- stop(+ length(split_label) == 1 && nzchar(split_label) |
||
| 1241 | -! | +|||
| 116 | +
- "Attempted to keep invalid factor level(s) in split ",+ ) {
|
|||
| 1242 | -! | +|||
| 117 | +19x |
- setdiff(levkeep, levels(iv_lev))+ addtl <- TRUE |
||
| 1243 | +118 |
- )+ ## label_position(spl) <- "hidden" |
||
| 1244 | +119 |
- }+ } |
||
| 1245 | +120 | |||
| 1246 | -19x | -
- df3 <- df3[iv_lev %in% levkeep, , drop = FALSE]- |
- ||
| 1247 | -+ | 121 | +551x |
-
+ rlyt <- split_rows(rlyt, spl, pos) |
| 1248 | -19x | +122 | +549x |
- if (is.factor(iv_lev)) {
+ rlayout(lyt) <- rlyt |
| 1249 | -19x | +123 | +549x |
- df3[[iv]] <- factor(as.character(df3[[iv]]),+ if (addtl) {
|
| 1250 | +124 | 19x |
- levels = levkeep+ lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt))) |
|
| 1251 | +125 |
- )+ } |
||
| 1252 | -+ | |||
| 126 | +549x |
- }+ lyt |
||
| 1253 | +127 |
- }+ } |
||
| 1254 | +128 | - - | -||
| 1255 | -19x | -
- df3+ ) |
||
| 1256 | +129 |
- })- |
- ||
| 1257 | -11x | -
- names(ret$datasplit) <- ret$values- |
- ||
| 1258 | -11x | -
- ret+ |
||
| 1259 | +130 |
- }+ #' @rdname int_methods |
||
| 1260 | +131 | - - | -||
| 1261 | -7x | -
- myfun+ setMethod( |
||
| 1262 | +132 |
- }+ "split_rows", "ANY", |
| 1 | +133 |
- ## Rules for pagination+ function(lyt, spl, pos) {
|
||
| 2 | -+ | |||
| 134 | +! |
- ##+ stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
|
||
| 3 | +135 |
- ## 1. user defined number of lines per page+ } |
||
| 4 | +136 |
- ## 2. all lines have the same height+ ) |
||
| 5 | +137 |
- ## 3. header always reprinted on all pages+ |
||
| 6 | +138 |
- ## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE)+ ## cmpnd_last_rowsplit ===== |
||
| 7 | +139 |
- ## 5. Never (?) break on a "label"/content row+ |
||
| 8 | +140 |
- ## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table.+ #' @rdname int_methods |
||
| 9 | +141 |
- ##+ #' |
||
| 10 | +142 |
- ## Current behavior: paginate_ttree takes a TableTree object and+ #' @param constructor (`function`)\cr constructor function. |
||
| 11 | -+ | |||
| 143 | +82x |
- ## returns a list of rtable (S3) objects for printing.+ setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))
|
||
| 12 | +144 | |||
| 13 | +145 |
- #' @inheritParams formatters::nlines+ #' @rdname int_methods |
||
| 14 | +146 |
- #'+ setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
|
||
| 15 | +147 |
- #' @rdname formatters_methods+ stop("no existing splits to compound with. contact the maintainer") # nocov
|
||
| 16 | +148 |
- #' @aliases nlines,TableRow-method+ }) |
||
| 17 | +149 |
- #' @exportMethod nlines+ |
||
| 18 | +150 |
- setMethod(+ #' @rdname int_methods |
||
| 19 | +151 |
- "nlines", "TableRow",+ setMethod( |
||
| 20 | +152 |
- function(x, colwidths, max_width, fontspec, col_gap = 3) {
+ "cmpnd_last_rowsplit", "PreDataRowLayout", |
||
| 21 | -11135x | +|||
| 153 | +
- fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) ++ function(lyt, spl, constructor) {
|
|||
| 22 | -11135x | +154 | +27x |
- sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))+ pos <- length(lyt) |
| 23 | -11135x | +155 | +27x |
- fcells <- as.vector(get_formatted_cells(x))+ tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) |
| 24 | -11135x | +156 | +27x |
- spans <- row_cspans(x)+ lyt[[pos]] <- tmp |
| 25 | -11135x | +157 | +27x |
- have_cw <- !is.null(colwidths)+ lyt |
| 26 | +158 |
- ## handle spanning so that the projected word-wrapping from nlines is correct+ } |
||
| 27 | -11135x | +|||
| 159 | +
- if (any(spans > 1)) {
+ ) |
|||
| 28 | -6x | +|||
| 160 | +
- new_fcells <- character(length(spans))+ #' @rdname int_methods |
|||
| 29 | -6x | +|||
| 161 | +
- new_colwidths <- numeric(length(spans))+ setMethod( |
|||
| 30 | -6x | +|||
| 162 | +
- cur_fcells <- fcells+ "cmpnd_last_rowsplit", "SplitVector", |
|||
| 31 | -6x | +|||
| 163 | +
- cur_colwidths <- colwidths[-1] ## not the row labels they can't span+ function(lyt, spl, constructor) {
|
|||
| 32 | -6x | +164 | +28x |
- for (i in seq_along(spans)) {
+ pos <- length(lyt) |
| 33 | -6x | +165 | +28x |
- spi <- spans[i]+ lst <- lyt[[pos]] |
| 34 | -6x | +166 | +28x |
- new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop+ tmp <- if (is(lst, "CompoundSplit")) {
|
| 35 | -6x | +167 | +3x |
- new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1)+ spl_payload(lst) <- c( |
| 36 | -6x | +168 | +3x |
- cur_fcells <- tail(cur_fcells, -1 * spi)+ .uncompound(spl_payload(lst)), |
| 37 | -6x | +169 | +3x |
- cur_colwidths <- tail(cur_colwidths, -1 * spi)+ .uncompound(spl) |
| 38 | +170 |
- }+ ) |
||
| 39 | -6x | -
- if (have_cw) {
- |
- ||
| 40 | -! | -
- colwidths <- c(colwidths[1], new_colwidths)- |
- ||
| 41 | -+ | 171 | +3x |
- }+ obj_name(lst) <- make_ma_name(spl = lst) |
| 42 | -6x | +172 | +3x |
- fcells <- new_fcells+ lst |
| 43 | +173 |
- }+ ## XXX never reached because AnalzyeMultiVars inherits from |
||
| 44 | +174 |
-
+ ## CompoundSplit??? |
||
| 45 | +175 |
- ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE),+ } else {
|
||
| 46 | -+ | |||
| 176 | +25x |
- ## length,+ constructor(.payload = list(lst, spl)) |
||
| 47 | +177 |
- ## 1L))- |
- ||
| 48 | -11135x | -
- rowext <- max(- |
- ||
| 49 | -11135x | -
- unlist(- |
- ||
| 50 | -11135x | -
- mapply(+ } |
||
| 51 | -11135x | +178 | +28x |
- function(s, w) {
+ lyt[[pos]] <- tmp |
| 52 | -60338x | +179 | +28x |
- nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec)+ lyt |
| 53 | +180 |
- },+ } |
||
| 54 | -11135x | +|||
| 181 | +
- s = c(obj_label(x), fcells),+ ) |
|||
| 55 | -11135x | +|||
| 182 | +
- w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
+
|
|||
| 56 | -11135x | +|||
| 183 | +
- SIMPLIFY = FALSE+ #' @rdname int_methods |
|||
| 57 | +184 |
- )+ setMethod( |
||
| 58 | +185 |
- )+ "cmpnd_last_rowsplit", "PreDataTableLayouts", |
||
| 59 | +186 |
- )+ function(lyt, spl, constructor) {
|
||
| 60 | -+ | |||
| 187 | +27x |
-
+ rlyt <- rlayout(lyt) |
||
| 61 | -11135x | +188 | +27x |
- rowext + fns+ rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor) |
| 62 | -+ | |||
| 189 | +27x |
- }+ rlayout(lyt) <- rlyt |
||
| 63 | -+ | |||
| 190 | +27x |
- )+ lyt |
||
| 64 | +191 |
-
+ } |
||
| 65 | +192 |
- #' @export+ ) |
||
| 66 | +193 |
- #' @rdname formatters_methods+ #' @rdname int_methods |
||
| 67 | +194 |
setMethod( |
||
| 68 | +195 |
- "nlines", "LabelRow",+ "cmpnd_last_rowsplit", "ANY", |
||
| 69 | +196 |
- function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
- |
- ||
| 70 | -3624x | -
- if (labelrow_visible(x)) {
- |
- ||
| 71 | -3624x | -
- nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) ++ function(lyt, spl, constructor) {
|
||
| 72 | -3624x | +|||
| 197 | +! |
- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))+ stop( |
||
| 73 | -+ | |||
| 198 | +! |
- } else {
+ "nope. can't do cmpnd_last_rowsplit to that (",
|
||
| 74 | +199 | ! |
- 0L+ class(lyt), "). contact the maintaner." |
|
| 75 | +200 |
- }+ ) |
||
| 76 | +201 |
} |
||
| 77 | +202 |
) |
||
| 78 | +203 | |||
| 79 | -- |
- #' @export- |
- ||
| 80 | +204 |
- #' @rdname formatters_methods+ ## split_cols ==== |
||
| 81 | +205 |
- setMethod(+ |
||
| 82 | +206 |
- "nlines", "RefFootnote",+ #' @rdname int_methods |
||
| 83 | +207 |
- function(x, colwidths, max_width, fontspec, col_gap = NULL) {
- |
- ||
| 84 | -2140x | -
- nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ setGeneric( |
||
| 85 | +208 |
- }+ "split_cols", |
||
| 86 | +209 |
- )+ function(lyt = NULL, spl, pos) {
|
||
| 87 | -+ | |||
| 210 | +1034x |
-
+ standardGeneric("split_cols")
|
||
| 88 | +211 |
- #' @export+ } |
||
| 89 | +212 |
- #' @rdname formatters_methods+ ) |
||
| 90 | +213 |
- setMethod(+ |
||
| 91 | +214 |
- "nlines", "InstantiatedColumnInfo",+ #' @rdname int_methods |
||
| 92 | +215 |
- function(x, colwidths, max_width, fontspec, col_gap = 3) {
- |
- ||
| 93 | -5x | -
- h_rows <- .do_tbl_h_piece2(x)+ setMethod("split_cols", "NULL", function(lyt, spl, pos) {
|
||
| 94 | -5x | +216 | +1x |
- tl <- top_left(x) %||% rep("", length(h_rows))
+ lifecycle::deprecate_warn( |
| 95 | -5x | +217 | +1x |
- main_nls <- vapply(+ when = "0.3.8", |
| 96 | -5x | +218 | +1x |
- seq_along(h_rows),+ what = I("split_cols(NULL)"),
|
| 97 | -5x | +219 | +1x |
- function(i) {
+ with = "basic_table()", |
| 98 | -5x | +220 | +1x |
- max(+ details = "Initializing layouts via `NULL` is no longer supported." |
| 99 | -5x | +|||
| 221 | +
- nlines(h_rows[[i]],+ ) |
|||
| 100 | -5x | +222 | +1x |
- colwidths = colwidths,+ cl <- PreDataColLayout(SplitVector(spl)) |
| 101 | -5x | +223 | +1x |
- fontspec = fontspec,+ rl <- PreDataRowLayout() |
| 102 | -5x | +224 | +1x |
- col_gap = col_gap+ PreDataTableLayouts(rlayout = rl, clayout = cl) |
| 103 | +225 |
- ),+ }) |
||
| 104 | -5x | +|||
| 226 | +
- nlines(tl[i],+ |
|||
| 105 | -5x | +|||
| 227 | +
- colwidths = colwidths[1],+ #' @rdname int_methods |
|||
| 106 | -5x | +|||
| 228 | +
- fontspec = fontspec+ setMethod( |
|||
| 107 | +229 |
- )+ "split_cols", "PreDataColLayout", |
||
| 108 | +230 |
- )+ function(lyt, spl, pos) {
|
||
| 109 | -+ | |||
| 231 | +316x |
- },+ stopifnot(pos > 0 && pos <= length(lyt) + 1) |
||
| 110 | -5x | +232 | +316x |
- 1L+ tmp <- if (pos <= length(lyt)) {
|
| 111 | -+ | |||
| 233 | +308x |
- )+ split_cols(lyt[[pos]], spl, pos) |
||
| 112 | +234 |
-
+ } else {
|
||
| 113 | -+ | |||
| 235 | +8x |
- ## lfs <- collect_leaves(coltree(x))+ SplitVector(spl) |
||
| 114 | +236 |
- ## depths <- sapply(lfs, function(l) length(pos_splits(l)))+ } |
||
| 115 | +237 | |||
| 116 | -5x | +238 | +316x |
- coldf <- make_col_df(x, colwidths = colwidths)+ lyt[[pos]] <- tmp |
| 117 | -5x | +239 | +316x |
- have_fnotes <- length(unlist(coldf$col_fnotes)) > 0+ lyt |
| 118 | +240 |
- ## ret <- max(depths, length(top_left(x))) ++ } |
||
| 119 | +241 |
- ## divider_height(x)+ ) |
||
| 120 | -5x | +|||
| 242 | +
- ret <- sum(main_nls, divider_height(x))+ |
|||
| 121 | -5x | +|||
| 243 | +
- if (have_fnotes) {
+ #' @rdname int_methods |
|||
| 122 | -! | +|||
| 244 | +
- ret <- sum(+ setMethod( |
|||
| 123 | -! | +|||
| 245 | +
- ret,+ "split_cols", "SplitVector", |
|||
| 124 | -! | +|||
| 246 | +
- vapply(unlist(coldf$col_fnotes),+ function(lyt, spl, pos) {
|
|||
| 125 | -! | +|||
| 247 | +401x |
- nlines,+ tmp <- c(lyt, spl) |
||
| 126 | -! | +|||
| 248 | +401x |
- 1,+ SplitVector(lst = tmp) |
||
| 127 | -! | +|||
| 249 | +
- max_width = max_width,+ } |
|||
| 128 | -! | +|||
| 250 | +
- fontspec = fontspec+ ) |
|||
| 129 | +251 |
- ),+ |
||
| 130 | -! | +|||
| 252 | +
- 2 * divider_height(x)+ #' @rdname int_methods |
|||
| 131 | +253 |
- )+ setMethod( |
||
| 132 | +254 |
- }+ "split_cols", "PreDataTableLayouts", |
||
| 133 | -5x | +|||
| 255 | +
- ret+ function(lyt, spl, pos) {
|
|||
| 134 | -+ | |||
| 256 | +316x |
- }+ rlyt <- lyt@col_layout |
||
| 135 | -+ | |||
| 257 | +316x |
- )+ rlyt <- split_cols(rlyt, spl, pos) |
||
| 136 | -+ | |||
| 258 | +316x |
-
+ lyt@col_layout <- rlyt |
||
| 137 | -+ | |||
| 259 | +316x |
- col_dfrow <- function(col,+ lyt |
||
| 138 | +260 |
- nm = obj_name(col),+ } |
||
| 139 | +261 |
- lab = obj_label(col),+ ) |
||
| 140 | +262 |
- cnum,+ |
||
| 141 | +263 |
- pth = NULL,+ #' @rdname int_methods |
||
| 142 | +264 |
- sibpos = NA_integer_,+ setMethod( |
||
| 143 | +265 |
- nsibs = NA_integer_,+ "split_cols", "ANY", |
||
| 144 | +266 |
- leaf_indices = cnum,+ function(lyt, spl, pos) {
|
||
| 145 | -+ | |||
| 267 | +! |
- span = length(leaf_indices),+ stop( |
||
| 146 | -+ | |||
| 268 | +! |
- col_fnotes = list()) {
+ "nope. can't add a col split to that (", class(lyt),
|
||
| 147 | -17825x | +|||
| 269 | +! |
- if (is.null(pth)) {
+ "). contact the maintaner." |
||
| 148 | -17231x | +|||
| 270 | +
- pth <- pos_to_path(tree_pos(col))+ ) |
|||
| 149 | +271 |
} |
||
| 150 | -17825x | +|||
| 272 | +
- data.frame(+ ) |
|||
| 151 | -17825x | +|||
| 273 | +
- stringsAsFactors = FALSE,+ |
|||
| 152 | -17825x | +|||
| 274 | +
- name = nm,+ # Constructors ===== |
|||
| 153 | -17825x | +|||
| 275 | +
- label = lab,+ |
|||
| 154 | -17825x | +|||
| 276 | +
- abs_pos = cnum,+ ## Pipe-able functions to add the various types of splits to the current layout |
|||
| 155 | -17825x | +|||
| 277 | +
- path = I(list(pth)),+ ## for both row and column. These all act as wrappers to the split_cols and |
|||
| 156 | -17825x | +|||
| 278 | +
- pos_in_siblings = sibpos,+ ## split_rows method stacks. |
|||
| 157 | -17825x | +|||
| 279 | +
- n_siblings = nsibs,+ |
|||
| 158 | -17825x | +|||
| 280 | +
- leaf_indices = I(list(leaf_indices)),+ #' Declaring a column-split based on levels of a variable |
|||
| 159 | -17825x | +|||
| 281 | +
- total_span = span,+ #' |
|||
| 160 | -17825x | +|||
| 282 | +
- col_fnotes = I(list(col_fnotes)),+ #' Will generate children for each subset of a categorical variable. |
|||
| 161 | -17825x | +|||
| 283 | +
- n_col_fnotes = length(col_fnotes)+ #' |
|||
| 162 | +284 |
- )+ #' @inheritParams lyt_args |
||
| 163 | +285 |
- }+ #' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference. |
||
| 164 | +286 |
-
+ #' |
||
| 165 | +287 |
- pos_to_path <- function(pos) {
+ #' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()]. |
||
| 166 | -18495x | +|||
| 288 | +
- spls <- pos_splits(pos)+ #' |
|||
| 167 | -18495x | +|||
| 289 | +
- vals <- pos_splvals(pos)+ #' @inheritSection custom_split_funs Custom Splitting Function Details |
|||
| 168 | +290 |
-
+ #' |
||
| 169 | -18495x | +|||
| 291 | +
- path <- character()+ #' @examples |
|||
| 170 | -18495x | +|||
| 292 | +
- for (i in seq_along(spls)) {
+ #' lyt <- basic_table() %>% |
|||
| 171 | -28070x | +|||
| 293 | +
- path <- c(+ #' split_cols_by("ARM") %>%
|
|||
| 172 | -28070x | +|||
| 294 | +
- path,+ #' analyze(c("AGE", "BMRKR2"))
|
|||
| 173 | -28070x | +|||
| 295 | +
- obj_name(spls[[i]]),+ #' |
|||
| 174 | +296 |
- ## rawvalues(vals[[i]]))+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 175 | -28070x | +|||
| 297 | +
- value_names(vals[[i]])+ #' tbl |
|||
| 176 | +298 |
- )+ #' |
||
| 177 | +299 |
- }+ #' # Let's look at the splits in more detail |
||
| 178 | -18495x | +|||
| 300 | +
- path+ #' |
|||
| 179 | +301 |
- }+ #' lyt1 <- basic_table() %>% split_cols_by("ARM")
|
||
| 180 | +302 |
-
+ #' lyt1 |
||
| 181 | +303 |
- # make_row_df ---------------------------------------------------------------+ #' |
||
| 182 | +304 |
-
+ #' # add an analysis (summary) |
||
| 183 | +305 |
- #' @inherit formatters::make_row_df+ #' lyt2 <- lyt1 %>% |
||
| 184 | +306 |
- #'+ #' analyze(c("AGE", "COUNTRY"),
|
||
| 185 | +307 |
- # #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and+ #' afun = list_wrap_x(summary), |
||
| 186 | +308 |
- # #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination.+ #' format = "xx.xx" |
||
| 187 | +309 |
- # #'+ #' ) |
||
| 188 | +310 |
- # #' @return a data.frame of row/column-structure information used by the pagination machinery.+ #' lyt2 |
||
| 189 | +311 |
- # #'+ #' |
||
| 190 | +312 |
- # #' @export+ #' tbl2 <- build_table(lyt2, DM) |
||
| 191 | +313 |
- # #' @name make_row_df+ #' tbl2 |
||
| 192 | +314 |
- # #' @rdname make_row_df+ #' |
||
| 193 | +315 |
- # #' @aliases make_row_df,VTableTree-method+ #' # By default sequentially adding layouts results in nesting |
||
| 194 | +316 |
- #' @rdname formatters_methods+ #' library(dplyr) |
||
| 195 | +317 |
- #' @exportMethod make_row_df+ #' |
||
| 196 | +318 |
- setMethod(+ #' DM_MF <- DM %>% |
||
| 197 | +319 |
- "make_row_df", "VTableTree",+ #' filter(SEX %in% c("M", "F")) %>%
|
||
| 198 | +320 |
- function(tt,+ #' mutate(SEX = droplevels(SEX)) |
||
| 199 | +321 |
- colwidths = NULL,+ #' |
||
| 200 | +322 |
- visible_only = TRUE,+ #' lyt3 <- basic_table() %>% |
||
| 201 | +323 |
- rownum = 0,+ #' split_cols_by("ARM") %>%
|
||
| 202 | +324 |
- indent = 0L,+ #' split_cols_by("SEX") %>%
|
||
| 203 | +325 |
- path = character(),+ #' analyze(c("AGE", "COUNTRY"),
|
||
| 204 | +326 |
- incontent = FALSE,+ #' afun = list_wrap_x(summary), |
||
| 205 | +327 |
- repr_ext = 0L,+ #' format = "xx.xx" |
||
| 206 | +328 |
- repr_inds = integer(),+ #' ) |
||
| 207 | +329 |
- sibpos = NA_integer_,+ #' lyt3 |
||
| 208 | +330 |
- nsibs = NA_integer_,+ #' |
||
| 209 | +331 |
- max_width = NULL,+ #' tbl3 <- build_table(lyt3, DM_MF) |
||
| 210 | +332 |
- fontspec = NULL,+ #' tbl3 |
||
| 211 | +333 |
- col_gap = 3) {
+ #' |
||
| 212 | -10383x | +|||
| 334 | +
- indent <- indent + indent_mod(tt)+ #' # nested=TRUE vs not |
|||
| 213 | +335 |
- ## retained for debugging info+ #' lyt4 <- basic_table() %>% |
||
| 214 | -10383x | +|||
| 336 | +
- orig_rownum <- rownum # nolint+ #' split_cols_by("ARM") %>%
|
|||
| 215 | -10383x | +|||
| 337 | +
- if (incontent) {
+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
|
|||
| 216 | -1438x | +|||
| 338 | +
- path <- c(path, "@content")+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
|||
| 217 | -8945x | +|||
| 339 | +
- } else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
+ #' analyze("AGE")
|
|||
| 218 | +340 |
- ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint+ #' lyt4 |
||
| 219 | -8903x | +|||
| 341 | +
- path <- c(path, obj_name(tt))+ #' |
|||
| 220 | +342 |
- }+ #' tbl4 <- build_table(lyt4, DM) |
||
| 221 | -10383x | +|||
| 343 | +
- ret <- list()+ #' tbl4 |
|||
| 222 | +344 |
-
+ #' |
||
| 223 | +345 |
- ## note this is the **table** not the label row+ #' lyt5 <- basic_table() %>% |
||
| 224 | -10383x | +|||
| 346 | +
- if (!visible_only) {
+ #' split_cols_by("ARM") %>%
|
|||
| 225 | -21x | +|||
| 347 | +
- ret <- c(+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
|
|||
| 226 | -21x | +|||
| 348 | +
- ret,+ #' analyze("AGE") %>%
|
|||
| 227 | -21x | +|||
| 349 | +
- list(pagdfrow(+ #' split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
|
|||
| 228 | -21x | +|||
| 350 | +
- rnum = NA,+ #' analyze("AGE")
|
|||
| 229 | -21x | +|||
| 351 | +
- nm = obj_name(tt),+ #' lyt5 |
|||
| 230 | -21x | +|||
| 352 | +
- lab = "",+ #' |
|||
| 231 | -21x | +|||
| 353 | +
- pth = path,+ #' tbl5 <- build_table(lyt5, DM) |
|||
| 232 | -21x | +|||
| 354 | +
- colwidths = colwidths,+ #' tbl5 |
|||
| 233 | -21x | +|||
| 355 | +
- repext = repr_ext,+ #' |
|||
| 234 | -21x | +|||
| 356 | +
- repind = list(repr_inds),+ #' @author Gabriel Becker |
|||
| 235 | -21x | +|||
| 357 | +
- extent = 0,+ #' @export |
|||
| 236 | -21x | +|||
| 358 | +
- indent = indent,+ split_cols_by <- function(lyt, |
|||
| 237 | -21x | +|||
| 359 | +
- rclass = class(tt), sibpos = sibpos,+ var, |
|||
| 238 | -21x | +|||
| 360 | +
- nsibs = nsibs,+ labels_var = var, |
|||
| 239 | -21x | +|||
| 361 | +
- nrowrefs = 0L,+ split_label = var, |
|||
| 240 | -21x | +|||
| 362 | +
- ncellrefs = 0L,+ split_fun = NULL, |
|||
| 241 | -21x | +|||
| 363 | +
- nreflines = 0L,+ format = NULL, |
|||
| 242 | -21x | +|||
| 364 | +
- fontspec = fontspec+ nested = TRUE, |
|||
| 243 | +365 |
- ))+ child_labels = c("default", "visible", "hidden"),
|
||
| 244 | +366 |
- )+ extra_args = list(), |
||
| 245 | +367 |
- }+ ref_group = NULL, |
||
| 246 | -10383x | +|||
| 368 | +
- if (labelrow_visible(tt)) {
+ show_colcounts = FALSE, |
|||
| 247 | -3604x | +|||
| 369 | +
- lr <- tt_labelrow(tt)+ colcount_format = NULL) { ## ,
|
|||
| 248 | -3604x | +370 | +281x |
- newdf <- make_row_df(lr,+ if (is.null(ref_group)) {
|
| 249 | -3604x | +371 | +272x |
- colwidths = colwidths,+ spl <- VarLevelSplit( |
| 250 | -3604x | +372 | +272x |
- visible_only = visible_only,+ var = var, |
| 251 | -3604x | +373 | +272x |
- rownum = rownum,+ split_label = split_label, |
| 252 | -3604x | +374 | +272x |
- indent = indent,+ labels_var = labels_var, |
| 253 | -3604x | +375 | +272x |
- path = path,+ split_format = format, |
| 254 | -3604x | +376 | +272x |
- incontent = TRUE,+ child_labels = child_labels, |
| 255 | -3604x | +377 | +272x |
- repr_ext = repr_ext,+ split_fun = split_fun, |
| 256 | -3604x | +378 | +272x |
- repr_inds = repr_inds,+ extra_args = extra_args, |
| 257 | -3604x | +379 | +272x |
- max_width = max_width,+ show_colcounts = show_colcounts, |
| 258 | -3604x | +380 | +272x |
- fontspec = fontspec+ colcount_format = colcount_format |
| 259 | +381 |
- )+ ) |
||
| 260 | -3604x | +|||
| 382 | +
- rownum <- max(newdf$abs_rownumber, na.rm = TRUE)+ } else {
|
|||
| 261 | -+ | |||
| 383 | +9x |
-
+ spl <- VarLevWBaselineSplit( |
||
| 262 | -3604x | +384 | +9x |
- ret <- c(+ var = var, |
| 263 | -3604x | +385 | +9x |
- ret,+ ref_group = ref_group, |
| 264 | -3604x | +386 | +9x |
- list(newdf)+ split_label = split_label, |
| 265 | -+ | |||
| 387 | +9x |
- )+ split_fun = split_fun, |
||
| 266 | -3604x | +388 | +9x |
- repr_ext <- repr_ext + 1L+ labels_var = labels_var, |
| 267 | -3604x | +389 | +9x |
- repr_inds <- c(repr_inds, rownum)+ split_format = format, |
| 268 | -3604x | +390 | +9x |
- indent <- indent + 1L+ show_colcounts = show_colcounts, |
| 269 | -+ | |||
| 391 | +9x |
- }+ colcount_format = colcount_format |
||
| 270 | +392 |
-
+ ) |
||
| 271 | -10383x | +|||
| 393 | +
- if (NROW(content_table(tt)) > 0) {
+ } |
|||
| 272 | -1438x | +394 | +281x |
- ct_tt <- content_table(tt)+ pos <- next_cpos(lyt, nested) |
| 273 | -1438x | +395 | +281x |
- cind <- indent + indent_mod(ct_tt)+ split_cols(lyt, spl, pos) |
| 274 | -1438x | +|||
| 396 | +
- trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt))+ } |
|||
| 275 | -1438x | +|||
| 397 | +
- contdf <- make_row_df(ct_tt,+ |
|||
| 276 | -1438x | +|||
| 398 | +
- colwidths = colwidths,+ ## .tl_indent ==== |
|||
| 277 | -1438x | +|||
| 399 | +
- visible_only = visible_only,+ |
|||
| 278 | -1438x | +400 | +57x |
- rownum = rownum,+ setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))
|
| 279 | -1438x | +|||
| 401 | +
- indent = cind,+ |
|||
| 280 | -1438x | +|||
| 402 | +
- path = path,+ setMethod( |
|||
| 281 | -1438x | +|||
| 403 | +
- incontent = TRUE,+ ".tl_indent_inner", "PreDataTableLayouts", |
|||
| 282 | -1438x | +404 | +19x |
- repr_ext = repr_ext,+ function(lyt) .tl_indent_inner(rlayout(lyt)) |
| 283 | -1438x | +|||
| 405 | +
- repr_inds = repr_inds,+ ) |
|||
| 284 | -1438x | +|||
| 406 | +
- max_width = max_width,+ setMethod( |
|||
| 285 | -1438x | +|||
| 407 | +
- fontspec = fontspec+ ".tl_indent_inner", "PreDataRowLayout", |
|||
| 286 | +408 |
- )+ function(lyt) {
|
||
| 287 | -1438x | +409 | +19x |
- crnums <- contdf$abs_rownumber+ if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
|
| 288 | -1438x | +|||
| 410 | +! |
- crnums <- crnums[!is.na(crnums)]+ 0L |
||
| 289 | +411 |
-
+ } else {
|
||
| 290 | -1438x | +412 | +19x |
- newrownum <- max(crnums, na.rm = TRUE)+ .tl_indent_inner(lyt[[length(lyt)]]) |
| 291 | -1438x | +|||
| 413 | +
- if (is.finite(newrownum)) {
+ } |
|||
| 292 | -1438x | +|||
| 414 | +
- rownum <- newrownum- |
- |||
| 293 | -1438x | -
- repr_ext <- repr_ext + length(crnums)- |
- ||
| 294 | -1438x | -
- repr_inds <- c(repr_inds, crnums)+ } |
||
| 295 | +415 |
- }- |
- ||
| 296 | -1438x | -
- ret <- c(ret, list(contdf))- |
- ||
| 297 | -1438x | -
- indent <- cind + 1+ ) |
||
| 298 | +416 |
- }+ |
||
| 299 | +417 | - - | -||
| 300 | -10383x | -
- allkids <- tree_children(tt)- |
- ||
| 301 | -10383x | -
- newnsibs <- length(allkids)- |
- ||
| 302 | -10383x | -
- for (i in seq_along(allkids)) {
- |
- ||
| 303 | -19250x | -
- kid <- allkids[[i]]- |
- ||
| 304 | -19250x | -
- kiddfs <- make_row_df(kid,+ setMethod( |
||
| 305 | -19250x | +|||
| 418 | +
- colwidths = colwidths,+ ".tl_indent_inner", "SplitVector", |
|||
| 306 | -19250x | +|||
| 419 | +
- visible_only = visible_only,+ function(lyt) {
|
|||
| 307 | -19250x | +420 | +19x |
- rownum = force(rownum),+ sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L |
| 308 | -19250x | +|||
| 421 | +
- indent = indent, ## + 1,+ } |
|||
| 309 | -19250x | +|||
| 422 | +
- path = path,+ ) ## length(lyt) - 1L) |
|||
| 310 | -19250x | +|||
| 423 | +
- incontent = incontent,+ |
|||
| 311 | -19250x | +|||
| 424 | +
- repr_ext = repr_ext,+ .tl_indent <- function(lyt, nested = TRUE) {
|
|||
| 312 | -19250x | +425 | +19x |
- repr_inds = repr_inds,+ if (!nested) {
|
| 313 | -19250x | +|||
| 426 | +! |
- nsibs = newnsibs,+ 0L |
||
| 314 | -19250x | +|||
| 427 | +
- sibpos = i,+ } else {
|
|||
| 315 | -19250x | +428 | +19x |
- max_width = max_width,+ .tl_indent_inner(lyt) |
| 316 | -19250x | +|||
| 429 | +
- fontspec = fontspec+ } |
|||
| 317 | +430 |
- )+ } |
||
| 318 | +431 | |||
| 319 | +432 |
- # print(kiddfs$abs_rownumber)- |
- ||
| 320 | -19250x | -
- rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)+ #' Add rows according to levels of a variable |
||
| 321 | -19250x | +|||
| 433 | +
- ret <- c(ret, list(kiddfs))+ #' |
|||
| 322 | +434 |
- }+ #' @inheritParams lyt_args |
||
| 323 | +435 |
-
+ #' |
||
| 324 | -10383x | +|||
| 436 | +
- ret <- do.call(rbind, ret)+ #' @inherit split_cols_by return |
|||
| 325 | +437 |
-
+ #' |
||
| 326 | +438 |
- # Case where it has Elementary table or VTableTree section_div it is overridden+ #' @inheritSection custom_split_funs Custom Splitting Function Details |
||
| 327 | -10383x | +|||
| 439 | +
- if (!is.na(trailing_section_div(tt))) {
+ #' |
|||
| 328 | -110x | +|||
| 440 | +
- ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt)+ #' @note |
|||
| 329 | +441 |
- }+ #' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor |
||
| 330 | -10383x | +|||
| 442 | +
- ret+ #' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very |
|||
| 331 | +443 |
- }+ #' informative, but that will change in the future. |
||
| 332 | +444 |
- )+ #' |
||
| 333 | +445 |
-
+ #' @examples |
||
| 334 | +446 |
- # #' @exportMethod make_row_df+ #' lyt <- basic_table() %>% |
||
| 335 | +447 |
- #' @inherit formatters::make_row_df+ #' split_cols_by("ARM") %>%
|
||
| 336 | +448 |
- #'+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
||
| 337 | +449 |
- #' @export+ #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
|
||
| 338 | +450 |
- #' @rdname formatters_methods+ #' |
||
| 339 | +451 |
- setMethod(+ #' tbl <- build_table(lyt, DM) |
||
| 340 | +452 |
- "make_row_df", "TableRow",+ #' tbl |
||
| 341 | +453 |
- function(tt, colwidths = NULL, visible_only = TRUE,+ #' |
||
| 342 | +454 |
- rownum = 0,+ #' lyt2 <- basic_table() %>% |
||
| 343 | +455 |
- indent = 0L,+ #' split_cols_by("ARM") %>%
|
||
| 344 | +456 |
- path = "root",+ #' split_rows_by("RACE") %>%
|
||
| 345 | +457 |
- incontent = FALSE,+ #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
|
||
| 346 | +458 |
- repr_ext = 0L,+ #' |
||
| 347 | +459 |
- repr_inds = integer(),+ #' tbl2 <- build_table(lyt2, DM) |
||
| 348 | +460 |
- sibpos = NA_integer_,+ #' tbl2 |
||
| 349 | +461 |
- nsibs = NA_integer_,+ #' |
||
| 350 | +462 |
- max_width = NULL,+ #' lyt3 <- basic_table() %>% |
||
| 351 | +463 |
- fontspec,+ #' split_cols_by("ARM") %>%
|
||
| 352 | +464 |
- col_gap = 3) {
+ #' split_cols_by("SEX") %>%
|
||
| 353 | -11130x | +|||
| 465 | +
- indent <- indent + indent_mod(tt)+ #' summarize_row_groups(label_fstr = "Overall (N)") %>% |
|||
| 354 | -11130x | +|||
| 466 | +
- rownum <- rownum + 1+ #' split_rows_by("RACE",
|
|||
| 355 | -11130x | +|||
| 467 | +
- rrefs <- row_footnotes(tt)+ #' split_label = "Ethnicity", labels_var = "ethn_lab", |
|||
| 356 | -11130x | +|||
| 468 | +
- crefs <- cell_footnotes(tt)+ #' split_fun = drop_split_levels |
|||
| 357 | -11130x | +|||
| 469 | +
- reflines <- sum(+ #' ) %>% |
|||
| 358 | -11130x | +|||
| 470 | +
- sapply(+ #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
|
|||
| 359 | -11130x | +|||
| 471 | +
- c(rrefs, crefs),+ #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
|
|||
| 360 | -11130x | +|||
| 472 | +
- nlines,+ #' |
|||
| 361 | -11130x | +|||
| 473 | +
- colwidths = colwidths,+ #' lyt3 |
|||
| 362 | -11130x | +|||
| 474 | +
- max_width = max_width,+ #' |
|||
| 363 | -11130x | +|||
| 475 | +
- fontspec = fontspec,+ #' library(dplyr) |
|||
| 364 | -11130x | +|||
| 476 | +
- col_gap = col_gap+ #' |
|||
| 365 | +477 |
- )+ #' DM2 <- DM %>% |
||
| 366 | -11130x | +|||
| 478 | +
- ) ## col_gap not strictly necessary as these aren't rows, but why not+ #' filter(SEX %in% c("M", "F")) %>%
|
|||
| 367 | -11130x | +|||
| 479 | +
- ret <- pagdfrow(+ #' mutate( |
|||
| 368 | -11130x | +|||
| 480 | +
- row = tt,+ #' SEX = droplevels(SEX), |
|||
| 369 | -11130x | +|||
| 481 | +
- rnum = rownum,+ #' gender_lab = c( |
|||
| 370 | -11130x | +|||
| 482 | +
- colwidths = colwidths,+ #' "F" = "Female", "M" = "Male", |
|||
| 371 | -11130x | +|||
| 483 | +
- sibpos = sibpos,+ #' "U" = "Unknown", |
|||
| 372 | -11130x | +|||
| 484 | +
- nsibs = nsibs,+ #' "UNDIFFERENTIATED" = "Undifferentiated" |
|||
| 373 | -11130x | +|||
| 485 | +
- pth = c(path, unname(obj_name(tt))),+ #' )[SEX], |
|||
| 374 | -11130x | +|||
| 486 | +
- repext = repr_ext,+ #' ethn_lab = c( |
|||
| 375 | -11130x | +|||
| 487 | +
- repind = repr_inds,+ #' "ASIAN" = "Asian", |
|||
| 376 | -11130x | +|||
| 488 | +
- indent = indent,+ #' "BLACK OR AFRICAN AMERICAN" = "Black or African American", |
|||
| 377 | -11130x | +|||
| 489 | +
- extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),+ #' "WHITE" = "White", |
|||
| 378 | +490 |
- ## these two are unlist calls cause they come in lists even with no footnotes+ #' "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native", |
||
| 379 | -11130x | +|||
| 491 | +
- nrowrefs = length(rrefs),+ #' "MULTIPLE" = "Multiple", |
|||
| 380 | -11130x | +|||
| 492 | +
- ncellrefs = length(unlist(crefs)),+ #' "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" = |
|||
| 381 | -11130x | +|||
| 493 | +
- nreflines = reflines,+ #' "Native Hawaiian or Other Pacific Islander", |
|||
| 382 | -11130x | +|||
| 494 | +
- trailing_sep = trailing_section_div(tt),+ #' "OTHER" = "Other", "UNKNOWN" = "Unknown" |
|||
| 383 | -11130x | +|||
| 495 | +
- fontspec = fontspec+ #' )[RACE] |
|||
| 384 | +496 |
- )+ #' ) |
||
| 385 | -11130x | +|||
| 497 | +
- ret+ #' |
|||
| 386 | +498 |
- }+ #' tbl3 <- build_table(lyt3, DM2) |
||
| 387 | +499 |
- )+ #' tbl3 |
||
| 388 | +500 |
-
+ #' |
||
| 389 | +501 |
- # #' @exportMethod make_row_df+ #' @author Gabriel Becker |
||
| 390 | +502 |
#' @export |
||
| 391 | +503 |
- #' @rdname formatters_methods+ split_rows_by <- function(lyt, |
||
| 392 | +504 |
- setMethod(+ var, |
||
| 393 | +505 |
- "make_row_df", "LabelRow",+ labels_var = var, |
||
| 394 | +506 |
- function(tt, colwidths = NULL, visible_only = TRUE,+ split_label = var, |
||
| 395 | +507 |
- rownum = 0,+ split_fun = NULL, |
||
| 396 | +508 |
- indent = 0L,+ format = NULL, |
||
| 397 | +509 |
- path = "root",+ na_str = NA_character_, |
||
| 398 | +510 |
- incontent = FALSE,+ nested = TRUE, |
||
| 399 | +511 |
- repr_ext = 0L,+ child_labels = c("default", "visible", "hidden"),
|
||
| 400 | +512 |
- repr_inds = integer(),+ label_pos = "hidden", |
||
| 401 | +513 |
- sibpos = NA_integer_,+ indent_mod = 0L, |
||
| 402 | +514 |
- nsibs = NA_integer_,+ page_by = FALSE, |
||
| 403 | +515 |
- max_width = NULL,+ page_prefix = split_label, |
||
| 404 | +516 |
- fontspec,+ section_div = NA_character_) {
|
||
| 405 | -+ | |||
| 517 | +243x |
- col_gap = 3) {
+ label_pos <- match.arg(label_pos, label_pos_values) |
||
| 406 | -3624x | +518 | +243x |
- rownum <- rownum + 1+ child_labels <- match.arg(child_labels) |
| 407 | -3624x | +519 | +243x |
- indent <- indent + indent_mod(tt)+ spl <- VarLevelSplit( |
| 408 | -3624x | +520 | +243x |
- ret <- pagdfrow(tt,+ var = var, |
| 409 | -3624x | +521 | +243x |
- extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),+ split_label = split_label, |
| 410 | -3624x | +522 | +243x |
- rnum = rownum,+ label_pos = label_pos, |
| 411 | -3624x | +523 | +243x |
- colwidths = colwidths,+ labels_var = labels_var, |
| 412 | -3624x | +524 | +243x |
- sibpos = sibpos,+ split_fun = split_fun, |
| 413 | -3624x | +525 | +243x |
- nsibs = nsibs,+ split_format = format, |
| 414 | -3624x | +526 | +243x |
- pth = path,+ split_na_str = na_str, |
| 415 | -3624x | +527 | +243x |
- repext = repr_ext,+ child_labels = child_labels, |
| 416 | -3624x | +528 | +243x |
- repind = repr_inds,+ indent_mod = indent_mod, |
| 417 | -3624x | +529 | +243x |
- indent = indent,+ page_prefix = if (page_by) page_prefix else NA_character_, |
| 418 | -3624x | +530 | +243x |
- nrowrefs = length(row_footnotes(tt)),+ section_div = section_div |
| 419 | -3624x | +|||
| 531 | +
- ncellrefs = 0L,+ ) |
|||
| 420 | -3624x | +|||
| 532 | +
- nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_,+ |
|||
| 421 | -3624x | +533 | +243x |
- colwidths = colwidths,+ pos <- next_rpos(lyt, nested) |
| 422 | -3624x | +534 | +243x |
- max_width = max_width,+ ret <- split_rows(lyt, spl, pos) |
| 423 | -3624x | +|||
| 535 | +
- fontspec = fontspec,+ |
|||
| 424 | -3624x | +536 | +241x |
- col_gap = col_gap+ ret |
| 425 | +537 |
- )),+ } |
||
| 426 | -3624x | +|||
| 538 | +
- trailing_sep = trailing_section_div(tt),+ |
|||
| 427 | -3624x | +|||
| 539 | +
- fontspec = fontspec+ #' Associate multiple variables with columns |
|||
| 428 | +540 |
- )+ #' |
||
| 429 | -3624x | +|||
| 541 | +
- if (!labelrow_visible(tt)) {
+ #' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis. |
|||
| 430 | -! | +|||
| 542 | +
- ret <- ret[0, , drop = FALSE]+ #' When we need columns to reflect different variables entirely, rather than different levels of a single |
|||
| 431 | +543 |
- }+ #' variable, we use `split_cols_by_multivar`. |
||
| 432 | -3624x | +|||
| 544 | +
- ret+ #' |
|||
| 433 | +545 |
- }+ #' @inheritParams lyt_args |
||
| 434 | +546 |
- )+ #' |
||
| 435 | +547 |
-
+ #' @inherit split_cols_by return |
||
| 436 | +548 |
- setGeneric("inner_col_df", function(ct,
+ #' |
||
| 437 | +549 |
- colwidths = NULL,+ #' @seealso [analyze_colvars()] |
||
| 438 | +550 |
- visible_only = TRUE,+ #' |
||
| 439 | +551 |
- colnum = 0L,+ #' @examples |
||
| 440 | +552 |
- sibpos = NA_integer_,+ #' library(dplyr) |
||
| 441 | +553 |
- nsibs = NA_integer_,+ #' |
||
| 442 | +554 |
- ncolref = 0L) {
+ #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n())) |
||
| 443 | -26322x | +|||
| 555 | +
- standardGeneric("inner_col_df")
+ #' |
|||
| 444 | +556 |
- })+ #' ## toy example where we take the mean of the first variable and the |
||
| 445 | +557 |
-
+ #' ## count of >.5 for the second. |
||
| 446 | +558 |
- #' Column layout summary+ #' colfuns <- list( |
||
| 447 | +559 |
- #'+ #' function(x) in_rows(mean = mean(x), .formats = "xx.x"), |
||
| 448 | +560 |
- #' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a+ #' function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
|
||
| 449 | +561 |
- #' `data.frame`.+ #' ) |
||
| 450 | +562 |
#' |
||
| 451 | +563 |
- #' @inheritParams formatters::make_row_df+ #' lyt <- basic_table() %>% |
||
| 452 | +564 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 453 | +565 |
- #' @export+ #' split_cols_by_multivar(c("value", "pctdiff")) %>%
|
||
| 454 | +566 |
- make_col_df <- function(tt,+ #' split_rows_by("RACE",
|
||
| 455 | +567 |
- colwidths = NULL,+ #' split_label = "ethnicity", |
||
| 456 | +568 |
- visible_only = TRUE) {
+ #' split_fun = drop_split_levels |
||
| 457 | -4627x | +|||
| 569 | +
- ctree <- coltree(tt) ## this is a null op if its already a coltree object+ #' ) %>% |
|||
| 458 | -4627x | +|||
| 570 | +
- rows <- inner_col_df(ctree,+ #' summarize_row_groups() %>% |
|||
| 459 | +571 |
- ## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)),+ #' analyze_colvars(afun = colfuns) |
||
| 460 | -4627x | +|||
| 572 | +
- colwidths = colwidths,+ #' lyt |
|||
| 461 | -4627x | +|||
| 573 | +
- visible_only = visible_only,+ #' |
|||
| 462 | -4627x | +|||
| 574 | +
- colnum = 1L,+ #' tbl <- build_table(lyt, ANL) |
|||
| 463 | -4627x | +|||
| 575 | +
- sibpos = 1L,+ #' tbl |
|||
| 464 | -4627x | +|||
| 576 | +
- nsibs = 1L+ #' |
|||
| 465 | -4627x | +|||
| 577 | +
- ) ## nsiblings includes current so 1 means "only child"+ #' @author Gabriel Becker |
|||
| 466 | +578 |
-
+ #' @export |
||
| 467 | -4627x | +|||
| 579 | +
- do.call(rbind, rows)+ split_cols_by_multivar <- function(lyt, |
|||
| 468 | +580 |
- }+ vars, |
||
| 469 | +581 |
-
+ split_fun = NULL, |
||
| 470 | +582 |
- setMethod(+ varlabels = vars, |
||
| 471 | +583 |
- "inner_col_df", "LayoutColLeaf",+ varnames = NULL, |
||
| 472 | +584 |
- function(ct, colwidths, visible_only,+ nested = TRUE, |
||
| 473 | +585 |
- colnum,+ extra_args = list(), |
||
| 474 | +586 |
- sibpos,+ ## for completeness even though it doesn't make sense |
||
| 475 | +587 |
- nsibs) {
+ show_colcounts = FALSE, |
||
| 476 | -17231x | +|||
| 588 | +
- list(col_dfrow(+ colcount_format = NULL) {
|
|||
| 477 | -17231x | +589 | +24x |
- col = ct,+ spl <- MultiVarSplit( |
| 478 | -17231x | +590 | +24x |
- cnum = colnum,+ vars = vars, split_label = "", |
| 479 | -17231x | +591 | +24x |
- sibpos = sibpos,+ varlabels = varlabels, |
| 480 | -17231x | +592 | +24x |
- nsibs = nsibs,+ varnames = varnames, |
| 481 | -17231x | +593 | +24x |
- leaf_indices = colnum,+ split_fun = split_fun, |
| 482 | -17231x | +594 | +24x |
- col_fnotes = col_footnotes(ct)+ extra_args = extra_args, |
| 483 | -+ | |||
| 595 | +24x |
- ))+ show_colcounts = show_colcounts, |
||
| 484 | -+ | |||
| 596 | +24x |
- }+ colcount_format = colcount_format |
||
| 485 | +597 |
- )+ ) |
||
| 486 | -+ | |||
| 598 | +24x |
-
+ pos <- next_cpos(lyt, nested) |
||
| 487 | -+ | |||
| 599 | +24x |
- setMethod(+ split_cols(lyt, spl, pos) |
||
| 488 | +600 |
- "inner_col_df", "LayoutColTree",+ } |
||
| 489 | +601 |
- function(ct, colwidths, visible_only,+ |
||
| 490 | +602 |
- colnum,+ #' Associate multiple variables with rows |
||
| 491 | +603 |
- sibpos,+ #' |
||
| 492 | +604 |
- nsibs) {
- |
- ||
| 493 | -9091x | -
- kids <- tree_children(ct)- |
- ||
| 494 | -9091x | -
- ret <- vector("list", length(kids))
- |
- ||
| 495 | -9091x | -
- for (i in seq_along(kids)) {
- |
- ||
| 496 | -21695x | -
- k <- kids[[i]]- |
- ||
| 497 | -21695x | -
- newrows <- do.call(- |
- ||
| 498 | -21695x | -
- rbind,- |
- ||
| 499 | -21695x | -
- inner_col_df(k,- |
- ||
| 500 | -21695x | -
- colnum = colnum,- |
- ||
| 501 | -21695x | -
- sibpos = i,+ #' When we need rows to reflect different variables rather than different |
||
| 502 | -21695x | +|||
| 605 | +
- nsibs = length(kids),+ #' levels of a single variable, we use `split_rows_by_multivar`. |
|||
| 503 | -21695x | +|||
| 606 | +
- visible_only = visible_only+ #' |
|||
| 504 | +607 |
- )+ #' @inheritParams lyt_args |
||
| 505 | +608 |
- )+ #' |
||
| 506 | -21695x | +|||
| 609 | +
- colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1+ #' @inherit split_rows_by return |
|||
| 507 | -21695x | +|||
| 610 | +
- ret[[i]] <- newrows+ #' |
|||
| 508 | +611 |
- }+ #' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of |
||
| 509 | +612 |
-
+ #' split on a column basis. |
||
| 510 | -9091x | +|||
| 613 | +
- if (!visible_only) {
+ #' |
|||
| 511 | -1240x | +|||
| 614 | +
- allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)]))+ #' @examples |
|||
| 512 | -1240x | +|||
| 615 | +
- thispth <- pos_to_path(tree_pos(ct))+ #' lyt <- basic_table() %>% |
|||
| 513 | -1240x | +|||
| 616 | +
- if (any(nzchar(thispth))) {
+ #' split_cols_by("ARM") %>%
|
|||
| 514 | -594x | +|||
| 617 | +
- thisone <- list(col_dfrow(+ #' split_rows_by_multivar(c("SEX", "STRATA1")) %>%
|
|||
| 515 | -594x | +|||
| 618 | +
- col = ct,+ #' summarize_row_groups() %>% |
|||
| 516 | -594x | +|||
| 619 | +
- cnum = NA_integer_,+ #' analyze(c("AGE", "SEX"))
|
|||
| 517 | -594x | +|||
| 620 | +
- leaf_indices = allindices,+ #' |
|||
| 518 | -594x | +|||
| 621 | +
- sibpos = sibpos,+ #' tbl <- build_table(lyt, DM) |
|||
| 519 | -594x | +|||
| 622 | +
- nsibs = nsibs,+ #' tbl |
|||
| 520 | -594x | +|||
| 623 | +
- pth = thispth,+ #' |
|||
| 521 | -594x | +|||
| 624 | +
- col_fnotes = col_footnotes(ct)+ #' @export |
|||
| 522 | +625 |
- ))+ split_rows_by_multivar <- function(lyt, |
||
| 523 | -594x | +|||
| 626 | +
- ret <- c(thisone, ret)+ vars, |
|||
| 524 | +627 |
- }+ split_fun = NULL, |
||
| 525 | +628 |
- }+ split_label = "", |
||
| 526 | +629 |
-
+ varlabels = vars, |
||
| 527 | -9091x | +|||
| 630 | +
- ret+ format = NULL, |
|||
| 528 | +631 |
- }+ na_str = NA_character_, |
||
| 529 | +632 |
- )+ nested = TRUE, |
||
| 530 | +633 |
-
+ child_labels = c("default", "visible", "hidden"),
|
||
| 531 | +634 |
- ## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND+ indent_mod = 0L, |
||
| 532 | +635 |
- ## title/subtitle!!!!!+ section_div = NA_character_, |
||
| 533 | +636 |
- .header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
+ extra_args = list()) {
|
||
| 534 | -3x | +637 | +2x |
- cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ child_labels <- match.arg(child_labels) |
| 535 | -3x | +638 | +2x |
- if (any(nzchar(all_titles(tt)))) {
+ spl <- MultiVarSplit( |
| 536 | -+ | |||
| 639 | +2x |
- ## +1 is for blank line between subtitles and divider+ vars = vars, split_label = split_label, varlabels, |
||
| 537 | +640 | 2x |
- tlines <- sum(nlines(all_titles(tt),+ split_format = format, |
|
| 538 | +641 | 2x |
- colwidths = colwidths,+ split_na_str = na_str, |
|
| 539 | +642 | 2x |
- max_width = max_width,+ child_labels = child_labels, |
|
| 540 | +643 | 2x |
- fontspec = fontspec+ indent_mod = indent_mod, |
|
| 541 | +644 | 2x |
- )) + divider_height(tt) + 1L+ split_fun = split_fun, |
|
| 542 | -+ | |||
| 645 | +2x |
- } else {
+ section_div = section_div, |
||
| 543 | -1x | +646 | +2x |
- tlines <- 0+ extra_args = extra_args |
| 544 | +647 |
- }+ ) |
||
| 545 | -3x | +648 | +2x |
- ret <- cinfo_lines + tlines+ pos <- next_rpos(lyt, nested) |
| 546 | -3x | -
- if (verbose) {
- |
- ||
| 547 | -! | -
- message(- |
- ||
| 548 | -! | -
- "Lines required for header content: ",- |
- ||
| 549 | -! | +649 | +2x |
- ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")"+ split_rows(lyt, spl, pos) |
| 550 | +650 |
- )+ } |
||
| 551 | +651 |
- }- |
- ||
| 552 | -3x | -
- ret+ |
||
| 553 | +652 |
- }+ #' Split on static or dynamic cuts of the data |
||
| 554 | +653 |
-
+ #' |
||
| 555 | +654 |
- ## this is ***only*** lines that are expected to be repeated on multiple pages:+ #' Create columns (or row splits) based on values (such as quartiles) of `var`. |
||
| 556 | +655 |
- ## main footer, prov footer, and referential footnotes on **columns**+ #' |
||
| 557 | +656 |
-
+ #' @inheritParams lyt_args |
||
| 558 | +657 |
- .footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
- |
- ||
| 559 | -3x | -
- flines <- nlines(main_footer(tt),- |
- ||
| 560 | -3x | -
- colwidths = colwidths,+ #' |
||
| 561 | -3x | +|||
| 658 | +
- max_width = max_width - table_inset(tt),+ #' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*, |
|||
| 562 | -3x | +|||
| 659 | +
- fontspec = fontspec+ #' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect |
|||
| 563 | +660 |
- ) ++ #' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under. |
||
| 564 | -3x | +|||
| 661 | +
- nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ #' |
|||
| 565 | -3x | +|||
| 662 | +
- if (flines > 0) {
+ #' @inherit split_cols_by return |
|||
| 566 | -2x | +|||
| 663 | +
- dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)+ #' |
|||
| 567 | -2x | +|||
| 664 | +
- flines <- flines + dl_contrib + 1L+ #' @examples |
|||
| 568 | +665 |
- }+ #' library(dplyr) |
||
| 569 | +666 |
-
+ #' |
||
| 570 | -3x | +|||
| 667 | +
- if (verbose) {
+ #' # split_cols_by_cuts |
|||
| 571 | -! | +|||
| 668 | +
- message(+ #' lyt <- basic_table() %>% |
|||
| 572 | -! | +|||
| 669 | +
- "Determining lines required for footer content",+ #' split_cols_by("ARM") %>%
|
|||
| 573 | -! | +|||
| 670 | +
- if (have_cfnotes) " [column fnotes present]",+ #' split_cols_by_cuts("AGE",
|
|||
| 574 | -! | +|||
| 671 | +
- ": ", flines, " lines"+ #' split_label = "Age", |
|||
| 575 | +672 |
- )+ #' cuts = c(0, 25, 35, 1000), |
||
| 576 | +673 |
- }+ #' cutlabels = c("young", "medium", "old")
|
||
| 577 | +674 |
-
+ #' ) %>% |
||
| 578 | -3x | +|||
| 675 | +
- flines+ #' analyze(c("BMRKR2", "STRATA2")) %>%
|
|||
| 579 | +676 |
- }+ #' append_topleft("counts")
|
||
| 580 | +677 |
-
+ #' |
||
| 581 | +678 |
- # Pagination ---------------------------------------------------------------+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 582 | +679 |
-
+ #' tbl |
||
| 583 | +680 |
- #' Pagination of a `TableTree`+ #' |
||
| 584 | +681 |
- #'+ #' # split_rows_by_cuts |
||
| 585 | +682 |
- #' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size.+ #' lyt2 <- basic_table() %>% |
||
| 586 | +683 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 587 | +684 |
- #' @inheritParams gen_args+ #' split_rows_by_cuts("AGE",
|
||
| 588 | +685 |
- #' @inheritParams paginate_table+ #' split_label = "Age", |
||
| 589 | +686 |
- #' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows.+ #' cuts = c(0, 25, 35, 1000), |
||
| 590 | +687 |
- #' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a+ #' cutlabels = c("young", "medium", "old")
|
||
| 591 | +688 |
- #' mid-subtable split to be valid. Defaults to 2.+ #' ) %>% |
||
| 592 | +689 |
- #' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other+ #' analyze(c("BMRKR2", "STRATA2")) %>%
|
||
| 593 | +690 |
- #' considerations. Defaults to none.+ #' append_topleft("counts")
|
||
| 594 | +691 |
#' |
||
| 595 | +692 |
- #' @return+ #' |
||
| 596 | +693 |
- #' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`.+ #' tbl2 <- build_table(lyt2, ex_adsl) |
||
| 597 | +694 |
- #' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`.+ #' tbl2 |
||
| 598 | +695 |
#' |
||
| 599 | +696 |
- #' @details+ #' # split_cols_by_quartiles |
||
| 600 | +697 |
- #' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated+ #' |
||
| 601 | +698 |
- #' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the+ #' lyt3 <- basic_table() %>% |
||
| 602 | +699 |
- #' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of+ #' split_cols_by("ARM") %>%
|
||
| 603 | +700 |
- #' text than rendering the table without pagination would.+ #' split_cols_by_quartiles("AGE", split_label = "Age") %>%
|
||
| 604 | +701 |
- #'+ #' analyze(c("BMRKR2", "STRATA2")) %>%
|
||
| 605 | +702 |
- #' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content.+ #' append_topleft("counts")
|
||
| 606 | +703 |
#' |
||
| 607 | +704 |
- #' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`).+ #' tbl3 <- build_table(lyt3, ex_adsl) |
||
| 608 | +705 |
- #'+ #' tbl3 |
||
| 609 | +706 |
- #' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same+ #' |
||
| 610 | +707 |
- #' algorithm used for vertical pagination to it.+ #' # split_rows_by_quartiles |
||
| 611 | +708 |
- #'+ #' lyt4 <- basic_table(show_colcounts = TRUE) %>% |
||
| 612 | +709 |
- #' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and+ #' split_cols_by("ARM") %>%
|
||
| 613 | +710 |
- #' characters-per-page (`cpp`) values.+ #' split_rows_by_quartiles("AGE", split_label = "Age") %>%
|
||
| 614 | +711 |
- #'+ #' analyze("BMRKR2") %>%
|
||
| 615 | +712 |
- #' The full multi-direction pagination algorithm then is as follows:+ #' append_topleft(c("Age Quartiles", " Counts BMRKR2"))
|
||
| 616 | +713 |
#' |
||
| 617 | +714 |
- #' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns):+ #' tbl4 <- build_table(lyt4, ex_adsl) |
||
| 618 | +715 |
- #' - titles/footers/column labels, and horizontal dividers in the vertical pagination case+ #' tbl4 |
||
| 619 | +716 |
- #' - row-labels, table_inset, and top-left materials in the horizontal case+ #' |
||
| 620 | +717 |
- #' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables.+ #' # split_cols_by_cutfun |
||
| 621 | +718 |
- #' 2. Perform vertical pagination separately on each table generated in (1).+ #' cutfun <- function(x) {
|
||
| 622 | +719 |
- #' 3. Perform horizontal pagination **on the entire table** and apply the results to each table+ #' cutpoints <- c( |
||
| 623 | +720 |
- #' page generated in (1)-(2).+ #' min(x), |
||
| 624 | +721 |
- #' 4. Return a list of subtables representing full bi-directional pagination.+ #' mean(x), |
||
| 625 | +722 |
- #'+ #' max(x) |
||
| 626 | +723 |
- #' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package:+ #' ) |
||
| 627 | +724 |
#' |
||
| 628 | -- |
- #' @inheritSection formatters::pagination_algo Pagination Algorithm- |
- ||
| 629 | +725 |
- #'+ #' names(cutpoints) <- c("", "Younger", "Older")
|
||
| 630 | +726 |
- #' @examples+ #' cutpoints |
||
| 631 | +727 |
- #' s_summary <- function(x) {
+ #' } |
||
| 632 | +728 |
- #' if (is.numeric(x)) {
+ #' |
||
| 633 | +729 |
- #' in_rows(+ #' lyt5 <- basic_table() %>% |
||
| 634 | +730 |
- #' "n" = rcell(sum(!is.na(x)), format = "xx"),+ #' split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
|
||
| 635 | +731 |
- #' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)),+ #' analyze("SEX")
|
||
| 636 | +732 |
- #' format = "xx.xx (xx.xx)"+ #' |
||
| 637 | +733 |
- #' ),+ #' tbl5 <- build_table(lyt5, ex_adsl) |
||
| 638 | +734 |
- #' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"),+ #' tbl5 |
||
| 639 | +735 |
- #' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx")+ #' |
||
| 640 | +736 |
- #' )+ #' # split_rows_by_cutfun |
||
| 641 | +737 |
- #' } else if (is.factor(x)) {
+ #' lyt6 <- basic_table() %>% |
||
| 642 | +738 |
- #' vs <- as.list(table(x))+ #' split_cols_by("SEX") %>%
|
||
| 643 | +739 |
- #' do.call(in_rows, lapply(vs, rcell, format = "xx"))+ #' split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
|
||
| 644 | +740 |
- #' } else {
+ #' analyze("BMRKR2")
|
||
| 645 | +741 |
- #' (+ #' |
||
| 646 | +742 |
- #' stop("type not supported")
+ #' tbl6 <- build_table(lyt6, ex_adsl) |
||
| 647 | +743 |
- #' )+ #' tbl6 |
||
| 648 | +744 |
- #' }+ #' |
||
| 649 | +745 |
- #' }+ #' @author Gabriel Becker |
||
| 650 | +746 |
- #'+ #' @export |
||
| 651 | +747 |
- #' lyt <- basic_table() %>%+ #' @rdname varcuts |
||
| 652 | +748 |
- #' split_cols_by(var = "ARM") %>%+ split_cols_by_cuts <- function(lyt, var, cuts, |
||
| 653 | +749 |
- #' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
+ cutlabels = NULL, |
||
| 654 | +750 |
- #'+ split_label = var, |
||
| 655 | +751 |
- #' tbl <- build_table(lyt, ex_adsl)+ nested = TRUE, |
||
| 656 | +752 |
- #' tbl+ cumulative = FALSE, |
||
| 657 | +753 |
- #'+ show_colcounts = FALSE, |
||
| 658 | +754 |
- #' nrow(tbl)+ colcount_format = NULL) {
|
||
| 659 | -+ | |||
| 755 | +3x |
- #'+ spl <- make_static_cut_split( |
||
| 660 | -+ | |||
| 756 | +3x |
- #' row_paths_summary(tbl)+ var = var, |
||
| 661 | -+ | |||
| 757 | +3x |
- #'+ split_label = split_label, |
||
| 662 | -+ | |||
| 758 | +3x |
- #' tbls <- paginate_table(tbl, lpp = 15)+ cuts = cuts, |
||
| 663 | -+ | |||
| 759 | +3x |
- #' mf <- matrix_form(tbl, indent_rownames = TRUE)+ cutlabels = cutlabels, |
||
| 664 | -+ | |||
| 760 | +3x |
- #' w_tbls <- propose_column_widths(mf) # so that we have the same column widths+ cumulative = cumulative, |
||
| 665 | -+ | |||
| 761 | +3x |
- #'+ show_colcounts = show_colcounts, |
||
| 666 | -+ | |||
| 762 | +3x |
- #'+ colcount_format = colcount_format |
||
| 667 | +763 |
- #' tmp <- lapply(tbls, function(tbli) {
+ ) |
||
| 668 | +764 |
- #' cat(toString(tbli, widths = w_tbls))+ ## if(cumulative) |
||
| 669 | +765 |
- #' cat("\n\n")
+ ## spl = as(spl, "CumulativeCutSplit") |
||
| 670 | -+ | |||
| 766 | +3x |
- #' cat("~~~~ PAGE BREAK ~~~~")
+ pos <- next_cpos(lyt, nested) |
||
| 671 | -+ | |||
| 767 | +3x |
- #' cat("\n\n")
+ split_cols(lyt, spl, pos) |
||
| 672 | +768 |
- #' })+ } |
||
| 673 | +769 |
- #'+ |
||
| 674 | +770 |
- #' @rdname paginate+ #' @export |
||
| 675 | +771 |
- #' @export+ #' @rdname varcuts |
||
| 676 | +772 |
- pag_tt_indices <- function(tt,+ split_rows_by_cuts <- function(lyt, var, cuts, |
||
| 677 | +773 |
- lpp = 15,+ cutlabels = NULL, |
||
| 678 | +774 |
- min_siblings = 2,+ split_label = var, |
||
| 679 | +775 |
- nosplitin = character(),+ format = NULL, |
||
| 680 | +776 |
- colwidths = NULL,+ na_str = NA_character_, |
||
| 681 | +777 |
- max_width = NULL,+ nested = TRUE, |
||
| 682 | +778 |
- fontspec = NULL,+ cumulative = FALSE, |
||
| 683 | +779 |
- col_gap = 3,+ label_pos = "hidden", |
||
| 684 | +780 |
- verbose = FALSE) {
+ section_div = NA_character_) {
|
||
| 685 | -3x | +781 | +2x |
- dheight <- divider_height(tt)+ label_pos <- match.arg(label_pos, label_pos_values) |
| 686 | +782 |
-
+ ## VarStaticCutSplit( |
||
| 687 | -+ | |||
| 783 | +2x |
- # cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width)+ spl <- make_static_cut_split(var, split_label, |
||
| 688 | -3x | +784 | +2x |
- coldf <- make_col_df(tt, colwidths)+ cuts = cuts, |
| 689 | -3x | +785 | +2x |
- have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0+ cutlabels = cutlabels, |
| 690 | -+ | |||
| 786 | +2x |
-
+ split_format = format, |
||
| 691 | -3x | +787 | +2x |
- hlines <- .header_rep_nlines(tt,+ split_na_str = na_str, |
| 692 | -3x | +788 | +2x |
- colwidths = colwidths, max_width = max_width,+ label_pos = label_pos, |
| 693 | -3x | +789 | +2x |
- verbose = verbose,+ cumulative = cumulative, |
| 694 | -3x | +790 | +2x |
- fontspec = fontspec+ section_div = section_div |
| 695 | +791 |
) |
||
| 696 | +792 |
- ## if(any(nzchar(all_titles(tt)))) {
+ ## if(cumulative) |
||
| 697 | +793 |
- ## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) ++ ## spl = as(spl, "CumulativeCutSplit")+ |
+ ||
| 794 | +2x | +
+ pos <- next_rpos(lyt, nested)+ |
+ ||
| 795 | +2x | +
+ split_rows(lyt, spl, pos) |
||
| 698 | +796 |
- ## length(wrap_txt(all_titles(tt), max_width = max_width)) ++ } |
||
| 699 | +797 |
- ## dheight + 1L+ |
||
| 700 | +798 |
- ## } else {
+ #' @export |
||
| 701 | +799 |
- ## tlines <- 0+ #' @rdname varcuts |
||
| 702 | +800 |
- ## }+ split_cols_by_cutfun <- function(lyt, var, |
||
| 703 | +801 |
- ## flines <- nlines(main_footer(tt), colwidths = colwidths,+ cutfun = qtile_cuts, |
||
| 704 | +802 |
- ## max_width = max_width - table_inset(tt)) ++ cutlabelfun = function(x) NULL, |
||
| 705 | +803 |
- ## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width)+ split_label = var, |
||
| 706 | +804 |
- ## if(flines > 0) {
+ nested = TRUE, |
||
| 707 | +805 |
- ## dl_contrib <- if(have_cfnotes) 0 else dheight+ extra_args = list(), |
||
| 708 | +806 |
- ## flines <- flines + dl_contrib + 1L+ cumulative = FALSE, |
||
| 709 | +807 |
- ## }+ show_colcounts = FALSE,+ |
+ ||
| 808 | ++ |
+ colcount_format = NULL) {
|
||
| 710 | +809 | 3x |
- flines <- .footer_rep_nlines(tt,+ spl <- VarDynCutSplit(var, split_label, |
|
| 711 | +810 | 3x |
- colwidths = colwidths,+ cutfun = cutfun, |
|
| 712 | +811 | 3x |
- max_width = max_width,+ cutlabelfun = cutlabelfun, |
|
| 713 | +812 | 3x |
- have_cfnotes = have_cfnotes,+ extra_args = extra_args, |
|
| 714 | +813 | 3x |
- fontspec = fontspec,+ cumulative = cumulative, |
|
| 715 | +814 | 3x |
- verbose = verbose+ label_pos = "hidden", |
|
| 716 | -+ | |||
| 815 | +3x |
- )+ show_colcounts = show_colcounts,+ |
+ ||
| 816 | +3x | +
+ colcount_format = colcount_format |
||
| 717 | +817 |
- ## row lines per page+ ) |
||
| 718 | +818 | 3x |
- rlpp <- lpp - hlines - flines+ pos <- next_cpos(lyt, nested) |
|
| 719 | +819 | 3x |
- if (verbose) {
+ split_cols(lyt, spl, pos) |
|
| 720 | -! | +|||
| 820 | +
- message(+ } |
|||
| 721 | -! | +|||
| 821 | +
- "Adjusted Lines Per Page: ",+ |
|||
| 722 | -! | +|||
| 822 | +
- rlpp, " (original lpp: ", lpp, ")"+ #' @export |
|||
| 723 | +823 |
- )+ #' @rdname varcuts |
||
| 724 | +824 |
- }+ split_cols_by_quartiles <- function(lyt, var, split_label = var, |
||
| 725 | -3x | +|||
| 825 | +
- pagdf <- make_row_df(tt, colwidths, max_width = max_width)+ nested = TRUE, |
|||
| 726 | +826 |
-
+ extra_args = list(),+ |
+ ||
| 827 | ++ |
+ cumulative = FALSE,+ |
+ ||
| 828 | ++ |
+ show_colcounts = FALSE,+ |
+ ||
| 829 | ++ |
+ colcount_format = NULL) {
|
||
| 727 | -3x | +830 | +2x |
- pag_indices_inner(pagdf,+ split_cols_by_cutfun( |
| 728 | -3x | +831 | +2x |
- rlpp = rlpp, min_siblings = min_siblings,+ lyt = lyt, |
| 729 | -3x | +832 | +2x |
- nosplitin = nosplitin,+ var = var, |
| 730 | -3x | +833 | +2x |
- verbose = verbose,+ split_label = split_label, |
| 731 | -3x | +834 | +2x |
- have_col_fnotes = have_cfnotes,+ cutfun = qtile_cuts, |
| 732 | -3x | +835 | +2x |
- div_height = dheight,+ cutlabelfun = function(x) {
|
| 733 | -3x | +836 | +2x |
- col_gap = col_gap,+ c( |
| 734 | -3x | +837 | +2x |
- has_rowlabels = TRUE+ "[min, Q1]", |
| 735 | -+ | |||
| 838 | +2x |
- )+ "(Q1, Q2]", |
||
| 736 | -+ | |||
| 839 | +2x |
- }+ "(Q2, Q3]",+ |
+ ||
| 840 | +2x | +
+ "(Q3, max]" |
||
| 737 | +841 |
-
+ ) |
||
| 738 | +842 |
- copy_title_footer <- function(to, from, newptitle) {
+ }, |
||
| 739 | -18x | +843 | +2x |
- main_title(to) <- main_title(from)+ nested = nested, |
| 740 | -18x | +844 | +2x |
- subtitles(to) <- subtitles(from)+ extra_args = extra_args, |
| 741 | -18x | +845 | +2x |
- page_titles(to) <- c(page_titles(from), newptitle)+ cumulative = cumulative, |
| 742 | -18x | +846 | +2x |
- main_footer(to) <- main_footer(from)+ show_colcounts = show_colcounts, |
| 743 | -18x | +847 | +2x |
- prov_footer(to) <- prov_footer(from)+ colcount_format = colcount_format |
| 744 | -18x | +|||
| 848 | +
- to+ ) |
|||
| 745 | +849 |
- }+ ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, |
||
| 746 | +850 |
-
+ ## cutlabelfun = function(x) c("[min, Q1]",
|
||
| 747 | +851 |
- pag_btw_kids <- function(tt) {
+ ## "(Q1, Q2]", |
||
| 748 | -8x | +|||
| 852 | +
- pref <- ptitle_prefix(tt)+ ## "(Q2, Q3]", |
|||
| 749 | -8x | +|||
| 853 | +
- lapply(+ ## "(Q3, max]"), |
|||
| 750 | -8x | +|||
| 854 | +
- tree_children(tt),+ ## split_format = format, |
|||
| 751 | -8x | +|||
| 855 | +
- function(tbl) {
+ ## extra_args = extra_args, |
|||
| 752 | -18x | +|||
| 856 | +
- tbl <- copy_title_footer(+ ## cumulative = cumulative, |
|||
| 753 | -18x | +|||
| 857 | +
- tbl, tt,+ ## label_pos = "hidden") |
|||
| 754 | -18x | +|||
| 858 | +
- paste(pref, obj_label(tbl), sep = ": ")+ ## pos = next_cpos(lyt, nested) |
|||
| 755 | +859 |
- )+ ## split_cols(lyt, spl, pos) |
||
| 756 | -18x | +|||
| 860 | +
- labelrow_visible(tbl) <- FALSE+ } |
|||
| 757 | -18x | +|||
| 861 | +
- tbl+ |
|||
| 758 | +862 |
- }+ #' @export |
||
| 759 | +863 |
- )+ #' @rdname varcuts |
||
| 760 | +864 |
- }+ split_rows_by_quartiles <- function(lyt, var, split_label = var, |
||
| 761 | +865 |
-
+ format = NULL, |
||
| 762 | +866 |
- force_paginate <- function(tt,+ na_str = NA_character_, |
||
| 763 | +867 |
- force_pag = vapply(tree_children(tt), has_force_pag, NA),+ nested = TRUE, |
||
| 764 | +868 |
- verbose = FALSE) {
+ child_labels = c("default", "visible", "hidden"),
|
||
| 765 | +869 |
- ## forced pagination is happening at this+ extra_args = list(), |
||
| 766 | -114x | +|||
| 870 | +
- if (has_force_pag(tt)) {
+ cumulative = FALSE, |
|||
| 767 | -8x | +|||
| 871 | +
- ret <- pag_btw_kids(tt)+ indent_mod = 0L, |
|||
| 768 | -8x | +|||
| 872 | +
- return(unlist(lapply(ret, force_paginate)))+ label_pos = "hidden", |
|||
| 769 | +873 |
- }+ section_div = NA_character_) {
|
||
| 770 | -106x | +874 | +2x |
- chunks <- list()+ split_rows_by_cutfun( |
| 771 | -106x | +875 | +2x |
- kinds <- seq_along(force_pag)+ lyt = lyt, |
| 772 | -106x | +876 | +2x |
- while (length(kinds) > 0) {
+ var = var, |
| 773 | -106x | +877 | +2x |
- if (force_pag[kinds[1]]) {
+ split_label = split_label, |
| 774 | -! | +|||
| 878 | +2x |
- outertbl <- copy_title_footer(+ format = format, |
||
| 775 | -! | +|||
| 879 | +2x |
- tree_children(tt)[[kinds[1]]],+ na_str = na_str, |
||
| 776 | -! | +|||
| 880 | +2x |
- tt,+ cutfun = qtile_cuts, |
||
| 777 | -! | +|||
| 881 | +2x |
- NULL+ cutlabelfun = function(x) {
|
||
| 778 | -+ | |||
| 882 | +2x |
- )+ c( |
||
| 779 | -+ | |||
| 883 | +2x |
-
+ "[min, Q1]", |
||
| 780 | -! | +|||
| 884 | +2x |
- chunks <- c(chunks, force_paginate(outertbl))+ "(Q1, Q2]", |
||
| 781 | -! | +|||
| 885 | +2x |
- kinds <- kinds[-1]+ "(Q2, Q3]", |
||
| 782 | -+ | |||
| 886 | +2x |
- } else {
+ "(Q3, max]" |
||
| 783 | -106x | +|||
| 887 | +
- tmptbl <- tt+ ) |
|||
| 784 | -106x | +|||
| 888 | +
- runend <- min(which(force_pag[kinds]), length(kinds))+ }, |
|||
| 785 | -106x | +889 | +2x |
- useinds <- 1:runend+ nested = nested, |
| 786 | -106x | +890 | +2x |
- tree_children(tmptbl) <- tree_children(tt)[useinds]+ child_labels = child_labels, |
| 787 | -106x | +891 | +2x |
- chunks <- c(chunks, tmptbl)+ extra_args = extra_args, |
| 788 | -106x | +892 | +2x |
- kinds <- kinds[-useinds]+ cumulative = cumulative, |
| 789 | -+ | |||
| 893 | +2x |
- }+ indent_mod = indent_mod, |
||
| 790 | -+ | |||
| 894 | +2x |
- }+ label_pos = label_pos, |
||
| 791 | -106x | +895 | +2x |
- unlist(chunks, recursive = TRUE)+ section_div = section_div |
| 792 | +896 |
- }+ ) |
||
| 793 | +897 | |||
| 794 | +898 |
- #' @importFrom formatters do_forced_paginate+ ## label_pos <- match.arg(label_pos, label_pos_values) |
||
| 795 | +899 |
- setMethod(+ ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, |
||
| 796 | +900 |
- "do_forced_paginate", "VTableTree",- |
- ||
| 797 | -96x | -
- function(obj) force_paginate(obj)+ ## cutlabelfun = , |
||
| 798 | +901 |
- )+ ## split_format = format, |
||
| 799 | +902 | - - | -||
| 800 | -190x | -
- non_null_na <- function(x) !is.null(x) && is.na(x)+ ## child_labels = child_labels, |
||
| 801 | +903 |
-
+ ## extra_args = extra_args, |
||
| 802 | +904 |
- #' @inheritParams formatters::vert_pag_indices+ ## cumulative = cumulative, |
||
| 803 | +905 |
- #' @inheritParams formatters::page_lcpp+ ## indent_mod = indent_mod, |
||
| 804 | +906 |
- #' @inheritParams formatters::toString+ ## label_pos = label_pos) |
||
| 805 | +907 |
- #' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination.+ ## pos = next_rpos(lyt, nested) |
||
| 806 | +908 |
- #' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal+ ## split_rows(lyt, spl, pos) |
||
| 807 | +909 |
- #' pagination should be done regardless of page size.+ } |
||
| 808 | +910 |
- #'+ |
||
| 809 | +911 |
- #' @rdname paginate+ qtile_cuts <- function(x) {
|
||
| 810 | -+ | |||
| 912 | +6x |
- #' @aliases paginate_table+ ret <- quantile(x) |
||
| 811 | -+ | |||
| 913 | +6x |
- #' @export+ names(ret) <- c( |
||
| 812 | +914 |
- paginate_table <- function(tt,+ "", |
||
| 813 | -+ | |||
| 915 | +6x |
- page_type = "letter",+ "1st qrtile", |
||
| 814 | -+ | |||
| 916 | +6x |
- font_family = "Courier",+ "2nd qrtile", |
||
| 815 | -+ | |||
| 917 | +6x |
- font_size = 8,+ "3rd qrtile", |
||
| 816 | -+ | |||
| 918 | +6x |
- lineheight = 1,+ "4th qrtile" |
||
| 817 | +919 |
- landscape = FALSE,+ ) |
||
| 818 | -+ | |||
| 920 | +6x |
- pg_width = NULL,+ ret |
||
| 819 | +921 |
- pg_height = NULL,+ } |
||
| 820 | +922 |
- margins = c(top = .5, bottom = .5, left = .75, right = .75),+ |
||
| 821 | +923 |
- lpp = NA_integer_,+ #' @export |
||
| 822 | +924 |
- cpp = NA_integer_,+ #' @rdname varcuts |
||
| 823 | +925 |
- min_siblings = 2,+ split_rows_by_cutfun <- function(lyt, var, |
||
| 824 | +926 |
- nosplitin = character(),+ cutfun = qtile_cuts, |
||
| 825 | +927 |
- colwidths = NULL,+ cutlabelfun = function(x) NULL, |
||
| 826 | +928 |
- tf_wrap = FALSE,+ split_label = var, |
||
| 827 | +929 |
- max_width = NULL,+ format = NULL, |
||
| 828 | +930 |
- fontspec = font_spec(font_family, font_size, lineheight),+ na_str = NA_character_, |
||
| 829 | +931 |
- col_gap = 3,+ nested = TRUE, |
||
| 830 | +932 |
- verbose = FALSE) {
+ child_labels = c("default", "visible", "hidden"),
|
||
| 831 | -52x | +|||
| 933 | +
- new_dev <- open_font_dev(fontspec)+ extra_args = list(), |
|||
| 832 | -52x | +|||
| 934 | +
- if (new_dev) {
+ cumulative = FALSE, |
|||
| 833 | -39x | +|||
| 935 | +
- on.exit(close_font_dev())+ indent_mod = 0L, |
|||
| 834 | +936 |
- }+ label_pos = "hidden", |
||
| 835 | +937 |
-
+ section_div = NA_character_) {
|
||
| 836 | -52x | +938 | +2x |
- if ((non_null_na(lpp) || non_null_na(cpp)) &&+ label_pos <- match.arg(label_pos, label_pos_values) |
| 837 | -52x | +939 | +2x |
- (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
+ child_labels <- match.arg(child_labels) |
| 838 | -12x | +940 | +2x |
- pg_lcpp <- page_lcpp(+ spl <- VarDynCutSplit(var, split_label, |
| 839 | -12x | +941 | +2x |
- page_type = page_type,+ cutfun = cutfun, |
| 840 | -12x | +942 | +2x |
- font_family = font_family,+ cutlabelfun = cutlabelfun, |
| 841 | -12x | +943 | +2x |
- font_size = font_size,+ split_format = format, |
| 842 | -12x | +944 | +2x |
- lineheight = lineheight,+ split_na_str = na_str, |
| 843 | -12x | +945 | +2x |
- pg_width = pg_width,+ child_labels = child_labels, |
| 844 | -12x | +946 | +2x |
- pg_height = pg_height,+ extra_args = extra_args, |
| 845 | -12x | +947 | +2x |
- margins = margins,+ cumulative = cumulative, |
| 846 | -12x | +948 | +2x |
- landscape = landscape,+ indent_mod = indent_mod, |
| 847 | -12x | +949 | +2x |
- fontspec = fontspec+ label_pos = label_pos, |
| 848 | -+ | |||
| 950 | +2x |
- )+ section_div = section_div |
||
| 849 | +951 |
-
+ ) |
||
| 850 | -12x | +952 | +2x |
- if (non_null_na(lpp)) {
+ pos <- next_rpos(lyt, nested) |
| 851 | -6x | +953 | +2x |
- lpp <- pg_lcpp$lpp+ split_rows(lyt, spl, pos) |
| 852 | +954 |
- }+ } |
||
| 853 | -12x | +|||
| 955 | +
- if (is.na(cpp)) {
+
|
|||
| 854 | -8x | +|||
| 956 | +
- cpp <- pg_lcpp$cpp+ #' .spl_context within analysis and split functions |
|||
| 855 | +957 |
- }+ #' |
||
| 856 | +958 |
- } else {
+ #' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function |
||
| 857 | -40x | +|||
| 959 | +
- if (non_null_na(cpp)) {
+ #' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for |
|||
| 858 | -! | +|||
| 960 | +
- cpp <- NULL+ #' [split_rows_by()]). |
|||
| 859 | +961 |
- }+ #' |
||
| 860 | -40x | +|||
| 962 | +
- if (non_null_na(lpp)) {
+ #' @details |
|||
| 861 | -! | +|||
| 963 | +
- lpp <- 70+ #' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within |
|||
| 862 | +964 |
- }+ #' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set |
||
| 863 | +965 |
- }+ #' of) rows the analysis function is creating, although the information is in a slightly different form. Each split |
||
| 864 | +966 | - - | -||
| 865 | -52x | -
- if (is.null(colwidths)) {
- |
- ||
| 866 | -35x | -
- colwidths <- propose_column_widths(- |
- ||
| 867 | -35x | -
- matrix_form(- |
- ||
| 868 | -35x | -
- tt,- |
- ||
| 869 | -35x | -
- indent_rownames = TRUE,- |
- ||
| 870 | -35x | -
- fontspec = fontspec,- |
- ||
| 871 | -35x | -
- col_gap = col_gap+ #' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented |
||
| 872 | +967 |
- ),- |
- ||
| 873 | -35x | -
- fontspec = fontspec+ #' via the following columns: |
||
| 874 | +968 |
- )+ #' |
||
| 875 | +969 |
- }+ #' \describe{
|
||
| 876 | +970 | - - | -||
| 877 | -52x | -
- if (!tf_wrap) {
- |
- ||
| 878 | -42x | -
- if (!is.null(max_width)) {
- |
- ||
| 879 | -! | -
- warning("tf_wrap is FALSE - ignoring non-null max_width value.")
+ #' \item{split}{The name of the split (often the variable being split).}
|
||
| 880 | +971 |
- }- |
- ||
| 881 | -42x | -
- max_width <- NULL- |
- ||
| 882 | -10x | -
- } else if (is.null(max_width)) {
- |
- ||
| 883 | -5x | -
- max_width <- cpp- |
- ||
| 884 | -5x | -
- } else if (identical(max_width, "auto")) {
+ #' \item{value}{The string representation of the value at that split (`split`).}
|
||
| 885 | +972 |
- ## XXX this 3 is column sep width!!!!!!!- |
- ||
| 886 | -! | -
- max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1)+ #' \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
|
||
| 887 | +973 |
- }- |
- ||
| 888 | -52x | -
- if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
- |
- ||
| 889 | -! | -
- warning("max_width specified is wider than characters per page width (cpp).")
+ #' defined by the combination of `split` and `value` of this row *and all rows above this row*.} |
||
| 890 | +974 |
- }+ #' \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
|
||
| 891 | +975 |
-
+ #' \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
|
||
| 892 | +976 |
- ## taken care of in vert_pag_indices now+ #' (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's |
||
| 893 | +977 |
- ## if(!is.null(cpp))+ #' `full_parent_df` corresponding to the column.} |
||
| 894 | +978 |
- ## cpp <- cpp - table_inset(tt)+ #' \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
|
||
| 895 | +979 | - - | -||
| 896 | -52x | -
- force_pag <- vapply(tree_children(tt), has_force_pag, TRUE)+ #' column path together.} |
||
| 897 | -52x | +|||
| 980 | +
- if (has_force_pag(tt) || any(force_pag)) {
+ #' \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
|
|||
| 898 | -5x | +|||
| 981 | +
- spltabs <- do_forced_paginate(tt)+ #' for the column currently being created by the analysis function.} |
|||
| 899 | -5x | +|||
| 982 | +
- spltabs <- unlist(spltabs, recursive = TRUE)+ #' \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
|
|||
| 900 | -5x | +|||
| 983 | +
- ret <- lapply(spltabs, paginate_table,+ #' data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.} |
|||
| 901 | -5x | +|||
| 984 | +
- lpp = lpp,+ #' \item{cur_col_n}{Integer column containing the observation counts for that split.}
|
|||
| 902 | -5x | +|||
| 985 | +
- cpp = cpp,+ #' \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
|
|||
| 903 | -5x | +|||
| 986 | +
- min_siblings = min_siblings,+ #' \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
|
|||
| 904 | -5x | +|||
| 987 | +
- nosplitin = nosplitin,+ #' } |
|||
| 905 | -5x | +|||
| 988 | +
- colwidths = colwidths,+ #' |
|||
| 906 | -5x | +|||
| 989 | +
- tf_wrap = tf_wrap,+ #' @note |
|||
| 907 | -5x | +|||
| 990 | +
- max_width = max_width,+ #' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame |
|||
| 908 | -5x | +|||
| 991 | +
- fontspec = fontspec,+ #' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the |
|||
| 909 | -5x | +|||
| 992 | +
- verbose = verbose,+ #' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the |
|||
| 910 | -5x | +|||
| 993 | +
- col_gap = col_gap+ #' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()]. |
|||
| 911 | +994 |
- )+ #' |
||
| 912 | -5x | +|||
| 995 | +
- return(unlist(ret, recursive = TRUE))+ #' @name spl_context |
|||
| 913 | +996 |
- }+ NULL |
||
| 914 | +997 | |||
| 915 | -47x | -
- inds <- paginate_indices(tt,- |
- ||
| 916 | -47x | -
- page_type = page_type,- |
- ||
| 917 | -47x | -
- fontspec = fontspec,- |
- ||
| 918 | +998 |
- ## font_family = font_family,+ #' Additional parameters within analysis and content functions (`afun`/`cfun`) |
||
| 919 | +999 |
- ## font_size = font_size,+ #' |
||
| 920 | +1000 |
- ## lineheight = lineheight,- |
- ||
| 921 | -47x | -
- landscape = landscape,- |
- ||
| 922 | -47x | -
- pg_width = pg_width,+ #' @description |
||
| 923 | -47x | +|||
| 1001 | +
- pg_height = pg_height,+ #' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()], |
|||
| 924 | -47x | +|||
| 1002 | +
- margins = margins,+ #' respectively. These parameters grant access to relevant information like the row split structure (see |
|||
| 925 | -47x | +|||
| 1003 | +
- lpp = lpp,+ #' [spl_context]) and the predefined baseline (`.ref_group`). |
|||
| 926 | -47x | +|||
| 1004 | +
- cpp = cpp,+ #' |
|||
| 927 | -47x | +|||
| 1005 | +
- min_siblings = min_siblings,+ #' @details |
|||
| 928 | -47x | +|||
| 1006 | +
- nosplitin = nosplitin,+ #' We list and describe all the parameters that can be added to a custom analysis function below: |
|||
| 929 | -47x | +|||
| 1007 | +
- colwidths = colwidths,+ #' |
|||
| 930 | -47x | +|||
| 1008 | +
- tf_wrap = tf_wrap,+ #' \describe{
|
|||
| 931 | -47x | +|||
| 1009 | +
- max_width = max_width,+ #' \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
|
|||
| 932 | -47x | +|||
| 1010 | +
- col_gap = col_gap,+ #' \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
|
|||
| 933 | -47x | +|||
| 1011 | +
- verbose = verbose+ #' \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
|
|||
| 934 | -47x | +|||
| 1012 | +
- ) ## paginate_table apparently doesn't accept indent_size+ #' column-based subsetting).} |
|||
| 935 | +1013 |
-
+ #' \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
|
||
| 936 | -42x | +|||
| 1014 | +
- res <- lapply(+ #' subsetting).} |
|||
| 937 | -42x | +|||
| 1015 | +
- inds$pag_row_indices,+ #' \item{.var}{Variable being analyzed.}
|
|||
| 938 | -42x | +|||
| 1016 | +
- function(ii) {
+ #' \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
|
|||
| 939 | -117x | +|||
| 1017 | +
- subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]+ #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.} |
|||
| 940 | -117x | +|||
| 1018 | +
- lapply(+ #' \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
|
|||
| 941 | -117x | +|||
| 1019 | +
- inds$pag_col_indices,+ #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.} |
|||
| 942 | -117x | +|||
| 1020 | +
- function(jj) {
+ #' \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
|
|||
| 943 | -216x | +|||
| 1021 | +
- subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]+ #' \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
|
|||
| 944 | +1022 |
- }+ #' See [spl_context].} |
||
| 945 | +1023 |
- )+ #' \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with
|
||
| 946 | +1024 |
- }+ #' `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`. |
||
| 947 | +1025 |
- )+ #' It can be an empty table if all the entries are filtered out.} |
||
| 948 | -42x | +|||
| 1026 | +
- res <- unlist(res, recursive = FALSE)+ #' \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
|
|||
| 949 | -42x | +|||
| 1027 | +
- res+ #' faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs` |
|||
| 950 | +1028 |
- }+ #' in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.} |
| 1 | +1029 |
- #' @importFrom tools file_ext+ #' \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
|
||
| 2 | +1030 |
- NULL+ #' \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
|
||
| 3 | +1031 |
-
+ #' if `alt_counts_df` is used (see [build_table()]).} |
||
| 4 | +1032 |
- #' Create enriched flat value table with paths+ #' } |
||
| 5 | +1033 |
#' |
||
| 6 | +1034 |
- #' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then+ #' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be |
||
| 7 | +1035 |
- #' writes that data frame out as a `tsv` file.+ #' treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during |
||
| 8 | +1036 |
- #'+ #' data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is |
||
| 9 | +1037 |
- #' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are+ #' provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present. |
||
| 10 | +1038 |
- #' collapsed to character vectors by collapsing the list element with `"|"`.+ #' |
||
| 11 | +1039 |
- #'+ #' @name additional_fun_params |
||
| 12 | +1040 |
- #' @note+ NULL |
||
| 13 | +1041 |
- #' There is currently no round-trip capability for this type of export. You can read values exported this way back in+ |
||
| 14 | +1042 |
- #' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`.+ #' Generate rows analyzing variables across columns |
||
| 15 | +1043 |
#' |
||
| 16 | +1044 |
- #' @inheritParams gen_args+ #' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by |
||
| 17 | +1045 |
- #' @inheritParams data.frame_export+ #' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting, |
||
| 18 | +1046 |
- #' @param file (`string`)\cr the path of the file to written to or read from.+ #' the tabulation will occur at the current/next level of nesting by default. |
||
| 19 | +1047 |
#' |
||
| 20 | +1048 |
- #' @return+ #' @inheritParams lyt_args |
||
| 21 | +1049 |
- #' * `export_as_tsv` returns `NULL` silently.+ #' |
||
| 22 | +1050 |
- #' * `import_from_tsv` returns a `data.frame` with re-constituted list values.+ #' @inherit split_cols_by return |
||
| 23 | +1051 |
#' |
||
| 24 | +1052 |
- #' @seealso [path_enriched_df()] for the underlying function that does the work.+ #' @details |
||
| 25 | +1053 |
- #'+ #' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a |
||
| 26 | +1054 |
- #' @importFrom utils write.table read.table+ #' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the |
||
| 27 | +1055 |
- #' @rdname tsv_io+ #' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`. |
||
| 28 | +1056 |
- #' @export+ #' |
||
| 29 | +1057 |
- export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,+ #' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the |
||
| 30 | +1058 |
- value_fun = collapse_values) {
- |
- ||
| 31 | -1x | -
- df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)- |
- ||
| 32 | -1x | -
- write.table(df, file, sep = "\t")+ #' function accepts will change the behavior when tabulation is performed as follows: |
||
| 33 | +1059 |
- }+ #' |
||
| 34 | +1060 |
-
+ #' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant |
||
| 35 | +1061 |
- #' @rdname tsv_io+ #' column (from `var` here) of the raw data being used to build the table. |
||
| 36 | +1062 |
- #' @export+ #' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of |
||
| 37 | +1063 |
- import_from_tsv <- function(file) {
- |
- ||
| 38 | -1x | -
- rawdf <- read.table(file, header = TRUE, sep = "\t")- |
- ||
| 39 | -1x | -
- as.data.frame(lapply(- |
- ||
| 40 | -1x | -
- rawdf,- |
- ||
| 41 | -1x | -
- function(col) {
- |
- ||
| 42 | -7x | -
- if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
- |
- ||
| 43 | -! | -
- col+ #' the raw data being tabulated. |
||
| 44 | +1064 |
- } else {
- |
- ||
| 45 | -7x | -
- I(strsplit(col, split = .collapse_char_esc))+ #' |
||
| 46 | +1065 |
- }+ #' In addition to differentiation on the first argument, the analysis function can optionally accept a number of |
||
| 47 | +1066 |
- }+ #' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation |
||
| 48 | +1067 |
- ))+ #' machinery. These are listed and described in [additional_fun_params]. |
||
| 49 | +1068 |
- }+ #' |
||
| 50 | +1069 |
-
+ #' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling |
||
| 51 | +1070 |
- ### Migrated to formatters ----+ #' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()]. |
||
| 52 | +1071 |
-
+ #' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and |
||
| 53 | +1072 |
- #' @importFrom formatters export_as_txt+ #' the unmodified values provided by the tabulation framework. |
||
| 54 | +1073 |
#' |
||
| 55 | +1074 |
#' @examples |
||
| 56 | +1075 |
#' lyt <- basic_table() %>% |
||
| 57 | +1076 |
#' split_cols_by("ARM") %>%
|
||
| 58 | +1077 |
- #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
|
||
| 59 | +1078 |
- #'+ #' lyt |
||
| 60 | +1079 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' |
||
| 61 | +1080 |
- #'+ #' tbl <- build_table(lyt, DM) |
||
| 62 | +1081 |
- #' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8))+ #' tbl |
||
| 63 | +1082 |
#' |
||
| 64 | +1083 |
- #' \dontrun{
+ #' lyt2 <- basic_table() %>% |
||
| 65 | +1084 |
- #' tf <- tempfile(fileext = ".txt")+ #' split_cols_by("Species") %>%
|
||
| 66 | +1085 |
- #' export_as_txt(tbl, file = tf)+ #' analyze(head(names(iris), -1), afun = function(x) {
|
||
| 67 | +1086 |
- #' system2("cat", tf)
+ #' list( |
||
| 68 | +1087 |
- #' }+ #' "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
||
| 69 | +1088 |
- #'+ #' "range" = rcell(diff(range(x)), format = "xx.xx") |
||
| 70 | +1089 |
- #' @export+ #' ) |
||
| 71 | +1090 |
- formatters::export_as_txt+ #' }) |
||
| 72 | +1091 |
-
+ #' lyt2 |
||
| 73 | +1092 |
- # data.frame output ------------------------------------------------------------+ #' |
||
| 74 | +1093 |
-
+ #' tbl2 <- build_table(lyt2, iris) |
||
| 75 | +1094 |
- #' Generate a result data frame+ #' tbl2 |
||
| 76 | +1095 |
#' |
||
| 77 | +1096 |
- #' Collection of utilities to extract `data.frame` objects from `TableTree` objects.+ #' @author Gabriel Becker |
||
| 78 | +1097 |
- #'+ #' @export |
||
| 79 | +1098 |
- #' @inheritParams gen_args+ analyze <- function(lyt, |
||
| 80 | +1099 |
- #' @param spec (`string`)\cr the specification to use to extract the result data frame. See Details below.+ vars, |
||
| 81 | +1100 |
- #' @param simplify (`flag`)\cr whether the result data frame should only have labels and result columns visible.+ afun = simple_analysis, |
||
| 82 | +1101 |
- #' @param ... additional arguments passed to spec-specific result data frame conversion function. Currently it can be+ var_labels = vars, |
||
| 83 | +1102 |
- #' one or more of the following parameters (valid only for `v0_experimental` spec. for now):+ table_names = vars, |
||
| 84 | +1103 |
- #' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual+ format = NULL, |
||
| 85 | +1104 |
- #' output. This is useful when the result data frame is used for further processing.+ na_str = NA_character_, |
||
| 86 | +1105 |
- #' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns.+ nested = TRUE, |
||
| 87 | +1106 |
- #' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear+ ## can't name this na_rm symbol conflict with possible afuns!! |
||
| 88 | +1107 |
- #' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for+ inclNAs = FALSE, |
||
| 89 | +1108 |
- #' column counts if `expand_colnames = TRUE`.+ extra_args = list(), |
||
| 90 | +1109 |
- #' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table,+ show_labels = c("default", "visible", "hidden"),
|
||
| 91 | +1110 |
- #' i.e. with the same precision and numbers, but in easy-to-use numeric form.+ indent_mod = 0L, |
||
| 92 | +1111 |
- #' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the+ section_div = NA_character_) {
|
||
| 93 | -+ | |||
| 1112 | +309x |
- #' final table.+ show_labels <- match.arg(show_labels) |
||
| 94 | -+ | |||
| 1113 | +309x |
- #' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table,+ subafun <- substitute(afun) |
||
| 95 | +1114 |
- #' but without information about the row structure. Row labels will be assigned to rows so to work well+ if ( |
||
| 96 | -+ | |||
| 1115 | +309x |
- #' with [df_to_tt()].+ is.name(subafun) && |
||
| 97 | -+ | |||
| 1116 | +309x |
- #'+ is.function(afun) && |
||
| 98 | +1117 |
- #' @details `as_result_df()`: Result data frame specifications may differ in the exact information+ ## this is gross. basically testing |
||
| 99 | +1118 |
- #' they include and the form in which they represent it. Specifications whose names end in "_experimental"+ ## if the symbol we have corresponds |
||
| 100 | +1119 |
- #' are subject to change without notice, but specifications without the "_experimental"+ ## in some meaningful way to the function |
||
| 101 | +1120 |
- #' suffix will remain available *including any bugs in their construction* indefinitely.+ ## we will be calling. |
||
| 102 | -+ | |||
| 1121 | +309x |
- #'+ identical( |
||
| 103 | -+ | |||
| 1122 | +309x |
- #' @return+ mget( |
||
| 104 | -- |
- #' * `as_result_df` returns a result `data.frame`.+ | ||
| 1123 | +309x | +
+ as.character(subafun), |
||
| 105 | -+ | |||
| 1124 | +309x |
- #'+ mode = "function", |
||
| 106 | -+ | |||
| 1125 | +309x |
- #' @seealso [df_to_tt()] when using `as_is = TRUE` and [make_row_df()] to have a comprehensive view of the+ ifnotfound = list(NULL), |
||
| 107 | -+ | |||
| 1126 | +309x |
- #' hierarchical structure of the rows.+ inherits = TRUE |
||
| 108 | -+ | |||
| 1127 | +309x |
- #'+ )[[1]], afun |
||
| 109 | +1128 |
- #' @examples+ ) |
||
| 110 | +1129 |
- #' lyt <- basic_table() %>%+ ) {
|
||
| 111 | -+ | |||
| 1130 | +175x |
- #' split_cols_by("ARM") %>%
+ defrowlab <- as.character(subafun) |
||
| 112 | +1131 |
- #' split_rows_by("STRATA1") %>%
+ } else {
|
||
| 113 | -+ | |||
| 1132 | +134x |
- #' analyze(c("AGE", "BMRKR2"))
+ defrowlab <- var_labels |
||
| 114 | +1133 |
- #'+ } |
||
| 115 | +1134 |
- #' tbl <- build_table(lyt, ex_adsl)+ |
||
| 116 | -+ | |||
| 1135 | +309x |
- #' as_result_df(tbl)+ spl <- AnalyzeMultiVars(vars, var_labels, |
||
| 117 | -+ | |||
| 1136 | +309x |
- #'+ afun = afun, |
||
| 118 | -+ | |||
| 1137 | +309x |
- #' @name data.frame_export+ split_format = format, |
||
| 119 | -+ | |||
| 1138 | +309x |
- #' @export+ split_na_str = na_str, |
||
| 120 | -+ | |||
| 1139 | +309x |
- as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) {
+ defrowlab = defrowlab, |
||
| 121 | -24x | +1140 | +309x |
- checkmate::assert_class(tt, "VTableTree")+ inclNAs = inclNAs, |
| 122 | -24x | +1141 | +309x |
- checkmate::assert_string(spec)+ extra_args = extra_args, |
| 123 | -24x | +1142 | +309x |
- checkmate::assert_flag(simplify)+ indent_mod = indent_mod, |
| 124 | -+ | |||
| 1143 | +309x |
-
+ child_names = table_names, |
||
| 125 | -24x | +1144 | +309x |
- if (nrow(tt) == 0) {
+ child_labels = show_labels, |
| 126 | -2x | +1145 | +309x |
- return(sanitize_table_struct(tt))+ section_div = section_div |
| 127 | +1146 |
- }+ ) |
||
| 128 | +1147 | |||
| 129 | -22x | +1148 | +309x |
- result_df_fun <- lookup_result_df_specfun(spec)+ if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
|
| 130 | -22x | +1149 | +27x |
- out <- result_df_fun(tt, ...)+ cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars) |
| 131 | +1150 |
-
+ } else {
|
||
| 132 | -22x | +|||
| 1151 | +
- if (simplify) {
+ ## analysis compounding now done in split_rows |
|||
| 133 | -4x | +1152 | +280x |
- out <- .simplify_result_df(out)+ pos <- next_rpos(lyt, nested) |
| 134 | -+ | |||
| 1153 | +280x |
- }+ split_rows(lyt, spl, pos) |
||
| 135 | +1154 | - - | -||
| 136 | -22x | -
- out+ } |
||
| 137 | +1155 |
} |
||
| 138 | +1156 | |||
| 139 | +1157 |
- # Function that selects specific outputs from the result data frame+ get_acolvar_name <- function(lyt) {
|
||
| 140 | +1158 |
- .simplify_result_df <- function(df) {
+ ## clyt <- clayout(lyt) |
||
| 141 | -4x | +|||
| 1159 | +
- col_df <- colnames(df)+ ## stopifnot(length(clyt) == 1L) |
|||
| 142 | -4x | +|||
| 1160 | +
- row_names_col <- which(col_df == "row_name")+ ## vec = clyt[[1]] |
|||
| 143 | -4x | +|||
| 1161 | +
- result_cols <- seq(which(col_df == "node_class") + 1, length(col_df))+ ## vcls = vapply(vec, class, "") |
|||
| 144 | +1162 |
-
+ ## pos = max(which(vcls == "MultiVarSplit")) |
||
| 145 | -4x | +1163 | +22x |
- df[, c(row_names_col, result_cols)]+ paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
|
| 146 | +1164 |
} |
||
| 147 | +1165 | |||
| 148 | +1166 |
- # Not used in rtables+ get_acolvar_vars <- function(lyt) {
+ |
+ ||
| 1167 | +35x | +
+ clyt <- clayout(lyt)+ |
+ ||
| 1168 | +35x | +
+ stopifnot(length(clyt) == 1L)+ |
+ ||
| 1169 | +35x | +
+ vec <- clyt[[1]]+ |
+ ||
| 1170 | +35x | +
+ vcls <- vapply(vec, class, "")+ |
+ ||
| 1171 | +35x | +
+ pos <- which(vcls == "MultiVarSplit")+ |
+ ||
| 1172 | +35x | +
+ if (length(pos) > 0) {
+ |
+ ||
| 1173 | +35x | +
+ spl_payload(vec[[pos]]) |
||
| 149 | +1174 |
- # .split_colwidths <- function(ptabs, nctot, colwidths) {
+ } else {
+ |
+ ||
| 1175 | +! | +
+ "non_multivar" |
||
| 150 | +1176 |
- # ret <- list()+ } |
||
| 151 | +1177 |
- # i <- 1L+ } |
||
| 152 | +1178 |
- #+ |
||
| 153 | +1179 |
- # rlw <- colwidths[1]+ #' Generate rows analyzing different variables across columns |
||
| 154 | +1180 |
- # colwidths <- colwidths[-1]+ #' |
||
| 155 | +1181 |
- # donenc <- 0+ #' @inheritParams lyt_args |
||
| 156 | +1182 |
- # while (donenc < nctot) {
+ #' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list |
||
| 157 | +1183 |
- # curnc <- NCOL(ptabs[[i]])+ #' will be repped out as needed and matched by position with the columns during tabulation. This functions |
||
| 158 | +1184 |
- # ret[[i]] <- c(rlw, colwidths[seq_len(curnc)])+ #' accepts the same parameters as [analyze()] like `afun` and `format`. For further information see |
||
| 159 | +1185 |
- # colwidths <- colwidths[-1 * seq_len(curnc)]+ #' [additional_fun_params]. |
||
| 160 | +1186 |
- # donenc <- donenc + curnc+ #' |
||
| 161 | +1187 |
- # i <- i + 1+ #' @inherit split_cols_by return |
||
| 162 | +1188 |
- # }+ #' |
||
| 163 | +1189 |
- # ret+ #' @seealso [split_cols_by_multivar()] |
||
| 164 | +1190 |
- # }+ #' |
||
| 165 | +1191 |
-
+ #' @examples |
||
| 166 | +1192 |
- #' @describeIn data.frame_export A list of functions that extract result data frames from `TableTree`s.+ #' library(dplyr) |
||
| 167 | +1193 |
#' |
||
| 168 | +1194 |
- #' @return+ #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n())) |
||
| 169 | +1195 |
- #' * `result_df_specs()` returns a named list of result data frame extraction functions by "specification".+ #' |
||
| 170 | +1196 |
- #'+ #' ## toy example where we take the mean of the first variable and the |
||
| 171 | +1197 |
- #' @examples+ #' ## count of >.5 for the second. |
||
| 172 | +1198 |
- #' result_df_specs()+ #' colfuns <- list( |
||
| 173 | +1199 |
- #'+ #' function(x) rcell(mean(x), format = "xx.x"), |
||
| 174 | +1200 |
- #' @export+ #' function(x) rcell(sum(x > .5), format = "xx") |
||
| 175 | +1201 |
- result_df_specs <- function() {
+ #' ) |
||
| 176 | -44x | +|||
| 1202 | +
- list(v0_experimental = result_df_v0_experimental)+ #' |
|||
| 177 | +1203 |
- }+ #' lyt <- basic_table() %>% |
||
| 178 | +1204 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 179 | +1205 |
- lookup_result_df_specfun <- function(spec) {
+ #' split_cols_by_multivar(c("value", "pctdiff")) %>%
|
||
| 180 | -22x | +|||
| 1206 | +
- if (!(spec %in% names(result_df_specs()))) {
+ #' split_rows_by("RACE",
|
|||
| 181 | -! | +|||
| 1207 | +
- stop(+ #' split_label = "ethnicity", |
|||
| 182 | -! | +|||
| 1208 | +
- "unrecognized result data frame specification: ",+ #' split_fun = drop_split_levels |
|||
| 183 | -! | +|||
| 1209 | +
- spec,+ #' ) %>% |
|||
| 184 | -! | +|||
| 1210 | +
- "If that specification is correct you may need to update your version of rtables"+ #' summarize_row_groups() %>% |
|||
| 185 | +1211 |
- )+ #' analyze_colvars(afun = colfuns) |
||
| 186 | +1212 |
- }+ #' lyt |
||
| 187 | -22x | +|||
| 1213 | +
- result_df_specs()[[spec]]+ #' |
|||
| 188 | +1214 |
- }+ #' tbl <- build_table(lyt, ANL) |
||
| 189 | +1215 |
-
+ #' tbl |
||
| 190 | +1216 |
- result_df_v0_experimental <- function(tt,+ #' |
||
| 191 | +1217 |
- as_viewer = FALSE,+ #' lyt2 <- basic_table() %>% |
||
| 192 | +1218 |
- as_strings = FALSE,+ #' split_cols_by("ARM") %>%
|
||
| 193 | +1219 |
- expand_colnames = FALSE,+ #' split_cols_by_multivar(c("value", "pctdiff"),
|
||
| 194 | +1220 |
- keep_label_rows = FALSE,+ #' varlabels = c("Measurement", "Pct Diff")
|
||
| 195 | +1221 |
- as_is = FALSE) {
+ #' ) %>% |
||
| 196 | -22x | +|||
| 1222 | +
- checkmate::assert_flag(as_viewer)+ #' split_rows_by("RACE",
|
|||
| 197 | -22x | +|||
| 1223 | +
- checkmate::assert_flag(as_strings)+ #' split_label = "ethnicity", |
|||
| 198 | -22x | +|||
| 1224 | +
- checkmate::assert_flag(expand_colnames)+ #' split_fun = drop_split_levels |
|||
| 199 | -22x | +|||
| 1225 | +
- checkmate::assert_flag(keep_label_rows)+ #' ) %>% |
|||
| 200 | -22x | +|||
| 1226 | +
- checkmate::assert_flag(as_is)+ #' summarize_row_groups() %>% |
|||
| 201 | +1227 |
-
+ #' analyze_colvars(afun = mean, format = "xx.xx") |
||
| 202 | -22x | +|||
| 1228 | +
- if (as_is) {
+ #' |
|||
| 203 | -2x | +|||
| 1229 | +
- keep_label_rows <- TRUE+ #' tbl2 <- build_table(lyt2, ANL) |
|||
| 204 | -2x | +|||
| 1230 | +
- expand_colnames <- FALSE+ #' tbl2 |
|||
| 205 | +1231 |
- }+ #' |
||
| 206 | +1232 |
-
+ #' @author Gabriel Becker |
||
| 207 | -22x | +|||
| 1233 | +
- raw_cvals <- cell_values(tt)+ #' @export |
|||
| 208 | +1234 |
- ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values+ analyze_colvars <- function(lyt, |
||
| 209 | +1235 |
- ## rather than a list of length 1 representing the single row. This is bad but may not be changeable+ afun, |
||
| 210 | +1236 |
- ## at this point.+ format = NULL, |
||
| 211 | -22x | +|||
| 1237 | +
- if (nrow(tt) == 1 && length(raw_cvals) > 1) {
+ na_str = NA_character_, |
|||
| 212 | -2x | +|||
| 1238 | +
- raw_cvals <- list(raw_cvals)+ nested = TRUE, |
|||
| 213 | +1239 |
- }+ extra_args = list(), |
||
| 214 | +1240 |
-
+ indent_mod = 0L, |
||
| 215 | +1241 |
- # Flatten the list of lists (rows) of cell values into a data frame+ inclNAs = FALSE) {
|
||
| 216 | +1242 | 22x |
- cellvals <- as.data.frame(do.call(rbind, raw_cvals))+ if (is.function(afun)) {
|
|
| 217 | -22x | +1243 | +13x |
- row.names(cellvals) <- NULL+ subafun <- substitute(afun) |
| 218 | +1244 |
-
+ if ( |
||
| 219 | -22x | +1245 | +13x |
- if (nrow(tt) == 1 && ncol(tt) == 1) {
+ is.name(subafun) && |
| 220 | -5x | +1246 | +13x |
- colnames(cellvals) <- names(raw_cvals)+ is.function(afun) && |
| 221 | +1247 |
- }+ ## this is gross. basically testing |
||
| 222 | +1248 |
-
+ ## if the symbol we have corresponds |
||
| 223 | -22x | +|||
| 1249 | +
- if (as_viewer || as_strings) {
+ ## in some meaningful way to the function |
|||
| 224 | +1250 |
- # we keep previous calculations to check the format of the data+ ## we will be calling. |
||
| 225 | -9x | +1251 | +13x |
- mf_tt <- matrix_form(tt)+ identical( |
| 226 | -9x | +1252 | +13x |
- mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1]+ mget( |
| 227 | -9x | +1253 | +13x |
- mf_result_chars <- .remove_empty_elements(mf_result_chars)+ as.character(subafun), |
| 228 | -9x | +1254 | +13x |
- mf_result_numeric <- as.data.frame(+ mode = "function", |
| 229 | -9x | +1255 | +13x |
- .make_numeric_char_mf(mf_result_chars)+ ifnotfound = list(NULL), |
| 230 | -+ | |||
| 1256 | +13x |
- )+ inherits = TRUE |
||
| 231 | -9x | +1257 | +13x |
- mf_result_chars <- as.data.frame(mf_result_chars)+ )[[1]], |
| 232 | -9x | +1258 | +13x |
- if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
+ afun |
| 233 | -! | +|||
| 1259 | +
- stop(+ ) |
|||
| 234 | -! | +|||
| 1260 | +
- "The extracted numeric data.frame does not have the same dimension of the",+ ) {
|
|||
| 235 | -! | +|||
| 1261 | +13x |
- " cell values extracted with cell_values(). This is a bug. Please report it."+ defrowlab <- as.character(subafun)+ |
+ ||
| 1262 | ++ |
+ } else {
|
||
| 236 | +1263 | ! |
- ) # nocov+ defrowlab <- "" |
|
| 237 | +1264 |
} |
||
| 238 | -9x | +1265 | +13x |
- if (as_strings) {
+ afun <- lapply( |
| 239 | -5x | +1266 | +13x |
- colnames(mf_result_chars) <- colnames(cellvals)+ get_acolvar_vars(lyt), |
| 240 | -5x | +1267 | +13x |
- cellvals <- mf_result_chars+ function(x) afun |
| 241 | +1268 |
- } else {
+ ) |
||
| 242 | -4x | +|||
| 1269 | +
- colnames(mf_result_numeric) <- colnames(cellvals)+ } else {
|
|||
| 243 | -4x | +1270 | +9x |
- cellvals <- mf_result_numeric+ defrowlab <- "" |
| 244 | +1271 |
- }+ } |
||
| 245 | -+ | |||
| 1272 | +22x |
- }+ spl <- AnalyzeColVarSplit( |
||
| 246 | -+ | |||
| 1273 | +22x |
-
+ afun = afun, |
||
| 247 | +1274 | 22x |
- rdf <- make_row_df(tt)+ defrowlab = defrowlab, |
|
| 248 | -+ | |||
| 1275 | +22x |
-
+ split_format = format, |
||
| 249 | +1276 | 22x |
- df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
+ split_na_str = na_str, |
|
| 250 | -+ | |||
| 1277 | +22x |
- # Removing initial root elements from path (out of the loop -> right maxlen)+ split_name = get_acolvar_name(lyt), |
||
| 251 | +1278 | 22x |
- df$path <- lapply(df$path, .remove_root_elems_from_path,+ indent_mod = indent_mod, |
|
| 252 | +1279 | 22x |
- which_root_name = c("root", "rbind_root"),
+ extra_args = extra_args, |
|
| 253 | +1280 | 22x |
- all = TRUE+ inclNAs = inclNAs |
|
| 254 | +1281 |
) |
||
| 255 | +1282 | 22x |
- maxlen <- max(lengths(df$path))+ pos <- next_rpos(lyt, nested, for_analyze = TRUE)+ |
+ |
| 1283 | +22x | +
+ split_rows(lyt, spl, pos) |
||
| 256 | +1284 |
-
+ } |
||
| 257 | +1285 |
- # Loop for metadata (path and details from make_row_df)+ |
||
| 258 | -22x | +|||
| 1286 | +
- metadf <- do.call(+ ## Add a total column at the next **top level** spot in |
|||
| 259 | -22x | +|||
| 1287 | +
- rbind.data.frame,+ ## the column layout. |
|||
| 260 | -22x | +|||
| 1288 | +
- lapply(+ |
|||
| 261 | -22x | +|||
| 1289 | +
- seq_len(NROW(df)),+ #' Add overall column |
|||
| 262 | -22x | +|||
| 1290 | +
- function(ii) {
+ #' |
|||
| 263 | -433x | +|||
| 1291 | +
- handle_rdf_row(df[ii, ], maxlen = maxlen)+ #' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits. |
|||
| 264 | +1292 |
- }+ #' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits. |
||
| 265 | +1293 |
- )+ #' |
||
| 266 | +1294 |
- )+ #' @inheritParams lyt_args |
||
| 267 | +1295 |
-
+ #' |
||
| 268 | +1296 |
- # Should we keep label rows with NAs instead of values?+ #' @inherit split_cols_by return |
||
| 269 | -22x | +|||
| 1297 | +
- if (keep_label_rows) {
+ #' |
|||
| 270 | -7x | +|||
| 1298 | +
- cellvals_mat_struct <- as.data.frame(+ #' @seealso [add_overall_level()] |
|||
| 271 | -7x | +|||
| 1299 | +
- matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals))+ #' |
|||
| 272 | +1300 |
- )+ #' @examples |
||
| 273 | -7x | +|||
| 1301 | +
- colnames(cellvals_mat_struct) <- colnames(cellvals)+ #' lyt <- basic_table() %>% |
|||
| 274 | -7x | +|||
| 1302 | +
- cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals+ #' split_cols_by("ARM") %>%
|
|||
| 275 | -7x | +|||
| 1303 | +
- ret <- cbind(metadf, cellvals_mat_struct)+ #' add_overall_col("All Patients") %>%
|
|||
| 276 | +1304 |
- } else {
+ #' analyze("AGE")
|
||
| 277 | -15x | +|||
| 1305 | +
- ret <- cbind(+ #' lyt |
|||
| 278 | -15x | +|||
| 1306 | +
- metadf[metadf$node_class != "LabelRow", ],+ #' |
|||
| 279 | -15x | +|||
| 1307 | +
- cellvals+ #' tbl <- build_table(lyt, DM) |
|||
| 280 | +1308 |
- )+ #' tbl |
||
| 281 | +1309 |
- }+ #' |
||
| 282 | +1310 |
-
+ #' @export |
||
| 283 | +1311 |
- # If we want to expand colnames+ add_overall_col <- function(lyt, label) {
|
||
| 284 | -22x | +1312 | +99x |
- if (expand_colnames) {
+ spl <- AllSplit(label) |
| 285 | -6x | +1313 | +99x |
- col_name_structure <- .get_formatted_colnames(clayout(tt))+ split_cols( |
| 286 | -6x | +1314 | +99x |
- number_of_non_data_cols <- which(colnames(ret) == "node_class")+ lyt, |
| 287 | -6x | +1315 | +99x |
- if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
+ spl, |
| 288 | -! | +|||
| 1316 | +99x |
- stop(+ next_cpos(lyt, FALSE) |
||
| 289 | -! | +|||
| 1317 | +
- "When expanding colnames structure, we were not able to find the same",+ ) |
|||
| 290 | -! | +|||
| 1318 | +
- " number of columns as in the result data frame. This is a bug. Please report it."+ } |
|||
| 291 | -! | +|||
| 1319 | +
- ) # nocov+ |
|||
| 292 | +1320 |
- }+ ## add_row_summary ==== |
||
| 293 | +1321 | |||
| 294 | -6x | +|||
| 1322 | +
- buffer_rows_for_colnames <- matrix(+ #' @inheritParams lyt_args |
|||
| 295 | -6x | +|||
| 1323 | +
- rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
+ #' |
|||
| 296 | -6x | +|||
| 1324 | +
- nrow = NROW(col_name_structure)+ #' @export |
|||
| 297 | +1325 |
- )+ #' |
||
| 298 | +1326 |
-
+ #' @rdname int_methods |
||
| 299 | -6x | +|||
| 1327 | +
- header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure))+ setGeneric( |
|||
| 300 | -6x | +|||
| 1328 | +
- colnames(header_colnames_matrix) <- colnames(ret)+ ".add_row_summary", |
|||
| 301 | +1329 |
-
+ function(lyt, |
||
| 302 | -6x | +|||
| 1330 | +
- count_row <- NULL+ label, |
|||
| 303 | -6x | +|||
| 1331 | +
- if (disp_ccounts(tt)) {
+ cfun, |
|||
| 304 | -3x | +|||
| 1332 | +
- ccounts <- col_counts(tt)+ child_labels = c("default", "visible", "hidden"),
|
|||
| 305 | -3x | +|||
| 1333 | +
- if (as_strings) {
+ cformat = NULL, |
|||
| 306 | -2x | +|||
| 1334 | +
- ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ]+ cna_str = "-", |
|||
| 307 | -2x | +|||
| 1335 | +
- ccounts <- .remove_empty_elements(ccounts)+ indent_mod = 0L, |
|||
| 308 | +1336 |
- }+ cvar = "", |
||
| 309 | -3x | +|||
| 1337 | +
- count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
+ extra_args = list()) {
|
|||
| 310 | -3x | +1338 | +411x |
- header_colnames_matrix <- rbind(header_colnames_matrix, count_row)+ standardGeneric(".add_row_summary")
|
| 311 | +1339 |
- }- |
- ||
| 312 | -6x | -
- ret <- rbind(header_colnames_matrix, ret)+ } |
||
| 313 | +1340 |
- }+ ) |
||
| 314 | +1341 | |||
| 315 | +1342 |
- # Using only labels for row names and losing information about paths+ #' @rdname int_methods |
||
| 316 | -22x | +|||
| 1343 | +
- if (as_is) {
+ setMethod( |
|||
| 317 | -2x | +|||
| 1344 | +
- tmp_rownames <- ret$label_name+ ".add_row_summary", "PreDataTableLayouts", |
|||
| 318 | -2x | +|||
| 1345 | +
- ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))]+ function(lyt, |
|||
| 319 | -2x | +|||
| 1346 | +
- if (length(unique(tmp_rownames)) == length(tmp_rownames)) {
+ label, |
|||
| 320 | -1x | +|||
| 1347 | +
- rownames(ret) <- tmp_rownames+ cfun, |
|||
| 321 | +1348 |
- } else {
+ child_labels = c("default", "visible", "hidden"),
|
||
| 322 | -1x | +|||
| 1349 | +
- ret <- cbind("label_name" = tmp_rownames, ret)
+ cformat = NULL, |
|||
| 323 | -1x | +|||
| 1350 | +
- rownames(ret) <- NULL+ cna_str = "-", |
|||
| 324 | +1351 |
- }+ indent_mod = 0L, |
||
| 325 | +1352 |
- } else {
+ cvar = "", |
||
| 326 | -20x | +|||
| 1353 | +
- rownames(ret) <- NULL+ extra_args = list()) {
|
|||
| 327 | -+ | |||
| 1354 | +105x |
- }+ child_labels <- match.arg(child_labels) |
||
| 328 | -+ | |||
| 1355 | +105x |
-
+ tmp <- .add_row_summary(rlayout(lyt), label, cfun, |
||
| 329 | -22x | +1356 | +105x |
- ret+ child_labels = child_labels, |
| 330 | -+ | |||
| 1357 | +105x |
- }+ cformat = cformat, |
||
| 331 | -+ | |||
| 1358 | +105x |
-
+ cna_str = cna_str, |
||
| 332 | -+ | |||
| 1359 | +105x |
- .remove_empty_elements <- function(char_df) {
+ indent_mod = indent_mod, |
||
| 333 | -11x | +1360 | +105x |
- if (is.null(dim(char_df))) {
+ cvar = cvar, |
| 334 | -5x | +1361 | +105x |
- return(char_df[nzchar(char_df, keepNA = TRUE)])+ extra_args = extra_args |
| 335 | +1362 |
- }+ ) |
||
| 336 | -+ | |||
| 1363 | +105x |
-
+ rlayout(lyt) <- tmp |
||
| 337 | -6x | +1364 | +105x |
- apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)])+ lyt |
| 338 | +1365 |
- }+ } |
||
| 339 | +1366 |
-
+ ) |
||
| 340 | +1367 |
- # Helper function to make the character matrix numeric+ |
||
| 341 | +1368 |
- .make_numeric_char_mf <- function(char_df) {
+ #' @rdname int_methods |
||
| 342 | -9x | +|||
| 1369 | +
- if (is.null(dim(char_df))) {
+ setMethod( |
|||
| 343 | -3x | +|||
| 1370 | +
- return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+")))+ ".add_row_summary", "PreDataRowLayout", |
|||
| 344 | +1371 |
- }+ function(lyt, |
||
| 345 | +1372 |
-
+ label, |
||
| 346 | -6x | +|||
| 1373 | +
- ret <- apply(char_df, 2, function(col_i) {
+ cfun, |
|||
| 347 | -27x | +|||
| 1374 | +
- lapply(+ child_labels = c("default", "visible", "hidden"),
|
|||
| 348 | -27x | +|||
| 1375 | +
- stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"),+ cformat = NULL, |
|||
| 349 | -27x | +|||
| 1376 | +
- as.numeric+ cna_str = "-", |
|||
| 350 | +1377 |
- )+ indent_mod = 0L, |
||
| 351 | +1378 |
- })+ cvar = "", |
||
| 352 | +1379 |
-
+ extra_args = list()) {
|
||
| 353 | -6x | +1380 | +105x |
- do.call(cbind, ret)+ child_labels <- match.arg(child_labels) |
| 354 | -+ | |||
| 1381 | +105x |
- }+ if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
|
||
| 355 | +1382 |
-
+ ## XXX ignoring indent mod here |
||
| 356 | -+ | |||
| 1383 | +9x |
- make_result_df_md_colnames <- function(maxlen) {
+ rt <- root_spl(lyt) |
||
| 357 | -433x | +1384 | +9x |
- spllen <- floor((maxlen - 2) / 2)+ rt <- .add_row_summary(rt, |
| 358 | -433x | +1385 | +9x |
- ret <- character()+ label, |
| 359 | -433x | +1386 | +9x |
- if (spllen > 0) {
+ cfun, |
| 360 | -387x | +1387 | +9x |
- ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_")
+ child_labels = child_labels, |
| 361 | -+ | |||
| 1388 | +9x |
- }+ cformat = cformat, |
||
| 362 | -433x | +1389 | +9x |
- ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
+ cna_str = cna_str, |
| 363 | -+ | |||
| 1390 | +9x |
- }+ cvar = cvar, |
||
| 364 | -+ | |||
| 1391 | +9x |
-
+ extra_args = extra_args |
||
| 365 | +1392 |
- do_label_row <- function(rdfrow, maxlen) {
+ ) |
||
| 366 | -143x | +1393 | +9x |
- pth <- rdfrow$path[[1]]+ root_spl(lyt) <- rt |
| 367 | +1394 |
- # Adjusting for the fact that we have two columns for each split+ } else {
|
||
| 368 | -143x | +1395 | +96x |
- extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2+ ind <- length(lyt) |
| 369 | -+ | |||
| 1396 | +96x |
-
+ tmp <- .add_row_summary(lyt[[ind]], label, cfun, |
||
| 370 | -+ | |||
| 1397 | +96x |
- # Special cases with hidden labels+ child_labels = child_labels, |
||
| 371 | -143x | +1398 | +96x |
- if (length(pth) %% 2 == 1) {
+ cformat = cformat, |
| 372 | -108x | +1399 | +96x |
- extra_nas_from_splits <- extra_nas_from_splits + 1+ cna_str = cna_str, |
| 373 | -+ | |||
| 1400 | +96x |
- }+ indent_mod = indent_mod, |
||
| 374 | -+ | |||
| 1401 | +96x |
-
+ cvar = cvar, |
||
| 375 | -143x | +1402 | +96x |
- c(+ extra_args = extra_args |
| 376 | -143x | +|||
| 1403 | +
- as.list(pth[seq_len(length(pth) - 1)]),+ ) |
|||
| 377 | -143x | +1404 | +96x |
- as.list(replicate(extra_nas_from_splits, list(NA_character_))),+ lyt[[ind]] <- tmp |
| 378 | -143x | +|||
| 1405 | +
- as.list(tail(pth, 1)),+ } |
|||
| 379 | -143x | +1406 | +105x |
- list(+ lyt |
| 380 | -143x | +|||
| 1407 | +
- label_name = rdfrow$label,+ } |
|||
| 381 | -143x | +|||
| 1408 | +
- row_num = rdfrow$abs_rownumber,+ ) |
|||
| 382 | -143x | +|||
| 1409 | +
- content = FALSE,+ |
|||
| 383 | -143x | +|||
| 1410 | +
- node_class = rdfrow$node_class+ #' @rdname int_methods |
|||
| 384 | +1411 |
- )+ setMethod( |
||
| 385 | +1412 |
- )+ ".add_row_summary", "SplitVector", |
||
| 386 | +1413 |
- }+ function(lyt, |
||
| 387 | +1414 |
-
+ label, |
||
| 388 | +1415 |
- do_content_row <- function(rdfrow, maxlen) {
+ cfun, |
||
| 389 | -36x | +|||
| 1416 | +
- pth <- rdfrow$path[[1]]+ child_labels = c("default", "visible", "hidden"),
|
|||
| 390 | -36x | +|||
| 1417 | +
- contpos <- which(pth == "@content")+ cformat = NULL, |
|||
| 391 | +1418 |
-
+ cna_str = "-", |
||
| 392 | -36x | +|||
| 1419 | +
- seq_before <- seq_len(contpos - 1)+ indent_mod = 0L, |
|||
| 393 | +1420 |
-
+ cvar = "", |
||
| 394 | -36x | +|||
| 1421 | +
- c(+ extra_args = list()) {
|
|||
| 395 | -36x | +1422 | +96x |
- as.list(pth[seq_before]),+ child_labels <- match.arg(child_labels) |
| 396 | -36x | +1423 | +96x |
- as.list(replicate(maxlen - contpos, list(NA_character_))),+ ind <- length(lyt) |
| 397 | -36x | +|||
| 1424 | +! |
- list(tail(pth, 1)),+ if (ind == 0) stop("no split to add content rows at")
|
||
| 398 | -36x | +1425 | +96x |
- list(+ spl <- lyt[[ind]] |
| 399 | -36x | +|||
| 1426 | +
- label_name = rdfrow$label,+ # if(is(spl, "AnalyzeVarSplit")) |
|||
| 400 | -36x | +|||
| 1427 | +
- row_num = rdfrow$abs_rownumber,+ # stop("can't add content rows to analyze variable split")
|
|||
| 401 | -36x | +1428 | +96x |
- content = TRUE,+ tmp <- .add_row_summary(spl, |
| 402 | -36x | +1429 | +96x |
- node_class = rdfrow$node_class+ label, |
| 403 | -+ | |||
| 1430 | +96x |
- )+ cfun, |
||
| 404 | -+ | |||
| 1431 | +96x |
- )+ child_labels = child_labels, |
||
| 405 | -+ | |||
| 1432 | +96x |
- }+ cformat = cformat, |
||
| 406 | -+ | |||
| 1433 | +96x |
-
+ cna_str = cna_str, |
||
| 407 | -+ | |||
| 1434 | +96x |
- do_data_row <- function(rdfrow, maxlen) {
+ indent_mod = indent_mod, |
||
| 408 | -254x | +1435 | +96x |
- pth <- rdfrow$path[[1]]+ cvar = cvar, |
| 409 | -254x | +1436 | +96x |
- pthlen <- length(pth)+ extra_args = extra_args |
| 410 | +1437 |
- ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame+ ) |
||
| 411 | -254x | +1438 | +96x |
- if (pthlen %% 2 == 1) {
+ lyt[[ind]] <- tmp |
| 412 | -38x | +1439 | +96x |
- pth <- pth[-1 * (pthlen - 2)]+ lyt |
| 413 | +1440 |
} |
||
| 414 | -254x | +|||
| 1441 | +
- pthlen_new <- length(pth)+ ) |
|||
| 415 | -33x | +|||
| 1442 | +
- if (maxlen == 1) pthlen_new <- 3+ |
|||
| 416 | -254x | +|||
| 1443 | +
- c(+ #' @rdname int_methods |
|||
| 417 | -254x | +|||
| 1444 | +
- as.list(pth[seq_len(pthlen_new - 2)]),+ setMethod( |
|||
| 418 | -254x | +|||
| 1445 | +
- replicate(maxlen - pthlen, list(NA_character_)),+ ".add_row_summary", "Split", |
|||
| 419 | -254x | +|||
| 1446 | +
- as.list(tail(pth, 2)),+ function(lyt, |
|||
| 420 | -254x | +|||
| 1447 | +
- list(+ label, |
|||
| 421 | -254x | +|||
| 1448 | +
- label_name = rdfrow$label,+ cfun, |
|||
| 422 | -254x | +|||
| 1449 | +
- row_num = rdfrow$abs_rownumber,+ child_labels = c("default", "visible", "hidden"),
|
|||
| 423 | -254x | +|||
| 1450 | +
- content = FALSE,+ cformat = NULL, |
|||
| 424 | -254x | +|||
| 1451 | +
- node_class = rdfrow$node_class+ cna_str = "-", |
|||
| 425 | +1452 |
- )+ indent_mod = 0L, |
||
| 426 | +1453 |
- )+ cvar = "", |
||
| 427 | +1454 |
- }+ extra_args = list()) {
|
||
| 428 | -+ | |||
| 1455 | +105x |
-
+ child_labels <- match.arg(child_labels) |
||
| 429 | +1456 |
- .remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
+ # lbl_kids = .labelkids_helper(child_labels) |
||
| 430 | -434x | +1457 | +105x |
- any_root_paths <- path[1] %in% which_root_name+ content_fun(lyt) <- cfun |
| 431 | -434x | +1458 | +105x |
- if (any_root_paths) {
+ content_indent_mod(lyt) <- indent_mod |
| 432 | -274x | +1459 | +105x |
- if (isTRUE(all)) {
+ content_var(lyt) <- cvar |
| 433 | +1460 |
- # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later)+ ## obj_format(lyt) = cformat |
||
| 434 | -274x | +1461 | +105x |
- root_indices <- which(path %in% which_root_name)+ content_format(lyt) <- cformat |
| 435 | -274x | +1462 | +105x |
- if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
+ if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
|
| 436 | +1463 | ! |
- end_point_root_headers <- which(diff(root_indices) > 1)[1]+ label_kids(lyt) <- child_labels |
|
| 437 | +1464 |
- } else {
+ } |
||
| 438 | -274x | +1465 | +105x |
- end_point_root_headers <- length(root_indices)+ content_na_str <- cna_str |
| 439 | -+ | |||
| 1466 | +105x |
- }+ content_extra_args(lyt) <- extra_args |
||
| 440 | -274x | +1467 | +105x |
- root_path_to_remove <- seq_len(end_point_root_headers)+ lyt |
| 441 | +1468 |
- } else {
- |
- ||
| 442 | -! | -
- root_path_to_remove <- 1+ } |
||
| 443 | +1469 |
- }- |
- ||
| 444 | -274x | -
- path <- path[-root_path_to_remove]+ ) |
||
| 445 | +1470 |
- }+ |
||
| 446 | +1471 |
-
+ .count_raw_constr <- function(var, format, label_fstr) {
|
||
| 447 | -+ | |||
| 1472 | +2x |
- # Fix for very edge case where we have only root elements+ function(df, labelstr = "") {
|
||
| 448 | -434x | +1473 | +24x |
- if (length(path) == 0) {
+ if (grepl("%s", label_fstr, fixed = TRUE)) {
|
| 449 | -1x | +1474 | +21x |
- path <- which_root_name[1]+ label <- sprintf(label_fstr, labelstr) |
| 450 | +1475 |
- }+ } else {
+ |
+ ||
| 1476 | +3x | +
+ label <- label_fstr |
||
| 451 | +1477 |
-
+ } |
||
| 452 | -434x | +1478 | +24x |
- path+ if (is(df, "data.frame")) {
|
| 453 | -+ | |||
| 1479 | +24x |
- }+ if (!is.null(var) && nzchar(var)) {
|
||
| 454 | -+ | |||
| 1480 | +3x |
-
+ cnt <- sum(!is.na(df[[var]])) |
||
| 455 | +1481 |
- handle_rdf_row <- function(rdfrow, maxlen) {
+ } else {
|
||
| 456 | -433x | +1482 | +21x |
- nclass <- rdfrow$node_class+ cnt <- nrow(df) |
| 457 | +1483 |
-
+ } |
||
| 458 | -433x | +1484 | +2x |
- ret <- switch(nclass,+ } else { # df is the data column vector
|
| 459 | -433x | +|||
| 1485 | +! |
- LabelRow = do_label_row(rdfrow, maxlen),+ cnt <- sum(!is.na(df))+ |
+ ||
| 1486 | ++ |
+ } |
||
| 460 | -433x | +1487 | +24x |
- ContentRow = do_content_row(rdfrow, maxlen),+ ret <- rcell(cnt, |
| 461 | -433x | +1488 | +24x |
- DataRow = do_data_row(rdfrow, maxlen),+ format = format, |
| 462 | -433x | +1489 | +24x |
- stop("Unrecognized node type in row dataframe, unable to generate result data frame")
+ label = label |
| 463 | +1490 |
- )+ ) |
||
| 464 | -433x | +1491 | +24x |
- setNames(ret, make_result_df_md_colnames(maxlen))+ ret |
| 465 | +1492 |
- }+ } |
||
| 466 | +1493 |
-
+ } |
||
| 467 | +1494 |
- # Helper recurrent function to get the column names for the result data frame from the VTableTree+ |
||
| 468 | +1495 |
- .get_formatted_colnames <- function(clyt) {
+ .count_wpcts_constr <- function(var, format, label_fstr) {
|
||
| 469 | -41x | +1496 | +90x |
- ret <- obj_label(clyt)+ function(df, labelstr = "", .N_col) {
|
| 470 | -41x | +1497 | +1523x |
- if (!nzchar(ret)) {
+ if (grepl("%s", label_fstr, fixed = TRUE)) {
|
| 471 | -6x | +1498 | +1499x |
- ret <- NULL+ label <- sprintf(label_fstr, labelstr) |
| 472 | +1499 |
- }+ } else {
|
||
| 473 | -41x | -
- if (is.null(tree_children(clyt))) {
- |
- ||
| 474 | -! | +1500 | +24x |
- return(ret)+ label <- label_fstr |
| 475 | +1501 |
- } else {
- |
- ||
| 476 | -41x | -
- ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames)))+ } |
||
| 477 | -41x | +1502 | +1523x |
- colnames(ret) <- NULL+ if (is(df, "data.frame")) {
|
| 478 | -41x | +1503 | +1523x |
- rownames(ret) <- NULL+ if (!is.null(var) && nzchar(var)) {
|
| 479 | -41x | -
- return(ret)- |
- ||
| 480 | -- |
- }- |
- ||
| 481 | -+ | 1504 | +407x |
- }+ cnt <- sum(!is.na(df[[var]])) |
| 482 | +1505 |
-
+ } else {
|
||
| 483 | -+ | |||
| 1506 | +1116x |
- #' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`.+ cnt <- nrow(df) |
||
| 484 | +1507 |
- #'+ } |
||
| 485 | -+ | |||
| 1508 | +90x |
- #' @param path_fun (`function`)\cr function to transform paths into single-string row/column names.+ } else { # df is the data column vector
|
||
| 486 | -+ | |||
| 1509 | +! |
- #' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to+ cnt <- sum(!is.na(df)) |
||
| 487 | +1510 |
- #' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`.+ } |
||
| 488 | +1511 |
- #'+ ## the formatter does the *100 so we don't here. |
||
| 489 | +1512 |
- #' @return+ ## TODO name elements of this so that ARD generation has access to them |
||
| 490 | +1513 |
- #' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by+ ## ret <- rcell(c(n = cnt, pct = cnt / .N_col), |
||
| 491 | -+ | |||
| 1514 | +1523x |
- #' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed+ ret <- rcell(c(cnt, cnt / .N_col), |
||
| 492 | -+ | |||
| 1515 | +1523x |
- #' by `path_fun`).+ format = format, |
||
| 493 | -+ | |||
| 1516 | +1523x |
- #'+ label = label |
||
| 494 | +1517 |
- #' @examples+ ) |
||
| 495 | -+ | |||
| 1518 | +1523x |
- #' lyt <- basic_table() %>%+ ret |
||
| 496 | +1519 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 497 | +1520 |
- #' analyze(c("AGE", "BMRKR2"))
+ } |
||
| 498 | +1521 |
- #'+ |
||
| 499 | +1522 |
- #' tbl <- build_table(lyt, ex_adsl)+ .validate_cfuns <- function(fun) {
|
||
| 500 | -+ | |||
| 1523 | +111x |
- #' path_enriched_df(tbl)+ if (is.list(fun)) {
|
||
| 501 | -+ | |||
| 1524 | +2x |
- #'+ return(unlist(lapply(fun, .validate_cfuns))) |
||
| 502 | +1525 |
- #' @export+ } |
||
| 503 | +1526 |
- path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
- |
- ||
| 504 | -3x | -
- rdf <- make_row_df(tt)+ |
||
| 505 | -3x | +1527 | +109x |
- cdf <- make_col_df(tt)+ frmls <- formals(fun) |
| 506 | -3x | +1528 | +109x |
- cvs <- as.data.frame(do.call(rbind, cell_values(tt)))+ ls_pos <- match("labelstr", names(frmls))
|
| 507 | -3x | +1529 | +109x |
- cvs <- as.data.frame(lapply(cvs, value_fun))+ if (is.na(ls_pos)) {
|
| 508 | -3x | +|||
| 1530 | +! |
- row.names(cvs) <- NULL+ stop("content functions must explicitly accept a 'labelstr' argument")
|
||
| 509 | -3x | +|||
| 1531 | +
- colnames(cvs) <- path_fun(cdf$path)+ } |
|||
| 510 | -3x | +|||
| 1532 | +
- preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path)+ |
|||
| 511 | -3x | +1533 | +109x |
- cbind.data.frame(row_path = preppaths, cvs)+ list(fun) |
| 512 | +1534 |
} |
||
| 513 | +1535 | |||
| 514 | +1536 |
- .collapse_char <- "|"+ #' Analysis function to count levels of a factor with percentage of the column total |
||
| 515 | +1537 |
- .collapse_char_esc <- "\\|"+ #' |
||
| 516 | +1538 |
-
+ #' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery. |
||
| 517 | +1539 |
- collapse_path <- function(paths) {
+ #' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery. |
||
| 518 | -196x | +|||
| 1540 | +
- if (is.list(paths)) {
+ #' |
|||
| 519 | -6x | +|||
| 1541 | +
- return(vapply(paths, collapse_path, ""))+ #' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor. |
|||
| 520 | +1542 |
- }+ #' |
||
| 521 | -190x | +|||
| 1543 | +
- paste(paths, collapse = .collapse_char)+ #' @examples |
|||
| 522 | +1544 |
- }+ #' counts_wpcts(DM$SEX, 400) |
||
| 523 | +1545 |
-
+ #' |
||
| 524 | +1546 |
- collapse_values <- function(colvals) {
+ #' @export |
||
| 525 | -13x | +|||
| 1547 | +
- if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
+ counts_wpcts <- function(x, .N_col) {
|
|||
| 526 | -! | +|||
| 1548 | +2x |
- return(colvals)+ if (!is.factor(x)) {
|
||
| 527 | -13x | +1549 | +1x |
- } else if (all(vapply(colvals, length, 1L) == 1)) {
+ stop( |
| 528 | +1550 | 1x |
- return(unlist(colvals))+ "using the 'counts_wpcts' analysis function requires factor data ", |
|
| 529 | -+ | |||
| 1551 | +1x |
- }+ "to guarantee equal numbers of rows across all collumns, got class ", |
||
| 530 | -12x | +1552 | +1x |
- vapply(colvals, paste, "", collapse = .collapse_char)+ class(x), "." |
| 531 | +1553 |
- }+ ) |
||
| 532 | +1554 |
-
+ } |
||
| 533 | -+ | |||
| 1555 | +1x |
- # pdf output -------------------------------------------------------------------+ ret <- table(x) |
||
| 534 | -+ | |||
| 1556 | +1x |
-
+ in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)"))) |
||
| 535 | +1557 |
- ### Export as PDF - migrated to formatters+ } |
||
| 536 | +1558 | |||
| 537 | +1559 |
- #' @importFrom formatters export_as_pdf+ #' Add a content row of summary counts |
||
| 538 | +1560 |
#' |
||
| 539 | +1561 |
- #' @examples+ #' @inheritParams lyt_args |
||
| 540 | +1562 |
- #' lyt <- basic_table() %>%+ #' |
||
| 541 | +1563 |
- #' split_cols_by("ARM") %>%
+ #' @inherit split_cols_by return |
||
| 542 | +1564 |
- #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
+ #' |
||
| 543 | +1565 |
- #'+ #' @details |
||
| 544 | +1566 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values |
||
| 545 | +1567 |
- #'+ #' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of |
||
| 546 | +1568 |
- #' \dontrun{
+ #' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only |
||
| 547 | +1569 |
- #' tf <- tempfile(fileext = ".pdf")+ #' raw counts are used. |
||
| 548 | +1570 |
- #' export_as_pdf(tbl, file = tf, pg_height = 4)+ #' |
||
| 549 | +1571 |
- #' tf <- tempfile(fileext = ".pdf")+ #' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset |
||
| 550 | +1572 |
- #' export_as_pdf(tbl, file = tf, lpp = 8)+ #' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept |
||
| 551 | +1573 |
- #' }+ #' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently |
||
| 552 | +1574 |
- #'+ #' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]). |
||
| 553 | +1575 |
- #' @export+ #' |
||
| 554 | +1576 |
- formatters::export_as_pdf+ #' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params] |
||
| 555 | +1577 |
-
+ #' that can be used in `cfun`. |
||
| 556 | +1578 |
- # only used in pagination+ #' |
||
| 557 | +1579 |
- .tab_to_colpath_set <- function(tt) {
- |
- ||
| 558 | -4x | -
- vapply(- |
- ||
| 559 | -4x | -
- collect_leaves(coltree(tt)),- |
- ||
| 560 | -4x | -
- function(y) paste(pos_to_path(tree_pos(y)), collapse = " "),+ #' @examples |
||
| 561 | +1580 |
- ""+ #' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
|
||
| 562 | +1581 |
- )+ #' |
||
| 563 | +1582 |
- }+ #' lyt <- basic_table() %>% |
||
| 564 | +1583 |
- .figure_out_colinds <- function(subtab, fulltab) {
+ #' split_cols_by("ARM") %>%
|
||
| 565 | -2x | +|||
| 1584 | +
- match(+ #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
|
|||
| 566 | -2x | +|||
| 1585 | +
- .tab_to_colpath_set(subtab),+ #' summarize_row_groups(label_fstr = "%s (n)") %>% |
|||
| 567 | -2x | +|||
| 1586 | +
- .tab_to_colpath_set(fulltab)+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
|
|||
| 568 | +1587 |
- )+ #' lyt |
||
| 569 | +1588 |
- }+ #' |
||
| 570 | +1589 |
-
+ #' tbl <- build_table(lyt, DM2) |
||
| 571 | +1590 |
- # Flextable and docx -----------------------------------------------------------+ #' tbl |
||
| 572 | +1591 |
-
+ #' |
||
| 573 | +1592 |
- #' Export as word document+ #' row_paths_summary(tbl) # summary count is a content table |
||
| 574 | +1593 |
#' |
||
| 575 | +1594 |
- #' From a table, produce a self-contained word document or attach it to a template word+ #' ## use a cfun and extra_args to customize summarization |
||
| 576 | +1595 |
- #' file (`template_file`). This function is based on the [tt_to_flextable()] transformer and+ #' ## behavior |
||
| 577 | +1596 |
- #' the `officer` package.+ #' sfun <- function(x, labelstr, trim) {
|
||
| 578 | +1597 |
- #'+ #' in_rows( |
||
| 579 | +1598 |
- #' @inheritParams gen_args+ #' c(mean(x, trim = trim), trim), |
||
| 580 | +1599 |
- #' @param file (`string`)\cr string that indicates the final file output. Must have `.docx` extension.+ #' .formats = "xx.x (xx.x%)", |
||
| 581 | +1600 |
- #' @param doc_metadata (`list` of `string`s)\cr any value that can be used as metadata by+ #' .labels = sprintf( |
||
| 582 | +1601 |
- #' `?officer::set_doc_properties`. Important text values are `title`, `subject`, `creator`, and `description`,+ #' "%s (Trimmed mean and trim %%)", |
||
| 583 | +1602 |
- #' while `created` is a date object.+ #' labelstr |
||
| 584 | +1603 |
- #' @inheritParams tt_to_flextable+ #' ) |
||
| 585 | +1604 |
- #' @param template_file (`string`)\cr template file that `officer` will use as a starting point for the final+ #' ) |
||
| 586 | +1605 |
- #' document. Document attaches the table and uses the defaults defined in the template file.+ #' } |
||
| 587 | +1606 |
- #' @param section_properties (`officer::prop_section`)\cr an [officer::prop_section()] object which sets margins and+ #' |
||
| 588 | +1607 |
- #' page size.+ #' lyt2 <- basic_table(show_colcounts = TRUE) %>% |
||
| 589 | +1608 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 590 | +1609 |
- #' @note `export_as_docx()` has few customization options available. If you require specific formats and details,+ #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
|
||
| 591 | +1610 |
- #' we suggest that you use [tt_to_flextable()] prior to `export_as_docx`. Only the `title_as_header` and+ #' summarize_row_groups("AGE",
|
||
| 592 | +1611 |
- #' `footer_as_text` parameters must be re-specified if the table is changed first using [tt_to_flextable()].+ #' cfun = sfun, |
||
| 593 | +1612 |
- #'+ #' extra_args = list(trim = .2) |
||
| 594 | +1613 |
- #' @seealso [tt_to_flextable()]+ #' ) %>% |
||
| 595 | +1614 |
- #'+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
|
||
| 596 | +1615 |
- #' @examples+ #' append_topleft(c("Country", " Age"))
|
||
| 597 | +1616 |
- #' lyt <- basic_table() %>%+ #' |
||
| 598 | +1617 |
- #' split_cols_by("ARM") %>%
+ #' tbl2 <- build_table(lyt2, DM2) |
||
| 599 | +1618 |
- #' analyze(c("AGE", "BMRKR2", "COUNTRY"))
+ #' tbl2 |
||
| 600 | +1619 |
#' |
||
| 601 | +1620 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' @author Gabriel Becker |
||
| 602 | +1621 |
- #'+ #' @export |
||
| 603 | +1622 |
- #' # See how section_properties_portrait function is built for custom+ summarize_row_groups <- function(lyt, |
||
| 604 | +1623 |
- #' \dontrun{
+ var = "", |
||
| 605 | +1624 |
- #' tf <- tempfile(fileext = ".docx")+ label_fstr = "%s", |
||
| 606 | +1625 |
- #' export_as_docx(tbl, file = tf, section_properties = section_properties_portrait())+ format = "xx (xx.x%)", |
||
| 607 | +1626 |
- #' }+ na_str = "-", |
||
| 608 | +1627 |
- #'+ cfun = NULL, |
||
| 609 | +1628 |
- #' @export+ indent_mod = 0L, |
||
| 610 | +1629 |
- export_as_docx <- function(tt,+ extra_args = list()) {
|
||
| 611 | -+ | |||
| 1630 | +105x |
- file,+ if (is.null(cfun)) {
|
||
| 612 | -+ | |||
| 1631 | +92x |
- doc_metadata = NULL,+ if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
|
||
| 613 | -+ | |||
| 1632 | +2x |
- titles_as_header = FALSE,+ cfun <- .count_raw_constr(var, format, label_fstr) |
||
| 614 | +1633 |
- footers_as_text = TRUE,+ } else {
|
||
| 615 | -+ | |||
| 1634 | +90x |
- template_file = NULL,+ cfun <- .count_wpcts_constr(var, format, label_fstr) |
||
| 616 | +1635 |
- section_properties = NULL) {
+ } |
||
| 617 | +1636 |
- # Checks+ } |
||
| 618 | -3x | +1637 | +105x |
- check_required_packages(c("flextable", "officer"))
+ cfun <- .validate_cfuns(cfun) |
| 619 | -3x | +1638 | +105x |
- if (inherits(tt, "VTableTree")) {
+ .add_row_summary(lyt, |
| 620 | -2x | +1639 | +105x |
- flex_tbl <- tt_to_flextable(tt,+ cfun = cfun, |
| 621 | -2x | +1640 | +105x |
- titles_as_header = titles_as_header,+ cformat = format, |
| 622 | -2x | -
- footers_as_text = footers_as_text- |
- ||
| 623 | -+ | 1641 | +105x |
- )+ cna_str = na_str, |
| 624 | -2x | -
- if (isFALSE(titles_as_header) || isTRUE(footers_as_text)) {
- |
- ||
| 625 | -+ | 1642 | +105x |
- # Ugly but I could not find a getter for font.size+ indent_mod = indent_mod, |
| 626 | -2x | +1643 | +105x |
- font_sz <- flex_tbl$header$styles$text$font.size$data[1, 1]+ cvar = var, |
| 627 | -2x | +1644 | +105x |
- font_sz_footer <- flex_tbl$header$styles$text$font.size$data[1, 1] - 1+ extra_args = extra_args |
| 628 | -2x | +|||
| 1645 | +
- font_fam <- flex_tbl$header$styles$text$font.family$data[1, 1]+ ) |
|||
| 629 | +1646 |
-
+ } |
||
| 630 | +1647 |
- # Set the test as the tt+ |
||
| 631 | -2x | +|||
| 1648 | +
- fpt <- officer::fp_text(font.family = font_fam, font.size = font_sz)+ #' Add the column population counts to the header |
|||
| 632 | -2x | +|||
| 1649 | +
- fpt_footer <- officer::fp_text(font.family = font_fam, font.size = font_sz_footer)+ #' |
|||
| 633 | +1650 |
- }+ #' Add the data derived column counts. |
||
| 634 | +1651 |
- } else {
+ #' |
||
| 635 | -1x | +|||
| 1652 | +
- flex_tbl <- tt+ #' @details It is often the case that the the column counts derived from the |
|||
| 636 | +1653 |
- }+ #' input data to [build_table()] is not representative of the population counts. |
||
| 637 | -3x | +|||
| 1654 | +
- if (!is.null(template_file) && !file.exists(template_file)) {
+ #' For example, if events are counted in the table and the header should |
|||
| 638 | -1x | +|||
| 1655 | +
- template_file <- NULL+ #' display the number of subjects and not the total number of events. |
|||
| 639 | +1656 |
- }+ #' |
||
| 640 | +1657 |
-
+ #' @inheritParams lyt_args |
||
| 641 | +1658 |
- # Create a new empty Word document+ #' |
||
| 642 | -3x | +|||
| 1659 | +
- if (!is.null(template_file)) {
+ #' @inherit split_cols_by return |
|||
| 643 | -2x | +|||
| 1660 | +
- doc <- officer::read_docx(template_file)+ #' |
|||
| 644 | +1661 |
- } else {
+ #' @examples |
||
| 645 | -1x | +|||
| 1662 | +
- doc <- officer::read_docx()+ #' lyt <- basic_table() %>% |
|||
| 646 | +1663 |
- }+ #' split_cols_by("ARM") %>%
|
||
| 647 | +1664 |
-
+ #' add_colcounts() %>% |
||
| 648 | -3x | +|||
| 1665 | +
- if (!is.null(section_properties)) {
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
|||
| 649 | -3x | +|||
| 1666 | +
- doc <- officer::body_set_default_section(doc, section_properties)+ #' analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
|
|||
| 650 | +1667 |
- }+ #' lyt |
||
| 651 | +1668 |
-
+ #' |
||
| 652 | +1669 |
- # Extract title+ #' tbl <- build_table(lyt, DM)+ |
+ ||
| 1670 | ++ |
+ #' tbl+ |
+ ||
| 1671 | ++ |
+ #'+ |
+ ||
| 1672 | ++ |
+ #' @author Gabriel Becker+ |
+ ||
| 1673 | ++ |
+ #' @export+ |
+ ||
| 1674 | ++ |
+ add_colcounts <- function(lyt, format = "(N=xx)") {
|
||
| 653 | -3x | +1675 | +5x |
- if (isFALSE(titles_as_header) && inherits(tt, "VTableTree")) {
+ if (is.null(lyt)) {
+ |
+
| 1676 | +! | +
+ lyt <- PreDataTableLayouts()+ |
+ ||
| 1677 | ++ |
+ } |
||
| 654 | -2x | +1678 | +5x |
- ts_tbl <- all_titles(tt)+ disp_ccounts(lyt) <- TRUE |
| 655 | -2x | +1679 | +5x |
- if (length(ts_tbl) > 0) {
+ colcount_format(lyt) <- format |
| 656 | -2x | +1680 | +5x |
- doc <- add_text_par(doc, ts_tbl, fpt)+ lyt |
| 657 | +1681 |
- }+ } |
||
| 658 | +1682 |
- }+ |
||
| 659 | +1683 |
-
+ ## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting. |
||
| 660 | +1684 |
- # Add the table to the document+ #' Add an already calculated table to the layout |
||
| 661 | -3x | +|||
| 1685 | +
- doc <- flextable::body_add_flextable(doc, flex_tbl, align = "left")+ #' |
|||
| 662 | +1686 |
-
+ #' @inheritParams lyt_args |
||
| 663 | +1687 |
- # add footers as paragraphs+ #' @inheritParams gen_args |
||
| 664 | -3x | +|||
| 1688 | +
- if (isTRUE(footers_as_text) && inherits(tt, "VTableTree")) {
+ #' |
|||
| 665 | +1689 |
- # Adding referantial footer line separator if present+ #' @inherit split_cols_by return |
||
| 666 | +1690 |
- # (this is usually done differently, i.e. inside footnotes)+ #' |
||
| 667 | -2x | +|||
| 1691 | +
- matform <- matrix_form(tt, indent_rownames = TRUE)+ #' @examples |
|||
| 668 | -2x | +|||
| 1692 | +
- if (length(matform$ref_footnotes) > 0) {
+ #' lyt1 <- basic_table() %>% |
|||
| 669 | -2x | +|||
| 1693 | +
- doc <- add_text_par(doc, matform$ref_footnotes, fpt_footer)+ #' split_cols_by("ARM") %>%
|
|||
| 670 | +1694 |
- }+ #' analyze("AGE", afun = mean, format = "xx.xx")
|
||
| 671 | +1695 |
- # Footer lines+ #' |
||
| 672 | -2x | +|||
| 1696 | +
- if (length(all_footers(tt)) > 0) {
+ #' tbl1 <- build_table(lyt1, DM) |
|||
| 673 | -2x | +|||
| 1697 | +
- doc <- add_text_par(doc, all_footers(tt), fpt_footer)+ #' tbl1 |
|||
| 674 | +1698 |
- }+ #' |
||
| 675 | +1699 |
- }+ #' lyt2 <- basic_table() %>% |
||
| 676 | +1700 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 677 | -3x | +|||
| 1701 | +
- if (!is.null(doc_metadata)) {
+ #' analyze("AGE", afun = sd, format = "xx.xx") %>%
|
|||
| 678 | +1702 |
- # Checks for values rely on officer function+ #' add_existing_table(tbl1) |
||
| 679 | -3x | +|||
| 1703 | +
- doc <- do.call(officer::set_doc_properties, c(list("x" = doc), doc_metadata))
+ #' |
|||
| 680 | +1704 |
- }+ #' tbl2 <- build_table(lyt2, DM) |
||
| 681 | +1705 |
-
+ #' tbl2 |
||
| 682 | +1706 |
- # Save the Word document to a file+ #' |
||
| 683 | -3x | +|||
| 1707 | +
- print(doc, target = file)+ #' table_structure(tbl2) |
|||
| 684 | +1708 |
- }+ #' row_paths_summary(tbl2) |
||
| 685 | +1709 |
-
+ #' |
||
| 686 | +1710 |
- # Shorthand to add text paragraph+ #' @author Gabriel Becker |
||
| 687 | +1711 |
- add_text_par <- function(doc, chr_v, text_format) {
+ #' @export+ |
+ ||
| 1712 | ++ |
+ add_existing_table <- function(lyt, tt, indent_mod = 0) {
|
||
| 688 | -6x | +1713 | +1x |
- for (ii in seq_along(chr_v)) {
+ indent_mod(tt) <- indent_mod |
| 689 | -16x | +1714 | +1x |
- cur_fp <- officer::fpar(officer::ftext(chr_v[ii], prop = text_format))+ lyt <- split_rows( |
| 690 | -16x | +1715 | +1x |
- doc <- officer::body_add_fpar(doc, cur_fp)+ lyt,+ |
+
| 1716 | +1x | +
+ tt,+ |
+ ||
| 1717 | +1x | +
+ next_rpos(lyt, nested = FALSE) |
||
| 691 | +1718 |
- }+ ) |
||
| 692 | -6x | +1719 | +1x |
- doc+ lyt |
| 693 | +1720 |
} |
||
| 694 | +1721 | |||
| 695 | +1722 |
- #' @describeIn export_as_docx Helper function that defines standard portrait properties for tables.+ ## takes_coln = function(f) {
|
||
| 696 | +1723 |
- #' @export+ ## stopifnot(is(f, "function")) |
||
| 697 | +1724 |
- section_properties_portrait <- function() {
+ ## forms = names(formals(f)) |
||
| 698 | -2x | +|||
| 1725 | +
- officer::prop_section(+ ## res = ".N_col" %in% forms |
|||
| 699 | -2x | +|||
| 1726 | +
- page_size = officer::page_size(+ ## res |
|||
| 700 | -2x | +|||
| 1727 | +
- orient = "portrait",+ ## } |
|||
| 701 | -2x | +|||
| 1728 | +
- width = 8.5, height = 11+ |
|||
| 702 | +1729 |
- ),+ ## takes_totn = function(f) {
|
||
| 703 | -2x | +|||
| 1730 | +
- type = "continuous",+ ## stopifnot(is(f, "function")) |
|||
| 704 | -2x | +|||
| 1731 | +
- page_margins = margins_potrait()+ ## forms = names(formals(f)) |
|||
| 705 | +1732 |
- )+ ## res = ".N_total" %in% forms |
||
| 706 | +1733 |
- }+ ## res |
||
| 707 | +1734 |
-
+ ## } |
||
| 708 | +1735 |
- #' @describeIn export_as_docx Helper function that defines standard landscape properties for tables.+ |
||
| 709 | +1736 |
- #' @export+ ## use data to transform dynamic cuts to static cuts |
||
| 710 | +1737 |
- section_properties_landscape <- function() {
+ #' @rdname int_methods |
||
| 711 | -1x | +1738 | +2696x |
- officer::prop_section(+ setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))
|
| 712 | -1x | +|||
| 1739 | +
- page_size = officer::page_size(+ |
|||
| 713 | -1x | +|||
| 1740 | +
- orient = "landscape",+ #' @rdname int_methods |
|||
| 714 | -1x | +1741 | +1011x |
- width = 8.5, height = 11+ setMethod("fix_dyncuts", "Split", function(spl, df) spl)
|
| 715 | +1742 |
- ),+ |
||
| 716 | -1x | +|||
| 1743 | +
- type = "continuous",+ #' @rdname int_methods |
|||
| 717 | -1x | +|||
| 1744 | +
- page_margins = margins_landscape()+ setMethod( |
|||
| 718 | +1745 |
- )+ "fix_dyncuts", "VarDynCutSplit", |
||
| 719 | +1746 |
- }+ function(spl, df) {
+ |
+ ||
| 1747 | +5x | +
+ var <- spl_payload(spl)+ |
+ ||
| 1748 | +5x | +
+ varvec <- df[[var]] |
||
| 720 | +1749 | |||
| 721 | -+ | |||
| 1750 | +5x |
- #' @describeIn export_as_docx Helper function that defines standard portrait margins for tables.+ cfun <- spl_cutfun(spl) |
||
| 722 | -+ | |||
| 1751 | +5x |
- #' @export+ cuts <- cfun(varvec) |
||
| 723 | -+ | |||
| 1752 | +5x |
- margins_potrait <- function() {
+ cutlabels <- spl_cutlabelfun(spl)(cuts) |
||
| 724 | -2x | +1753 | +5x |
- officer::page_mar(bottom = 0.98, top = 0.95, left = 1.5, right = 1, gutter = 0)+ if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
|
| 725 | -+ | |||
| 1754 | +1x |
- }+ cutlabels <- names(cuts)[-1] |
||
| 726 | +1755 |
- #' @describeIn export_as_docx Helper function that defines standard landscape margins for tables.+ } |
||
| 727 | +1756 |
- #' @export+ |
||
| 728 | -+ | |||
| 1757 | +5x |
- margins_landscape <- function() {
+ ret <- make_static_cut_split( |
||
| 729 | -1x | +1758 | +5x |
- officer::page_mar(bottom = 1, top = 1.5, left = 0.98, right = 0.95, gutter = 0)+ var = var, split_label = obj_label(spl), |
| 730 | -+ | |||
| 1759 | +5x |
- }+ cuts = cuts, cutlabels = cutlabels, |
||
| 731 | -+ | |||
| 1760 | +5x |
-
+ cumulative = spl_is_cmlcuts(spl) |
||
| 732 | +1761 |
- #' Create a `flextable` from an `rtables` table+ ) |
||
| 733 | +1762 |
- #'+ ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl), |
||
| 734 | +1763 |
- #' Principally used for export ([export_as_docx()]), this function produces a `flextable`+ ## cuts = cuts, cutlabels = cutlabels) |
||
| 735 | +1764 |
- #' from an `rtables` table. If `theme = NULL`, `rtables`-like style will be used. Otherwise,+ ## ## classes are tthe same structurally CumulativeCutSplit |
||
| 736 | +1765 |
- #' [theme_docx_default()] will produce a `.docx`-friendly table.+ ## ## is just a sentinal so it can hit different make_subset_expr |
||
| 737 | +1766 |
- #'+ ## ## method |
||
| 738 | +1767 |
- #' @inheritParams gen_args+ ## if(spl_is_cmlcuts(spl)) |
||
| 739 | +1768 |
- #' @inheritParams paginate_table+ ## ret = as(ret, "CumulativeCutSplit")+ |
+ ||
| 1769 | +5x | +
+ ret |
||
| 740 | +1770 |
- #' @param theme (`function` or `NULL`)\cr A theme function that is designed internally as a function of a `flextable`+ } |
||
| 741 | +1771 |
- #' object to change its layout and style. If `NULL`, it will produce a table similar to `rtables` default. Defaults+ ) |
||
| 742 | +1772 |
- #' to `theme_docx_default(tt)`.+ |
||
| 743 | +1773 |
- #' @param border (`officer` border object)\cr defaults to `officer::fp_border(width = 0.5)`.+ #' @rdname int_methods |
||
| 744 | +1774 |
- #' @param indent_size (`integer(1)`)\cr if `NULL`, the default indent size of the table (see [matrix_form()]+ setMethod( |
||
| 745 | +1775 |
- #' `indent_size`) is used. To work with `docx`, any size is multiplied by 2 mm (5.67 pt) by default.+ "fix_dyncuts", "VTableTree",+ |
+ ||
| 1776 | +1x | +
+ function(spl, df) spl |
||
| 746 | +1777 |
- #' @param titles_as_header (`flag`)\cr defaults to `TRUE` for [tt_to_flextable()], so the table is self-contained+ ) |
||
| 747 | +1778 |
- #' as it makes additional header rows for [main_title()] string and [subtitles()] character vector (one per element).+ |
||
| 748 | +1779 |
- #' `FALSE` is suggested for [export_as_docx()]. This adds titles and subtitles as a text paragraph above the table.+ .fd_helper <- function(spl, df) {
+ |
+ ||
| 1780 | +1350x | +
+ lst <- lapply(spl, fix_dyncuts, df = df)+ |
+ ||
| 1781 | +1350x | +
+ spl@.Data <- lst+ |
+ ||
| 1782 | +1350x | +
+ spl |
||
| 749 | +1783 |
- #' The same style is applied.+ } |
||
| 750 | +1784 |
- #' @param footers_as_text (`flag`)\cr defaults to `FALSE` for [tt_to_flextable()], so the table is self-contained with+ |
||
| 751 | +1785 |
- #' the `flextable` definition of footnotes. `TRUE` is used for [export_as_docx()] to add the footers as a new+ #' @rdname int_methods |
||
| 752 | +1786 |
- #' paragraph after the table. The same style is applied, but with a smaller font.+ setMethod( |
||
| 753 | +1787 |
- #' @param counts_in_newline (`flag`)\cr defaults to `FALSE`. In `rtables` text printing ([formatters::toString()]),+ "fix_dyncuts", "PreDataRowLayout", |
||
| 754 | +1788 |
- #' the column counts, i.e. `(N=xx)`, are always on a new line. For `docx` exports it could be necessary to print it+ function(spl, df) {
|
||
| 755 | +1789 |
- #' on the same line.+ # rt = root_spl(spl)+ |
+ ||
| 1790 | +329x | +
+ ret <- .fd_helper(spl, df) |
||
| 756 | +1791 |
- #' @param paginate (`flag`)\cr when exporting `.docx` documents using `export_as_docx`, we suggest relying on the+ # root_spl(ret) = rt+ |
+ ||
| 1792 | +329x | +
+ ret |
||
| 757 | +1793 |
- #' Microsoft Word pagination system. If `TRUE`, this option splits `tt` into different "pages" as multiple+ } |
||
| 758 | +1794 |
- #' `flextables`. Cooperation between the two mechanisms is not guaranteed. Defaults to `FALSE`.+ ) |
||
| 759 | +1795 |
- #' @param total_width (`numeric(1)`)\cr total width (in inches) for the resulting flextable(s). Defaults to 10.+ |
||
| 760 | +1796 |
- #'+ #' @rdname int_methods |
||
| 761 | +1797 |
- #' @return A `flextable` object.+ setMethod( |
||
| 762 | +1798 |
- #'+ "fix_dyncuts", "PreDataColLayout", |
||
| 763 | +1799 |
- #' @seealso [export_as_docx()]+ function(spl, df) {
|
||
| 764 | +1800 |
- #'+ # rt = root_spl(spl)+ |
+ ||
| 1801 | +329x | +
+ ret <- .fd_helper(spl, df) |
||
| 765 | +1802 |
- #' @examples+ # root_spl(ret) = rt |
||
| 766 | +1803 |
- #' analysisfun <- function(x, ...) {
+ # disp_ccounts(ret) = disp_ccounts(spl) |
||
| 767 | +1804 |
- #' in_rows(+ # colcount_format(ret) = colcount_format(spl)+ |
+ ||
| 1805 | +329x | +
+ ret |
||
| 768 | +1806 |
- #' row1 = 5,+ } |
||
| 769 | +1807 |
- #' row2 = c(1, 2),+ ) |
||
| 770 | +1808 |
- #' .row_footnotes = list(row1 = "row 1 - row footnote"),+ |
||
| 771 | +1809 |
- #' .cell_footnotes = list(row2 = "row 2 - cell footnote")+ #' @rdname int_methods |
||
| 772 | +1810 |
- #' )+ setMethod( |
||
| 773 | +1811 |
- #' }+ "fix_dyncuts", "SplitVector", |
||
| 774 | +1812 |
- #'+ function(spl, df) {
+ |
+ ||
| 1813 | +692x | +
+ .fd_helper(spl, df) |
||
| 775 | +1814 |
- #' lyt <- basic_table(+ } |
||
| 776 | +1815 |
- #' title = "Title says Whaaaat", subtitles = "Oh, ok.",+ ) |
||
| 777 | +1816 |
- #' main_footer = "ha HA! Footer!"+ |
||
| 778 | +1817 |
- #' ) %>%+ #' @rdname int_methods |
||
| 779 | +1818 |
- #' split_cols_by("ARM") %>%
+ setMethod( |
||
| 780 | +1819 |
- #' analyze("AGE", afun = analysisfun)
+ "fix_dyncuts", "PreDataTableLayouts", |
||
| 781 | +1820 |
- #'+ function(spl, df) {
+ |
+ ||
| 1821 | +329x | +
+ rlayout(spl) <- fix_dyncuts(rlayout(spl), df)+ |
+ ||
| 1822 | +329x | +
+ clayout(spl) <- fix_dyncuts(clayout(spl), df)+ |
+ ||
| 1823 | +329x | +
+ spl |
||
| 782 | +1824 |
- #' tbl <- build_table(lyt, ex_adsl)+ } |
||
| 783 | +1825 |
- #' # rtables style+ ) |
||
| 784 | +1826 |
- #' tt_to_flextable(tbl, theme = NULL)+ |
||
| 785 | +1827 |
- #'+ ## Manual column construction in a simple (seeming to the user) way. |
||
| 786 | +1828 |
- #' tt_to_flextable(tbl, theme = theme_docx_default(tbl, font_size = 7))+ #' Manual column declaration |
||
| 787 | +1829 |
#' |
||
| 788 | +1830 |
- #' @export+ #' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given, |
||
| 789 | +1831 |
- tt_to_flextable <- function(tt,+ #' the values of the second are nested within each value of the first, and so on. |
||
| 790 | +1832 |
- theme = theme_docx_default(tt),+ #' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`. |
||
| 791 | +1833 |
- border = flextable::fp_border_default(width = 0.5),+ #' @param ccount_format (`FormatSpec`)\cr the format to use when counts are displayed. |
||
| 792 | +1834 |
- indent_size = NULL,+ #' |
||
| 793 | +1835 |
- titles_as_header = TRUE,+ #' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed |
||
| 794 | +1836 |
- footers_as_text = FALSE,+ #' table. |
||
| 795 | +1837 |
- counts_in_newline = FALSE,+ #' |
||
| 796 | +1838 |
- paginate = FALSE,+ #' @examples |
||
| 797 | +1839 |
- lpp = NULL,+ #' # simple one level column space |
||
| 798 | +1840 |
- cpp = NULL,+ #' rows <- lapply(1:5, function(i) {
|
||
| 799 | +1841 |
- ...,+ #' DataRow(rep(i, times = 3)) |
||
| 800 | +1842 |
- colwidths = propose_column_widths(matrix_form(tt, indent_rownames = TRUE)),+ #' }) |
||
| 801 | +1843 |
- tf_wrap = !is.null(cpp),+ #' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
|
||
| 802 | +1844 |
- max_width = cpp,+ #' tbl |
||
| 803 | +1845 |
- total_width = 10) {
+ #' |
||
| 804 | -13x | +|||
| 1846 | +
- check_required_packages("flextable")
+ #' # manually declared nesting |
|||
| 805 | -13x | +|||
| 1847 | +
- if (!inherits(tt, "VTableTree")) {
+ #' tbl2 <- TableTree( |
|||
| 806 | -! | +|||
| 1848 | +
- stop("Input table is not an rtables' object.")
+ #' kids = list(DataRow(as.list(1:4))), |
|||
| 807 | +1849 |
- }+ #' cinfo = manual_cols( |
||
| 808 | -13x | +|||
| 1850 | +
- checkmate::assert_flag(titles_as_header)+ #' Arm = c("Arm A", "Arm B"),
|
|||
| 809 | -13x | +|||
| 1851 | +
- checkmate::assert_flag(footers_as_text)+ #' Gender = c("M", "F")
|
|||
| 810 | -13x | +|||
| 1852 | +
- checkmate::assert_flag(counts_in_newline)+ #' ) |
|||
| 811 | +1853 |
-
+ #' ) |
||
| 812 | +1854 |
- ## if we're paginating, just call -> pagination happens also afterwards if needed+ #' tbl2 |
||
| 813 | -13x | +|||
| 1855 | +
- if (paginate) {
+ #' |
|||
| 814 | -1x | +|||
| 1856 | +
- if (is.null(lpp)) {
+ #' @author Gabriel Becker |
|||
| 815 | -! | +|||
| 1857 | +
- stop("lpp must be specified when calling tt_to_flextable with paginate=TRUE")
+ #' @export |
|||
| 816 | +1858 |
- }+ manual_cols <- function(..., .lst = list(...), ccount_format = NULL) {
|
||
| 817 | -1x | +1859 | +40x |
- tabs <- paginate_table(tt, lpp = lpp, cpp = cpp, tf_wrap = tf_wrap, max_width = max_width, ...)+ if (is.null(names(.lst))) {
|
| 818 | -1x | +1860 | +40x |
- cinds <- lapply(tabs, function(tb) c(1, .figure_out_colinds(tb, tt) + 1L))+ names(.lst) <- paste("colsplit", seq_along(.lst))
|
| 819 | -1x | +|||
| 1861 | +
- return(mapply(tt_to_flextable,+ }+ |
+ |||
| 1862 | ++ | + | ||
| 820 | -1x | +1863 | +40x |
- tt = tabs, colwidths = cinds,+ splvec <- SplitVector(lst = mapply(ManualSplit, |
| 821 | -1x | +1864 | +40x |
- MoreArgs = list(paginate = FALSE, total_width = total_width),+ levels = .lst, |
| 822 | -1x | +1865 | +40x |
- SIMPLIFY = FALSE+ label = names(.lst) |
| 823 | +1866 |
- ))+ )) |
||
| 824 | -+ | |||
| 1867 | +40x |
- }+ ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos(), global_cc_format = ccount_format) |
||
| 825 | +1868 | |||
| 826 | -+ | |||
| 1869 | +40x |
- # Calculate the needed colwidths+ ret <- InstantiatedColumnInfo(treelyt = ctree) |
||
| 827 | -12x | +1870 | +40x |
- final_cwidths <- total_width * colwidths / sum(colwidths) # xxx to fix+ rm_all_colcounts(ret) |
| 828 | +1871 |
- # xxx FIXME missing transformer from character based widths to mm or pt+ } |
||
| 829 | +1872 | |||
| 830 | +1873 |
- # Extract relevant information- |
- ||
| 831 | -12x | -
- matform <- matrix_form(tt, indent_rownames = TRUE)- |
- ||
| 832 | -12x | -
- body <- mf_strings(matform) # Contains header+ |
||
| 833 | -12x | +|||
| 1874 | +
- spans <- mf_spans(matform) # Contains header+ #' Set all column counts at all levels of nesting to NA |
|||
| 834 | -12x | +|||
| 1875 | +
- mpf_aligns <- mf_aligns(matform) # Contains header+ #' |
|||
| 835 | -12x | +|||
| 1876 | +
- hnum <- mf_nlheader(matform) # Number of lines for the header+ #' @inheritParams gen_args |
|||
| 836 | -12x | +|||
| 1877 | +
- rdf <- make_row_df(tt) # Row-wise info+ #' |
|||
| 837 | +1878 |
-
+ #' @return `obj` with all column counts reset to missing |
||
| 838 | +1879 |
- # decimal alignment pre-proc+ #' |
||
| 839 | -12x | +|||
| 1880 | +
- if (any(grepl("dec", mpf_aligns))) {
+ #' @export |
|||
| 840 | -! | +|||
| 1881 | +
- body <- decimal_align(body, mpf_aligns)+ #' @examples |
|||
| 841 | +1882 |
- # Coercion for flextable+ #' lyt <- basic_table() %>% |
||
| 842 | -! | +|||
| 1883 | +
- mpf_aligns[mpf_aligns == "decimal"] <- "center"+ #' split_cols_by("ARM") %>%
|
|||
| 843 | -! | +|||
| 1884 | +
- mpf_aligns[mpf_aligns == "dec_left"] <- "left"+ #' split_cols_by("SEX") %>%
|
|||
| 844 | -! | +|||
| 1885 | +
- mpf_aligns[mpf_aligns == "dec_right"] <- "right"+ #' analyze("AGE")
|
|||
| 845 | +1886 |
- }+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 846 | +1887 |
-
+ #' |
||
| 847 | +1888 |
- # Fundamental content of the table+ #' # before |
||
| 848 | -12x | +|||
| 1889 | +
- content <- as.data.frame(body[-seq_len(hnum), , drop = FALSE])+ #' col_counts(tbl) |
|||
| 849 | -12x | +|||
| 1890 | +
- flx <- flextable::qflextable(content) %>%+ #' tbl <- rm_all_colcounts(tbl) |
|||
| 850 | +1891 |
- # Default rtables if no footnotes+ #' col_counts(tbl) |
||
| 851 | -12x | +1892 | +215x |
- remove_hborder(part = "body", w = "bottom")+ setGeneric("rm_all_colcounts", function(obj) standardGeneric("rm_all_colcounts"))
|
| 852 | +1893 | |||
| 853 | +1894 |
- # Header addition -> NB: here we have a problem with (N=xx)- |
- ||
| 854 | -12x | -
- hdr <- body[seq_len(hnum), , drop = FALSE]+ #' @rdname rm_all_colcounts |
||
| 855 | +1895 |
-
+ #' @export |
||
| 856 | +1896 |
- # IMPORTANT: Fix of (N=xx) which is by default on a new line but we usually do not+ setMethod( |
||
| 857 | +1897 |
- # want this, and it depends on the size of the table, it is not another+ "rm_all_colcounts", "VTableTree", |
||
| 858 | +1898 |
- # row with different columns -> All of this should be fixed at source (in toString)+ function(obj) {
|
||
| 859 | -12x | +|||
| 1899 | +! |
- if (hnum > 1) { # otherwise nothing to do
+ cinfo <- col_info(obj) |
||
| 860 | -12x | +|||
| 1900 | +! |
- det_nclab <- apply(hdr, 2, grepl, pattern = "\\(N=[0-9]+\\)$")+ cinfo <- rm_all_colcounts(cinfo) |
||
| 861 | -12x | +|||
| 1901 | +! |
- has_nclab <- apply(det_nclab, 1, any)+ col_info(obj) <- cinfo |
||
| 862 | -12x | +|||
| 1902 | +! |
- if (isFALSE(counts_in_newline) && any(has_nclab)) {
+ obj |
||
| 863 | -5x | +|||
| 1903 | +
- whsnc <- which(has_nclab) # which rows have it+ } |
|||
| 864 | -5x | +|||
| 1904 | +
- what_is_nclab <- det_nclab[whsnc, ]+ ) |
|||
| 865 | +1905 | |||
| 866 | +1906 |
- # condition for popping the interested row by merging the upper one- |
- ||
| 867 | -5x | -
- hdr[whsnc, what_is_nclab] <- paste(hdr[whsnc - 1, what_is_nclab],- |
- ||
| 868 | -5x | -
- hdr[whsnc, what_is_nclab],- |
- ||
| 869 | -5x | -
- sep = " "+ #' @rdname rm_all_colcounts |
||
| 870 | +1907 |
- )+ #' @export |
||
| 871 | -5x | +|||
| 1908 | +
- hdr[whsnc - 1, what_is_nclab] <- ""+ setMethod( |
|||
| 872 | +1909 |
-
+ "rm_all_colcounts", "InstantiatedColumnInfo", |
||
| 873 | +1910 |
- # We can remove the row if they are all ""+ function(obj) {
|
||
| 874 | -5x | +1911 | +40x |
- row_to_pop <- whsnc - 1+ ctree <- coltree(obj) |
| 875 | -5x | +1912 | +40x |
- if (all(!nzchar(hdr[row_to_pop, ]))) {
+ ctree <- rm_all_colcounts(ctree) |
| 876 | -4x | +1913 | +40x |
- hdr <- hdr[-row_to_pop, , drop = FALSE]+ coltree(obj) <- ctree |
| 877 | -4x | +1914 | +40x |
- spans <- spans[-row_to_pop, , drop = FALSE]+ obj |
| 878 | -4x | +|||
| 1915 | +
- body <- body[-row_to_pop, , drop = FALSE]+ } |
|||
| 879 | -4x | +|||
| 1916 | +
- mpf_aligns <- mpf_aligns[-row_to_pop, , drop = FALSE]+ ) |
|||
| 880 | -4x | +|||
| 1917 | +
- hnum <- hnum - 1+ |
|||
| 881 | +1918 |
- }+ #' @rdname rm_all_colcounts |
||
| 882 | +1919 |
- }+ #' @export |
||
| 883 | +1920 |
- }+ setMethod( |
||
| 884 | +1921 |
-
+ "rm_all_colcounts", "LayoutColTree", |
||
| 885 | -12x | +|||
| 1922 | +
- flx <- flx %>%+ function(obj) {
|
|||
| 886 | -12x | +1923 | +51x |
- flextable::set_header_labels( # Needed bc headers must be unique+ obj@column_count <- NA_integer_ |
| 887 | -12x | +1924 | +51x |
- values = setNames(+ tree_children(obj) <- lapply(tree_children(obj), rm_all_colcounts) |
| 888 | -12x | +1925 | +51x |
- as.vector(hdr[hnum, , drop = TRUE]),+ obj |
| 889 | -12x | +|||
| 1926 | +
- names(content)+ } |
|||
| 890 | +1927 |
- )+ ) |
||
| 891 | +1928 |
- )+ |
||
| 892 | +1929 |
- # If there are more rows+ #' @rdname rm_all_colcounts |
||
| 893 | -12x | +|||
| 1930 | +
- if (hnum > 1) {
+ #' @export |
|||
| 894 | -11x | +|||
| 1931 | +
- for (i in seq(hnum - 1, 1)) {
+ setMethod( |
|||
| 895 | -11x | +|||
| 1932 | +
- sel <- spans_to_viscell(spans[i, ])+ "rm_all_colcounts", "LayoutColLeaf", |
|||
| 896 | -11x | +|||
| 1933 | +
- flx <- flextable::add_header_row(+ function(obj) {
|
|||
| 897 | -11x | +1934 | +124x |
- flx,+ obj@column_count <- NA_integer_ |
| 898 | -11x | +1935 | +124x |
- top = TRUE,+ obj |
| 899 | -11x | +|||
| 1936 | +
- values = as.vector(hdr[i, sel]),+ } |
|||
| 900 | -11x | +|||
| 1937 | +
- colwidths = as.integer(spans[i, sel]) # xxx to fix+ ) |
|||
| 901 | +1938 |
- )+ |
||
| 902 | +1939 |
- }+ #' Returns a function that coerces the return values of a function to a list |
||
| 903 | +1940 |
- }+ #' |
||
| 904 | +1941 |
-
+ #' @param f (`function`)\cr the function to wrap. |
||
| 905 | +1942 |
- # Polish the inner horizontal borders from the header+ #' |
||
| 906 | -12x | +|||
| 1943 | +
- flx <- flx %>%+ #' @details |
|||
| 907 | -12x | +|||
| 1944 | +
- remove_hborder(part = "header", w = "all") %>%+ #' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an |
|||
| 908 | -12x | +|||
| 1945 | +
- add_hborder("header", ii = c(0, hnum), border = border)
+ #' otherwise identical wrapper function whose first argument is named `df`. |
|||
| 909 | +1946 |
-
+ #' |
||
| 910 | +1947 |
- # ALIGNS+ #' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as |
||
| 911 | -12x | +|||
| 1948 | +
- flx <- flx %>%+ #' their first argument are passed the full subset data frame, while those which accept anything else notably |
|||
| 912 | -12x | +|||
| 1949 | +
- apply_alignments(mpf_aligns[seq_len(hnum), , drop = FALSE], "header") %>%+ #' including `x` are passed only the relevant subset of the variable being analyzed. |
|||
| 913 | -12x | +|||
| 1950 | +
- apply_alignments(mpf_aligns[-seq_len(hnum), , drop = FALSE], "body")+ #' |
|||
| 914 | +1951 |
-
+ #' @return A function that returns a list of `CellValue` objects. |
||
| 915 | +1952 |
- # Rownames indentation+ #' |
||
| 916 | -12x | +|||
| 1953 | +
- checkmate::check_int(indent_size, null.ok = TRUE)+ #' @examples |
|||
| 917 | -12x | +|||
| 1954 | +
- if (is.null(indent_size)) {
+ #' summary(iris$Sepal.Length) |
|||
| 918 | -12x | +|||
| 1955 | +
- indent_size <- matform$indent_size * word_mm_to_pt(2) # default is 2mm (5.7pt)+ #' |
|||
| 919 | +1956 |
- }+ #' f <- list_wrap_x(summary) |
||
| 920 | -12x | +|||
| 1957 | +
- for (i in seq_len(NROW(tt))) {
+ #' f(x = iris$Sepal.Length) |
|||
| 921 | -229x | +|||
| 1958 | +
- flx <- flextable::padding(flx,+ #' |
|||
| 922 | -229x | +|||
| 1959 | +
- i = i, j = 1,+ #' f2 <- list_wrap_df(summary) |
|||
| 923 | -229x | +|||
| 1960 | +
- padding.left = indent_size * rdf$indent[[i]] + word_mm_to_pt(0.1), # 0.1 mmm in pt+ #' f2(df = iris$Sepal.Length) |
|||
| 924 | -229x | +|||
| 1961 | +
- padding.right = word_mm_to_pt(0.1) # 0.1 mmm in pt (so not to touch the border)+ #' |
|||
| 925 | +1962 |
- )+ #' @author Gabriel Becker |
||
| 926 | +1963 |
- }+ #' @rdname list_wrap |
||
| 927 | +1964 |
-
+ #' @export |
||
| 928 | +1965 |
- # Adding referantial footer line separator if present+ list_wrap_x <- function(f) {
|
||
| 929 | -12x | +1966 | +17x |
- if (length(matform$ref_footnotes) > 0 && isFALSE(footers_as_text)) {
+ function(x, ...) {
|
| 930 | -7x | +1967 | +74x |
- flx <- flextable::add_footer_lines(flx, values = matform$ref_footnotes) %>%+ vs <- as.list(f(x, ...)) |
| 931 | -7x | +1968 | +74x |
- add_hborder(part = "body", ii = nrow(tt), border = border)+ ret <- mapply( |
| 932 | -+ | |||
| 1969 | +74x |
- }+ function(v, nm) {
|
||
| 933 | -+ | |||
| 1970 | +258x |
-
+ rcell(v, label = nm) |
||
| 934 | +1971 |
- # Footer lines+ }, |
||
| 935 | -12x | +1972 | +74x |
- if (length(all_footers(tt)) > 0 && isFALSE(footers_as_text)) {
+ v = vs, |
| 936 | -1x | -
- flx <- flextable::add_footer_lines(flx, values = all_footers(tt))- |
- ||
| 937 | -+ | 1973 | +74x |
- }+ nm = names(vs) |
| 938 | +1974 |
-
+ ) |
||
| 939 | -12x | +1975 | +74x |
- flx <- flextable::width(flx, width = final_cwidths) # xxx to fix+ ret |
| 940 | +1976 |
-
+ } |
||
| 941 | -12x | +|||
| 1977 | +
- if (!is.null(theme)) {
+ } |
|||
| 942 | -11x | +|||
| 1978 | +
- flx <- theme(flx)+ |
|||
| 943 | +1979 |
- }+ #' @rdname list_wrap |
||
| 944 | +1980 |
-
+ #' @export |
||
| 945 | +1981 |
- # Title lines (after theme for problems with lines)+ list_wrap_df <- function(f) {
|
||
| 946 | -11x | +1982 | +1x |
- if (titles_as_header && length(all_titles(tt)) > 0 && any(nzchar(all_titles(tt)))) {
+ function(df, ...) {
|
| 947 | +1983 | 1x |
- real_titles <- all_titles(tt)+ vs <- as.list(f(df, ...)) |
|
| 948 | +1984 | 1x |
- real_titles <- real_titles[nzchar(real_titles)]+ ret <- mapply( |
|
| 949 | +1985 | 1x |
- flx <- flextable::add_header_lines(flx, values = real_titles, top = TRUE) %>%- |
- |
| 950 | -- |
- # Remove the added borders+ function(v, nm) {
|
||
| 951 | -1x | +1986 | +6x |
- remove_hborder(part = "header", w = c("inner", "top")) %>%
+ rcell(v, label = nm) |
| 952 | +1987 |
- # Re-add the separator between titles and real headers- |
- ||
| 953 | -1x | -
- add_hborder(+ }, |
||
| 954 | +1988 | 1x |
- part = "header", ii = length(real_titles),+ v = vs, |
|
| 955 | +1989 | 1x |
- border = border- |
- |
| 956 | -- |
- ) %>%+ nm = names(vs) |
||
| 957 | +1990 |
- # Remove vertical borders added by theme eventually+ ) |
||
| 958 | +1991 | 1x |
- remove_vborder(part = "header", ii = seq_along(real_titles))+ ret |
|
| 959 | +1992 |
} |
||
| 960 | +1993 |
-
+ } |
||
| 961 | +1994 |
- # These final formatting need to work with colwidths+ |
||
| 962 | -11x | +|||
| 1995 | +
- flx <- flextable::set_table_properties(flx, layout = "autofit", align = "left") # xxx to fix+ #' Layout with 1 column and zero rows |
|||
| 963 | +1996 |
- # NB: autofit or fixed may be switched if widths are correctly staying in the page+ #' |
||
| 964 | -11x | +|||
| 1997 | +
- flx <- flextable::fix_border_issues(flx) # Fixes some rendering gaps in borders+ #' Every layout must start with a basic table. |
|||
| 965 | +1998 |
-
+ #' |
||
| 966 | -11x | +|||
| 1999 | +
- flx+ #' @inheritParams constr_args |
|||
| 967 | +2000 |
- }+ #' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of |
||
| 968 | +2001 |
-
+ #' applied to data. `NA`, the default, indicates that the `show_colcounts` |
||
| 969 | +2002 |
- #' @describeIn tt_to_flextable Main theme function for [export_as_docx()]+ #' argument(s) passed to the relevant calls to `split_cols_by*` |
||
| 970 | +2003 |
- #'+ #' functions. Non-missing values will override the behavior specified in |
||
| 971 | +2004 |
- #' @inheritParams export_as_docx+ #' column splitting layout instructions which create the lowest level, or |
||
| 972 | +2005 |
- #' @param font (`string`)\cr defaults to `"Arial"`. If the font is not available, `flextable` default is used.+ #' leaf, columns. |
||
| 973 | +2006 |
- #' @param font_size (`integer(1)`)\cr font size. Defaults to 9.+ #' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d |
||
| 974 | +2007 |
- #' @param bold (`character`)\cr parts of the table text that should be in bold. Can be any combination of+ #' where one component is a percent. This will also apply to any displayed higher |
||
| 975 | +2008 |
- #' `c("header", "content_rows", "label_rows")`. The first one renders all column names bold (not `topleft` content).
+ #' level column counts where an explicit format was not specified. Defaults to `"(N=xx)"`. See Details below. |
||
| 976 | +2009 |
- #' The second and third option use [rtables::make_row_df()] to render content or/and label rows as bold.+ #' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split |
||
| 977 | +2010 |
- #' @param bold_manual (named `list` or `NULL`)\cr list of index lists. See example for needed structure. Accepted+ #' or division of the table will be highlighted by a line made of that character. See [section_div] for more |
||
| 978 | +2011 |
- #' groupings/names are `c("header", "body")`.
+ #' information. |
||
| 979 | +2012 |
#' |
||
| 980 | +2013 |
- #' @seealso [export_as_docx()]+ #' @details |
||
| 981 | +2014 |
- #'+ #' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`, |
||
| 982 | +2015 |
- #' @examples+ #' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always |
||
| 983 | +2016 |
- #' # Custom theme+ #' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be, |
||
| 984 | +2017 |
- #' special_bold <- list(+ #' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of |
||
| 985 | +2018 |
- #' "header" = list("i" = 1, "j" = c(1, 3)),
+ #' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list |
||
| 986 | +2019 |
- #' "body" = list("i" = c(1, 2), "j" = 1)
+ #' of valid format labels to select from. |
||
| 987 | +2020 |
- #' )+ #' |
||
| 988 | +2021 |
- #' custom_theme <- theme_docx_default(tbl,+ #' @inherit split_cols_by return |
||
| 989 | +2022 |
- #' font_size = 10,+ #' |
||
| 990 | +2023 |
- #' font = "Brush Script MT",+ #' @note |
||
| 991 | +2024 |
- #' border = flextable::fp_border_default(color = "pink", width = 2),+ #' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably |
||
| 992 | +2025 |
- #' bold = NULL,+ #' strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as |
||
| 993 | +2026 |
- #' bold_manual = special_bold+ #' their percentage, even though the individual arm columns represent strict subsets of the "all patients" column. |
||
| 994 | +2027 |
- #' )+ #' |
||
| 995 | +2028 |
- #' tt_to_flextable(tbl,+ #' - Note that subtitles ([subtitles()]) and footers ([main_footer()] and [prov_footer()]) that span more than one |
||
| 996 | +2029 |
- #' border = flextable::fp_border_default(color = "pink", width = 2),+ #' line can be supplied as a character vector to maintain indentation on multiple lines. |
||
| 997 | +2030 |
- #' theme = custom_theme+ #' |
||
| 998 | +2031 |
- #' )+ #' @examples |
||
| 999 | +2032 |
- #'+ #' lyt <- basic_table() %>% |
||
| 1000 | +2033 |
- #' @export+ #' analyze("AGE", afun = mean)
|
||
| 1001 | +2034 |
- theme_docx_default <- function(tt = NULL, # Option for more complicated stuff+ #' |
||
| 1002 | +2035 |
- font = "Arial",+ #' tbl <- build_table(lyt, DM) |
||
| 1003 | +2036 |
- font_size = 9,+ #' tbl |
||
| 1004 | +2037 |
- bold = c("header", "content_rows", "label_rows"),
+ #' |
||
| 1005 | +2038 |
- bold_manual = NULL,+ #' lyt2 <- basic_table( |
||
| 1006 | +2039 |
- border = flextable::fp_border_default(width = 0.5)) {
- |
- ||
| 1007 | -11x | -
- function(flx) {
+ #' title = "Title of table", |
||
| 1008 | -11x | +|||
| 2040 | +
- check_required_packages("flextable")
+ #' subtitles = c("a number", "of subtitles"),
|
|||
| 1009 | -11x | +|||
| 2041 | +
- if (!inherits(flx, "flextable")) {
+ #' main_footer = "test footer", |
|||
| 1010 | -! | +|||
| 2042 | +
- stop(sprintf(+ #' prov_footer = paste( |
|||
| 1011 | -! | +|||
| 2043 | +
- "Function `%s` supports only flextable objects.",+ #' "test.R program, executed at", |
|||
| 1012 | -! | +|||
| 2044 | +
- "theme_box()"+ #' Sys.time() |
|||
| 1013 | +2045 |
- ))+ #' ) |
||
| 1014 | +2046 |
- }+ #' ) %>% |
||
| 1015 | -11x | +|||
| 2047 | +
- if (!is.null(tt) && !inherits(tt, "VTableTree")) {
+ #' split_cols_by("ARM") %>%
|
|||
| 1016 | -! | +|||
| 2048 | +
- stop("Input table is not an rtables' object.")
+ #' analyze("AGE", mean)
|
|||
| 1017 | +2049 |
- }+ #' |
||
| 1018 | -11x | +|||
| 2050 | +
- checkmate::assert_int(font_size, lower = 1)+ #' tbl2 <- build_table(lyt2, DM) |
|||
| 1019 | -11x | +|||
| 2051 | +
- checkmate::assert_string(font)+ #' tbl2 |
|||
| 1020 | -11x | +|||
| 2052 | +
- checkmate::assert_subset(bold,+ #' |
|||
| 1021 | -11x | +|||
| 2053 | +
- eval(formals(theme_docx_default)$bold),+ #' lyt3 <- basic_table( |
|||
| 1022 | -11x | +|||
| 2054 | +
- empty.ok = TRUE+ #' show_colcounts = TRUE, |
|||
| 1023 | +2055 |
- )+ #' colcount_format = "xx. (xx.%)" |
||
| 1024 | +2056 |
-
+ #' ) %>% |
||
| 1025 | +2057 |
- # Font setting+ #' split_cols_by("ARM")
|
||
| 1026 | -11x | +|||
| 2058 | +
- flx <- flextable::fontsize(flx, size = font_size, part = "all") %>%+ #' |
|||
| 1027 | -11x | +|||
| 2059 | +
- flextable::fontsize(size = font_size - 1, part = "footer") %>%+ #' @export |
|||
| 1028 | -11x | +|||
| 2060 | +
- flextable::font(fontname = font, part = "all")+ basic_table <- function(title = "", |
|||
| 1029 | +2061 |
-
+ subtitles = character(), |
||
| 1030 | +2062 |
- # Vertical borders+ main_footer = character(), |
||
| 1031 | -11x | +|||
| 2063 | +
- flx <- flx %>%+ prov_footer = character(), |
|||
| 1032 | -11x | +|||
| 2064 | +
- flextable::border_outer(part = "body", border = border) %>%+ show_colcounts = NA, # FALSE, |
|||
| 1033 | -11x | +|||
| 2065 | +
- flextable::border_outer(part = "header", border = border)+ colcount_format = "(N=xx)", |
|||
| 1034 | +2066 |
-
+ header_section_div = NA_character_, |
||
| 1035 | +2067 |
- # Vertical alignment -> all top for now, we will set it for the future+ top_level_section_div = NA_character_, |
||
| 1036 | -11x | +|||
| 2068 | +
- flx <- flx %>%+ inset = 0L) {
|
|||
| 1037 | -11x | +2069 | +311x |
- flextable::valign(j = 2:(NCOL(tt) + 1), valign = "top", part = "body") %>%+ inset <- as.integer(inset) |
| 1038 | -11x | +2070 | +311x |
- flextable::valign(j = 1, valign = "top", part = "body") %>%+ if (is.na(inset) || inset < 0L) {
|
| 1039 | -11x | -
- flextable::valign(j = 2:(NCOL(tt) + 1), valign = "top", part = "header")- |
- ||
| 1040 | -+ | 2071 | +2x |
-
+ stop("Got invalid table_inset value, must be an integer > 0")
|
| 1041 | +2072 |
- # Bold settings+ } |
||
| 1042 | -11x | +2073 | +309x |
- if (any(bold == "header")) {
+ .check_header_section_div(header_section_div) |
| 1043 | -9x | -
- flx <- flextable::bold(flx, j = 2:(NCOL(tt) + 1), part = "header") # Done with theme- |
- ||
| 1044 | -+ | 2074 | +309x |
- }+ checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1) |
| 1045 | +2075 |
- # Content rows are effectively our labels in row names+ |
||
| 1046 | -11x | -
- if (any(bold == "content_rows")) {
- |
- ||
| 1047 | -! | +2076 | +309x |
- if (is.null(tt)) stop('bold = "content_rows" needs the original rtables object (tt).')
+ ret <- PreDataTableLayouts( |
| 1048 | -9x | +2077 | +309x |
- rdf <- make_row_df(tt)+ title = title, |
| 1049 | -9x | +2078 | +309x |
- which_body <- which(rdf$node_class == "ContentRow")+ subtitles = subtitles, |
| 1050 | -9x | -
- flx <- flextable::bold(flx, j = 1, i = which_body, part = "body")- |
- ||
| 1051 | -+ | 2079 | +309x |
- }+ main_footer = main_footer, |
| 1052 | -11x | -
- if (any(bold == "label_rows")) {
- |
- ||
| 1053 | -! | +2080 | +309x |
- if (is.null(tt)) stop('bold = "content_rows" needs the original rtables object (tt).')
+ prov_footer = prov_footer, |
| 1054 | -9x | +2081 | +309x |
- rdf <- make_row_df(tt)+ header_section_div = header_section_div, |
| 1055 | -9x | +2082 | +309x |
- which_body <- which(rdf$node_class == "LabelRow")+ top_level_section_div = top_level_section_div, |
| 1056 | -9x | +2083 | +309x |
- flx <- flextable::bold(flx, j = 1, i = which_body, part = "body")+ table_inset = as.integer(inset) |
| 1057 | +2084 |
- }+ ) |
||
| 1058 | +2085 |
- # If you want specific cells to be bold+ |
||
| 1059 | -11x | +|||
| 2086 | +
- if (!is.null(bold_manual)) {
+ ## unconditional now, NA case is handled in cinfo construction |
|||
| 1060 | -2x | +2087 | +309x |
- checkmate::assert_list(bold_manual)+ disp_ccounts(ret) <- show_colcounts |
| 1061 | -2x | +2088 | +309x |
- valid_sections <- c("header", "body") # Only valid values
+ colcount_format(ret) <- colcount_format |
| 1062 | -2x | +|||
| 2089 | +
- checkmate::assert_subset(names(bold_manual), valid_sections)+ ## if (isTRUE(show_colcounts)) {
|
|||
| 1063 | -2x | +|||
| 2090 | +
- for (bi in seq_along(bold_manual)) {
+ ## ret <- add_colcounts(ret, format = colcount_format) |
|||
| 1064 | -3x | +|||
| 2091 | +
- bld_tmp <- bold_manual[[bi]]+ ## } |
|||
| 1065 | -3x | +2092 | +309x |
- checkmate::assert_list(bld_tmp)+ ret |
| 1066 | -3x | +|||
| 2093 | +
- if (!all(c("i", "j") %in% names(bld_tmp)) || !all(vapply(bld_tmp, checkmate::test_integerish, logical(1)))) {
+ } |
|||
| 1067 | -1x | +|||
| 2094 | +
- stop(+ |
|||
| 1068 | -1x | +|||
| 2095 | +
- "Found an allowed section for manual bold (", names(bold_manual)[bi],
+ #' Append a description to the 'top-left' materials for the layout |
|||
| 1069 | -1x | +|||
| 2096 | +
- ") that was not a named list with i (row) and j (col) integer vectors."+ #' |
|||
| 1070 | +2097 |
- )+ #' This function *adds* `newlines` to the current set of "top-left materials". |
||
| 1071 | +2098 |
- }+ #' |
||
| 1072 | -2x | +|||
| 2099 | +
- flx <- flextable::bold(flx,+ #' @details |
|||
| 1073 | -2x | +|||
| 2100 | +
- i = bld_tmp$i, j = bld_tmp$j,+ #' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content |
|||
| 1074 | -2x | +|||
| 2101 | +
- part = names(bold_manual)[bi]+ #' displayed to the left of the column labels when the resulting tables are printed). |
|||
| 1075 | +2102 |
- )+ #' |
||
| 1076 | +2103 |
- }+ #' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to |
||
| 1077 | +2104 |
- }+ #' them either when they are added or when they are displayed. |
||
| 1078 | +2105 |
-
+ #' |
||
| 1079 | +2106 |
- # vertical padding is manual atm and respect doc std+ #' @inheritParams lyt_args |
||
| 1080 | -10x | +|||
| 2107 | +
- flx <- flx %>%+ #' @param newlines (`character`)\cr the new line(s) to be added to the materials. |
|||
| 1081 | +2108 |
- # flextable::padding(j = 2:(NCOL(tt) + 1), padding.top = , part = "body") %>% # not specified+ #' |
||
| 1082 | -10x | +|||
| 2109 | +
- flextable::padding(j = 1, padding.top = 1, padding.bottom = 1, part = "body") %>%+ #' @note |
|||
| 1083 | -10x | +|||
| 2110 | +
- flextable::padding(j = 2:(NCOL(tt) + 1), padding.top = 0, padding.bottom = 3, part = "header")+ #' Currently, where in the construction of the layout this is called makes no difference, as it is independent of |
|||
| 1084 | +2111 |
-
+ #' the actual splitting keywords. This may change in the future. |
||
| 1085 | +2112 |
- # single line spacing (for safety) -> space = 1+ #' |
||
| 1086 | -10x | +|||
| 2113 | +
- flx <- flextable::line_spacing(flx, space = 1, part = "all")+ #' This function is experimental, its name and the details of its behavior are subject to change in future versions. |
|||
| 1087 | +2114 |
-
+ #' |
||
| 1088 | -10x | +|||
| 2115 | +
- flx+ #' @inherit split_cols_by return |
|||
| 1089 | +2116 |
- }+ #' |
||
| 1090 | +2117 |
- }+ #' @seealso [top_left()] |
||
| 1091 | +2118 |
-
+ #' |
||
| 1092 | +2119 |
- # Padding helper functions to transform mm to pt and viceversa+ #' @examples |
||
| 1093 | +2120 |
- # # General note for word: 1pt -> 0.3527777778mm -> 0.013888888888889"+ #' library(dplyr) |
||
| 1094 | +2121 |
- word_inch_to_pt <- function(inch) { # nocov
+ #' |
||
| 1095 | +2122 |
- inch / 0.013888888888889 # nocov+ #' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX)) |
||
| 1096 | +2123 |
- }+ #' |
||
| 1097 | +2124 |
-
+ #' lyt <- basic_table() %>% |
||
| 1098 | +2125 |
- word_mm_to_pt <- function(mm) {
+ #' split_cols_by("ARM") %>%
|
||
| 1099 | -470x | +|||
| 2126 | +
- mm / 0.3527777778+ #' split_cols_by("SEX") %>%
|
|||
| 1100 | +2127 |
- }+ #' split_rows_by("RACE") %>%
|
||
| 1101 | +2128 |
-
+ #' append_topleft("Ethnicity") %>%
|
||
| 1102 | +2129 |
- # Polish horizontal borders+ #' analyze("AGE") %>%
|
||
| 1103 | +2130 |
- remove_hborder <- function(flx, part, w = c("top", "bottom", "inner")) {
+ #' append_topleft(" Age")
|
||
| 1104 | +2131 |
- # If you need to remove all of them+ #' |
||
| 1105 | -25x | +|||
| 2132 | +
- if (length(w) == 1 && w == "all") {
+ #' tbl <- build_table(lyt, DM2) |
|||
| 1106 | -12x | +|||
| 2133 | +
- w <- eval(formals(remove_hborder)$w)+ #' tbl |
|||
| 1107 | +2134 |
- }+ #' |
||
| 1108 | +2135 |
-
+ #' @export |
||
| 1109 | -25x | +|||
| 2136 | +
- if (any(w == "top")) {
+ append_topleft <- function(lyt, newlines) {
|
|||
| 1110 | -13x | +2137 | +53x |
- flx <- flextable::hline_top(flx,+ stopifnot( |
| 1111 | -13x | +2138 | +53x |
- border = flextable::fp_border_default(width = 0),+ is(lyt, "PreDataTableLayouts"), |
| 1112 | -13x | -
- part = part- |
- ||
| 1113 | -+ | 2139 | +53x |
- )+ is(newlines, "character") |
| 1114 | +2140 |
- }+ ) |
||
| 1115 | -25x | +2141 | +53x |
- if (any(w == "bottom")) {
+ lyt@top_left <- c(lyt@top_left, newlines) |
| 1116 | -24x | +2142 | +53x |
- flx <- flextable::hline_bottom(flx,+ lyt |
| 1117 | -24x | +|||
| 2143 | +
- border = flextable::fp_border_default(width = 0),+ } |
|||
| 1118 | -24x | +
| 1 | +
- part = part+ #' Compare two rtables |
||
| 1119 | +2 |
- )+ #' |
|
| 1120 | +3 |
- }+ #' Prints a matrix where `.` means cell matches, `X` means cell does |
|
| 1121 | +4 |
- # Inner horizontal lines removal+ #' not match, `+` cell (row) is missing, and `-` cell (row) |
|
| 1122 | -25x | +||
| 5 | +
- if (any(w == "inner")) {
+ #' should not be there. If `structure` is set to `TRUE`, `C` indicates |
||
| 1123 | -13x | +||
| 6 | +
- flx <- flextable::border_inner_h(+ #' column-structure mismatch, `R` indicates row-structure mismatch, and |
||
| 1124 | -13x | +||
| 7 | +
- flx,+ #' `S` indicates mismatch in both row and column structure. |
||
| 1125 | -13x | +||
| 8 | +
- border = flextable::fp_border_default(width = 0),+ #' |
||
| 1126 | -13x | +||
| 9 | +
- part = part+ #' @param object (`VTableTree`)\cr `rtable` to test. |
||
| 1127 | +10 |
- )+ #' @param expected (`VTableTree`)\cr expected `rtable`. |
|
| 1128 | +11 |
- }+ #' @param tol (`numeric(1)`)\cr tolerance. |
|
| 1129 | -25x | +||
| 12 | +
- flx+ #' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are |
||
| 1130 | +13 |
- }+ #' silently ignored. |
|
| 1131 | +14 |
-
+ #' @param structure (`flag`)\cr whether structures (in the form of column and row |
|
| 1132 | +15 |
- # Remove vertical borders from both sides (for titles)+ #' paths to cells) should be compared. Currently defaults to `FALSE`, but this is |
|
| 1133 | +16 |
- remove_vborder <- function(flx, part, ii) {
+ #' subject to change in future versions. |
|
| 1134 | -1x | +||
| 17 | +
- flx <- flextable::border(flx,+ #' |
||
| 1135 | -1x | +||
| 18 | +
- i = ii, part = part,+ #' @note In its current form, `compare_rtables` does not take structure into |
||
| 1136 | -1x | +||
| 19 | +
- border.left = flextable::fp_border_default(width = 0),+ #' account, only row and cell position. |
||
| 1137 | -1x | +||
| 20 | +
- border.right = flextable::fp_border_default(width = 0)+ #' |
||
| 1138 | +21 |
- )+ #' @return A matrix of class `rtables_diff` representing the differences |
|
| 1139 | +22 |
- }+ #' between `object` and `expected` as described above. |
|
| 1140 | +23 |
-
+ #' |
|
| 1141 | +24 |
- # Add horizontal border+ #' @examples |
|
| 1142 | +25 |
- add_hborder <- function(flx, part, ii, border) {
+ #' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
|
|
| 1143 | -20x | +||
| 26 | +
- if (any(ii == 0)) {
+ #' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
|
||
| 1144 | -12x | +||
| 27 | +
- flx <- flextable::border(flx, i = 1, border.top = border, part = part)+ #' |
||
| 1145 | -12x | +||
| 28 | +
- ii <- ii[!(ii == 0)]+ #' compare_rtables(object = t1, expected = t2) |
||
| 1146 | +29 |
- }+ #' |
|
| 1147 | -20x | +||
| 30 | +
- if (length(ii) > 0) {
+ #' if (interactive()) {
|
||
| 1148 | -20x | +||
| 31 | +
- flx <- flextable::border(flx, i = ii, border.bottom = border, part = part)+ #' Viewer(t1, t2) |
||
| 1149 | +32 |
- }+ #' } |
|
| 1150 | -20x | +||
| 33 | +
- flx+ #' |
||
| 1151 | +34 |
- }+ #' expected <- rtable( |
|
| 1152 | +35 |
-
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
|
| 1153 | +36 |
- apply_alignments <- function(flx, aligns_df, part) {
+ #' format = "xx", |
|
| 1154 | +37 |
- # List of characters you want to search for+ #' rrow("row 1", 10, 15),
|
|
| 1155 | -24x | +||
| 38 | +
- search_chars <- unique(c(aligns_df))+ #' rrow(), |
||
| 1156 | +39 |
-
+ #' rrow("section title"),
|
|
| 1157 | +40 |
- # Loop through each character and find its indexes+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
|
|
| 1158 | -24x | +||
| 41 | +
- for (char in search_chars) {
+ #' ) |
||
| 1159 | -48x | +||
| 42 | +
- indexes <- which(aligns_df == char, arr.ind = TRUE)+ #' |
||
| 1160 | -48x | +||
| 43 | +
- tmp_inds <- as.data.frame(indexes)+ #' expected |
||
| 1161 | -48x | +||
| 44 | +
- flx <- flx %>%+ #' |
||
| 1162 | -48x | +||
| 45 | +
- flextable::align(+ #' object <- rtable( |
||
| 1163 | -48x | +||
| 46 | +
- i = tmp_inds[["row"]],+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 1164 | -48x | +||
| 47 | +
- j = tmp_inds[["col"]],+ #' format = "xx", |
||
| 1165 | -48x | +||
| 48 | +
- align = char,+ #' rrow("row 1", 10, 15),
|
||
| 1166 | -48x | +||
| 49 | +
- part = part+ #' rrow("section title"),
|
||
| 1167 | +50 |
- )+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
|
|
| 1168 | +51 |
- }- |
- |
| 1169 | -- | - - | -|
| 1170 | -24x | -
- flx- |
- |
| 1171 | -- |
- }- |
-
| 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 | -46646x | -
- if (length(lbl) == 0) {
- |
- |
| 13 | -10546x | -
- return(TRUE)- |
- |
| 14 | -- |
- }- |
- |
| 15 | -- | - - | -|
| 16 | -36100x | -
- if (length(lbl) > 1) {
- |
- |
| 17 | -1692x | -
- if (multi_ok) {
- |
- |
| 18 | -1692x | -
- return(all(vapply(lbl, check_ok_label, TRUE)))- |
- |
| 19 | -- |
- }- |
- |
| 20 | -! | -
- stop("got a label of length > 1")
- |
- |
| 21 | -- |
- }- |
- |
| 22 | -- | - - | -|
| 23 | -34408x | -
- if (grepl("([{}])", lbl)) {
- |
- |
| 24 | -1x | -
- stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
- |
- |
| 25 | -- |
- }- |
- |
| 26 | -34407x | -
- invisible(TRUE)- |
- |
| 27 | -- |
- }- |
- |
| 28 | -- | - - | -|
| 29 | -- |
- valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
- |
- |
| 30 | -- |
- .labelkids_helper <- function(charval) {
- |
- |
| 31 | -2382x | -
- ret <- switch(charval,- |
- |
| 32 | -2382x | -
- "default" = NA,- |
- |
| 33 | -2382x | -
- "visible" = TRUE,- |
- |
| 34 | -2382x | -
- "hidden" = FALSE,- |
- |
| 35 | -2382x | -
- "topleft" = FALSE,- |
- |
| 36 | -2382x | -
- stop(- |
- |
| 37 | -2382x | -
- "unrecognized charval in .labelkids_helper. ",- |
- |
| 38 | -2382x | -
- "this shouldn't ever happen"- |
- |
| 39 | -- |
- )- |
- |
| 40 | -- |
- )- |
- |
| 41 | -2382x | -
- 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",+ #' compare_rtables(object, expected, comp.attr = FALSE) |
||
| 54 |
- sval_labels = "character",+ #' |
||
| 55 |
- subset = "SubsetDef"+ #' object <- rtable( |
||
| 56 |
- ),+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 57 |
- validity = function(object) {
+ #' format = "xx", |
||
| 58 |
- nspl <- length(object@splits)+ #' rrow("row 1", 10, 15),
|
||
| 59 |
- length(object@s_values) == nspl && length(object@sval_labels) == nspl+ #' rrow(), |
||
| 60 |
- }+ #' rrow("section title")
|
||
| 61 |
- )+ #' ) |
||
| 62 |
-
+ #' |
||
| 63 |
- setClassUnion("functionOrNULL", c("NULL", "function"))
+ #' compare_rtables(object, expected) |
||
| 64 |
- setClassUnion("listOrNULL", c("NULL", "list"))
+ #' |
||
| 65 |
- ## TODO (?) make "list" more specific, e.g FormatList, or FunctionList?+ #' object <- rtable( |
||
| 66 |
- setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 67 |
- setClassUnion("ExprOrNULL", c("NULL", "expression"))
+ #' format = "xx", |
||
| 68 |
-
+ #' rrow("row 1", 14, 15.03),
|
||
| 69 |
- setClass("ValueWrapper", representation(
+ #' rrow(), |
||
| 70 |
- value = "ANY",+ #' rrow("section title"),
|
||
| 71 |
- label = "characterOrNULL",+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
|
||
| 72 |
- subset_expression = "ExprOrNULL"+ #' ) |
||
| 73 |
- ),+ #' |
||
| 74 |
- contains = "VIRTUAL"+ #' compare_rtables(object, expected) |
||
| 75 |
- )+ #' |
||
| 76 |
- ## heavier-weight than I'd like but I think we need+ #' object <- rtable( |
||
| 77 |
- ## this to carry around thee subsets for+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 78 |
- ## comparison-based splits+ #' format = "xx", |
||
| 79 |
-
+ #' rrow("row 1", 10, 15),
|
||
| 80 |
- setClass("SplitValue",
+ #' rrow(), |
||
| 81 |
- contains = "ValueWrapper",+ #' rrow("section title"),
|
||
| 82 |
- representation(extra = "list")+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
|
||
| 83 |
- )+ #' ) |
||
| 84 |
-
+ #' |
||
| 85 |
- SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
+ #' compare_rtables(object, expected) |
||
| 86 | -4267x | +
- if (is(val, "SplitValue")) {
+ #' |
|
| 87 | -1711x | +
- if (length(splv_extra(val)) > 0) {
+ #' @export |
|
| 88 | -29x | +
- extr <- c(splv_extra(val), extr)+ compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE, |
|
| 89 |
- }+ structure = FALSE) {
|
||
| 90 | -1711x | +
- splv_extra(val) <- extr+ # if (identical(object, expected)) return(invisible(TRUE)) |
|
| 91 | -1711x | +
- return(val)+ |
|
| 92 | -+ | 12x |
- }+ if (!is(object, "VTableTree")) {
|
| 93 | -2556x | +! |
- if (!is(extr, "list")) {
+ stop( |
| 94 | ! |
- extr <- list(extr)+ "argument object is expected to be of class TableTree or ", |
|
| 95 | -+ | ! |
- }+ "ElementaryTable" |
| 96 | -2556x | +
- if (!is(label, "character")) {
+ ) |
|
| 97 | -! | +
- label <- as.character(label)+ } |
|
| 98 | -+ | 12x |
- }+ if (!is(expected, "VTableTree")) {
|
| 99 | -+ | ! |
-
+ stop( |
| 100 | -2556x | +! |
- if (!is.null(sub_expr) && !is.expression(sub_expr)) {
+ "argument expected is expected to be of class TableTree or ", |
| 101 | -4x | +! |
- sub_expr <- as.expression(sub_expr)+ "ElementaryTable" |
| 102 |
- } ## sometimes they will be "call" objects, etc+ ) |
||
| 103 | -2556x | +
- check_ok_label(label)+ } |
|
| 104 | -2556x | +12x |
- new("SplitValue",
+ dim_out <- apply(rbind(dim(object), dim(expected)), 2, max) |
| 105 | -2556x | +
- value = val,+ |
|
| 106 | -2556x | +12x |
- extra = extr,+ X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
|
| 107 | -2556x | +12x |
- label = label,+ row.names(X) <- as.character(1:dim_out[1]) |
| 108 | -2556x | +12x |
- subset_expression = sub_expr+ 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 |
- setClass("LevelComboSplitValue",
+ } |
||
| 113 |
- contains = "SplitValue",+ |
||
| 114 | -+ | 12x |
- representation(combolevels = "character")+ if (!comp.attr) {
|
| 115 | -+ | ! |
- )+ attr(X, "info") <- c( |
| 116 | -+ | ! |
-
+ attr(X, "info"), |
| 117 | -+ | ! |
- ## wrapped in user-facing `add_combo_facet`+ "cell attributes have not been compared" |
| 118 |
- LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
+ ) |
||
| 119 | -22x | +
- check_ok_label(label)+ } |
|
| 120 | -22x | +12x |
- new("LevelComboSplitValue",
+ if (!identical(row.names(object), row.names(expected))) {
|
| 121 | -22x | +2x |
- value = val,+ attr(X, "info") <- c(attr(X, "info"), "row labels are not the same") |
| 122 | -22x | +
- extra = extr,+ } |
|
| 123 | -22x | +
- combolevels = combolevels,+ |
|
| 124 | -22x | +12x |
- label = label,+ nro <- nrow(object) |
| 125 | -22x | +12x |
- subset_expression = sub_expr+ nre <- nrow(expected) |
| 126 | -+ | 12x |
- )+ nco <- ncol(object) |
| 127 | -+ | 12x |
- }+ nce <- ncol(expected) |
| 129 | -+ | 12x |
- setClass("Split",
+ if (nco < nce) {
|
| 130 | -+ | 2x |
- contains = "VIRTUAL",+ X[, seq(nco + 1, nce)] <- "-" |
| 131 | -+ | 10x |
- representation(+ } else if (nce < nco) {
|
| 132 | -+ | 3x |
- payload = "ANY",+ X[, seq(nce + 1, nco)] <- "+" |
| 133 |
- name = "character",+ } |
||
| 134 | -+ | 12x |
- split_label = "character",+ if (nro < nre) {
|
| 135 | -+ | 1x |
- split_format = "FormatSpec",+ X[seq(nro + 1, nre), ] <- "-" |
| 136 | -+ | 11x |
- split_na_str = "character",+ } else if (nre < nro) {
|
| 137 | -+ | ! |
- split_label_position = "character",+ X[seq(nre + 1, nro), ] <- "+" |
| 138 |
- ## NB this is the function which is applied to+ } |
||
| 139 |
- ## get the content rows for the CHILDREN of this+ |
||
| 140 | -+ | 12x |
- ## split!!!+ orig_object <- object # nolint |
| 141 | -+ | 12x |
- content_fun = "listOrNULL", ## functionOrNULL",+ orig_expected <- expected # nolint |
| 142 | -+ | 12x |
- content_format = "FormatSpec",+ if (nro != nre || nco != nce) {
|
| 143 | -+ | 5x |
- content_na_str = "character",+ object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE] |
| 144 | -+ | 5x |
- content_var = "character",+ expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE] |
| 145 | -+ | 5x |
- label_children = "logical",+ inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure) |
| 146 | -+ | 5x |
- extra_args = "list",+ X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner |
| 147 | -+ | 5x |
- indent_modifier = "integer",+ class(X) <- c("rtables_diff", class(X))
|
| 148 | -+ | 5x |
- content_indent_modifier = "integer",+ return(X) |
| 149 |
- content_extra_args = "list",+ } |
||
| 150 |
- page_title_prefix = "character",+ |
||
| 151 |
- child_section_div = "character"+ ## 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 |
- setClass("CustomizableSplit",
+ if (nrow(object) == 1) {
|
| 156 | -+ | ! |
- contains = "Split",+ orows <- list(orows) |
| 157 | -+ | ! |
- representation(split_fun = "functionOrNULL")+ erows <- list(erows) |
| 158 |
- )+ } |
||
| 159 | -+ | 7x |
-
+ res <- mapply(compare_rrows, |
| 160 | -+ | 7x |
- #' @author Gabriel Becker+ row1 = orows, row2 = erows, tol = tol, ncol = ncol(object), |
| 161 | -+ | 7x |
- #' @exportClass VarLevelSplit+ USE.NAMES = FALSE, SIMPLIFY = FALSE |
| 162 |
- #' @rdname VarLevelSplit+ ) |
||
| 163 | -+ | 7x |
- setClass("VarLevelSplit",
+ X <- do.call(rbind, res) |
| 164 | -+ | 7x |
- contains = "CustomizableSplit",+ rpo <- row_paths(object) |
| 165 | -+ | 7x |
- representation(+ rpe <- row_paths(expected) |
| 166 |
- value_label_var = "character",+ |
||
| 167 | -+ | 7x |
- value_order = "ANY"+ if (comp.attr) {
|
| 168 | -+ | 7x |
- )+ ofmts <- value_formats(object) |
| 169 | -+ | 7x |
- )+ efmts <- value_formats(expected) |
| 170 |
- #' Split on levels within a variable+ ## dim(ofmts) <- NULL |
||
| 171 |
- #'+ ## dim(efmts) <- NULL |
||
| 172 |
- #' @inheritParams lyt_args+ |
||
| 173 | -+ | 7x |
- #' @inheritParams constr_args+ fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim |
| 174 |
- #'+ |
||
| 175 |
- #' @return a `VarLevelSplit` object.+ |
||
| 176 |
- #'+ ## note the single index here!!!, no comma!!!! |
||
| 177 | -+ | 7x |
- #' @export+ X[fmt_mismatch] <- "X" |
| 178 |
- VarLevelSplit <- function(var,+ } |
||
| 179 |
- split_label,+ |
||
| 180 |
- labels_var = NULL,+ |
||
| 181 | -+ | 7x |
- cfun = NULL,+ if (structure) {
|
| 182 | -+ | 1x |
- cformat = NULL,+ rp_mismatches <- !mapply(identical, x = rpo, y = rpe) |
| 183 | -+ | 1x |
- cna_str = NA_character_,+ cpo <- col_paths(object) |
| 184 | -+ | 1x |
- split_fun = NULL,+ cpe <- col_paths(expected) |
| 185 | -+ | 1x |
- split_format = NULL,+ cp_mismatches <- !mapply(identical, x = cpo, y = cpe) |
| 186 |
- split_na_str = NA_character_,+ |
||
| 187 | -+ | 1x |
- valorder = NULL,+ if (any(rp_mismatches)) { # P for (row or column) path do not match
|
| 188 | -+ | ! |
- split_name = var,+ X[rp_mismatches, ] <- "R" |
| 189 |
- child_labels = c("default", "visible", "hidden"),
+ } |
||
| 190 | -+ | 1x |
- extra_args = list(),+ if (any(cp_mismatches)) {
|
| 191 | -+ | 1x |
- indent_mod = 0L,+ crep <- rep("C", nrow(X))
|
| 192 | -+ | 1x |
- label_pos = c("topleft", "hidden", "visible"),
+ if (any(rp_mismatches)) {
|
| 193 | -+ | ! |
- cindent_mod = 0L,+ crep[rp_mismatches] <- "P" |
| 194 |
- cvar = "",+ } |
||
| 195 | -+ | 1x |
- cextra_args = list(),+ X[, cp_mismatches] <- rep(crep, sum(cp_mismatches)) |
| 196 |
- page_prefix = NA_character_,+ } |
||
| 197 |
- section_div = NA_character_) {
+ } |
||
| 198 | -490x | +7x |
- child_labels <- match.arg(child_labels)+ class(X) <- c("rtables_diff", class(X))
|
| 199 | -490x | +7x |
- if (is.null(labels_var)) {
+ X |
| 200 | -1x | +
- labels_var <- var+ } |
|
| 201 |
- }+ |
||
| 202 | -490x | +
- check_ok_label(split_label)+ ## for (i in 1:dim(X)[1]) {
|
|
| 203 | -490x | +
- new("VarLevelSplit",
+ ## for (j in 1:dim(X)[2]) {
|
|
| 204 | -490x | +
- payload = var,+ |
|
| 205 | -490x | +
- split_label = split_label,+ ## is_equivalent <- TRUE |
|
| 206 | -490x | +
- name = split_name,+ ## if (i <= nro && i <= nre && j <= nco && j <= nce) {
|
|
| 207 | -490x | +
- value_label_var = labels_var,+ ## x <- object[i,j, drop = TRUE] |
|
| 208 | -490x | +
- content_fun = cfun,+ ## y <- expected[i,j, drop = TRUE] |
|
| 209 | -490x | +
- content_format = cformat,+ |
|
| 210 | -490x | +
- content_na_str = cna_str,+ ## attr_x <- attributes(x) |
|
| 211 | -490x | +
- split_fun = split_fun,+ ## attr_y <- attributes(y) |
|
| 212 | -490x | +
- split_format = split_format,+ |
|
| 213 | -490x | +
- split_na_str = split_na_str,+ ## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))] |
|
| 214 | -490x | +
- value_order = NULL,+ ## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))] |
|
| 215 | -490x | +
- label_children = .labelkids_helper(child_labels),+ |
|
| 216 | -490x | +
- extra_args = extra_args,+ ## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
|
|
| 217 | -490x | +
- indent_modifier = as.integer(indent_mod),+ ## is_equivalent <- FALSE |
|
| 218 | -490x | +
- content_indent_modifier = as.integer(cindent_mod),+ ## } else if (is.numeric(x) && is.numeric(y)) {
|
|
| 219 | -490x | +
- content_var = cvar,+ ## if (any(abs(na.omit(x - y)) > tol)) {
|
|
| 220 | -490x | +
- split_label_position = label_pos,+ ## is_equivalent <- FALSE |
|
| 221 | -490x | +
- content_extra_args = cextra_args,+ ## } |
|
| 222 | -490x | +
- page_title_prefix = page_prefix,+ ## } else {
|
|
| 223 | -490x | +
- child_section_div = section_div+ ## if (!identical(x, y)) {
|
|
| 224 |
- )+ ## is_equivalent <- FALSE |
||
| 225 |
- }+ ## } |
||
| 226 |
-
+ ## } |
||
| 227 |
- setClass("AllSplit", contains = "Split")
+
|
||
| 228 |
-
+ ## if (!is_equivalent) {
|
||
| 229 |
- AllSplit <- function(split_label = "",+ ## X[i,j] <- "X" |
||
| 230 |
- cfun = NULL,+ ## } |
||
| 231 |
- cformat = NULL,+ ## } else if (i > nro || j > nco) {
|
||
| 232 |
- cna_str = NA_character_,+ ## ## missing in object |
||
| 233 |
- split_format = NULL,+ ## X[i, j] <- "+" |
||
| 234 |
- split_na_str = NA_character_,+ ## } else {
|
||
| 235 |
- split_name = NULL,+ ## ## too many elements |
||
| 236 |
- extra_args = list(),+ ## X[i, j] <- "-" |
||
| 237 |
- indent_mod = 0L,+ ## } |
||
| 238 |
- cindent_mod = 0L,+ ## } |
||
| 239 |
- cvar = "",+ ## } |
||
| 240 |
- cextra_args = list(),+ ## class(X) <- c("rtable_diff", class(X))
|
||
| 241 |
- ...) {
+ ## X |
||
| 242 | -100x | +
- if (is.null(split_name)) {
+ ## } |
|
| 243 | -100x | +
- if (nzchar(split_label)) {
+
|
|
| 244 | -7x | +
- split_name <- split_label+ compare_value <- function(x, y, tol) {
|
|
| 245 | -+ | 359x |
- } else {
+ if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
|
| 246 | -93x | +
- split_name <- "all obs"+ "." |
|
| 247 |
- }+ } else {
|
||
| 248 | -+ | 72x |
- }+ "X" |
| 249 | -100x | +
- check_ok_label(split_label)+ } |
|
| 250 | -100x | +
- new("AllSplit",
+ } |
|
| 251 | -100x | +
- split_label = split_label,+ |
|
| 252 | -100x | +
- content_fun = cfun,+ compare_rrows <- function(row1, row2, tol, ncol) {
|
|
| 253 | -100x | +173x |
- content_format = cformat,+ if (length(row1) == ncol && length(row2) == ncol) {
|
| 254 | -100x | +115x |
- content_na_str = cna_str,+ mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE) |
| 255 | -100x | +58x |
- split_format = split_format,+ } else if (length(row1) == 0 && length(row2) == 0) {
|
| 256 | -100x | +44x |
- split_na_str = split_na_str,+ rep(".", ncol)
|
| 257 | -100x | +
- name = split_name,+ } else {
|
|
| 258 | -100x | +14x |
- label_children = FALSE,+ rep("X", ncol)
|
| 259 | -100x | +
- extra_args = extra_args,+ } |
|
| 260 | -100x | +
- indent_modifier = as.integer(indent_mod),+ } |
|
| 261 | -100x | +
- content_indent_modifier = as.integer(cindent_mod),+ |
|
| 262 | -100x | +
- content_var = cvar,+ ## #' @export |
|
| 263 | -100x | +
- split_label_position = "hidden",+ ## print.rtable_diff <- function(x, ...) {
|
|
| 264 | -100x | +
- content_extra_args = cextra_args,+ ## print.default(unclass(x), quote = FALSE, ...) |
|
| 265 | -100x | +
- page_title_prefix = NA_character_,+ ## } |
|
| 266 | -100x | +
| 1 | +
- child_section_div = NA_character_+ #' Check if an object is a valid `rtable` |
|||
| 267 | +2 |
- )+ #' |
||
| 268 | +3 |
- }+ #' @param x (`ANY`)\cr an object. |
||
| 269 | +4 |
-
+ #' |
||
| 270 | +5 |
- setClass("RootSplit", contains = "AllSplit")
+ #' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise. |
||
| 271 | +6 |
-
+ #' |
||
| 272 | +7 |
- RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "",+ #' @examples |
||
| 273 | +8 |
- split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
+ #' is_rtable(build_table(basic_table(), iris)) |
||
| 274 | -611x | +|||
| 9 | +
- check_ok_label(split_label)+ #' |
|||
| 275 | -611x | +|||
| 10 | +
- new("RootSplit",
+ #' @export |
|||
| 276 | -611x | +|||
| 11 | +
- split_label = split_label,+ is_rtable <- function(x) {
|
|||
| 277 | -611x | +12 | +47x |
- content_fun = cfun,+ is(x, "VTableTree") |
| 278 | -611x | +|||
| 13 | +
- content_format = cformat,+ } |
|||
| 279 | -611x | +|||
| 14 | +
- content_na_str = cna_str,+ |
|||
| 280 | -611x | +|||
| 15 | +
- split_format = split_format,+ # nocov start |
|||
| 281 | -611x | +|||
| 16 | +
- split_na_str = split_na_str,+ ## is each object in a collection from a class |
|||
| 282 | -611x | +|||
| 17 | +
- name = "root",+ are <- function(object_collection, class2) {
|
|||
| 283 | -611x | +|||
| 18 | +
- label_children = FALSE,+ all(vapply(object_collection, is, logical(1), class2)) |
|||
| 284 | -611x | +|||
| 19 | +
- indent_modifier = 0L,+ } |
|||
| 285 | -611x | +|||
| 20 | +
- content_indent_modifier = 0L,+ |
|||
| 286 | -611x | +|||
| 21 | +
- content_var = cvar,+ num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
|
|||
| 287 | -611x | +|||
| 22 | +
- split_label_position = "hidden",+ stopifnot(is.numeric(x)) |
|||
| 288 | -611x | +|||
| 23 | +
- content_extra_args = cextra_args,+ |
|||
| 289 | -611x | +|||
| 24 | +
- child_section_div = NA_character_+ if (length(x) == 1) {
|
|||
| 290 | +25 |
- )+ return(TRUE) |
||
| 291 | +26 | ++ |
+ }+ |
+ |
| 27 | ++ | + + | +||
| 28 | ++ |
+ y <- range(x) / mean(x)+ |
+ ||
| 29 | ++ |
+ isTRUE(all.equal(y[1], y[2], tolerance = tol))+ |
+ ||
| 30 |
} |
|||
| 292 | +31 | |||
| 293 | +32 |
- setClass("ManualSplit",
+ # copied over from utils.nest which is not open-source |
||
| 294 | +33 |
- contains = "AllSplit",+ all_true <- function(lst, fcn, ...) {
|
||
| 295 | +34 |
- representation(levels = "character")+ all(vapply(lst, fcn, logical(1), ...)) |
||
| 296 | +35 |
- )+ } |
||
| 297 | +36 | |||
| 298 | +37 |
- #' Manually defined split+ is_logical_single <- function(x) {
|
||
| 299 | +38 |
- #'+ !is.null(x) && |
||
| 300 | +39 |
- #' @inheritParams lyt_args+ is.logical(x) && |
||
| 301 | +40 |
- #' @inheritParams constr_args+ length(x) == 1 && |
||
| 302 | +41 |
- #' @inheritParams gen_args+ !is.na(x) |
||
| 303 | +42 |
- #' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split).+ } |
||
| 304 | +43 |
- #'+ |
||
| 305 | +44 |
- #' @return A `ManualSplit` object.+ is_logical_vector_modif <- function(x, min_length = 1) {
|
||
| 306 | +45 |
- #'+ !is.null(x) && |
||
| 307 | +46 |
- #' @author Gabriel Becker+ is.logical(x) && |
||
| 308 | +47 |
- #' @export+ is.atomic(x) && |
||
| 309 | +48 |
- ManualSplit <- function(levels, label, name = "manual",+ !anyNA(x) && |
||
| 310 | +49 |
- extra_args = list(),+ ifelse(min_length > 0, length(x) >= min_length, TRUE) |
||
| 311 | +50 |
- indent_mod = 0L,+ } |
||
| 312 | +51 |
- cindent_mod = 0L,+ # nocov end |
||
| 313 | +52 |
- cvar = "",+ |
||
| 314 | +53 |
- cextra_args = list(),+ # Shorthand for functions that take df as first parameter |
||
| 315 | +54 |
- label_pos = "visible",+ .takes_df <- function(f) {
+ |
+ ||
| 55 | +1604x | +
+ func_takes(f, "df", is_first = TRUE) |
||
| 316 | +56 |
- page_prefix = NA_character_,+ } |
||
| 317 | +57 |
- section_div = NA_character_) {
+
|
||
| 318 | -47x | +|||
| 58 | +
- label_pos <- match.arg(label_pos, label_pos_values)+ # Checking if function takes parameters |
|||
| 319 | -47x | +|||
| 59 | +
- check_ok_label(label, multi_ok = TRUE)+ func_takes <- function(func, params, is_first = FALSE) {
|
|||
| 320 | -47x | +60 | +10984x |
- new("ManualSplit",
+ if (is.list(func)) {
|
| 321 | -47x | +61 | +2261x |
- split_label = label,+ return(lapply(func, func_takes, params = params, is_first = is_first)) |
| 322 | -47x | +|||
| 62 | +
- levels = levels,+ } |
|||
| 323 | -47x | +63 | +8723x |
- name = name,+ if (is.null(func) || !is(func, "function")) {
|
| 324 | -47x | +|||
| 64 | +
- label_children = FALSE,+ # safe-net: should this fail instead? |
|||
| 325 | -47x | +65 | +1768x |
- extra_args = extra_args,+ return(setNames(rep(FALSE, length(params)), params)) |
| 326 | -47x | +|||
| 66 | +
- indent_modifier = 0L,+ } |
|||
| 327 | -47x | +67 | +6955x |
- content_indent_modifier = as.integer(cindent_mod),+ f_params <- formals(func) |
| 328 | -47x | +68 | +6955x |
- content_var = cvar,+ if (!is_first) {
|
| 329 | -47x | +69 | +2276x |
- split_format = NULL,+ return(setNames(params %in% names(f_params), params)) |
| 330 | -47x | +|||
| 70 | +
- split_na_str = NA_character_,+ } else {
|
|||
| 331 | -47x | +71 | +4679x |
- split_label_position = label_pos,+ if (length(params) > 1L) {
|
| 332 | -47x | +72 | +1x |
- page_title_prefix = page_prefix,+ stop("is_first works only with one parameters.")
+ |
+
| 73 | ++ |
+ } |
||
| 333 | -47x | +74 | +4678x |
- child_section_div = section_div+ return(!is.null(f_params) && names(f_params)[1] == params) |
| 334 | +75 |
- )+ } |
||
| 335 | +76 |
} |
||
| 336 | +77 | |||
| 337 | +78 |
- ## splits across which variables are being analynzed+ #' Translate spl_context to a path to display in error messages |
||
| 338 | +79 |
- setClass("MultiVarSplit",
+ #' |
||
| 339 | +80 |
- contains = "CustomizableSplit", ## "Split",+ #' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred. |
||
| 340 | +81 |
- representation(+ #' |
||
| 341 | +82 |
- var_labels = "character",+ #' @return A character string containing a description of the row path corresponding to `ctx`. |
||
| 342 | +83 |
- var_names = "character"+ #' |
||
| 343 | +84 |
- ),+ #' @export |
||
| 344 | +85 |
- validity = function(object) {
+ spl_context_to_disp_path <- function(ctx) {
|
||
| 345 | +86 |
- length(object@payload) >= 1 &&+ ## this can happen in the first split in column space, but |
||
| 346 | +87 |
- all(!is.na(object@payload)) &&+ ## should never happen in row space |
||
| 347 | -+ | |||
| 88 | +13x |
- (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels))+ if (length(ctx$split) == 0) {
+ |
+ ||
| 89 | +2x | +
+ return("root")
|
||
| 348 | +90 |
} |
||
| 349 | -+ | |||
| 91 | +11x |
- )+ if (ctx$split[1] == "root" && ctx$value[1] == "root") {
|
||
| 350 | -+ | |||
| 92 | +10x |
-
+ ctx <- ctx[-1, ] |
||
| 351 | +93 |
- .make_suffix_vec <- function(n) {
+ } |
||
| 352 | -3x | +94 | +11x |
- c(+ ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
|
| 353 | -+ | |||
| 95 | +11x |
- "",+ collapse = "->" |
||
| 354 | -3x | +|||
| 96 | +
- sprintf(+ ) |
|||
| 355 | -3x | +97 | +11x |
- "._[[%d]]_.",+ if (length(ret) == 0 || nchar(ret) == 0) {
|
| 356 | -3x | +98 | +4x |
- seq_len(n - 1) + 1L+ ret <- "root" |
| 357 | +99 |
- )+ } |
||
| 358 | -+ | |||
| 100 | +11x |
- )+ ret |
||
| 359 | +101 |
} |
||
| 360 | +102 | |||
| 361 | +103 |
- .make_multivar_names <- function(vars) {
+ # Utility function to paste vector of values in a nice way |
||
| 362 | -28x | +|||
| 104 | +
- dups <- duplicated(vars)+ paste_vec <- function(vec) {
|
|||
| 363 | -28x | +105 | +7x |
- if (!any(dups)) {
+ paste0('c("', paste(vec, collapse = '", "'), '")')
|
| 364 | -25x | +|||
| 106 | +
- return(vars)+ } |
|||
| 365 | +107 |
- }+ |
||
| 366 | -3x | +|||
| 108 | +
- dupvars <- unique(vars[dups])+ # Utility for checking if a package is installed |
|||
| 367 | -3x | +|||
| 109 | +
- ret <- vars+ check_required_packages <- function(pkgs) {
|
|||
| 368 | -3x | +110 | +28x |
- for (v in dupvars) {
+ for (pkgi in pkgs) {
|
| 369 | -3x | +111 | +32x |
- pos <- which(ret == v)+ if (!requireNamespace(pkgi, quietly = TRUE)) {
|
| 370 | -3x | +112 | +1x |
- ret[pos] <- paste0(+ stop( |
| 371 | -3x | +113 | +1x |
- ret[pos],+ "This function requires the ", pkgi, " package. ", |
| 372 | -3x | +114 | +1x |
- .make_suffix_vec(length(pos))+ "Please install it if you wish to use it" |
| 373 | +115 |
- )+ ) |
||
| 374 | +116 |
- }+ } |
||
| 375 | -3x | +|||
| 117 | +
- ret+ } |
|||
| 376 | +118 |
} |
| 377 | +1 |
-
+ ## Generics and how they are used directly |
||
| 378 | +2 |
- #' Split between two or more different variables+ |
||
| 379 | +3 |
- #'+ ## check_validsplit - Check if the split is valid for the data, error if not |
||
| 380 | +4 |
- #' @inheritParams lyt_args+ |
||
| 381 | +5 |
- #' @inheritParams constr_args+ ## .apply_spl_extras - Generate Extras |
||
| 382 | +6 |
- #'+ |
||
| 383 | +7 |
- #' @return A `MultiVarSplit` object.+ ## .apply_spl_datapart - generate data partition |
||
| 384 | +8 |
- #'+ |
||
| 385 | +9 |
- #' @author Gabriel Becker+ ## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values |
||
| 386 | +10 |
- #' @export+ |
||
| 387 | +11 |
- MultiVarSplit <- function(vars,+ setGeneric( |
||
| 388 | +12 |
- split_label = "",+ ".applysplit_rawvals", |
||
| 389 | -+ | |||
| 13 | +982x |
- varlabels = NULL,+ function(spl, df) standardGeneric(".applysplit_rawvals")
|
||
| 390 | +14 |
- varnames = NULL,+ ) |
||
| 391 | +15 |
- cfun = NULL,+ |
||
| 392 | +16 |
- cformat = NULL,+ setGeneric( |
||
| 393 | +17 |
- cna_str = NA_character_,+ ".applysplit_datapart", |
||
| 394 | -+ | |||
| 18 | +1058x |
- split_format = NULL,+ function(spl, df, vals) standardGeneric(".applysplit_datapart")
|
||
| 395 | +19 |
- split_na_str = NA_character_,+ ) |
||
| 396 | +20 |
- split_name = "multivars",+ |
||
| 397 | +21 |
- child_labels = c("default", "visible", "hidden"),
+ setGeneric( |
||
| 398 | +22 |
- extra_args = list(),+ ".applysplit_extras", |
||
| 399 | -+ | |||
| 23 | +1058x |
- indent_mod = 0L,+ function(spl, df, vals) standardGeneric(".applysplit_extras")
|
||
| 400 | +24 |
- cindent_mod = 0L,+ ) |
||
| 401 | +25 |
- cvar = "",+ |
||
| 402 | +26 |
- cextra_args = list(),+ setGeneric( |
||
| 403 | +27 |
- label_pos = "visible",+ ".applysplit_partlabels", |
||
| 404 | -+ | |||
| 28 | +1057x |
- split_fun = NULL,+ function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
|
||
| 405 | +29 |
- page_prefix = NA_character_,+ ) |
||
| 406 | +30 |
- section_div = NA_character_) {
+
|
||
| 407 | -28x | +|||
| 31 | +
- check_ok_label(split_label)+ setGeneric( |
|||
| 408 | +32 |
- ## no topleft allowed+ "check_validsplit", |
||
| 409 | -28x | +33 | +2210x |
- label_pos <- match.arg(label_pos, label_pos_values[-3])+ function(spl, df) standardGeneric("check_validsplit")
|
| 410 | -28x | +|||
| 34 | +
- child_labels <- match.arg(child_labels)+ ) |
|||
| 411 | -28x | +|||
| 35 | +
- if (length(vars) == 1 && grepl(":", vars)) {
+
|
|||
| 412 | -! | +|||
| 36 | +
- vars <- strsplit(vars, ":")[[1]]+ setGeneric( |
|||
| 413 | +37 |
- }+ ".applysplit_ref_vals", |
||
| 414 | -28x | +38 | +17x |
- if (length(varlabels) == 0) { ## covers NULL and character()
+ function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
|
| 415 | -1x | +|||
| 39 | +
- varlabels <- vars+ ) |
|||
| 416 | +40 |
- }+ |
||
| 417 | -28x | +|||
| 41 | +
- vnames <- varnames %||% .make_multivar_names(vars)+ #' Custom split functions |
|||
| 418 | -28x | +|||
| 42 | +
- stopifnot(length(vnames) == length(vars))+ #' |
|||
| 419 | -28x | +|||
| 43 | +
- new("MultiVarSplit",
+ #' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set |
|||
| 420 | -28x | +|||
| 44 | +
- payload = vars,+ #' of incoming data and a split object, and return "splits" of that data. |
|||
| 421 | -28x | +|||
| 45 | +
- split_label = split_label,+ #' |
|||
| 422 | -28x | +|||
| 46 | +
- var_labels = varlabels,+ #' @section Custom Splitting Function Details: |
|||
| 423 | -28x | +|||
| 47 | +
- var_names = vnames,+ #' |
|||
| 424 | -28x | +|||
| 48 | +
- content_fun = cfun,+ #' User-defined custom split functions can perform any type of computation on the incoming data provided that they |
|||
| 425 | -28x | +|||
| 49 | +
- content_format = cformat,+ #' meet the requirements for generating "splits" of the incoming data based on the split object. |
|||
| 426 | -28x | +|||
| 50 | +
- content_na_str = cna_str,+ #' |
|||
| 427 | -28x | +|||
| 51 | +
- split_format = split_format,+ #' Split functions are functions that accept: |
|||
| 428 | -28x | +|||
| 52 | +
- split_na_str = split_na_str,+ #' \describe{
|
|||
| 429 | -28x | +|||
| 53 | +
- label_children = .labelkids_helper(child_labels),+ #' \item{df}{a `data.frame` of incoming data to be split.}
|
|||
| 430 | -28x | +|||
| 54 | +
- name = split_name,+ #' \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
|
|||
| 431 | -28x | +|||
| 55 | +
- extra_args = extra_args,+ #' but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting |
|||
| 432 | -28x | +|||
| 56 | +
- indent_modifier = as.integer(indent_mod),+ #' table.} |
|||
| 433 | -28x | +|||
| 57 | +
- content_indent_modifier = as.integer(cindent_mod),+ #' \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
|
|||
| 434 | -28x | +|||
| 58 | +
- content_var = cvar,+ #' Should be `NULL` in most cases and can usually be ignored.} |
|||
| 435 | -28x | +|||
| 59 | +
- split_label_position = label_pos,+ #' \item{labels}{any pre-calculated value labels. Same as above for `values`.}
|
|||
| 436 | -28x | +|||
| 60 | +
- content_extra_args = cextra_args,+ #' \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
|
|||
| 437 | -28x | +|||
| 61 | +
- split_fun = split_fun,+ #' \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
|
|||
| 438 | -28x | +|||
| 62 | +
- page_title_prefix = page_prefix,+ #' arrived at `df`.} |
|||
| 439 | -28x | +|||
| 63 | +
- child_section_div = section_div+ #' } |
|||
| 440 | +64 |
- )+ #' |
||
| 441 | +65 |
- }+ #' The function must then output a named `list` with the following elements: |
||
| 442 | +66 |
-
+ #' |
||
| 443 | +67 |
- #' Splits for cutting by values of a numeric variable+ #' \describe{
|
||
| 444 | +68 |
- #'+ #' \item{values}{the vector of all values corresponding to the splits of `df`.}
|
||
| 445 | +69 |
- #' @inheritParams lyt_args+ #' \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
|
||
| 446 | +70 |
- #' @inheritParams constr_args+ #' \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
|
||
| 447 | +71 |
- #'+ #' \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
|
||
| 448 | +72 |
- #' @exportClass VarStaticCutSplit+ #' whenever they are executed on the corresponding element of `datasplit` or a subset thereof.} |
||
| 449 | +73 |
- #' @rdname cutsplits+ #' } |
||
| 450 | +74 |
- setClass("VarStaticCutSplit",
+ #' |
||
| 451 | +75 |
- contains = "Split",+ #' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming |
||
| 452 | +76 |
- representation(+ #' data before they are called or their outputs. |
||
| 453 | +77 |
- cuts = "numeric",+ #' |
||
| 454 | +78 |
- cut_labels = "character"+ #' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of |
||
| 455 | +79 |
- )+ #' pre-defined split functions. |
||
| 456 | +80 |
- )+ #' |
||
| 457 | +81 |
-
+ #' @examples |
||
| 458 | +82 |
- .is_cut_lab_lst <- function(cuts) {
+ #' # Example of a picky split function. The number of values in the column variable |
||
| 459 | -12x | +|||
| 83 | +
- is.list(cuts) && is.numeric(cuts[[1]]) &&+ #' # var decrees if we are going to print also the column with all observation |
|||
| 460 | -12x | +|||
| 84 | +
- is.character(cuts[[2]]) &&+ #' # or not. |
|||
| 461 | -12x | +|||
| 85 | +
- length(cuts[[1]]) == length(cuts[[2]])+ #' |
|||
| 462 | +86 |
- }+ #' picky_splitter <- function(var) {
|
||
| 463 | +87 |
-
+ #' # Main layout function |
||
| 464 | +88 |
- #' Create static cut or static cumulative cut split+ #' function(df, spl, vals, labels, trim) {
|
||
| 465 | +89 |
- #'+ #' orig_vals <- vals |
||
| 466 | +90 |
- #' @inheritParams lyt_args+ #' |
||
| 467 | +91 |
- #' @inheritParams constr_args+ #' # Check for number of levels if all are selected |
||
| 468 | +92 |
- #'+ #' if (is.null(vals)) {
|
||
| 469 | +93 |
- #' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit`+ #' vec <- df[[var]] |
||
| 470 | +94 |
- #' object for [VarDynCutSplit()].+ #' vals <- unique(vec) |
||
| 471 | +95 |
- #'+ #' } |
||
| 472 | +96 |
- #' @rdname cutsplits+ #' |
||
| 473 | +97 |
- make_static_cut_split <- function(var,+ #' # Do a split with or without All obs |
||
| 474 | +98 |
- split_label,+ #' if (length(vals) == 1) {
|
||
| 475 | +99 |
- cuts,+ #' do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim) |
||
| 476 | +100 |
- cutlabels = NULL,+ #' } else {
|
||
| 477 | +101 |
- cfun = NULL,+ #' fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
|
||
| 478 | +102 |
- cformat = NULL,+ #' fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim) |
||
| 479 | +103 |
- cna_str = NA_character_,+ #' } |
||
| 480 | +104 |
- split_format = NULL,+ #' } |
||
| 481 | +105 |
- split_na_str = NA_character_,+ #' } |
||
| 482 | +106 |
- split_name = var,+ #' |
||
| 483 | +107 |
- child_labels = c("default", "visible", "hidden"),
+ #' # Data sub-set |
||
| 484 | +108 |
- extra_args = list(),+ #' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F")) |
||
| 485 | +109 |
- indent_mod = 0L,+ #' d1 <- subset(d1, SEX %in% c("M", "F"))
|
||
| 486 | +110 |
- cindent_mod = 0L,+ #' d1$SEX <- factor(d1$SEX) |
||
| 487 | +111 |
- cvar = "",+ #' |
||
| 488 | +112 |
- cextra_args = list(),+ #' # This table uses the number of values in the SEX column to add the overall col or not |
||
| 489 | +113 |
- label_pos = "visible",+ #' lyt <- basic_table() %>% |
||
| 490 | +114 |
- cumulative = FALSE,+ #' split_cols_by("ARM", split_fun = drop_split_levels) %>%
|
||
| 491 | +115 |
- page_prefix = NA_character_,+ #' split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
|
||
| 492 | +116 |
- section_div = NA_character_) {
+ #' analyze("AGE", show_labels = "visible")
|
||
| 493 | -12x | +|||
| 117 | +
- cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit"+ #' tbl <- build_table(lyt, d1) |
|||
| 494 | -12x | +|||
| 118 | +
- check_ok_label(split_label)+ #' tbl |
|||
| 495 | +119 |
-
+ #' |
||
| 496 | -12x | +|||
| 120 | +
- label_pos <- match.arg(label_pos, label_pos_values)+ #' @name custom_split_funs |
|||
| 497 | -12x | +|||
| 121 | +
- child_labels <- match.arg(child_labels)+ NULL |
|||
| 498 | -12x | +|||
| 122 | +
- if (.is_cut_lab_lst(cuts)) {
+
|
|||
| 499 | -! | +|||
| 123 | +
- cutlabels <- cuts[[2]]+ ## do various cleaning, and naming, plus |
|||
| 500 | -! | +|||
| 124 | +
- cuts <- cuts[[1]]+ ## ensure partinfo$values contains SplitValue objects only |
|||
| 501 | +125 |
- }+ .fixupvals <- function(partinfo) {
|
||
| 502 | -12x | +126 | +1085x |
- if (is.unsorted(cuts, strictly = TRUE)) {
+ if (is.factor(partinfo$labels)) {
|
| 503 | +127 | ! |
- stop("invalid cuts vector. not sorted unique values.")
+ partinfo$labels <- as.character(partinfo$labels) |
|
| 504 | +128 |
} |
||
| 505 | +129 | |||
| 506 | -12x | +130 | +1085x |
- if (is.null(cutlabels) && !is.null(names(cuts))) {
+ vals <- partinfo$values |
| 507 | -1x | +131 | +1085x |
- cutlabels <- names(cuts)[-1]+ if (is.factor(vals)) {
|
| 508 | -+ | |||
| 132 | +! |
- } ## XXX is this always right?+ vals <- levels(vals)[vals] |
||
| 509 | +133 |
-
+ } |
||
| 510 | -12x | +134 | +1085x |
- new(cls,+ extr <- partinfo$extras |
| 511 | -12x | +135 | +1085x |
- payload = var,+ dpart <- partinfo$datasplit |
| 512 | -12x | +136 | +1085x |
- split_label = split_label,+ labels <- partinfo$labels |
| 513 | -12x | +137 | +1085x |
- cuts = cuts,+ if (is.null(labels)) {
|
| 514 | -12x | +|||
| 138 | +! |
- cut_labels = cutlabels,+ if (!is.null(names(vals))) {
|
||
| 515 | -12x | +|||
| 139 | +! |
- content_fun = cfun,+ labels <- names(vals) |
||
| 516 | -12x | +|||
| 140 | +! |
- content_format = cformat,+ } else if (!is.null(names(dpart))) {
|
||
| 517 | -12x | +|||
| 141 | +! |
- content_na_str = cna_str,+ labels <- names(dpart) |
||
| 518 | -12x | +|||
| 142 | +! |
- split_format = split_format,+ } else if (!is.null(names(extr))) {
|
||
| 519 | -12x | +|||
| 143 | +! |
- split_na_str = split_na_str,+ labels <- names(extr) |
||
| 520 | -12x | +|||
| 144 | +
- name = split_name,+ } |
|||
| 521 | -12x | +|||
| 145 | +
- label_children = .labelkids_helper(child_labels),+ } |
|||
| 522 | -12x | +|||
| 146 | +
- extra_args = extra_args,+ |
|||
| 523 | -12x | +147 | +1085x |
- indent_modifier = as.integer(indent_mod),+ subsets <- partinfo$subset_exprs |
| 524 | -12x | +148 | +1085x |
- content_indent_modifier = as.integer(cindent_mod),+ if (is.null(subsets)) {
|
| 525 | -12x | +149 | +1069x |
- content_var = cvar,+ subsets <- vector(mode = "list", length = length(vals)) |
| 526 | -12x | +|||
| 150 | +
- split_label_position = label_pos,+ ## use labels here cause we already did all that work |
|||
| 527 | -12x | +|||
| 151 | +
- content_extra_args = cextra_args,+ ## to get the names on the labels vector right |
|||
| 528 | -12x | +152 | +1069x |
- page_title_prefix = page_prefix,+ names(subsets) <- names(labels) |
| 529 | -12x | +|||
| 153 | +
- child_section_div = section_div+ } |
|||
| 530 | +154 |
- )+ + |
+ ||
| 155 | +1085x | +
+ if (is.null(vals) && !is.null(extr)) {
+ |
+ ||
| 156 | +! | +
+ vals <- seq_along(extr) |
||
| 531 | +157 |
- }+ } |
||
| 532 | +158 | |||
| 533 | -+ | |||
| 159 | +1085x |
- #' @exportClass CumulativeCutSplit+ if (length(vals) == 0) {
+ |
+ ||
| 160 | +13x | +
+ stopifnot(length(extr) == 0)+ |
+ ||
| 161 | +13x | +
+ return(partinfo) |
||
| 534 | +162 |
- #' @rdname cutsplits+ } |
||
| 535 | +163 |
- setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")
+ ## length(vals) > 0 from here down |
||
| 536 | +164 | |||
| 537 | -+ | |||
| 165 | +1072x |
- ## make_static_cut_split with cumulative=TRUE is the constructor+ if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
|
||
| 538 | -+ | |||
| 166 | +22x |
- ## for CumulativeCutSplit+ if (!is.null(extr)) {
|
||
| 539 | +167 |
-
+ ## in_ref_cols is in here for some reason even though its already in the SplitValue object. |
||
| 540 | +168 |
- ## do we want this to be a CustomizableSplit instead of+ ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598 |
||
| 541 | +169 |
- ## taking cut_fun?+ ## the if is a bandaid. |
||
| 542 | +170 |
- ## cut_funct must take avector and no other arguments+ ## XXX FIXME RIGHT |
||
| 543 | -+ | |||
| 171 | +3x |
- ## and return a named vector of cut points+ sq <- seq_along(vals) |
||
| 544 | -+ | |||
| 172 | +3x |
- #' @exportClass VarDynCutSplit+ if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
|
||
| 545 | -+ | |||
| 173 | +! |
- #' @rdname cutsplits+ warning( |
||
| 546 | -+ | |||
| 174 | +! |
- setClass("VarDynCutSplit",
+ "Got a partinfo list with values that are ", |
||
| 547 | -+ | |||
| 175 | +! |
- contains = "Split",+ "already SplitValue objects and non-null extras ", |
||
| 548 | -+ | |||
| 176 | +! |
- representation(+ "element. This shouldn't happen" |
||
| 549 | +177 |
- cut_fun = "function",+ ) |
||
| 550 | +178 |
- cut_label_fun = "function",+ } |
||
| 551 | +179 |
- cumulative_cuts = "logical"+ } |
||
| 552 | +180 |
- )+ } else {
|
||
| 553 | -+ | |||
| 181 | +1050x |
- )+ if (is.null(extr)) {
|
||
| 554 | -+ | |||
| 182 | +6x |
-
+ extr <- rep(list(list()), length(vals)) |
||
| 555 | +183 |
- #' @export+ } |
||
| 556 | -+ | |||
| 184 | +1050x |
- #' @rdname cutsplits+ vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets) |
||
| 557 | +185 |
- VarDynCutSplit <- function(var,+ } |
||
| 558 | +186 |
- split_label,+ ## we're done with this so take it off |
||
| 559 | -+ | |||
| 187 | +1072x |
- cutfun,+ partinfo$extras <- NULL |
||
| 560 | +188 |
- cutlabelfun = function(x) NULL,+ |
||
| 561 | -+ | |||
| 189 | +1072x |
- cfun = NULL,+ vnames <- value_names(vals) |
||
| 562 | -+ | |||
| 190 | +1072x |
- cformat = NULL,+ names(vals) <- vnames |
||
| 563 | -+ | |||
| 191 | +1072x |
- cna_str = NA_character_,+ partinfo$values <- vals |
||
| 564 | +192 |
- split_format = NULL,+ |
||
| 565 | -+ | |||
| 193 | +1072x |
- split_na_str = NA_character_,+ if (!identical(names(dpart), vnames)) {
|
||
| 566 | -+ | |||
| 194 | +1072x |
- split_name = var,+ names(dpart) <- vnames |
||
| 567 | -+ | |||
| 195 | +1072x |
- child_labels = c("default", "visible", "hidden"),
+ partinfo$datasplit <- dpart |
||
| 568 | +196 |
- extra_args = list(),+ } |
||
| 569 | +197 |
- cumulative = FALSE,+ |
||
| 570 | -+ | |||
| 198 | +1072x |
- indent_mod = 0L,+ partinfo$labels <- labels |
||
| 571 | +199 |
- cindent_mod = 0L,+ |
||
| 572 | -+ | |||
| 200 | +1072x |
- cvar = "",+ stopifnot(length(unique(sapply(partinfo, NROW))) == 1)+ |
+ ||
| 201 | +1072x | +
+ partinfo |
||
| 573 | +202 |
- cextra_args = list(),+ } |
||
| 574 | +203 |
- label_pos = "visible",+ |
||
| 575 | +204 |
- page_prefix = NA_character_,+ .add_ref_extras <- function(spl, df, partinfo) {
|
||
| 576 | +205 |
- section_div = NA_character_) {
+ ## this is only the .in_ref_col booleans |
||
| 577 | -6x | +206 | +17x |
- check_ok_label(split_label)+ refvals <- .applysplit_ref_vals(spl, df, partinfo$values) |
| 578 | -6x | +207 | +17x |
- label_pos <- match.arg(label_pos, label_pos_values)+ ref_ind <- which(unlist(refvals)) |
| 579 | -6x | +208 | +17x |
- child_labels <- match.arg(child_labels)+ stopifnot(length(ref_ind) == 1) |
| 580 | -6x | +|||
| 209 | +
- new("VarDynCutSplit",
+
|
|||
| 581 | -6x | +210 | +17x |
- payload = var,+ vnames <- value_names(partinfo$values) |
| 582 | -6x | +211 | +17x |
- split_label = split_label,+ if (is.null(partinfo$extras)) {
|
| 583 | -6x | +212 | +3x |
- cut_fun = cutfun,+ names(refvals) <- vnames |
| 584 | -6x | +213 | +3x |
- cumulative_cuts = cumulative,+ partinfo$extras <- refvals |
| 585 | -6x | +|||
| 214 | +
- cut_label_fun = cutlabelfun,+ } else {
|
|||
| 586 | -6x | +215 | +14x |
- content_fun = cfun,+ newextras <- mapply( |
| 587 | -6x | +216 | +14x |
- content_format = cformat,+ function(old, incol, ref_full) {
|
| 588 | -6x | +217 | +37x |
- content_na_str = cna_str,+ c(old, list( |
| 589 | -6x | +218 | +37x |
- split_format = split_format,+ .in_ref_col = incol, |
| 590 | -6x | +219 | +37x |
- split_na_str = split_na_str,+ .ref_full = ref_full |
| 591 | -6x | +|||
| 220 | +
- name = split_name,+ )) |
|||
| 592 | -6x | +|||
| 221 | +
- label_children = .labelkids_helper(child_labels),+ }, |
|||
| 593 | -6x | +222 | +14x |
- extra_args = extra_args,+ old = partinfo$extras, |
| 594 | -6x | +223 | +14x |
- indent_modifier = as.integer(indent_mod),+ incol = unlist(refvals), |
| 595 | -6x | +224 | +14x |
- content_indent_modifier = as.integer(cindent_mod),+ MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]), |
| 596 | -6x | +225 | +14x |
- content_var = cvar,+ SIMPLIFY = FALSE |
| 597 | -6x | +|||
| 226 | +
- split_label_position = label_pos,+ ) |
|||
| 598 | -6x | +227 | +14x |
- content_extra_args = cextra_args,+ names(newextras) <- vnames |
| 599 | -6x | +228 | +14x |
- page_title_prefix = page_prefix,+ partinfo$extras <- newextras+ |
+
| 229 | ++ |
+ } |
||
| 600 | -6x | +230 | +17x |
- child_section_div = section_div+ partinfo |
| 601 | +231 |
- )+ } |
||
| 602 | +232 |
- }+ |
||
| 603 | +233 |
-
+ #' Apply basic split (for use in custom split functions) |
||
| 604 | +234 |
- ## NB analyze splits can't have content-related things+ #' |
||
| 605 | +235 |
- setClass("VAnalyzeSplit",
+ #' This function is intended for use inside custom split functions. It applies the current split *as if it had no |
||
| 606 | +236 |
- contains = "Split",+ #' custom splitting function* so that those default splits can be further manipulated. |
||
| 607 | +237 |
- representation(+ #' |
||
| 608 | +238 |
- default_rowlabel = "character",+ #' @inheritParams gen_args |
||
| 609 | +239 |
- include_NAs = "logical",+ #' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`. |
||
| 610 | +240 |
- var_label_position = "character"+ #' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should |
||
| 611 | +241 |
- )+ #' almost always be the case. |
||
| 612 | +242 |
- )+ #' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to |
||
| 613 | +243 |
-
+ #' `FALSE`. |
||
| 614 | +244 |
- setClass("AnalyzeVarSplit",
+ #' |
||
| 615 | +245 |
- contains = "VAnalyzeSplit",+ #' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs]. |
||
| 616 | +246 |
- representation(analysis_fun = "function")+ #' |
||
| 617 | +247 |
- )+ #' @examples |
||
| 618 | +248 |
-
+ #' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 619 | +249 |
- setClass("AnalyzeColVarSplit",
+ #' ret <- do_base_split(spl, df, vals, labels, trim) |
||
| 620 | +250 |
- contains = "VAnalyzeSplit",+ #' if (NROW(df) == 0) {
|
||
| 621 | +251 |
- representation(analysis_fun = "list")+ #' ret <- lapply(ret, function(x) x[1]) |
||
| 622 | +252 |
- )+ #' } |
||
| 623 | +253 |
-
+ #' ret |
||
| 624 | +254 |
- #' Define a subset tabulation/analysis+ #' } |
||
| 625 | +255 |
#' |
||
| 626 | +256 |
- #' @inheritParams lyt_args+ #' lyt <- basic_table() %>% |
||
| 627 | +257 |
- #' @inheritParams constr_args+ #' split_cols_by("ARM") %>%
|
||
| 628 | +258 |
- #' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`.+ #' split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
|
||
| 629 | +259 |
- #'+ #' varlabels = c("N", "E", "BMR1"),
|
||
| 630 | +260 |
- #' @return An `AnalyzeVarSplit` object.+ #' split_fun = uneven_splfun |
||
| 631 | +261 |
- #'+ #' ) %>% |
||
| 632 | +262 |
- #' @author Gabriel Becker+ #' analyze_colvars(list( |
||
| 633 | +263 |
- #' @export+ #' USUBJID = function(x, ...) length(unique(x)), |
||
| 634 | +264 |
- #' @rdname avarspl+ #' AESEQ = max, |
||
| 635 | +265 |
- AnalyzeVarSplit <- function(var,+ #' BMRKR1 = mean |
||
| 636 | +266 |
- split_label = var,+ #' )) |
||
| 637 | +267 |
- afun,+ #' |
||
| 638 | +268 |
- defrowlab = "",+ #' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2)) |
||
| 639 | +269 |
- cfun = NULL,+ #' tbl |
||
| 640 | +270 |
- cformat = NULL,+ #' |
||
| 641 | +271 |
- split_format = NULL,+ #' @export |
||
| 642 | +272 |
- split_na_str = NA_character_,+ 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 |
||
| 643 | +278 |
- inclNAs = FALSE,+ ) |
||
| 644 | +279 |
- split_name = var,+ } |
||
| 645 | +280 |
- extra_args = list(),+ |
||
| 646 | +281 |
- indent_mod = 0L,+ ### NB This is called at EACH level of recursive splitting |
||
| 647 | +282 |
- label_pos = "default",+ do_split <- function(spl, |
||
| 648 | +283 |
- cvar = "",+ df, |
||
| 649 | +284 |
- section_div = NA_character_) {
+ vals = NULL, |
||
| 650 | -328x | +|||
| 285 | +
- check_ok_label(split_label)+ labels = NULL, |
|||
| 651 | -328x | +|||
| 286 | +
- label_pos <- match.arg(label_pos, c("default", label_pos_values))
+ trim = FALSE, |
|||
| 652 | -328x | +|||
| 287 | +
- if (!any(nzchar(defrowlab))) {
+ spl_context) {
|
|||
| 653 | -1x | +|||
| 288 | +
- defrowlab <- as.character(substitute(afun))+ ## 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 |
||
| 654 | -1x | +291 | +1078x |
- if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
+ check_validsplit(spl, df) |
| 655 | -! | +|||
| 292 | +
- defrowlab <- ""+ ## note the <- here!!!+ |
+ |||
| 293 | +1077x | +
+ if (!is.null(splfun <- split_fun(spl))) {
|
||
| 656 | +294 |
- }+ ## Currently the contract is that split_functions take df, vals, labels and |
||
| 657 | +295 |
- }+ ## return list(values=., datasplit=., labels = .), optionally with |
||
| 658 | -328x | +|||
| 296 | +
- new("AnalyzeVarSplit",
+ ## an additional extras element |
|||
| 659 | -328x | +297 | +350x |
- payload = var,+ if (func_takes(splfun, ".spl_context")) {
|
| 660 | -328x | +298 | +23x |
- split_label = split_label,+ ret <- tryCatch( |
| 661 | -328x | +299 | +23x |
- content_fun = cfun,+ splfun(df, spl, vals, labels, |
| 662 | -328x | +300 | +23x |
- analysis_fun = afun,+ trim = trim, |
| 663 | -328x | +301 | +23x |
- content_format = cformat,+ .spl_context = spl_context |
| 664 | -328x | +|||
| 302 | +
- split_format = split_format,+ ), |
|||
| 665 | -328x | +303 | +23x |
- split_na_str = split_na_str,+ error = function(e) e |
| 666 | -328x | +304 | +23x |
- default_rowlabel = defrowlab,+ ) ## rawvalues(spl_context )) |
| 667 | -328x | +|||
| 305 | +
- include_NAs = inclNAs,+ } else {
|
|||
| 668 | -328x | +306 | +327x |
- name = split_name,+ ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim), |
| 669 | -328x | +307 | +327x |
- label_children = FALSE,+ error = function(e) e |
| 670 | -328x | +|||
| 308 | +
- extra_args = extra_args,+ ) |
|||
| 671 | -328x | +|||
| 309 | +
- indent_modifier = as.integer(indent_mod),+ } |
|||
| 672 | -328x | +310 | +350x |
- content_indent_modifier = 0L,+ if (is(ret, "error")) {
|
| 673 | -328x | +311 | +5x |
- var_label_position = label_pos,+ stop( |
| 674 | -328x | +312 | +5x |
- content_var = cvar,+ "Error applying custom split function: ", ret$message, "\n\tsplit: ", |
| 675 | -328x | +313 | +5x |
- page_title_prefix = NA_character_,+ class(spl), " (", payloadmsg(spl), ")\n",
|
| 676 | -328x | +314 | +5x |
- child_section_div = section_div+ "\toccured at path: ", |
| 677 | -328x | +315 | +5x |
- ) ## no content_extra_args+ spl_context_to_disp_path(spl_context), "\n" |
| 678 | +316 |
- }+ ) |
||
| 679 | +317 |
-
+ } |
||
| 680 | +318 |
- #' Define a subset tabulation/analysis+ } else {
|
||
| 681 | -+ | |||
| 319 | +727x |
- #'+ ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim) |
||
| 682 | +320 |
- #' @inheritParams lyt_args+ } |
||
| 683 | +321 |
- #' @inheritParams constr_args+ |
||
| 684 | +322 |
- #'+ ## this adds .ref_full and .in_ref_col |
||
| 685 | -+ | |||
| 323 | +1072x |
- #' @author Gabriel Becker+ if (is(spl, "VarLevWBaselineSplit")) {
|
||
| 686 | -+ | |||
| 324 | +17x |
- #' @export+ ret <- .add_ref_extras(spl, df, ret) |
||
| 687 | +325 |
- #' @rdname avarspl+ } |
||
| 688 | +326 |
- AnalyzeColVarSplit <- function(afun,+ |
||
| 689 | +327 |
- defrowlab = "",+ ## this: |
||
| 690 | +328 |
- cfun = NULL,+ ## - guarantees that ret$values contains SplitValue objects |
||
| 691 | +329 |
- cformat = NULL,+ ## - removes the extras element since its redundant after the above |
||
| 692 | +330 |
- split_format = NULL,+ ## - Ensures datasplit and values lists are named according to labels |
||
| 693 | +331 |
- split_na_str = NA_character_,+ ## - ensures labels are character not factor |
||
| 694 | -+ | |||
| 332 | +1072x |
- inclNAs = FALSE,+ ret <- .fixupvals(ret) |
||
| 695 | +333 |
- split_name = "",+ ## we didn't put this in .fixupvals because that get called withint he split functions |
||
| 696 | +334 |
- extra_args = list(),+ ## created by make_split_fun and its not clear this check should be happening then. |
||
| 697 | -+ | |||
| 335 | +1072x |
- indent_mod = 0L,+ if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
|
||
| 698 | -+ | |||
| 336 | +3x |
- label_pos = "default",+ stop( |
||
| 699 | -+ | |||
| 337 | +3x |
- cvar = "",+ "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ", |
||
| 700 | -+ | |||
| 338 | +3x |
- section_div = NA_character_) {
+ class(spl), " (", payloadmsg(spl), ")\n",
|
||
| 701 | -23x | +339 | +3x |
- label_pos <- match.arg(label_pos, c("default", label_pos_values))
+ "\toccured at path: ", |
| 702 | -23x | +340 | +3x |
- new("AnalyzeColVarSplit",
+ spl_context_to_disp_path(spl_context), "\n" |
| 703 | -23x | +|||
| 341 | +
- payload = NA_character_,+ ) |
|||
| 704 | -23x | +|||
| 342 | +
- split_label = "",+ } |
|||
| 705 | -23x | +343 | +1069x |
- content_fun = cfun,+ ret |
| 706 | -23x | +|||
| 344 | +
- analysis_fun = afun,+ } |
|||
| 707 | -23x | +|||
| 345 | +
- content_format = cformat,+ |
|||
| 708 | -23x | +|||
| 346 | +
- split_format = split_format,+ .apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
|
|||
| 709 | -23x | +347 | +1058x |
- split_na_str = split_na_str,+ if (is.null(vals)) {
|
| 710 | -23x | +348 | +982x |
- default_rowlabel = defrowlab,+ vals <- .applysplit_rawvals(spl, df) |
| 711 | -23x | +|||
| 349 | +
- include_NAs = inclNAs,+ } |
|||
| 712 | -23x | +350 | +1058x |
- name = split_name,+ extr <- .applysplit_extras(spl, df, vals) |
| 713 | -23x | +|||
| 351 | +
- label_children = FALSE,+ |
|||
| 714 | -23x | +352 | +1058x |
- extra_args = extra_args,+ if (is.null(vals)) {
|
| 715 | -23x | +|||
| 353 | +! |
- indent_modifier = as.integer(indent_mod),+ return(list( |
||
| 716 | -23x | +|||
| 354 | +! |
- content_indent_modifier = 0L,+ values = list(), |
||
| 717 | -23x | +|||
| 355 | +! |
- var_label_position = label_pos,+ datasplit = list(), |
||
| 718 | -23x | +|||
| 356 | +! |
- content_var = cvar,+ labels = list(), |
||
| 719 | -23x | +|||
| 357 | +! |
- page_title_prefix = NA_character_,+ extras = list() |
||
| 720 | -23x | +|||
| 358 | +
- child_section_div = section_div+ )) |
|||
| 721 | -23x | +|||
| 359 | +
- ) ## no content_extra_args+ } |
|||
| 722 | +360 |
- }+ + |
+ ||
| 361 | +1058x | +
+ dpart <- .applysplit_datapart(spl, df, vals) |
||
| 723 | +362 | |||
| 363 | +1058x | +
+ if (is.null(labels)) {
+ |
+ ||
| 364 | +1057x | +
+ labels <- .applysplit_partlabels(spl, df, vals, labels)+ |
+ ||
| 724 | +365 |
- setClass("CompoundSplit",
+ } else {
+ |
+ ||
| 366 | +1x | +
+ stopifnot(names(labels) == names(vals)) |
||
| 725 | +367 |
- contains = "Split",+ } |
||
| 726 | +368 |
- validity = function(object) are(object@payload, "Split")+ ## get rid of columns that would not have any |
||
| 727 | +369 |
- )+ ## observations. |
||
| 728 | +370 |
-
+ ## |
||
| 729 | +371 |
- setClass("AnalyzeMultiVars", contains = "CompoundSplit")
+ ## But only if there were any rows to start with |
||
| 730 | +372 |
-
+ ## if not we're in a manually constructed table |
||
| 731 | +373 |
- .repoutlst <- function(x, nv) {
+ ## column tree |
||
| 732 | -1800x | +374 | +1058x |
- if (!is.function(x) && length(x) == nv) {
+ if (trim) {
|
| 733 | -864x | +|||
| 375 | +! |
- return(x)+ hasdata <- sapply(dpart, function(x) nrow(x) > 0) |
||
| 734 | -+ | |||
| 376 | +! |
- }+ if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
|
||
| 735 | -936x | +|||
| 377 | +! |
- if (!is(x, "list")) {
+ dpart <- dpart[hasdata] |
||
| 736 | -936x | +|||
| 378 | +! |
- x <- list(x)+ vals <- vals[hasdata] |
||
| 737 | -+ | |||
| 379 | +! |
- }+ extr <- extr[hasdata] |
||
| 738 | -936x | +|||
| 380 | +! |
- rep(x, length.out = nv)+ labels <- labels[hasdata] |
||
| 739 | +381 |
- }+ } |
||
| 740 | +382 |
-
+ } |
||
| 741 | +383 |
- .uncompound <- function(csplit) {
+
|
||
| 742 | -63x | +384 | +1058x |
- if (is(csplit, "list")) {
+ if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
|
| 743 | -3x | +385 | +150x |
- return(unlist(lapply(csplit, .uncompound)))+ vord <- seq_along(vals) |
| 744 | +386 |
- }+ } else {
|
||
| 745 | -+ | |||
| 387 | +908x |
-
+ vord <- match( |
||
| 746 | -60x | +388 | +908x |
- if (!is(csplit, "CompoundSplit")) {
+ spl_child_order(spl), |
| 747 | -59x | +389 | +908x |
- return(csplit)+ vals |
| 748 | +390 | ++ |
+ )+ |
+ |
| 391 | +908x | +
+ vord <- vord[!is.na(vord)]+ |
+ ||
| 392 |
} |
|||
| 749 | +393 | |||
| 750 | -1x | +|||
| 394 | +
- pld <- spl_payload(csplit)+ ## FIXME: should be an S4 object, not a list |
|||
| 751 | -1x | +395 | +1058x |
- done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit"))+ ret <- list( |
| 752 | -1x | +396 | +1058x |
- if (done) {
+ values = vals[vord], |
| 753 | -1x | +397 | +1058x |
- pld+ datasplit = dpart[vord], |
| 754 | -+ | |||
| 398 | +1058x |
- } else {
+ labels = labels[vord], |
||
| 755 | -! | +|||
| 399 | +1058x |
- unlist(lapply(pld, .uncompound))+ extras = extr[vord] |
||
| 756 | +400 |
- }+ )+ |
+ ||
| 401 | +1058x | +
+ ret |
||
| 757 | +402 |
} |
||
| 758 | +403 | |||
| 759 | +404 |
- strip_compound_name <- function(obj) {
+ .checkvarsok <- function(spl, df) {
|
||
| 760 | -11x | +405 | +1986x |
- nm <- obj_name(obj)- |
-
| 761 | -11x | -
- gsub("^ma_", "", nm)
+ vars <- spl_payload(spl) |
||
| 762 | +406 |
- }+ ## could be multiple vars in the future? |
||
| 763 | +407 |
-
+ ## no reason not to make that work here now. |
||
| 764 | -+ | |||
| 408 | +1986x |
- make_ma_name <- function(spl, pld = spl_payload(spl)) {
+ if (!all(vars %in% names(df))) {
|
||
| 765 | -3x | +409 | +2x |
- paste(+ stop( |
| 766 | -3x | +410 | +2x |
- c(+ " variable(s) [", |
| 767 | -3x | +411 | +2x |
- "ma",+ paste(setdiff(vars, names(df)), |
| 768 | -3x | +412 | +2x |
- vapply(pld, strip_compound_name, "")+ collapse = ", " |
| 769 | +413 |
- ),+ ), |
||
| 770 | -3x | +414 | +2x |
- collapse = "_"+ "] not present in data. (",
+ |
+
| 415 | +2x | +
+ class(spl), ")" |
||
| 771 | +416 |
- )+ ) |
||
| 772 | +417 |
- }+ }+ |
+ ||
| 418 | +1984x | +
+ invisible(NULL) |
||
| 773 | +419 |
-
+ } |
||
| 774 | +420 |
- #' @param .payload (`list`)\cr used internally, not intended to be set by end users.+ |
||
| 775 | +421 |
- #'+ ### Methods to verify a split appears to be valid, applicable |
||
| 776 | +422 |
- #' @return An `AnalyzeMultiVars` split object.+ ### to the ***current subset*** of the df. |
||
| 777 | +423 |
- #'+ ### |
||
| 778 | +424 |
- #' @export+ ### This is called at each level of recursive splitting so |
||
| 779 | +425 |
- #' @rdname avarspl+ ### do NOT make it check, e.g., if the ref_group level of |
||
| 780 | +426 |
- AnalyzeMultiVars <- function(var,+ ### a factor is present in the data, because it may not be. |
||
| 781 | +427 |
- split_label = "",+ |
||
| 782 | +428 |
- afun,+ setMethod( |
||
| 783 | +429 |
- defrowlab = "",+ "check_validsplit", "VarLevelSplit", |
||
| 784 | +430 |
- cfun = NULL,+ function(spl, df) {
+ |
+ ||
| 431 | +853x | +
+ .checkvarsok(spl, df) |
||
| 785 | +432 |
- cformat = NULL,+ } |
||
| 786 | +433 |
- split_format = NULL,+ ) |
||
| 787 | +434 |
- split_na_str = NA_character_,+ |
||
| 788 | +435 |
- inclNAs = FALSE,+ setMethod( |
||
| 789 | +436 |
- .payload = NULL,+ "check_validsplit", "MultiVarSplit", |
||
| 790 | +437 |
- split_name = NULL,+ function(spl, df) {
+ |
+ ||
| 438 | +55x | +
+ .checkvarsok(spl, df) |
||
| 791 | +439 |
- extra_args = list(),+ } |
||
| 792 | +440 |
- indent_mod = 0L,+ ) |
||
| 793 | +441 |
- child_labels = c("default", "topleft", "visible", "hidden"),
+
|
||
| 794 | +442 |
- child_names = var,+ setMethod( |
||
| 795 | +443 |
- cvar = "",+ "check_validsplit", "VAnalyzeSplit", |
||
| 796 | +444 |
- section_div = NA_character_) {
+ function(spl, df) {
+ |
+ ||
| 445 | +1132x | +
+ if (!is.na(spl_payload(spl))) {
+ |
+ ||
| 446 | +1078x | +
+ .checkvarsok(spl, df) |
||
| 797 | +447 |
- ## NB we used to resolve to strict TRUE/FALSE for label visibillity+ } else {
+ |
+ ||
| 448 | +54x | +
+ TRUE |
||
| 798 | +449 |
- ## in this function but that was too greedy for repeated+ } |
||
| 799 | +450 |
- ## analyze calls, so that now occurs in the tabulation machinery+ } |
||
| 800 | +451 |
- ## when the table is actually being built.+ ) |
||
| 801 | +452 |
- ## show_kidlabs = .labelkids_helper(match.arg(child_labels))+ |
||
| 802 | -325x | +|||
| 453 | +
- child_labels <- match.arg(child_labels)+ setMethod( |
|||
| 803 | -325x | +|||
| 454 | +
- show_kidlabs <- child_labels+ "check_validsplit", "CompoundSplit", |
|||
| 804 | -325x | +|||
| 455 | +
- if (is.null(.payload)) {
+ function(spl, df) {
|
|||
| 805 | -300x | +|||
| 456 | +! |
- nv <- length(var)+ all(sapply(spl_payload(spl), df)) |
||
| 806 | -300x | +|||
| 457 | +
- defrowlab <- .repoutlst(defrowlab, nv)+ } |
|||
| 807 | -300x | +|||
| 458 | +
- afun <- .repoutlst(afun, nv)+ ) |
|||
| 808 | -300x | +|||
| 459 | +
- split_label <- .repoutlst(split_label, nv)+ |
|||
| 809 | -300x | +|||
| 460 | +
- check_ok_label(split_label, multi_ok = TRUE)+ ## default does nothing, add methods as they become |
|||
| 810 | -300x | +|||
| 461 | +
- cfun <- .repoutlst(cfun, nv)+ ## required |
|||
| 811 | -300x | +|||
| 462 | +
- cformat <- .repoutlst(cformat, nv)+ setMethod( |
|||
| 812 | +463 |
- ## split_format = .repoutlst(split_format, nv)+ "check_validsplit", "Split", |
||
| 813 | -300x | +464 | +119x |
- inclNAs <- .repoutlst(inclNAs, nv)+ function(spl, df) invisible(NULL) |
| 814 | -300x | +|||
| 465 | +
- section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div+ ) |
|||
| 815 | -300x | +|||
| 466 | +
- pld <- mapply(AnalyzeVarSplit,+ |
|||
| 816 | -300x | +|||
| 467 | +
- var = var,+ setMethod( |
|||
| 817 | -300x | +|||
| 468 | +
- split_name = child_names,+ ".applysplit_rawvals", "VarLevelSplit", |
|||
| 818 | -300x | +|||
| 469 | +
- split_label = split_label,+ function(spl, df) {
|
|||
| 819 | -300x | +470 | +764x |
- afun = afun,+ varvec <- df[[spl_payload(spl)]] |
| 820 | -300x | +471 | +764x |
- defrowlab = defrowlab,+ if (is.factor(varvec)) {
|
| 821 | -300x | +472 | +561x |
- cfun = cfun,+ levels(varvec)+ |
+
| 473 | ++ |
+ } else {
|
||
| 822 | -300x | +474 | +203x |
- cformat = cformat,+ unique(varvec) |
| 823 | +475 |
- ## split_format = split_format,+ } |
||
| 824 | -300x | +|||
| 476 | +
- inclNAs = inclNAs,+ } |
|||
| 825 | -300x | +|||
| 477 | +
- MoreArgs = list(+ ) |
|||
| 826 | -300x | +|||
| 478 | +
- extra_args = extra_args,+ |
|||
| 827 | -300x | +|||
| 479 | +
- indent_mod = indent_mod,+ setMethod( |
|||
| 828 | -300x | +|||
| 480 | +
- label_pos = show_kidlabs,+ ".applysplit_rawvals", "MultiVarSplit", |
|||
| 829 | -300x | +|||
| 481 | +
- split_format = split_format,+ function(spl, df) {
|
|||
| 830 | -300x | +|||
| 482 | +
- split_na_str = split_na_str,+ ## spl_payload(spl) |
|||
| 831 | -300x | +483 | +48x |
- section_div = section_div_if_multivar+ spl_varnames(spl) |
| 832 | -300x | +|||
| 484 | +
- ), ## rvis),+ } |
|||
| 833 | -300x | +|||
| 485 | +
- SIMPLIFY = FALSE+ ) |
|||
| 834 | +486 |
- )+ |
||
| 835 | +487 |
- } else {
+ setMethod( |
||
| 836 | +488 |
- ## we're combining existing splits here+ ".applysplit_rawvals", "AllSplit", |
||
| 837 | -25x | +489 | +97x |
- pld <- unlist(lapply(.payload, .uncompound))+ function(spl, df) obj_name(spl) |
| 838 | +490 |
-
+ ) # "all obs") |
||
| 839 | +491 |
- ## only override the childen being combined if the constructor+ |
||
| 840 | +492 |
- ## was passed a non-default value for child_labels+ setMethod( |
||
| 841 | +493 |
- ## and the child was at NA before+ ".applysplit_rawvals", "ManualSplit", |
||
| 842 | -25x | +494 | +51x |
- pld <- lapply(+ function(spl, df) spl@levels |
| 843 | -25x | +|||
| 495 | +
- pld,+ ) |
|||
| 844 | -25x | +|||
| 496 | +
- function(x) {
+
|
|||
| 845 | -50x | +|||
| 497 | +
- rvis <- label_position(x) ## labelrow_visible(x)+ ## setMethod(".applysplit_rawvals", "NULLSplit",
|
|||
| 846 | -50x | +|||
| 498 | +
- if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
+ ## function(spl, df) "") |
|||
| 847 | -! | +|||
| 499 | +
- if (identical(rvis, "default")) { ## ois.na(rvis))
+
|
|||
| 848 | -! | +|||
| 500 | +
- rvis <- show_kidlabs+ setMethod( |
|||
| 849 | +501 |
- }+ ".applysplit_rawvals", "VAnalyzeSplit",+ |
+ ||
| 502 | +! | +
+ function(spl, df) spl_payload(spl) |
||
| 850 | +503 |
- }+ ) |
||
| 851 | -50x | +|||
| 504 | +
- label_position(x) <- rvis+ |
|||
| 852 | -50x | +|||
| 505 | +
- x+ ## formfactor here is gross we're gonna have ot do this |
|||
| 853 | +506 |
- }+ ## all again in tthe data split part :-/ |
||
| 854 | +507 |
- )+ setMethod( |
||
| 855 | +508 |
- }+ ".applysplit_rawvals", "VarStaticCutSplit", |
||
| 856 | -325x | +|||
| 509 | +
- if (length(pld) == 1) {
+ function(spl, df) {
|
|||
| 857 | -277x | +510 | +22x |
- ret <- pld[[1]]+ spl_cutlabels(spl) |
| 858 | +511 |
- } else {
+ } |
||
| 859 | -48x | +|||
| 512 | +
- if (is.null(split_name)) {
+ ) |
|||
| 860 | -48x | +|||
| 513 | +
- split_name <- paste(c("ma", vapply(pld, obj_name, "")),
+
|
|||
| 861 | -48x | +|||
| 514 | +
- collapse = "_"+ setMethod( |
|||
| 862 | +515 |
- )+ ".applysplit_datapart", "VarLevelSplit", |
||
| 863 | +516 |
- }+ function(spl, df, vals) {
|
||
| 864 | -48x | +517 | +840x |
- ret <- new("AnalyzeMultiVars",
+ if (!(spl_payload(spl) %in% names(df))) {
|
| 865 | -48x | +|||
| 518 | +! |
- payload = pld,+ stop( |
||
| 866 | -48x | +|||
| 519 | +! |
- split_label = "",+ "Attempted to split on values of column (", spl_payload(spl),
|
||
| 867 | -48x | +|||
| 520 | +! |
- split_format = NULL,+ ") not present in the data" |
||
| 868 | -48x | +|||
| 521 | +
- split_na_str = split_na_str,+ ) |
|||
| 869 | -48x | +|||
| 522 | +
- content_fun = NULL,+ } |
|||
| 870 | -48x | +523 | +840x |
- content_format = NULL,+ ret <- lapply(seq_along(vals), function(i) {
|
| 871 | -+ | |||
| 524 | +2283x |
- ## I beleive this is superfluous now+ spl_col <- df[[spl_payload(spl)]] |
||
| 872 | -+ | |||
| 525 | +2283x |
- ## the payloads carry aroudn the real instructions+ df[!is.na(spl_col) & spl_col == vals[[i]], ] |
||
| 873 | +526 |
- ## XXX+ }) |
||
| 874 | -48x | +527 | +840x |
- label_children = .labelkids_helper(show_kidlabs),+ names(ret) <- as.character(vals) |
| 875 | -48x | +528 | +840x |
- split_label_position = "hidden", ## XXX is this right?+ ret |
| 876 | -48x | +|||
| 529 | +
- name = split_name,+ } |
|||
| 877 | -48x | +|||
| 530 | +
- extra_args = extra_args,+ ) |
|||
| 878 | +531 |
- ## modifier applied on splits in payload+ |
||
| 879 | -48x | +|||
| 532 | +
- indent_modifier = 0L,+ setMethod( |
|||
| 880 | -48x | +|||
| 533 | +
- content_indent_modifier = 0L,+ ".applysplit_datapart", "MultiVarSplit", |
|||
| 881 | -48x | +|||
| 534 | +
- content_var = cvar,+ function(spl, df, vals) {
|
|||
| 882 | +535 | 48x |
- page_title_prefix = NA_character_,+ allvnms <- spl_varnames(spl) |
|
| 883 | +536 | 48x |
- child_section_div = section_div+ if (!is.null(vals) && !identical(allvnms, vals)) {
|
|
| 884 | -+ | |||
| 537 | +! |
- )+ incl <- match(vals, allvnms) |
||
| 885 | +538 |
- }+ } else {
|
||
| 886 | -325x | +539 | +48x |
- ret+ incl <- seq_along(allvnms) |
| 887 | +540 |
- }+ } |
||
| 888 | -+ | |||
| 541 | +48x |
-
+ vars <- spl_payload(spl)[incl] |
||
| 889 | +542 |
- setClass("VarLevWBaselineSplit",
+ ## don't remove nas |
||
| 890 | +543 |
- contains = "VarLevelSplit",+ ## ret = lapply(vars, function(cl) {
|
||
| 891 | +544 |
- representation(+ ## df[!is.na(df[[cl]]),] |
||
| 892 | +545 |
- var = "character",+ ## }) |
||
| 893 | -+ | |||
| 546 | +48x |
- ref_group_value = "character"+ ret <- rep(list(df), length(vars))+ |
+ ||
| 547 | +48x | +
+ names(ret) <- vals+ |
+ ||
| 548 | +48x | +
+ ret |
||
| 894 | +549 |
- )+ } |
||
| 895 | +550 |
) |
||
| 896 | +551 | |||
| 897 | +552 |
- #' @rdname VarLevelSplit+ setMethod( |
||
| 898 | +553 |
- #' @export+ ".applysplit_datapart", "AllSplit", |
||
| 899 | -+ | |||
| 554 | +97x |
- VarLevWBaselineSplit <- function(var,+ function(spl, df, vals) list(df) |
||
| 900 | +555 |
- ref_group,+ ) |
||
| 901 | +556 |
- labels_var = var,+ |
||
| 902 | +557 |
- split_label,+ ## ## not sure I need this |
||
| 903 | +558 |
- split_fun = NULL,+ setMethod( |
||
| 904 | +559 |
- label_fstr = "%s - %s",+ ".applysplit_datapart", "ManualSplit", |
||
| 905 | -+ | |||
| 560 | +51x |
- ## not needed I Think...+ function(spl, df, vals) rep(list(df), times = length(vals)) |
||
| 906 | +561 |
- cfun = NULL,+ ) |
||
| 907 | +562 |
- cformat = NULL,+ |
||
| 908 | +563 |
- cna_str = NA_character_,+ ## setMethod(".applysplit_datapart", "NULLSplit",
|
||
| 909 | +564 |
- cvar = "",+ ## function(spl, df, vals) list(df[FALSE,])) |
||
| 910 | +565 |
- split_format = NULL,+ |
||
| 911 | +566 |
- split_na_str = NA_character_,+ setMethod( |
||
| 912 | +567 |
- valorder = NULL,+ ".applysplit_datapart", "VarStaticCutSplit", |
||
| 913 | +568 |
- split_name = var,+ function(spl, df, vals) {
|
||
| 914 | +569 |
- extra_args = list()) {
+ # lbs = spl_cutlabels(spl) |
||
| 915 | -10x | +570 | +14x |
- check_ok_label(split_label)+ var <- spl_payload(spl) |
| 916 | -10x | +571 | +14x |
- new("VarLevWBaselineSplit",
+ varvec <- df[[var]] |
| 917 | -10x | +572 | +14x |
- payload = var,+ cts <- spl_cuts(spl) |
| 918 | -10x | +573 | +14x |
- ref_group_value = ref_group,+ cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ |
+
| 574 | +14x | +
+ split(df, cfct, drop = FALSE) |
||
| 919 | +575 |
- ## This will occur at the row level not on the column split, for now+ } |
||
| 920 | +576 |
- ## TODO revisit this to confirm its right+ ) |
||
| 921 | +577 |
- ## comparison_func = comparison,+ |
||
| 922 | +578 |
- # label_format = label_fstr,+ setMethod( |
||
| 923 | -10x | +|||
| 579 | +
- value_label_var = labels_var,+ ".applysplit_datapart", "CumulativeCutSplit", |
|||
| 924 | -10x | +|||
| 580 | +
- split_label = split_label,+ function(spl, df, vals) {
|
|||
| 925 | -10x | +|||
| 581 | +
- content_fun = cfun,+ # lbs = spl_cutlabels(spl) |
|||
| 926 | -10x | +582 | +8x |
- content_format = cformat,+ var <- spl_payload(spl) |
| 927 | -10x | +583 | +8x |
- content_na_str = cna_str,+ varvec <- df[[var]] |
| 928 | -10x | +584 | +8x |
- split_format = split_format,+ cts <- spl_cuts(spl) |
| 929 | -10x | +585 | +8x |
- split_na_str = split_na_str,+ cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs) |
| 930 | -10x | -
- split_fun = split_fun,- |
- ||
| 931 | -10x | +586 | +8x |
- name = split_name,+ ret <- lapply( |
| 932 | -10x | +587 | +8x |
- label_children = FALSE,+ seq_len(length(levels(cfct))), |
| 933 | -10x | +588 | +8x |
- extra_args = extra_args,+ function(i) df[as.integer(cfct) <= i, ] |
| 934 | +589 |
- ## this is always a column split+ ) |
||
| 935 | -10x | +590 | +8x |
- indent_modifier = 0L,+ names(ret) <- levels(cfct) |
| 936 | -10x | +591 | +8x |
- content_indent_modifier = 0L,+ ret |
| 937 | -10x | +|||
| 592 | +
- content_var = cvar,+ } |
|||
| 938 | +593 |
- ## so long as this is columnspace only+ ) |
||
| 939 | -10x | +|||
| 594 | +
- page_title_prefix = NA_character_,+ |
|||
| 940 | -10x | +|||
| 595 | +
- child_section_div = NA_character_+ ## XXX TODO *CutSplit Methods |
|||
| 941 | +596 |
- )+ |
||
| 942 | +597 |
- }+ setClass("NullSentinel", contains = "NULL")
|
||
| 943 | +598 | ++ |
+ nullsentinel <- new("NullSentinel")
+ |
+ |
| 599 | +! | +
+ noarg <- function() nullsentinel+ |
+ ||
| 600 | ||||
| 944 | +601 |
- .chkname <- function(nm) {
+ ## Extras generation methods |
||
| 945 | -18732x | +|||
| 602 | +
- if (is.null(nm)) {
+ setMethod( |
|||
| 946 | -352x | +|||
| 603 | +
- nm <- ""+ ".applysplit_extras", "Split", |
|||
| 947 | +604 |
- }+ function(spl, df, vals) {
|
||
| 948 | -18732x | +605 | +1007x |
- if (length(nm) != 1) {
+ splex <- split_exargs(spl) |
| 949 | -! | +|||
| 606 | +1007x |
- stop("name is not of length one")
+ nvals <- length(vals) |
||
| 950 | -18732x | +607 | +1007x |
- } else if (is.na(nm)) {
+ lapply(seq_len(nvals), function(vpos) {
+ |
+
| 608 | +2572x | +
+ one_ex <- lapply(splex, function(arg) {
|
||
| 951 | +609 | ! |
- warning("Got missing value for name, converting to characters '<NA>'")
+ if (length(arg) >= vpos) {
|
|
| 952 | +610 | ! |
- nm <- "<NA>"+ arg[[vpos]] |
|
| 953 | +611 |
- }+ } else {
+ |
+ ||
| 612 | +! | +
+ noarg()+ |
+ ||
| 613 | ++ |
+ }+ |
+ ||
| 614 | ++ |
+ }) |
||
| 954 | -18732x | +615 | +2572x |
- nm+ names(one_ex) <- names(splex)+ |
+
| 616 | +2572x | +
+ one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")]+ |
+ ||
| 617 | +2572x | +
+ one_ex |
||
| 955 | +618 |
- }+ }) |
||
| 956 | +619 |
-
+ } |
||
| 957 | +620 |
- ### Tree Position Representation+ ) |
||
| 958 | +621 |
- ###+ |
||
| 959 | +622 |
- ### Class(es) that represent position with in a+ setMethod( |
||
| 960 | +623 |
- ### tree as parallel vectors of Split objects and+ ".applysplit_ref_vals", "Split",+ |
+ ||
| 624 | +! | +
+ function(spl, df, vals) rep(list(NULL), length(vals)) |
||
| 961 | +625 |
- ### values chosen at that split, plus labeling info+ ) |
||
| 962 | +626 |
- TreePos <- function(spls = list(),+ |
||
| 963 | +627 |
- svals = list(),+ setMethod( |
||
| 964 | +628 |
- svlabels = character(),+ ".applysplit_ref_vals", "VarLevWBaselineSplit", |
||
| 965 | +629 |
- sub = NULL) {
+ function(spl, df, vals) {
|
||
| 966 | -1595x | +630 | +17x |
- check_ok_label(svlabels, multi_ok = TRUE)+ bl_level <- spl@ref_group_value # XXX XXX |
| 967 | -1595x | +631 | +17x |
- svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr))+ vnames <- value_names(vals) |
| 968 | -1595x | +632 | +17x |
- if (is.null(sub)) {
+ ret <- lapply(vnames, function(vl) {
|
| 969 | -358x | +633 | +46x |
- if (length(spls) > 0) {
+ list(.in_ref_col = vl == bl_level) |
| 970 | -! | +|||
| 634 | +
- sub <- make_pos_subset(+ }) |
|||
| 971 | -! | +|||
| 635 | +17x |
- spls = spls,+ names(ret) <- vnames |
||
| 972 | -! | +|||
| 636 | +17x |
- svals = svals+ ret |
||
| 973 | +637 |
- )+ } |
||
| 974 | +638 |
- } else {
+ ) |
||
| 975 | -358x | +|||
| 639 | +
- sub <- expression(TRUE)+ |
|||
| 976 | +640 |
- }+ ## XXX TODO FIXME |
||
| 977 | +641 |
- }+ setMethod( |
||
| 978 | -1595x | +|||
| 642 | +
- new("TreePos",
+ ".applysplit_partlabels", "Split", |
|||
| 979 | -1595x | +643 | +119x |
- splits = spls, s_values = svals,+ function(spl, df, vals, labels) as.character(vals) |
| 980 | -1595x | +|||
| 644 | +
- sval_labels = svlabels,+ ) |
|||
| 981 | -1595x | +|||
| 645 | +
- subset = sub+ |
|||
| 982 | +646 |
- )+ setMethod( |
||
| 983 | +647 |
- }+ ".applysplit_partlabels", "VarLevelSplit", |
||
| 984 | +648 |
-
+ function(spl, df, vals, labels) {
|
||
| 985 | -+ | |||
| 649 | +839x |
- ## Tree position convenience functions+ varname <- spl_payload(spl) |
||
| 986 | -+ | |||
| 650 | +839x |
- ##+ vlabelname <- spl_labelvar(spl) |
||
| 987 | -+ | |||
| 651 | +839x |
- make_child_pos <- function(parpos,+ varvec <- df[[varname]] |
||
| 988 | +652 |
- newspl,+ ## we used to check if vals was NULL but |
||
| 989 | +653 |
- newval,+ ## this is called after a short-circuit return in .apply_split_inner in that |
||
| 990 | +654 |
- newlab = newval,+ ## case |
||
| 991 | +655 |
- newextra = list()) {
+ ## so vals is guaranteed to be non-null here |
||
| 992 | -1237x | -
- if (!is(newval, "SplitValue")) {
- |
- ||
| 993 | -! | +656 | +839x |
- nsplitval <- SplitValue(newval, extr = newextra, label = newlab)+ if (is.null(labels)) {
|
| 994 | -+ | |||
| 657 | +839x |
- } else {
+ if (varname == vlabelname) {
|
||
| 995 | -1237x | +658 | +704x |
- nsplitval <- newval+ labels <- vals |
| 996 | +659 |
- }+ } else {
|
||
| 997 | -1237x | +660 | +135x |
- check_ok_label(newlab)+ labfact <- is.factor(df[[vlabelname]]) |
| 998 | -1237x | +661 | +135x |
- newpos <- TreePos(+ lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL |
| 999 | -1237x | +662 | +135x |
- spls = c(pos_splits(parpos), newspl),+ labels <- sapply(vals, function(v) {
|
| 1000 | -1237x | +663 | +272x |
- svals = c(pos_splvals(parpos), nsplitval),+ vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE]) |
| 1001 | -1237x | +|||
| 664 | +
- svlabels = c(pos_splval_labels(parpos), newlab),+ ## TODO remove this once 1-to-1 value-label map is enforced+ |
+ |||
| 665 | ++ |
+ ## elsewhere. |
||
| 1002 | -1237x | +666 | +272x |
- sub = .combine_subset_exprs(+ stopifnot(length(vlabel) < 2) |
| 1003 | -1237x | +667 | +272x |
- pos_subset(parpos),+ if (length(vlabel) == 0) {
|
| 1004 | -+ | |||
| 668 | +! |
- ## this will grab the value's custom subset expression if present+ vlabel <- "" |
||
| 1005 | -1237x | +669 | +272x |
- make_subset_expr(newspl, nsplitval)+ } else if (labfact) {
|
| 1006 | -+ | |||
| 670 | +6x |
- )+ vlabel <- lablevs[vlabel] |
||
| 1007 | +671 |
- )+ } |
||
| 1008 | -1237x | +672 | +272x |
- newpos+ vlabel |
| 1009 | +673 |
- }+ }) |
||
| 1010 | +674 |
-
+ } |
||
| 1011 | +675 |
- ## Virtual Classes for Tree Nodes and Layouts =================================+ } |
||
| 1012 | -+ | |||
| 676 | +839x |
- ##+ names(labels) <- as.character(vals)+ |
+ ||
| 677 | +839x | +
+ labels |
||
| 1013 | +678 |
- ## Virtual class hiearchy for the various types of trees in use in the S4+ } |
||
| 1014 | +679 |
- ## implementation of the TableTree machinery+ ) |
||
| 1015 | +680 | |||
| 1016 | +681 |
- ## core basics+ setMethod( |
||
| 1017 | +682 |
- setClass("VNodeInfo",
+ ".applysplit_partlabels", "MultiVarSplit", |
||
| 1018 | -+ | |||
| 683 | +48x |
- contains = "VIRTUAL",+ function(spl, df, vals, labels) value_labels(spl) |
||
| 1019 | +684 |
- representation(+ ) |
||
| 1020 | +685 |
- level = "integer",+ |
||
| 1021 | +686 |
- name = "character" ## ,+ make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals, |
||
| 1022 | +687 |
- ## label = "character"+ subset_exprs) {
|
||
| 1023 | -+ | |||
| 688 | +2795x |
- )+ if (length(vals) == 0) {
+ |
+ ||
| 689 | +369x | +
+ return(vals) |
||
| 1024 | +690 |
- )+ } |
||
| 1025 | +691 | |||
| 1026 | -+ | |||
| 692 | +2426x |
- setClass("VTree",
+ if (is(extrs, "AsIs")) {
|
||
| 1027 | -+ | |||
| 693 | +! |
- contains = c("VIRTUAL", "VNodeInfo"),
+ extrs <- unclass(extrs) |
||
| 1028 | +694 |
- representation(children = "list")+ } |
||
| 1029 | +695 |
- )+ ## if(are(vals, "SplitValue")) {
|
||
| 1030 | +696 | |||
| 1031 | +697 |
- setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))
+ ## return(vals) |
||
| 1032 | +698 |
-
+ ## } |
||
| 1033 | +699 |
- ## Layout trees =================================+ |
||
| 1034 | -+ | |||
| 700 | +2426x |
-
+ mapply(SplitValue, |
||
| 1035 | -+ | |||
| 701 | +2426x |
- # setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))
+ val = vals, extr = extrs, |
||
| 1036 | -+ | |||
| 702 | +2426x |
-
+ label = labels, |
||
| 1037 | -+ | |||
| 703 | +2426x |
- setClass("VLayoutLeaf",
+ sub_expr = subset_exprs, |
||
| 1038 | -+ | |||
| 704 | +2426x |
- contains = c("VIRTUAL", "VLeaf"),
+ SIMPLIFY = FALSE |
||
| 1039 | +705 |
- representation(+ ) |
||
| 1040 | +706 |
- pos_in_tree = "TreePos",+ } |
||
| 1041 | +707 |
- label = "character"+ |
||
| 1042 | +708 |
- )+ #' Split functions |
||
| 1043 | +709 |
- )+ #' |
||
| 1044 | +710 |
-
+ #' @inheritParams sf_args |
||
| 1045 | +711 |
- setClass("VLayoutTree",
+ #' @inheritParams gen_args |
||
| 1046 | +712 |
- contains = c("VIRTUAL", "VTree"),
+ #' @param vals (`ANY`)\cr for internal use only. |
||
| 1047 | +713 |
- representation(+ #' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones. |
||
| 1048 | +714 |
- split = "Split",+ #' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure |
||
| 1049 | +715 |
- pos_in_tree = "TreePos",+ #' regardless of presence in the data). |
||
| 1050 | +716 |
- label = "character"+ #' |
||
| 1051 | +717 |
- )+ #' @inheritSection custom_split_funs Custom Splitting Function Details |
||
| 1052 | +718 |
- )+ #' |
||
| 1053 | +719 |
-
+ #' @inherit add_overall_level return |
||
| 1054 | +720 |
- setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))
+ #' |
||
| 1055 | +721 |
-
+ #' @name split_funcs |
||
| 1056 | +722 |
- ## LayoutAxisTree classes =================================+ NULL |
||
| 1057 | +723 | |||
| 1058 | +724 |
- setOldClass("function")
+
|
||
| 1059 | +725 |
- setOldClass("NULL")
+ #' @examples |
||
| 1060 | +726 |
- setClassUnion("FunctionOrNULL", c("function", "NULL"))
+ #' lyt <- basic_table() %>% |
||
| 1061 | +727 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 1062 | +728 |
- setClass("LayoutAxisTree",
+ #' split_rows_by("COUNTRY",
|
||
| 1063 | +729 |
- contains = "VLayoutTree",+ #' split_fun = remove_split_levels(c( |
||
| 1064 | +730 |
- representation(summary_func = "FunctionOrNULL"),+ #' "USA", "CAN", |
||
| 1065 | +731 |
- validity = function(object) {
+ #' "CHE", "BRA" |
||
| 1066 | +732 |
- all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf")))+ #' )) |
||
| 1067 | +733 |
- }+ #' ) %>% |
||
| 1068 | +734 |
- )+ #' analyze("AGE")
|
||
| 1069 | +735 |
-
+ #' |
||
| 1070 | +736 |
- setClass("LayoutAxisLeaf",
+ #' tbl <- build_table(lyt, DM) |
||
| 1071 | +737 |
- contains = "VLayoutLeaf", ## "VNodeInfo",+ #' tbl |
||
| 1072 | +738 |
- representation(+ #' |
||
| 1073 | +739 |
- func = "function",+ #' @rdname split_funcs |
||
| 1074 | +740 |
- col_footnotes = "list"+ #' @export |
||
| 1075 | +741 |
- )+ remove_split_levels <- function(excl) {
|
||
| 1076 | -+ | |||
| 742 | +28x |
- )+ stopifnot(is.character(excl)) |
||
| 1077 | -+ | |||
| 743 | +28x |
-
+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 1078 | -+ | |||
| 744 | +56x |
- setClass("LayoutColTree",
+ var <- spl_payload(spl) |
||
| 1079 | -+ | |||
| 745 | +56x |
- contains = "LayoutAxisTree",+ df2 <- df[!(df[[var]] %in% excl), ] |
||
| 1080 | -+ | |||
| 746 | +56x |
- representation(+ if (is.factor(df2[[var]])) {
|
||
| 1081 | -+ | |||
| 747 | +1x |
- display_columncounts = "logical",+ levels <- levels(df2[[var]]) |
||
| 1082 | -+ | |||
| 748 | +1x |
- columncount_format = "character",+ levels <- levels[!(levels %in% excl)] |
||
| 1083 | -+ | |||
| 749 | +1x |
- col_footnotes = "list"+ df2[[var]] <- factor(df2[[var]], levels = levels) |
||
| 1084 | +750 |
- )+ }+ |
+ ||
| 751 | +56x | +
+ .apply_split_inner(spl, df2,+ |
+ ||
| 752 | +56x | +
+ vals = vals,+ |
+ ||
| 753 | +56x | +
+ labels = labels,+ |
+ ||
| 754 | +56x | +
+ trim = trim |
||
| 1085 | +755 |
- )+ ) |
||
| 1086 | +756 |
-
+ } |
||
| 1087 | +757 |
- setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
+ } |
||
| 1088 | +758 |
- LayoutColTree <- function(lev = 0L,+ |
||
| 1089 | +759 |
- name = obj_name(spl),+ #' @param only (`character`)\cr levels to retain (all others will be dropped). |
||
| 1090 | +760 |
- label = obj_label(spl),+ #' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the |
||
| 1091 | +761 |
- kids = list(),+ #' split. Defaults to `TRUE`. |
||
| 1092 | +762 |
- spl = EmptyAllSplit,+ #' |
||
| 1093 | +763 |
- tpos = TreePos(),+ #' @examples |
||
| 1094 | +764 |
- summary_function = NULL,+ #' lyt <- basic_table() %>% |
||
| 1095 | +765 |
- disp_colcounts = FALSE,+ #' split_cols_by("ARM") %>%
|
||
| 1096 | +766 |
- colcount_format = "(N=xx)",+ #' split_rows_by("COUNTRY",
|
||
| 1097 | +767 |
- footnotes = list()) { ## ,
+ #' split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
|
||
| 1098 | +768 |
- ## sub = expression(TRUE),+ #' ) %>% |
||
| 1099 | +769 |
- ## svar = NA_character_,+ #' analyze("AGE")
|
||
| 1100 | +770 |
- ## slab = NA_character_) {
+ #' |
||
| 1101 | -553x | +|||
| 771 | +
- if (is.null(spl)) {
+ #' tbl <- build_table(lyt, DM) |
|||
| 1102 | -! | +|||
| 772 | +
- stop(+ #' tbl |
|||
| 1103 | -! | +|||
| 773 | +
- "LayoutColTree constructor got NULL for spl. ", # nocov+ #' |
|||
| 1104 | -! | +|||
| 774 | +
- "This should never happen. Please contact the maintainer."+ #' @rdname split_funcs |
|||
| 1105 | +775 |
- )+ #' @export |
||
| 1106 | +776 |
- } # nocov+ keep_split_levels <- function(only, reorder = TRUE) {
|
||
| 1107 | -553x | +777 | +43x |
- footnotes <- make_ref_value(footnotes)+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
| 1108 | -553x | +778 | +76x |
- check_ok_label(label)+ var <- spl_payload(spl) |
| 1109 | -553x | +779 | +76x |
- new("LayoutColTree",
+ varvec <- df[[var]] |
| 1110 | -553x | +780 | +76x |
- level = lev, children = kids,+ if (is.factor(varvec) && !all(only %in% levels(varvec))) {
|
| 1111 | -553x | +781 | +1x |
- name = .chkname(name),+ stop( |
| 1112 | -553x | +782 | +1x |
- summary_func = summary_function,+ "Attempted to keep invalid factor level(s) in split ", |
| 1113 | -553x | +783 | +1x |
- pos_in_tree = tpos,- |
-
| 1114 | -553x | -
- split = spl,+ setdiff(only, levels(varvec)) |
||
| 1115 | +784 |
- ## subset = sub,+ ) |
||
| 1116 | +785 |
- ## splitvar = svar,- |
- ||
| 1117 | -553x | -
- label = label,+ } |
||
| 1118 | -553x | +786 | +75x |
- display_columncounts = disp_colcounts,+ df2 <- df[df[[var]] %in% only, ] |
| 1119 | -553x | +787 | +75x |
- columncount_format = colcount_format,+ if (reorder) {
|
| 1120 | -553x | -
- col_footnotes = footnotes- |
- ||
| 1121 | -- |
- )- |
- ||
| 1122 | -- |
- }- |
- ||
| 1123 | -- | - - | -||
| 1124 | -- |
- LayoutColLeaf <- function(lev = 0L,- |
- ||
| 1125 | -+ | 788 | +75x |
- name = label,+ df2[[var]] <- factor(df2[[var]], levels = only) |
| 1126 | +789 |
- label = "",+ } |
||
| 1127 | -+ | |||
| 790 | +75x |
- tpos = TreePos()) {
+ spl_child_order(spl) <- only |
||
| 1128 | -1047x | +791 | +75x |
- check_ok_label(label)+ .apply_split_inner(spl, df2, |
| 1129 | -1047x | +792 | +75x |
- new("LayoutColLeaf",
+ vals = only, |
| 1130 | -1047x | +793 | +75x |
- level = lev, name = .chkname(name), label = label,+ labels = labels, |
| 1131 | -1047x | +794 | +75x |
- pos_in_tree = tpos ## ,+ trim = trim |
| 1132 | +795 |
- ## subset = sub#,+ ) |
||
| 1133 | +796 |
- ## N_count = n,+ } |
||
| 1134 | +797 |
- ## splitvar = svar+ } |
||
| 1135 | +798 |
- )+ |
||
| 1136 | +799 |
- }+ #' @examples |
||
| 1137 | +800 |
-
+ #' lyt <- basic_table() %>% |
||
| 1138 | +801 |
- ## Instantiated column info class ==============================================+ #' split_cols_by("ARM") %>%
|
||
| 1139 | +802 |
- ##+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
|
||
| 1140 | +803 |
- ## This is so we don't need multiple arguments+ #' analyze("AGE")
|
||
| 1141 | +804 |
- ## in the recursive functions that track+ #' |
||
| 1142 | +805 |
- ## various aspects of the column layout+ #' tbl <- build_table(lyt, DM) |
||
| 1143 | +806 |
- ## once its applied to the data.+ #' tbl |
||
| 1144 | +807 |
-
+ #' |
||
| 1145 | +808 |
- #' Instantiated column info+ #' @rdname split_funcs |
||
| 1146 | +809 |
- #'+ #' @export |
||
| 1147 | +810 |
- #' @inheritParams gen_args+ drop_split_levels <- function(df, |
||
| 1148 | +811 |
- #'+ spl, |
||
| 1149 | +812 |
- #' @exportClass InstantiatedColumnInfo+ vals = NULL, |
||
| 1150 | +813 |
- #' @rdname cinfo+ labels = NULL, |
||
| 1151 | +814 |
- setClass(+ trim = FALSE) {
|
||
| 1152 | -+ | |||
| 815 | +168x |
- "InstantiatedColumnInfo",+ var <- spl_payload(spl) |
||
| 1153 | -+ | |||
| 816 | +168x |
- representation(+ df2 <- df |
||
| 1154 | -+ | |||
| 817 | +168x |
- tree_layout = "VLayoutNode", ## LayoutColTree",+ df2[[var]] <- factor(df[[var]]) |
||
| 1155 | -+ | |||
| 818 | +168x |
- subset_exprs = "list",+ lblvar <- spl_label_var(spl) |
||
| 1156 | -+ | |||
| 819 | +168x |
- cextra_args = "list",+ if (!is.null(lblvar)) {
|
||
| 1157 | -+ | |||
| 820 | +168x |
- counts = "integer",+ df2[[lblvar]] <- factor(df[[lblvar]]) |
||
| 1158 | +821 |
- total_count = "integer",+ } |
||
| 1159 | +822 |
- display_columncounts = "logical",+ |
||
| 1160 | -+ | |||
| 823 | +168x |
- columncount_format = "FormatSpec",+ .apply_split_inner(spl, df2, |
||
| 1161 | -+ | |||
| 824 | +168x |
- columncount_na_str = "character",+ vals = vals, |
||
| 1162 | -+ | |||
| 825 | +168x |
- top_left = "character"+ labels = labels,+ |
+ ||
| 826 | +168x | +
+ trim = trim |
||
| 1163 | +827 |
) |
||
| 1164 | +828 |
- )+ } |
||
| 1165 | +829 | |||
| 1166 | +830 |
- #' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object.+ #' @examples |
||
| 1167 | +831 |
- #' @param csubs (`list`)\cr a list of subsetting expressions.+ #' lyt <- basic_table() %>% |
||
| 1168 | +832 |
- #' @param extras (`list`)\cr extra arguments associated with the columns.+ #' split_cols_by("ARM") %>%
|
||
| 1169 | +833 |
- #' @param cnts (`integer`)\cr counts.+ #' split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
|
||
| 1170 | +834 |
- #' @param total_cnt (`integer(1)`)\cr total observations represented across all columns.+ #' analyze("AGE")
|
||
| 1171 | +835 |
- #' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated+ #' |
||
| 1172 | +836 |
- #' table is printed.+ #' tbl <- build_table(lyt, DM) |
||
| 1173 | +837 |
- #' @param countformat (`string`)\cr format for the counts if they are displayed.+ #' tbl |
||
| 1174 | +838 |
- #' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults+ #' |
||
| 1175 | +839 |
- #' to `""`.+ #' @rdname split_funcs |
||
| 1176 | +840 |
- #'+ #' @export |
||
| 1177 | +841 |
- #' @return An `InstantiateadColumnInfo` object.+ drop_and_remove_levels <- function(excl) {
|
||
| 1178 | -+ | |||
| 842 | +4x |
- #'+ stopifnot(is.character(excl)) |
||
| 1179 | -+ | |||
| 843 | +4x |
- #' @export+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 1180 | -+ | |||
| 844 | +13x |
- #' @rdname cinfo+ var <- spl_payload(spl) |
||
| 1181 | -+ | |||
| 845 | +13x |
- InstantiatedColumnInfo <- function(treelyt = LayoutColTree(),+ df2 <- df[!(df[[var]] %in% excl), ] |
||
| 1182 | -+ | |||
| 846 | +13x |
- csubs = list(expression(TRUE)),+ df2[[var]] <- factor(df2[[var]]) |
||
| 1183 | -+ | |||
| 847 | +13x |
- extras = list(list()),+ .apply_split_inner( |
||
| 1184 | -+ | |||
| 848 | +13x |
- cnts = NA_integer_,+ spl, |
||
| 1185 | -+ | |||
| 849 | +13x |
- total_cnt = NA_integer_,+ df2, |
||
| 1186 | -+ | |||
| 850 | +13x |
- dispcounts = FALSE,+ vals = vals, |
||
| 1187 | -+ | |||
| 851 | +13x |
- countformat = "(N=xx)",+ labels = labels,+ |
+ ||
| 852 | +13x | +
+ trim = trim |
||
| 1188 | +853 |
- count_na_str = "",+ ) |
||
| 1189 | +854 |
- topleft = character()) {
+ } |
||
| 1190 | -620x | +|||
| 855 | +
- leaves <- collect_leaves(treelyt)+ } |
|||
| 1191 | -620x | +|||
| 856 | +
- nl <- length(leaves)+ |
|||
| 1192 | -620x | +|||
| 857 | +
- extras <- rep(extras, length.out = nl)+ #' @param neworder (`character`)\cr new order of factor levels. |
|||
| 1193 | -620x | +|||
| 858 | +
- cnts <- rep(cnts, length.out = nl)+ #' @param newlabels (`character`)\cr labels for (new order of) factor levels. |
|||
| 1194 | -620x | +|||
| 859 | +
- csubs <- rep(csubs, length.out = nl)+ #' @param drlevels (`flag`)\cr whether levels in the data which do not appear in `neworder` should be dropped. |
|||
| 1195 | +860 |
-
+ #' Defaults to `TRUE`. |
||
| 1196 | -620x | +|||
| 861 | +
- nleaves <- length(leaves)+ #' |
|||
| 1197 | -620x | +|||
| 862 | +
- snas <- sum(is.na(cnts))+ #' @rdname split_funcs |
|||
| 1198 | -620x | +|||
| 863 | +
- if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
+ #' @export |
|||
| 1199 | -! | +|||
| 864 | +
- stop(+ reorder_split_levels <- function(neworder, |
|||
| 1200 | -! | +|||
| 865 | +
- "Mismatching number of columns indicated by: csubs [",+ newlabels = neworder, |
|||
| 1201 | -! | +|||
| 866 | +
- length(csubs), "], ",+ drlevels = TRUE) {
|
|||
| 1202 | -! | +|||
| 867 | +1x |
- "treelyt [", nl, "], extras [", length(extras),+ if (length(neworder) != length(newlabels)) {
|
||
| 1203 | +868 | ! |
- "] and counts [", cnts, "]."- |
- |
| 1204 | -- |
- )+ stop("Got mismatching lengths for neworder and newlabels.")
|
||
| 1205 | +869 |
} |
||
| 1206 | -620x | +870 | +1x |
- if (snas != 0 && snas != nleaves) {
+ function(df, spl, trim, ...) {
|
| 1207 | -2x | +871 | +1x |
- warning(+ df2 <- df |
| 1208 | -2x | +872 | +1x |
- "Mixture of missing and non-missing column counts when ",+ valvec <- df2[[spl_payload(spl)]] |
| 1209 | -2x | +873 | +1x |
- "creating column info."+ vals <- if (is.factor(valvec)) levels(valvec) else unique(valvec) |
| 1210 | -+ | |||
| 874 | +1x |
- )+ if (!drlevels) {
|
||
| 1211 | -+ | |||
| 875 | +! |
- }+ neworder <- c(neworder, setdiff(vals, neworder)) |
||
| 1212 | +876 | - - | -||
| 1213 | -620x | -
- new("InstantiatedColumnInfo",
+ } |
||
| 1214 | -620x | +877 | +1x |
- tree_layout = treelyt,+ df2[[spl_payload(spl)]] <- factor(valvec, levels = neworder) |
| 1215 | -620x | +878 | +1x |
- subset_exprs = csubs,+ if (drlevels) {
|
| 1216 | -620x | +879 | +1x |
- cextra_args = extras,+ orig_order <- neworder |
| 1217 | -620x | +880 | +1x |
- counts = cnts,+ df2[[spl_payload(spl)]] <- droplevels(df2[[spl_payload(spl)]]) |
| 1218 | -620x | +881 | +1x |
- total_count = total_cnt,+ neworder <- levels(df2[[spl_payload(spl)]]) |
| 1219 | -620x | +882 | +1x |
- display_columncounts = dispcounts,+ newlabels <- newlabels[orig_order %in% neworder] |
| 1220 | -620x | +|||
| 883 | +
- columncount_format = countformat,+ } |
|||
| 1221 | -620x | +884 | +1x |
- columncount_na_str = count_na_str,+ spl_child_order(spl) <- neworder |
| 1222 | -620x | +885 | +1x |
- top_left = topleft+ .apply_split_inner(spl, df2, vals = neworder, labels = newlabels, trim = trim) |
| 1223 | +886 |
- )+ } |
||
| 1224 | +887 |
} |
||
| 1225 | +888 | |||
| 1226 | +889 |
- ## TableTrees and row classes ==================================================+ #' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped) |
||
| 1227 | +890 |
- ## XXX Rowspans as implemented dont really work+ #' *separately within each grouping defined at this point in the structure*. |
||
| 1228 | +891 |
- ## they're aren't attached to the right data structures+ #' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer" |
||
| 1229 | +892 |
- ## during conversions.+ #' variable, not `innervar`) should be dropped. Defaults to `TRUE`. |
||
| 1230 | +893 |
-
+ #' |
||
| 1231 | +894 |
- ## FIXME: if we ever actually need row spanning+ #' @rdname split_funcs |
||
| 1232 | +895 |
- setClass("VTableNodeInfo",
+ #' @export |
||
| 1233 | +896 |
- contains = c("VNodeInfo", "VIRTUAL"),
+ trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
|
||
| 1234 | -+ | |||
| 897 | +6x |
- representation(+ myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 1235 | -+ | |||
| 898 | +6x |
- ## col_layout = "VLayoutNode",+ if (!drop_outlevs) {
|
||
| 1236 | -+ | |||
| 899 | +! |
- col_info = "InstantiatedColumnInfo",+ ret <- .apply_split_inner(spl, df, |
||
| 1237 | -+ | |||
| 900 | +! |
- format = "FormatSpec",+ vals = vals, |
||
| 1238 | -+ | |||
| 901 | +! |
- na_str = "character",+ labels = labels, trim = trim |
||
| 1239 | +902 |
- indent_modifier = "integer",+ ) |
||
| 1240 | +903 |
- table_inset = "integer"+ } else {
|
||
| 1241 | -+ | |||
| 904 | +6x |
- )+ ret <- drop_split_levels( |
||
| 1242 | -+ | |||
| 905 | +6x |
- )+ df = df, spl = spl, vals = vals, |
||
| 1243 | -+ | |||
| 906 | +6x |
-
+ labels = labels, trim = trim |
||
| 1244 | +907 |
- setClass("TableRow",
+ ) |
||
| 1245 | +908 |
- contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
+ } |
||
| 1246 | +909 |
- representation(+ |
||
| 1247 | -+ | |||
| 910 | +6x |
- leaf_value = "ANY",+ ret$datasplit <- lapply(ret$datasplit, function(x) {
|
||
| 1248 | -+ | |||
| 911 | +14x |
- var_analyzed = "character",+ coldat <- x[[innervar]] |
||
| 1249 | -+ | |||
| 912 | +14x |
- ## var_label = "character",+ if (is(coldat, "character")) {
|
||
| 1250 | -+ | |||
| 913 | +! |
- label = "character",+ if (!is.null(vals)) {
|
||
| 1251 | -+ | |||
| 914 | +! |
- row_footnotes = "list",+ lvs <- vals |
||
| 1252 | +915 |
- trailing_section_div = "character"+ } else {
|
||
| 1253 | -+ | |||
| 916 | +! |
- )+ lvs <- unique(coldat) |
||
| 1254 | +917 |
- )+ } |
||
| 1255 | -+ | |||
| 918 | +! |
-
+ coldat <- factor(coldat, levels = lvs) ## otherwise |
||
| 1256 | +919 |
- ## TableTree Core Non-Virtual Classes ==============+ } else {
|
||
| 1257 | -+ | |||
| 920 | +14x |
- ##+ coldat <- droplevels(coldat) |
||
| 1258 | +921 |
- #' Row classes and constructors+ } |
||
| 1259 | -+ | |||
| 922 | +14x |
- #'+ x[[innervar]] <- coldat |
||
| 1260 | -+ | |||
| 923 | +14x |
- #' @inheritParams constr_args+ x |
||
| 1261 | +924 |
- #' @inheritParams lyt_args+ }) |
||
| 1262 | -+ | |||
| 925 | +6x |
- #' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only).+ ret$labels <- as.character(ret$labels) # TODO |
||
| 1263 | -+ | |||
| 926 | +6x |
- #'+ ret |
||
| 1264 | +927 |
- #' @return A formal object representing a table row of the constructed type.+ } |
||
| 1265 | -+ | |||
| 928 | +6x |
- #'+ myfun |
||
| 1266 | +929 |
- #' @author Gabriel Becker+ } |
||
| 1267 | +930 |
- #' @export+ |
||
| 1268 | +931 |
- #' @rdname rowclasses+ .add_combo_part_info <- function(part, |
||
| 1269 | +932 |
- LabelRow <- function(lev = 1L,+ df, |
||
| 1270 | +933 |
- label = "",+ valuename, |
||
| 1271 | +934 |
- name = label,+ levels, |
||
| 1272 | +935 |
- vis = !is.na(label) && nzchar(label),+ label, |
||
| 1273 | +936 |
- cinfo = EmptyColInfo,+ extras, |
||
| 1274 | +937 |
- indent_mod = 0L,+ first = TRUE) {
|
||
| 1275 | -+ | |||
| 938 | +24x |
- table_inset = 0L,+ value <- LevelComboSplitValue(valuename, extras, |
||
| 1276 | -+ | |||
| 939 | +24x |
- trailing_section_div = NA_character_) {
+ combolevels = levels, |
||
| 1277 | -4733x | +940 | +24x |
- check_ok_label(label)+ label = label |
| 1278 | -4733x | +|||
| 941 | +
- new("LabelRow",
+ ) |
|||
| 1279 | -4733x | +942 | +24x |
- leaf_value = list(),+ newdat <- setNames(list(df), valuename) |
| 1280 | -4733x | +943 | +24x |
- level = lev,+ newval <- setNames(list(value), valuename) |
| 1281 | -4733x | +944 | +24x |
- label = label,+ newextra <- setNames(list(extras), valuename) |
| 1282 | -+ | |||
| 945 | +24x |
- ## XXX this means that a label row and its talbe can have the same name....+ if (first) {
|
||
| 1283 | -+ | |||
| 946 | +6x |
- ## XXX that is bad but how bad remains to be seen+ part$datasplit <- c(newdat, part$datasplit) |
||
| 1284 | -+ | |||
| 947 | +6x |
- ## XXX+ part$values <- c(newval, part$values) |
||
| 1285 | -4733x | +948 | +6x |
- name = .chkname(name),+ part$labels <- c(setNames(label, valuename), part$labels) |
| 1286 | -4733x | +949 | +6x |
- col_info = cinfo,+ part$extras <- c(newextra, part$extras)+ |
+
| 950 | ++ |
+ } else {
|
||
| 1287 | -4733x | +951 | +18x |
- visible = vis,+ part$datasplit <- c(part$datasplit, newdat) |
| 1288 | -4733x | +952 | +18x |
- indent_modifier = as.integer(indent_mod),+ part$values <- c(part$values, newval) |
| 1289 | -4733x | +953 | +18x |
- table_inset = as.integer(table_inset),+ part$labels <- c(part$labels, setNames(label, valuename)) |
| 1290 | -4733x | +954 | +18x |
- trailing_section_div = trailing_section_div+ part$extras <- c(part$extras, newextra) |
| 1291 | +955 |
- )+ } |
||
| 1292 | +956 |
- }+ ## not needed even in custom split function case. |
||
| 1293 | +957 |
-
+ ## part = .fixupvals(part) |
||
| 1294 | -+ | |||
| 958 | +24x |
- #' Row constructors and classes+ part |
||
| 1295 | +959 |
- #'+ } |
||
| 1296 | -- |
- #' @rdname rowclasses- |
- ||
| 1297 | -- |
- #' @exportClass DataRow- |
- ||
| 1298 | +960 |
- setClass("DataRow",
+
|
||
| 1299 | +961 |
- contains = "TableRow",+ #' Add a virtual "overall" level to split |
||
| 1300 | +962 |
- representation(colspans = "integer") ## ,+ #' |
||
| 1301 | +963 |
- ## pos_in_tree = "TableRowPos"),+ #' @inheritParams lyt_args |
||
| 1302 | +964 |
- ## validity = function(object) {
+ #' @inheritParams sf_args |
||
| 1303 | +965 |
- ## lcsp = length(object@colspans)+ #' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to |
||
| 1304 | +966 |
- ## length(lcsp == 0) || lcsp == length(object@leaf_value)+ #' `"Overall"`. |
||
| 1305 | +967 |
- ## }+ #' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults |
||
| 1306 | +968 |
- )+ #' to `TRUE`. |
||
| 1307 | +969 |
-
+ #' |
||
| 1308 | +970 |
- #' @rdname rowclasses+ #' @return A closure suitable for use as a splitting function (`splfun`) when creating a table layout. |
||
| 1309 | +971 |
- #' @exportClass ContentRow+ #' |
||
| 1310 | +972 |
- setClass("ContentRow",
+ #' @examples |
||
| 1311 | +973 |
- contains = "TableRow",+ #' lyt <- basic_table() %>% |
||
| 1312 | +974 |
- representation(colspans = "integer") ## ,+ #' split_cols_by("ARM", split_fun = add_overall_level("All Patients",
|
||
| 1313 | +975 |
- ## pos_in_tree = "TableRowPos"),+ #' first = FALSE |
||
| 1314 | +976 |
- ## validity = function(object) {
+ #' )) %>% |
||
| 1315 | +977 |
- ## lcsp = length(object@colspans)+ #' analyze("AGE")
|
||
| 1316 | +978 |
- ## length(lcsp == 0) || lcsp == length(object@leaf_value)+ #' |
||
| 1317 | +979 |
- ## }+ #' tbl <- build_table(lyt, DM) |
||
| 1318 | +980 |
- )+ #' tbl |
||
| 1319 | +981 |
-
+ #' |
||
| 1320 | +982 |
- #' @rdname rowclasses+ #' lyt2 <- basic_table() %>% |
||
| 1321 | +983 |
- #' @exportClass LabelRow+ #' split_cols_by("ARM") %>%
|
||
| 1322 | +984 |
- setClass("LabelRow",
+ #' split_rows_by("RACE",
|
||
| 1323 | +985 |
- contains = "TableRow",+ #' split_fun = add_overall_level("All Ethnicities")
|
||
| 1324 | +986 |
- representation(visible = "logical")+ #' ) %>% |
||
| 1325 | +987 |
- )+ #' summarize_row_groups(label_fstr = "%s (n)") %>% |
||
| 1326 | +988 |
-
+ #' analyze("AGE")
|
||
| 1327 | +989 |
- #' @param klass (`character`)\cr internal detail.+ #' lyt2 |
||
| 1328 | +990 |
#' |
||
| 1329 | -- |
- #' @export- |
- ||
| 1330 | -- |
- #' @rdname rowclasses- |
- ||
| 1331 | -- |
- .tablerow <- function(vals = list(),- |
- ||
| 1332 | -- |
- name = "",- |
- ||
| 1333 | -- |
- lev = 1L,- |
- ||
| 1334 | -- |
- label = name,- |
- ||
| 1335 | -- |
- cspan = rep(1L, length(vals)),- |
- ||
| 1336 | +991 |
- cinfo = EmptyColInfo,+ #' tbl2 <- build_table(lyt2, DM) |
||
| 1337 | +992 |
- var = NA_character_,+ #' tbl2 |
||
| 1338 | +993 |
- format = NULL,+ #' |
||
| 1339 | +994 |
- na_str = NA_character_,+ #' @export |
||
| 1340 | +995 |
- klass,+ add_overall_level <- function(valname = "Overall", |
||
| 1341 | +996 |
- indent_mod = 0L,+ label = valname, |
||
| 1342 | +997 |
- footnotes = list(),+ extra_args = list(), |
||
| 1343 | +998 |
- table_inset = 0L,+ first = TRUE, |
||
| 1344 | +999 |
- trailing_section_div = NA_character_) {
+ trim = FALSE) {
|
||
| 1345 | -3238x | +1000 | +5x |
- if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
+ combodf <- data.frame( |
| 1346 | -260x | -
- name <- label- |
- ||
| 1347 | -+ | 1001 | +5x |
- }+ valname = valname, |
| 1348 | -3238x | +1002 | +5x |
- vals <- lapply(vals, rcell)+ label = label, |
| 1349 | -3238x | +1003 | +5x |
- rlabels <- unique(unlist(lapply(vals, obj_label)))+ levelcombo = I(list(select_all_levels)), |
| 1350 | -3238x | +1004 | +5x |
- if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
+ exargs = I(list(extra_args)), |
| 1351 | -! | +|||
| 1005 | +5x |
- label <- rlabels[nzchar(rlabels)]+ stringsAsFactors = FALSE |
||
| 1352 | +1006 |
- }+ ) |
||
| 1353 | -3238x | +1007 | +5x |
- if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
+ add_combo_levels(combodf, |
| 1354 | -2979x | +1008 | +5x |
- cspan <- vapply(vals, cell_cspan, 0L)+ trim = trim, first = first |
| 1355 | +1009 |
- }+ ) |
||
| 1356 | +1010 |
-
+ } |
||
| 1357 | -3238x | +|||
| 1011 | +
- check_ok_label(label)+ |
|||
| 1358 | -3238x | +|||
| 1012 | +
- rw <- new(klass,+ setClass("AllLevelsSentinel", contains = "character")
|
|||
| 1359 | -3238x | +|||
| 1013 | +
- leaf_value = vals,+ |
|||
| 1360 | -3238x | +|||
| 1014 | +
- name = .chkname(name),+ # nocov start |
|||
| 1361 | -3238x | +|||
| 1015 | +
- level = lev,+ #' @rdname add_combo_levels |
|||
| 1362 | -3238x | +|||
| 1016 | +
- label = .chkname(label),+ #' @export |
|||
| 1363 | -3238x | +|||
| 1017 | +
- colspans = cspan,+ select_all_levels <- new("AllLevelsSentinel")
|
|||
| 1364 | -3238x | +|||
| 1018 | +
- col_info = cinfo,+ # nocov end |
|||
| 1365 | -3238x | +|||
| 1019 | +
- var_analyzed = var,+ |
|||
| 1366 | +1020 |
- ## these are set in set_format_recursive below+ #' Add combination levels to split |
||
| 1367 | -3238x | +|||
| 1021 | +
- format = NULL,+ #' |
|||
| 1368 | -3238x | +|||
| 1022 | +
- na_str = NA_character_,+ #' @inheritParams sf_args |
|||
| 1369 | -3238x | +|||
| 1023 | +
- indent_modifier = indent_mod,+ #' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and |
|||
| 1370 | -3238x | +|||
| 1024 | +
- row_footnotes = footnotes,+ #' `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in |
|||
| 1371 | -3238x | +|||
| 1025 | +
- table_inset = table_inset,+ #' `comblevels` column indicates that an overall/all-observations level should be created. |
|||
| 1372 | -3238x | +|||
| 1026 | +
- trailing_section_div = trailing_section_div+ #' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and |
|||
| 1373 | +1027 |
- )+ #' individual levels. |
||
| 1374 | -3238x | +|||
| 1028 | +
- rw <- set_format_recursive(rw, format, na_str, FALSE)+ #' |
|||
| 1375 | -3238x | +|||
| 1029 | +
- rw+ #' @inherit add_overall_level return |
|||
| 1376 | +1030 |
- }+ #' |
||
| 1377 | +1031 |
-
+ #' @note |
||
| 1378 | +1032 |
- #' @param ... additional parameters passed to shared constructor (`.tablerow`).+ #' Analysis or summary functions for which the order matters should never be used within the tabulation framework. |
||
| 1379 | +1033 |
#' |
||
| 1380 | +1034 |
- #' @export+ #' @examples |
||
| 1381 | +1035 |
- #' @rdname rowclasses+ #' library(tibble) |
||
| 1382 | -2723x | +|||
| 1036 | +
- DataRow <- function(...) .tablerow(..., klass = "DataRow")+ #' combodf <- tribble( |
|||
| 1383 | +1037 |
-
+ #' ~valname, ~label, ~levelcombo, ~exargs, |
||
| 1384 | +1038 |
- #' @export+ #' "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
|
||
| 1385 | +1039 |
- #' @rdname rowclasses+ #' "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
|
||
| 1386 | -515x | +|||
| 1040 | +
- ContentRow <- function(...) .tablerow(..., klass = "ContentRow")+ #' ) |
|||
| 1387 | +1041 |
-
+ #' |
||
| 1388 | +1042 |
- setClass("VTitleFooter",
+ #' lyt <- basic_table(show_colcounts = TRUE) %>% |
||
| 1389 | +1043 |
- contains = "VIRTUAL",+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
|
||
| 1390 | +1044 |
- representation(+ #' analyze("AGE")
|
||
| 1391 | +1045 |
- main_title = "character",+ #' |
||
| 1392 | +1046 |
- subtitles = "character",+ #' tbl <- build_table(lyt, DM) |
||
| 1393 | +1047 |
- main_footer = "character",+ #' tbl |
||
| 1394 | +1048 |
- provenance_footer = "character"+ #' |
||
| 1395 | +1049 |
- )+ #' lyt1 <- basic_table(show_colcounts = TRUE) %>% |
||
| 1396 | +1050 |
- )+ #' split_cols_by("ARM",
|
||
| 1397 | +1051 |
-
+ #' split_fun = add_combo_levels(combodf, |
||
| 1398 | +1052 |
- setClass("VTableTree",
+ #' keep_levels = c( |
||
| 1399 | +1053 |
- contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
+ #' "A_B", |
||
| 1400 | +1054 |
- representation(+ #' "A_C" |
||
| 1401 | +1055 |
- children = "list",+ #' ) |
||
| 1402 | +1056 |
- rowspans = "data.frame",+ #' ) |
||
| 1403 | +1057 |
- labelrow = "LabelRow",+ #' ) %>% |
||
| 1404 | +1058 |
- page_titles = "character",+ #' analyze("AGE")
|
||
| 1405 | +1059 |
- horizontal_sep = "character",+ #' |
||
| 1406 | +1060 |
- header_section_div = "character",+ #' tbl1 <- build_table(lyt1, DM) |
||
| 1407 | +1061 |
- trailing_section_div = "character"+ #' tbl1 |
||
| 1408 | +1062 |
- )+ #' |
||
| 1409 | +1063 |
- )+ #' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
|
||
| 1410 | +1064 |
-
+ #' grepl("^(A|B)", ARM)))
|
||
| 1411 | +1065 |
- setClassUnion("IntegerOrNull", c("integer", "NULL"))
+ #' lyt2 <- basic_table(show_colcounts = TRUE) %>% |
||
| 1412 | +1066 |
- ## covered because it's ElementaryTable's validity method but covr misses it+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
|
||
| 1413 | +1067 |
- ## nocov start+ #' split_cols_by("SEX",
|
||
| 1414 | +1068 |
- etable_validity <- function(object) {
+ #' split_fun = add_overall_level("SEX_ALL", "All Genders")
|
||
| 1415 | +1069 |
- kids <- tree_children(object)+ #' ) %>% |
||
| 1416 | +1070 |
- all(sapply(+ #' analyze("AGE")
|
||
| 1417 | +1071 |
- kids,+ #' |
||
| 1418 | +1072 |
- function(k) {
+ #' lyt3 <- basic_table(show_colcounts = TRUE) %>% |
||
| 1419 | +1073 |
- (is(k, "DataRow") || is(k, "ContentRow"))+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
|
||
| 1420 | +1074 |
- }+ #' split_rows_by("SEX",
|
||
| 1421 | +1075 |
- )) ### &&+ #' split_fun = add_overall_level("SEX_ALL", "All Genders")
|
||
| 1422 | +1076 |
- }+ #' ) %>% |
||
| 1423 | +1077 |
- ## nocov end+ #' summarize_row_groups() %>% |
||
| 1424 | +1078 |
-
+ #' analyze("AGE")
|
||
| 1425 | +1079 |
- #' `TableTree` classes+ #' |
||
| 1426 | +1080 |
- #'+ #' tbl3 <- build_table(lyt3, smallerDM) |
||
| 1427 | +1081 |
- #' @return A formal object representing a populated table.+ #' tbl3 |
||
| 1428 | +1082 |
#' |
||
| 1429 | +1083 |
- #' @author Gabriel Becker+ #' @export |
||
| 1430 | +1084 |
- #' @exportClass ElementaryTable+ add_combo_levels <- function(combosdf, |
||
| 1431 | +1085 |
- #' @rdname tabclasses+ trim = FALSE, |
||
| 1432 | +1086 |
- setClass("ElementaryTable",
+ first = FALSE, |
||
| 1433 | +1087 |
- contains = "VTableTree",+ keep_levels = NULL) {
|
||
| 1434 | -+ | |||
| 1088 | +13x |
- representation(var_analyzed = "character"),+ myfun <- function(df, spl, vals = NULL, labels = NULL, ...) {
|
||
| 1435 | -+ | |||
| 1089 | +18x |
- validity = etable_validity ## function(object) {
+ if (is(spl, "MultiVarSplit")) {
|
||
| 1436 | -+ | |||
| 1090 | +! |
- )+ stop("Combining levels of a MultiVarSplit does not make sense.",
|
||
| 1437 | -+ | |||
| 1091 | +! |
-
+ call. = FALSE |
||
| 1438 | +1092 |
- .enforce_valid_kids <- function(lst, colinfo) {
+ ) |
||
| 1439 | -+ | |||
| 1093 | +13x |
- ## colinfo+ } # nocov |
||
| 1440 | -5923x | +1094 | +18x |
- if (!no_colinfo(colinfo)) {
+ ret <- .apply_split_inner(spl, df, |
| 1441 | -5923x | +1095 | +18x |
- lst <- lapply(+ vals = vals, |
| 1442 | -5923x | +1096 | +18x |
- lst,+ labels = labels, trim = trim+ |
+
| 1097 | ++ |
+ ) |
||
| 1443 | -5923x | +1098 | +18x |
- function(x) {
+ for (i in seq_len(nrow(combosdf))) {
|
| 1444 | -7423x | +1099 | +24x |
- if (no_colinfo(x)) {
+ lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]] |
| 1445 | -208x | +1100 | +24x |
- col_info(x) <- colinfo+ spld <- spl_payload(spl) |
| 1446 | -7215x | +1101 | +24x |
- } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
+ if (is(lcombo, "AllLevelsSentinel")) {
|
| 1447 | -+ | |||
| 1102 | +6x |
- ## split functions from function factories (e.g. add_combo_levels)+ subdf <- df |
||
| 1448 | -+ | |||
| 1103 | +18x |
- ## have different environments so we can't use identical here+ } else if (is(spl, "VarLevelSplit")) {
|
||
| 1449 | -+ | |||
| 1104 | +18x |
- ## all.equal requires the **values within the closures** to be the+ subdf <- df[df[[spld]] %in% lcombo, ] |
||
| 1450 | -+ | |||
| 1105 | +13x |
- ## same but not the actual enclosing environments.+ } else { ## this covers non-var splits, e.g. Cut-based splits
|
||
| 1451 | +1106 | ! |
- stop(+ stopifnot(all(lcombo %in% c(ret$labels, ret$vals))) |
|
| 1452 | +1107 | ! |
- "attempted to add child with non-matching, non-empty ",+ subdf <- do.call( |
|
| 1453 | +1108 | ! |
- "column info to an existing table"+ rbind, |
|
| 1454 | -+ | |||
| 1109 | +! |
- )+ ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo] |
||
| 1455 | +1110 |
- }- |
- ||
| 1456 | -7423x | -
- x+ ) |
||
| 1457 | +1111 |
} |
||
| 1458 | -- |
- )- |
- ||
| 1459 | -- |
- }- |
- ||
| 1460 | -- | - - | -||
| 1461 | -5923x | +1112 | +24x |
- if (are(lst, "ElementaryTable") &&+ ret <- .add_combo_part_info( |
| 1462 | -5923x | +1113 | +24x |
- all(sapply(lst, function(tb) {
+ ret, subdf, |
| 1463 | -1042x | -
- nrow(tb) <= 1 && identical(obj_name(tb), "")- |
- ||
| 1464 | -+ | 1114 | +24x |
- }))) {
+ combosdf[i, "valname", drop = TRUE], |
| 1465 | -1534x | +1115 | +24x |
- lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]]))+ lcombo, |
| 1466 | -+ | |||
| 1116 | +24x |
- }+ combosdf[i, "label", drop = TRUE], |
||
| 1467 | -5923x | +1117 | +24x |
- if (length(lst) == 0) {
+ combosdf[i, "exargs", drop = TRUE][[1]], |
| 1468 | -1534x | +1118 | +24x |
- return(list())+ first |
| 1469 | +1119 |
- }+ ) |
||
| 1470 | +1120 |
- ## names+ } |
||
| 1471 | -4389x | +1121 | +18x |
- realnames <- sapply(lst, obj_name)+ if (!is.null(keep_levels)) {
|
| 1472 | -4389x | +1122 | +3x |
- lstnames <- names(lst)+ keep_inds <- value_names(ret$values) %in% keep_levels |
| 1473 | -4389x | +1123 | +3x |
- if (is.null(lstnames)) {
+ ret <- lapply(ret, function(x) x[keep_inds]) |
| 1474 | -1868x | +|||
| 1124 | +
- names(lst) <- realnames+ } |
|||
| 1475 | -2521x | +|||
| 1125 | +
- } else if (!identical(realnames, lstnames)) {
+
|
|||
| 1476 | -2521x | +1126 | +18x |
- names(lst) <- realnames+ ret |
| 1477 | +1127 |
} |
||
| 1478 | -- | - - | -||
| 1479 | -4389x | +1128 | +13x |
- lst+ myfun |
| 1480 | +1129 |
} |
||
| 1481 | +1130 | |||
| 1482 | +1131 |
- #' Table constructors and classes+ #' Trim levels to map |
||
| 1483 | +1132 |
#' |
||
| 1484 | +1133 |
- #' @inheritParams constr_args+ #' This split function constructor creates a split function which trims levels of a variable to reflect restrictions |
||
| 1485 | +1134 |
- #' @inheritParams gen_args+ #' on the possible combinations of two or more variables which the data is split by (along the same axis) within a |
||
| 1486 | +1135 |
- #' @inheritParams lyt_args+ #' layout. |
||
| 1487 | +1136 |
- #' @param rspans (`data.frame`)\cr currently stored but otherwise ignored.+ #' |
||
| 1488 | +1137 |
- #'+ #' @param map data.frame. A data.frame defining allowed combinations of |
||
| 1489 | +1138 |
- #' @author Gabriel Becker+ #' variables. Any combination at the level of this split not present in the |
||
| 1490 | +1139 |
- #' @export+ #' map will be removed from the data, both for the variable being split and |
||
| 1491 | +1140 |
- #' @rdname tabclasses+ #' those present in the data but not associated with this split or any parents |
||
| 1492 | +1141 |
- ElementaryTable <- function(kids = list(),+ #' of it. |
||
| 1493 | +1142 |
- name = "",+ #' |
||
| 1494 | +1143 |
- lev = 1L,+ #' @details |
||
| 1495 | +1144 |
- label = "",+ #' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the |
||
| 1496 | +1145 |
- labelrow = LabelRow(+ #' variable being split are then pruned to only those still present within this subset of the map representing the |
||
| 1497 | +1146 |
- lev = lev,+ #' current hierarchical splitting context. |
||
| 1498 | +1147 |
- label = label,+ #' |
||
| 1499 | +1148 |
- vis = !isTRUE(iscontent) &&+ #' Splitting is then performed via the [keep_split_levels()] split function. |
||
| 1500 | +1149 |
- !is.na(label) &&+ #' |
||
| 1501 | +1150 |
- nzchar(label)+ #' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables |
||
| 1502 | +1151 |
- ),+ #' specified in the map to those values allowed under the combination of the previous and current split. |
||
| 1503 | +1152 |
- rspans = data.frame(),+ #' |
||
| 1504 | +1153 |
- cinfo = NULL,+ #' @return A function that can be used as a split function. |
||
| 1505 | +1154 |
- iscontent = NA,+ #' |
||
| 1506 | +1155 |
- var = NA_character_,+ #' @seealso [trim_levels_in_group()] |
||
| 1507 | +1156 |
- format = NULL,+ #' |
||
| 1508 | +1157 |
- na_str = NA_character_,+ #' @examples |
||
| 1509 | +1158 |
- indent_mod = 0L,+ #' map <- data.frame( |
||
| 1510 | +1159 |
- title = "",+ #' LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
|
||
| 1511 | +1160 |
- subtitles = character(),+ #' PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
|
||
| 1512 | +1161 |
- main_footer = character(),+ #' ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
|
||
| 1513 | +1162 |
- prov_footer = character(),+ #' stringsAsFactors = FALSE |
||
| 1514 | +1163 |
- header_section_div = NA_character_,+ #' ) |
||
| 1515 | +1164 |
- hsep = default_hsep(),+ #' |
||
| 1516 | +1165 |
- trailing_section_div = NA_character_,+ #' lyt <- basic_table() %>% |
||
| 1517 | +1166 |
- inset = 0L) {
+ #' split_rows_by("LBCAT") %>%
|
||
| 1518 | -3054x | +|||
| 1167 | +
- check_ok_label(label)+ #' split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
|
|||
| 1519 | -3054x | +|||
| 1168 | +
- if (is.null(cinfo)) {
+ #' analyze("ANRIND")
|
|||
| 1520 | -! | +|||
| 1169 | +
- if (length(kids) > 0) {
+ #' tbl <- build_table(lyt, ex_adlb) |
|||
| 1521 | -! | +|||
| 1170 | +
- cinfo <- col_info(kids[[1]])+ #' |
|||
| 1522 | +1171 |
- } else {
+ #' @export+ |
+ ||
| 1172 | ++ |
+ trim_levels_to_map <- function(map = NULL) {
+ |
+ ||
| 1173 | +7x | +
+ if (is.null(map) || any(sapply(map, class) != "character")) {
|
||
| 1523 | +1174 | ! |
- cinfo <- EmptyColInfo+ stop(+ |
+ |
| 1175 | +! | +
+ "No map dataframe was provided or not all of the columns are of ",+ |
+ ||
| 1176 | +! | +
+ "type character." |
||
| 1524 | +1177 |
- }+ ) |
||
| 1525 | +1178 |
} |
||
| 1526 | +1179 | |||
| 1527 | -3054x | +1180 | +7x |
- if (no_colinfo(labelrow)) {
+ myfun <- function(df, |
| 1528 | -1863x | +1181 | +7x |
- col_info(labelrow) <- cinfo+ spl, |
| 1529 | -+ | |||
| 1182 | +7x |
- }+ vals = NULL, |
||
| 1530 | -3054x | +1183 | +7x |
- kids <- .enforce_valid_kids(kids, cinfo)+ labels = NULL, |
| 1531 | -3054x | +1184 | +7x |
- tab <- new("ElementaryTable",
+ trim = FALSE, |
| 1532 | -3054x | +1185 | +7x |
- children = kids,+ .spl_context) {
|
| 1533 | -3054x | +1186 | +12x |
- name = .chkname(name),+ allvars <- colnames(map) |
| 1534 | -3054x | +1187 | +12x |
- level = lev,+ splvar <- spl_payload(spl)+ |
+
| 1188 | ++ | + | ||
| 1535 | -3054x | +1189 | +12x |
- labelrow = labelrow,+ allvmatches <- match(.spl_context$split, allvars) |
| 1536 | -3054x | +1190 | +12x |
- rowspans = rspans,+ outvars <- allvars[na.omit(allvmatches)]+ |
+
| 1191 | ++ |
+ ## invars are variables present in data, but not in+ |
+ ||
| 1192 | ++ |
+ ## previous or current splits |
||
| 1537 | -3054x | +1193 | +12x |
- col_info = cinfo,+ invars <- intersect( |
| 1538 | -3054x | +1194 | +12x |
- var_analyzed = var,+ setdiff(allvars, c(outvars, splvar)),+ |
+
| 1195 | +12x | +
+ names(df) |
||
| 1539 | +1196 |
- ## XXX these are hardcoded, because they both get set during+ ) |
||
| 1540 | +1197 |
- ## set_format_recursive anyway+ ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits |
||
| 1541 | -3054x | +|||
| 1198 | +
- format = NULL,+ ## which(allvars == splvar), ## this split |
|||
| 1542 | -3054x | +|||
| 1199 | +
- na_str = NA_character_,+ ## allvars[-1*na.omit(allvmatches)]) ## "outvars" |
|||
| 1543 | -3054x | +|||
| 1200 | +
- table_inset = 0L,+ |
|||
| 1544 | -3054x | +|||
| 1201 | +
- indent_modifier = as.integer(indent_mod),+ ## allvars <- allvars[allvarord] |
|||
| 1545 | -3054x | +|||
| 1202 | +
- main_title = title,+ ## outvars <- allvars[-(which(allvars == splvar):length(allvars))] |
|||
| 1546 | -3054x | +1203 | +12x |
- subtitles = subtitles,+ if (length(outvars) > 0) {
|
| 1547 | -3054x | +1204 | +10x |
- main_footer = main_footer,+ indfilters <- vapply(outvars, function(ivar) {
|
| 1548 | -3054x | +1205 | +12x |
- provenance_footer = prov_footer,+ obsval <- .spl_context$value[match(ivar, .spl_context$split)] |
| 1549 | -3054x | +1206 | +12x |
- horizontal_sep = hsep,+ sprintf("%s == '%s'", ivar, obsval)
+ |
+
| 1207 | ++ |
+ }, "")+ |
+ ||
| 1208 | ++ | + | ||
| 1550 | -3054x | +1209 | +10x |
- header_section_div = header_section_div,+ allfilters <- paste(indfilters, collapse = " & ") |
| 1551 | -3054x | +1210 | +10x |
- trailing_section_div = trailing_section_div+ map <- map[eval(parse(text = allfilters), envir = map), ] |
| 1552 | +1211 |
- )+ } |
||
| 1553 | -3054x | +1212 | +12x |
- tab <- set_format_recursive(tab, format, na_str, FALSE)+ map_splvarpos <- which(names(map) == splvar) |
| 1554 | -3054x | +1213 | +12x |
- table_inset(tab) <- as.integer(inset)+ nondup <- !duplicated(map[[splvar]]) |
| 1555 | -3054x | +1214 | +12x |
- tab+ ksl_fun <- keep_split_levels(+ |
+
| 1215 | +12x | +
+ only = map[[splvar]][nondup],+ |
+ ||
| 1216 | +12x | +
+ reorder = TRUE |
||
| 1556 | +1217 |
- }+ )+ |
+ ||
| 1218 | +12x | +
+ ret <- ksl_fun(df, spl, vals, labels, trim = trim) |
||
| 1557 | +1219 | |||
| 1220 | +12x | +
+ if (length(ret$datasplit) == 0) {
+ |
+ ||
| 1221 | +1x | +
+ msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
+ |
+ ||
| 1222 | +1x | +
+ collapse = "->"+ |
+ ||
| 1558 | +1223 |
- ttable_validity <- function(object) {
+ ) |
||
| 1559 | -! | +|||
| 1224 | +1x |
- all(sapply(+ stop( |
||
| 1560 | -! | +|||
| 1225 | +1x |
- tree_children(object),+ "map does not allow any values present in data for split ", |
||
| 1561 | -! | +|||
| 1226 | +1x |
- function(x) is(x, "VTableTree") || is(x, "TableRow")+ "variable ", splvar,+ |
+ ||
| 1227 | +1x | +
+ " under the following parent splits:\n\t", msg |
||
| 1562 | +1228 |
- ))+ ) |
||
| 1563 | +1229 |
- }+ } |
||
| 1564 | +1230 | |||
| 1565 | +1231 |
- .calc_cinfo <- function(cinfo, cont, kids) {
+ ## keep non-split (inner) variables levels |
||
| 1566 | -2869x | +1232 | +11x |
- if (!is.null(cinfo)) {
+ ret$datasplit <- lapply(ret$values, function(splvar_lev) {
|
| 1567 | -2869x | +1233 | +19x |
- cinfo+ df3 <- ret$datasplit[[splvar_lev]] |
| 1568 | -! | +|||
| 1234 | +19x |
- } else if (!is.null(cont)) {
+ curmap <- map[map[[map_splvarpos]] == splvar_lev, ]+ |
+ ||
| 1235 | ++ |
+ ## loop through inner variables+ |
+ ||
| 1236 | +19x | +
+ for (iv in invars) { ## setdiff(colnames(map), splvar)) {
+ |
+ ||
| 1237 | +19x | +
+ iv_lev <- df3[[iv]]+ |
+ ||
| 1238 | +19x | +
+ levkeep <- as.character(unique(curmap[[iv]]))+ |
+ ||
| 1239 | +19x | +
+ if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) {
|
||
| 1569 | +1240 | ! |
- col_info(cont)+ stop( |
|
| 1570 | +1241 | ! |
- } else if (length(kids) >= 1) {
+ "Attempted to keep invalid factor level(s) in split ", |
|
| 1571 | +1242 | ! |
- col_info(kids[[1]])+ setdiff(levkeep, levels(iv_lev)) |
|
| 1572 | +1243 |
- } else {
+ ) |
||
| 1573 | -! | +|||
| 1244 | +
- EmptyColInfo+ } |
|||
| 1574 | +1245 |
- }+ |
||
| 1575 | -+ | |||
| 1246 | +19x |
- }+ df3 <- df3[iv_lev %in% levkeep, , drop = FALSE] |
||
| 1576 | +1247 | |||
| 1248 | +19x | +
+ if (is.factor(iv_lev)) {
+ |
+ ||
| 1249 | +19x | +
+ df3[[iv]] <- factor(as.character(df3[[iv]]),+ |
+ ||
| 1250 | +19x | +
+ levels = levkeep+ |
+ ||
| 1577 | +1251 |
- ## under this model, non-leaf nodes can have a content table where rollup+ ) |
||
| 1578 | +1252 |
- ## analyses live+ } |
||
| 1579 | +1253 |
- #' @exportClass TableTree+ } |
||
| 1580 | +1254 |
- #' @rdname tabclasses+ + |
+ ||
| 1255 | +19x | +
+ df3 |
||
| 1581 | +1256 |
- setClass("TableTree",
+ })+ |
+ ||
| 1257 | +11x | +
+ names(ret$datasplit) <- ret$values+ |
+ ||
| 1258 | +11x | +
+ ret |
||
| 1582 | +1259 |
- contains = c("VTableTree"),
+ } |
||
| 1583 | +1260 |
- representation(+ + |
+ ||
| 1261 | +7x | +
+ myfun |
||
| 1584 | +1262 |
- content = "ElementaryTable",+ } |
| 1585 | +1 |
- page_title_prefix = "character"+ ## NB handling the case where there are no values is done during tabulation |
|||
| 1586 | +2 |
- ),+ ## which is the only reason expression(TRUE) is ok, because otherwise |
|||
| 1587 | +3 |
- validity = ttable_validity+ ## we (sometimes) run into |
|||
| 1588 | +4 |
- )+ ## factor()[TRUE] giving <NA> (i.e. length 1)+ |
+ |||
| 5 | +4321x | +
+ setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
|
|||
| 1589 | +6 | ||||
| 1590 | +7 |
- #' @export+ setMethod( |
|||
| 1591 | +8 |
- #' @rdname tabclasses+ "make_subset_expr", "VarLevelSplit", |
|||
| 1592 | +9 |
- TableTree <- function(kids = list(),+ function(spl, val) {
|
|||
| 1593 | +10 |
- name = if (!is.na(var)) var else "",+ ## this is how custom split functions will communicate the correct expression |
|||
| 1594 | +11 |
- cont = EmptyElTable,+ ## to the column modeling code+ |
+ |||
| 12 | +3262x | +
+ if (length(value_expr(val)) > 0) {
+ |
+ |||
| 13 | +12x | +
+ return(value_expr(val)) |
|||
| 1595 | +14 |
- lev = 1L,+ } |
|||
| 1596 | +15 |
- label = name,+ + |
+ |||
| 16 | +3250x | +
+ v <- unlist(rawvalues(val)) |
|||
| 1597 | +17 |
- labelrow = LabelRow(+ ## XXX if we're including all levels should even missing be included?+ |
+ |||
| 18 | +3250x | +
+ if (is(v, "AllLevelsSentinel")) {
+ |
+ |||
| 19 | +9x | +
+ as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl))))) |
|||
| 1598 | +20 |
- lev = lev,+ } else {
+ |
+ |||
| 21 | +3241x | +
+ as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(+ |
+ |||
| 22 | +3241x | +
+ a = as.name(spl_payload(spl)),+ |
+ |||
| 23 | +3241x | +
+ b = v |
|||
| 1599 | +24 |
- label = label,+ ))) |
|||
| 1600 | +25 |
- vis = nrow(cont) == 0 && !is.na(label) &&+ } |
|||
| 1601 | +26 |
- nzchar(label)+ } |
|||
| 1602 | +27 |
- ),+ ) |
|||
| 1603 | +28 |
- rspans = data.frame(),+ |
|||
| 1604 | +29 |
- iscontent = NA,+ setMethod( |
|||
| 1605 | +30 |
- var = NA_character_,+ "make_subset_expr", "MultiVarSplit", |
|||
| 1606 | +31 |
- cinfo = NULL,+ function(spl, val) {
|
|||
| 1607 | +32 |
- format = NULL,+ ## this is how custom split functions will communicate the correct expression |
|||
| 1608 | +33 |
- na_str = NA_character_,+ ## to the column modeling code+ |
+ |||
| 34 | +300x | +
+ if (length(value_expr(val)) > 0) {
+ |
+ |||
| 35 | +! | +
+ return(value_expr(val)) |
|||
| 1609 | +36 |
- indent_mod = 0L,+ } |
|||
| 1610 | +37 |
- title = "",+ |
|||
| 1611 | +38 |
- subtitles = character(),+ ## v = rawvalues(val) |
|||
| 1612 | +39 |
- main_footer = character(),+ ## as.expression(bquote(!is.na(.(a)), list(a = v)))+ |
+ |||
| 40 | +300x | +
+ expression(TRUE) |
|||
| 1613 | +41 |
- prov_footer = character(),+ } |
|||
| 1614 | +42 |
- page_title = NA_character_,+ ) |
|||
| 1615 | +43 |
- hsep = default_hsep(),+ |
|||
| 1616 | +44 |
- header_section_div = NA_character_,+ setMethod( |
|||
| 1617 | +45 |
- trailing_section_div = NA_character_,+ "make_subset_expr", "AnalyzeVarSplit", |
|||
| 1618 | +46 |
- inset = 0L) {
+ function(spl, val) {
|
|||
| 1619 | -2869x | +||||
| 47 | +! |
- check_ok_label(label)+ if (avar_inclNAs(spl)) {
|
|||
| 1620 | -2869x | +||||
| 48 | +! |
- cinfo <- .calc_cinfo(cinfo, cont, kids)+ expression(TRUE) |
|||
| 1621 | +49 |
-
+ } else {
|
|||
| 1622 | -2869x | +||||
| 50 | +! |
- kids <- .enforce_valid_kids(kids, cinfo)+ as.expression(bquote( |
|||
| 1623 | -2869x | +||||
| 51 | +! |
- if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
+ !is.na(.(a)), |
|||
| 1624 | +52 | ! |
- stop("Got table tree with content table and content position")
+ list(a = as.name(spl_payload(spl))) |
||
| 1625 | +53 | ++ |
+ ))+ |
+ ||
| 54 | ++ |
+ }+ |
+ |||
| 55 |
} |
||||
| 1626 | -2869x | +||||
| 56 | +
- if (no_colinfo(labelrow)) {
+ ) |
||||
| 1627 | -1628x | +||||
| 57 | +
- col_info(labelrow) <- cinfo+ |
||||
| 1628 | +58 |
- }+ setMethod( |
|||
| 1629 | -2869x | +||||
| 59 | +
- if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
+ "make_subset_expr", "AnalyzeColVarSplit", |
||||
| 1630 | -1173x | +||||
| 60 | +
- if (!is.na(page_title)) {
+ function(spl, val) {
|
||||
| 1631 | +61 | ! |
- stop("Got a page title prefix for an Elementary Table")
+ expression(TRUE) |
||
| 1632 | +62 |
- }+ } |
|||
| 1633 | +63 |
- ## constructor takes care of recursive format application+ ) |
|||
| 1634 | -1173x | +||||
| 64 | +
- ElementaryTable(+ |
||||
| 1635 | -1173x | +||||
| 65 | +
- kids = kids,+ ## XXX these are going to be ridiculously slow |
||||
| 1636 | -1173x | +||||
| 66 | +
- name = .chkname(name),+ ## FIXME |
||||
| 1637 | -1173x | +||||
| 67 | +
- lev = lev,+ |
||||
| 1638 | -1173x | +||||
| 68 | +
- labelrow = labelrow,+ setMethod( |
||||
| 1639 | -1173x | +||||
| 69 | +
- rspans = rspans,+ "make_subset_expr", "VarStaticCutSplit", |
||||
| 1640 | -1173x | +||||
| 70 | +
- cinfo = cinfo,+ function(spl, val) {
|
||||
| 1641 | -1173x | +71 | +135x |
- var = var,+ v <- rawvalues(val) |
|
| 1642 | -1173x | +||||
| 72 | +
- format = format,+ ## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels), |
||||
| 1643 | -1173x | +73 | +135x |
- na_str = na_str,+ as.expression(bquote( |
|
| 1644 | -1173x | +74 | +135x |
- indent_mod = indent_mod,+ cut(.(a), |
|
| 1645 | -1173x | +75 | +135x |
- title = title,+ breaks = .(brk), labels = .(labels), |
|
| 1646 | -1173x | +76 | +135x |
- subtitles = subtitles,+ include.lowest = TRUE |
|
| 1647 | -1173x | +77 | +135x |
- main_footer = main_footer,+ ) == .(b), |
|
| 1648 | -1173x | +78 | +135x |
- prov_footer = prov_footer,+ list( |
|
| 1649 | -1173x | +79 | +135x |
- hsep = hsep,+ a = as.name(spl_payload(spl)), |
|
| 1650 | -1173x | +80 | +135x |
- header_section_div = header_section_div,+ b = v, |
|
| 1651 | -1173x | -
- trailing_section_div = trailing_section_div,+ | 81 | +135x | +
+ brk = spl_cuts(spl), |
| 1652 | -1173x | +82 | +135x |
- inset = inset+ labels = spl_cutlabels(spl) |
|
| 1653 | +83 |
- )+ ) |
|||
| 1654 | +84 |
- } else {
- |
- |||
| 1655 | -1696x | -
- tab <- new("TableTree",
+ )) |
|||
| 1656 | -1696x | +||||
| 85 | +
- content = cont,+ } |
||||
| 1657 | -1696x | +||||
| 86 | +
- children = kids,+ ) |
||||
| 1658 | -1696x | +||||
| 87 | +
- name = .chkname(name),+ |
||||
| 1659 | -1696x | +||||
| 88 | +
- level = lev,+ ## NB this assumes spl_cutlabels(spl) is in order!!!!!! |
||||
| 1660 | -1696x | +||||
| 89 | +
- labelrow = labelrow,+ setMethod( |
||||
| 1661 | -1696x | +||||
| 90 | +
- rowspans = rspans,+ "make_subset_expr", "CumulativeCutSplit", |
||||
| 1662 | -1696x | +||||
| 91 | +
- col_info = cinfo,+ function(spl, val) {
|
||||
| 1663 | -1696x | +92 | +63x |
- format = NULL,+ v <- rawvalues(val) |
|
| 1664 | -1696x | +||||
| 93 | +
- na_str = na_str,+ ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk), |
||||
| 1665 | -1696x | +94 | +63x |
- table_inset = 0L,+ as.expression(bquote( |
|
| 1666 | -1696x | +95 | +63x |
- indent_modifier = as.integer(indent_mod),+ as.integer(cut(.(a), |
|
| 1667 | -1696x | +96 | +63x |
- main_title = title,+ breaks = .(brk), |
|
| 1668 | -1696x | +97 | +63x |
- subtitles = subtitles,+ labels = .(labels), |
|
| 1669 | -1696x | +98 | +63x |
- main_footer = main_footer,+ include.lowest = TRUE |
|
| 1670 | -1696x | +||||
| 99 | +
- provenance_footer = prov_footer,+ )) <= |
||||
| 1671 | -1696x | +100 | +63x |
- page_title_prefix = page_title,+ as.integer(factor(.(b), levels = .(labels))), |
|
| 1672 | -1696x | +101 | +63x |
- horizontal_sep = "-",+ list( |
|
| 1673 | -1696x | +102 | +63x |
- header_section_div = header_section_div,+ a = as.name(spl_payload(spl)), |
|
| 1674 | -1696x | +103 | +63x |
- trailing_section_div = trailing_section_div+ b = v, |
|
| 1675 | -1696x | +104 | +63x |
- ) ## this is overridden below to get recursiveness+ brk = spl_cuts(spl), |
|
| 1676 | -1696x | -
- tab <- set_format_recursive(tab, format, na_str, FALSE)- |
- |||
| 1677 | -+ | 105 | +63x |
-
+ labels = spl_cutlabels(spl) |
|
| 1678 | +106 |
- ## these is recursive+ ) |
|||
| 1679 | +107 |
- ## XXX combine these probably- |
- |||
| 1680 | -1696x | -
- horizontal_sep(tab) <- hsep- |
- |||
| 1681 | -1696x | -
- table_inset(tab) <- as.integer(inset)- |
- |||
| 1682 | -1696x | -
- tab+ )) |
|||
| 1683 | +108 |
} |
|||
| 1684 | +109 |
- }+ ) |
|||
| 1685 | +110 | ||||
| 1686 | +111 |
- ### Pre-Data Layout Declaration Classes+ ## I think this one is unnecessary, |
|||
| 1687 | +112 |
- ###+ ## build_table collapses DynCutSplits into |
|||
| 1688 | +113 |
- ### Notably these are NOT represented as trees+ ## static ones. |
|||
| 1689 | +114 |
- ### because without data we cannot know what the+ ## |
|||
| 1690 | +115 |
- ### children should be.+ ## XXX TODO fixme |
|||
| 1691 | +116 |
-
+ ## setMethod("make_subset_expr", "VarDynCutSplit",
|
|||
| 1692 | +117 |
- ## Vector (ordered list) of splits.+ ## function(spl, val) {
|
|||
| 1693 | +118 |
- ##+ ## v = rawvalues(val) |
|||
| 1694 | +119 |
- ## This is a vector (ordered list) of splits to be+ ## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)), |
|||
| 1695 | +120 |
- ## applied recursively to the data when provided.+ ## as.expression(bquote(.(fun)(.(a)) == .(b)), |
|||
| 1696 | +121 |
- ##+ ## list(a = as.name(spl_payload(spl)), |
|||
| 1697 | +122 |
- ## For convenience, if this is length 1, it can contain+ ## b = v, |
|||
| 1698 | +123 |
- ## a pre-existing TableTree/ElementaryTable.+ ## fun = spl@cut_fun)) |
|||
| 1699 | +124 |
- ## This is used for add_existing_table in colby_constructors.R+ ## }) |
|||
| 1700 | +125 | ||||
| 1701 | -- |
- setClass("SplitVector",
- |
- |||
| 1702 | +126 |
- contains = "list",+ setMethod( |
|||
| 1703 | +127 |
- validity = function(object) {
+ "make_subset_expr", "AllSplit", |
|||
| 1704 | -+ | ||||
| 128 | +291x |
- if (length(object) >= 1) {
+ function(spl, val) expression(TRUE) |
|||
| 1705 | +129 |
- lst <- tail(object, 1)[[1]]+ ) |
|||
| 1706 | +130 |
- } else {
+
|
|||
| 1707 | +131 |
- lst <- NULL+ ## probably don't need this |
|||
| 1708 | +132 |
- }+ |
|||
| 1709 | +133 |
- all(sapply(head(object, -1), is, "Split")) &&+ setMethod( |
|||
| 1710 | +134 |
- (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo"))+ "make_subset_expr", "expression", |
|||
| 1711 | -+ | ||||
| 135 | +! |
- }+ function(spl, val) spl |
|||
| 1712 | +136 |
) |
|||
| 1713 | +137 | ||||
| 1714 | +138 |
- SplitVector <- function(x = NULL,+ setMethod( |
|||
| 1715 | +139 |
- ...,+ "make_subset_expr", "character", |
|||
| 1716 | +140 |
- lst = list(...)) {
+ function(spl, val) {
|
|||
| 1717 | -2365x | +||||
| 141 | +! |
- if (!is.null(x)) {
+ newspl <- VarLevelSplit(spl, spl) |
|||
| 1718 | -453x | +||||
| 142 | +! |
- lst <- unlist(c(list(x), lst), recursive = FALSE)+ make_subset_expr(newspl, val) |
|||
| 1719 | +143 |
} |
|||
| 1720 | -2365x | -
- new("SplitVector", lst)
- |
- |||
| 1721 | +144 |
- }+ ) |
|||
| 1722 | +145 | ||||
| 1723 | +146 |
- avar_noneorlast <- function(vec) {
+ .combine_subset_exprs <- function(ex1, ex2) {
|
|||
| 1724 | -950x | -
- if (!is(vec, "SplitVector")) {
- |
- |||
| 1725 | -! | -
- return(FALSE)- |
- |||
| 1726 | -+ | 147 | +2945x |
- }+ if (is.null(ex1) || identical(ex1, expression(TRUE))) {
|
|
| 1727 | -950x | +148 | +1855x |
- if (length(vec) == 0) {
+ if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
|
|
| 1728 | -616x | +149 | +1446x |
- return(TRUE)+ return(ex2) |
|
| 1729 | +150 |
- }+ } else {
|
|||
| 1730 | -334x | +151 | +409x |
- isavar <- which(sapply(vec, is, "AnalyzeVarSplit"))+ return(expression(TRUE)) |
|
| 1731 | -334x | +||||
| 152 | +
- (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec))+ } |
||||
| 1732 | +153 |
- }+ } |
|||
| 1733 | +154 | ||||
| 1734 | +155 |
- setClass("PreDataAxisLayout",
+ ## if(is.null(ex2)) |
|||
| 1735 | +156 |
- contains = "list",+ ## ex2 <- expression(TRUE) |
|||
| 1736 | -+ | ||||
| 157 | +1090x |
- representation(root_split = "ANY"),+ stopifnot(is.expression(ex1), is.expression(ex2)) |
|||
| 1737 | -+ | ||||
| 158 | +1090x |
- validity = function(object) {
+ as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]]))) |
|||
| 1738 | +159 |
- allleafs <- unlist(object, recursive = TRUE)+ } |
|||
| 1739 | +160 |
- all(sapply(object, avar_noneorlast)) &&+ |
|||
| 1740 | +161 |
- all(sapply(+ make_pos_subset <- function(spls = pos_splits(pos), |
|||
| 1741 | +162 |
- allleafs,+ svals = pos_splvals(pos), |
|||
| 1742 | +163 |
- ## remember existing table trees can be added to layouts+ pos) {
|
|||
| 1743 | -+ | ||||
| 164 | +1007x |
- ## for now...+ expr <- NULL |
|||
| 1744 | -+ | ||||
| 165 | +1007x |
- function(x) is(x, "Split") || is(x, "VTableTree")+ for (i in seq_along(spls)) {
|
|||
| 1745 | -+ | ||||
| 166 | +1569x |
- ))+ newexpr <- make_subset_expr(spls[[i]], svals[[i]]) |
|||
| 1746 | -+ | ||||
| 167 | +1569x |
- }+ expr <- .combine_subset_exprs(expr, newexpr) |
|||
| 1747 | +168 |
- )+ } |
|||
| 1748 | -+ | ||||
| 169 | +1007x |
-
+ expr |
|||
| 1749 | +170 |
- setClass("PreDataColLayout",
+ } |
|||
| 1750 | +171 |
- contains = "PreDataAxisLayout",+ |
|||
| 1751 | +172 |
- representation(+ get_pos_extra <- function(svals = pos_splvals(pos), |
|||
| 1752 | +173 |
- display_columncounts = "logical",+ pos) {
|
|||
| 1753 | -+ | ||||
| 174 | +1013x |
- columncount_format = "character"+ ret <- list() |
|||
| 1754 | -+ | ||||
| 175 | +1013x |
- )+ for (i in seq_along(svals)) {
|
|||
| 1755 | -+ | ||||
| 176 | +1581x |
- )+ extrs <- splv_extra(svals[[i]]) |
|||
| 1756 | -+ | ||||
| 177 | +1581x |
-
+ if (any(names(ret) %in% names(extrs))) {
|
|||
| 1757 | -+ | ||||
| 178 | +! |
- setClass("PreDataRowLayout", contains = "PreDataAxisLayout")
+ stop("same extra argument specified at multiple levels of nesting. Not currently supported")
|
|||
| 1758 | +179 |
-
+ } |
|||
| 1759 | -+ | ||||
| 180 | +1581x |
- PreDataColLayout <- function(x = SplitVector(),+ ret <- c(ret, extrs) |
|||
| 1760 | +181 |
- rtsp = RootSplit(),+ } |
|||
| 1761 | -+ | ||||
| 182 | +1013x |
- ...,+ ret |
|||
| 1762 | +183 |
- lst = list(x, ...),+ } |
|||
| 1763 | +184 |
- disp_colcounts = FALSE,+ |
|||
| 1764 | +185 |
- colcount_format = "(N=xx)") {
+ get_col_extras <- function(ctree) {
|
|||
| 1765 | -303x | +186 | +312x |
- ret <- new("PreDataColLayout", lst,
+ leaves <- collect_leaves(ctree) |
|
| 1766 | -303x | +187 | +312x |
- display_columncounts = disp_colcounts,+ lapply( |
|
| 1767 | -303x | -
- columncount_format = colcount_format- |
- |||
| 1768 | -+ | 188 | +312x |
- )+ leaves, |
|
| 1769 | -303x | +189 | +312x |
- ret@root_split <- rtsp+ function(x) get_pos_extra(pos = tree_pos(x)) |
|
| 1770 | -303x | +||||
| 190 | +
- ret+ ) |
||||
| 1771 | +191 |
} |
|||
| 1772 | +192 | ||||
| 1773 | +193 |
- PreDataRowLayout <- function(x = SplitVector(),+ setGeneric( |
|||
| 1774 | +194 |
- root = RootSplit(),+ "make_col_subsets", |
|||
| 1775 | -+ | ||||
| 195 | +1318x |
- ...,+ function(lyt, df) standardGeneric("make_col_subsets")
|
|||
| 1776 | +196 |
- lst = list(x, ...)) {
+ ) |
|||
| 1777 | -622x | +||||
| 197 | +
- new("PreDataRowLayout", lst, root_split = root)
+
|
||||
| 1778 | +198 |
- }+ setMethod( |
|||
| 1779 | +199 |
-
+ "make_col_subsets", "LayoutColTree", |
|||
| 1780 | +200 |
- setClass("PreDataTableLayouts",
+ function(lyt, df) {
|
|||
| 1781 | -+ | ||||
| 201 | +311x |
- contains = "VTitleFooter",+ leaves <- collect_leaves(lyt) |
|||
| 1782 | -+ | ||||
| 202 | +311x |
- representation(+ lapply(leaves, make_col_subsets) |
|||
| 1783 | +203 |
- row_layout = "PreDataRowLayout",+ } |
|||
| 1784 | +204 |
- col_layout = "PreDataColLayout",+ ) |
|||
| 1785 | +205 |
- top_left = "character",+ |
|||
| 1786 | +206 |
- header_section_div = "character",+ setMethod( |
|||
| 1787 | +207 |
- top_level_section_div = "character",+ "make_col_subsets", "LayoutColLeaf", |
|||
| 1788 | +208 |
- table_inset = "integer"+ function(lyt, df) {
+ |
+ |||
| 209 | +1007x | +
+ make_pos_subset(pos = tree_pos(lyt)) |
|||
| 1789 | +210 |
- )+ } |
|||
| 1790 | +211 |
) |
|||
| 1791 | +212 | ||||
| 1792 | +213 |
- PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),+ create_colinfo <- function(lyt, df, rtpos = TreePos(), |
|||
| 1793 | +214 |
- clayout = PreDataColLayout(),+ counts = NULL, |
|||
| 1794 | +215 |
- topleft = character(),+ alt_counts_df = NULL, |
|||
| 1795 | +216 |
- title = "",+ total = NULL, |
|||
| 1796 | +217 |
- subtitles = character(),+ topleft = NULL) {
|
|||
| 1797 | +218 |
- main_footer = character(),+ ## this will work whether clayout is pre or post |
|||
| 1798 | +219 |
- prov_footer = character(),+ ## data |
|||
| 1799 | -+ | ||||
| 220 | +317x |
- header_section_div = NA_character_,+ clayout <- clayout(lyt) |
|||
| 1800 | -+ | ||||
| 221 | +317x |
- top_level_section_div = NA_character_,+ if (is.null(topleft)) {
+ |
+ |||
| 222 | +317x | +
+ topleft <- top_left(lyt) |
|||
| 1801 | +223 |
- table_inset = 0L) {
+ } |
|||
| 1802 | -303x | +224 | +317x |
- new("PreDataTableLayouts",
+ cc_format <- colcount_format(lyt) %||% "(N=xx)" |
|
| 1803 | -303x | +||||
| 225 | +
- row_layout = rlayout,+ |
||||
| 1804 | -303x | +||||
| 226 | +
- col_layout = clayout,+ ## do it this way for full backwards compatibility |
||||
| 1805 | -303x | +227 | +317x |
- top_left = topleft,+ if (is.null(alt_counts_df)) {
|
|
| 1806 | -303x | +228 | +298x |
- main_title = title,+ alt_counts_df <- df |
|
| 1807 | -303x | +||||
| 229 | +
- subtitles = subtitles,+ } |
||||
| 1808 | -303x | +230 | +317x |
- main_footer = main_footer,+ ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format) |
|
| 1809 | -303x | +231 | +310x |
- provenance_footer = prov_footer,+ if (!is.na(disp_ccounts(lyt))) {
|
|
| 1810 | -303x | +232 | +84x |
- header_section_div = header_section_div,+ leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path |
|
| 1811 | -303x | +233 | +84x |
- top_level_section_div = top_level_section_div,+ for (path in leaf_pths) {
|
|
| 1812 | -303x | +234 | +333x |
- table_inset = table_inset+ colcount_visible(ctree, path) <- disp_ccounts(lyt) |
|
| 1813 | +235 |
- )+ } |
|||
| 1814 | +236 |
- }+ } |
|||
| 1815 | +237 | ||||
| 1816 | -+ | ||||
| 238 | +310x |
- ## setClass("CellValue", contains = "ValueWrapper",
+ cexprs <- make_col_subsets(ctree, df) |
|||
| 1817 | -+ | ||||
| 239 | +310x |
- ## representation(format = "FormatSpec",+ colextras <- col_extra_args(ctree) |
|||
| 1818 | +240 |
- ## colspan = "integerOrNULL",+ |
|||
| 1819 | +241 |
- ## label = "characterOrNULL"),+ ## calculate the counts based on the df |
|||
| 1820 | +242 |
- ## prototype = list(label ="", colspan = NULL, format = NULL))+ ## This presumes that it is called on the WHOLE dataset, |
|||
| 1821 | +243 |
-
+ ## NOT after any splitting has occurred. Otherwise |
|||
| 1822 | +244 |
- setOldClass("CellValue")
+ ## the counts will obviously be wrong. |
|||
| 1823 | -+ | ||||
| 245 | +310x |
-
+ if (is.null(counts)) {
|
|||
| 1824 | -+ | ||||
| 246 | +306x |
- #' Length of a Cell value+ counts <- rep(NA_integer_, length(cexprs)) |
|||
| 1825 | -+ | ||||
| 247 | +4x |
- #'+ } else if (length(counts) != length(cexprs)) {
|
|||
| 1826 | -+ | ||||
| 248 | +1x |
- #' @param x (`CellValue`)\cr a `CellValue` object.+ stop( |
|||
| 1827 | -+ | ||||
| 249 | +1x |
- #'+ "Length of overriding counts must equal number of columns. Got ", |
|||
| 1828 | -+ | ||||
| 250 | +1x |
- #' @return Always returns `1L`.+ length(counts), " values for ", length(cexprs), " columns. ", |
|||
| 1829 | -+ | ||||
| 251 | +1x |
- #'+ "Use NAs to specify that the default counting machinery should be ", |
|||
| 1830 | -+ | ||||
| 252 | +1x |
- #' @exportMethod length+ "used for that position." |
|||
| 1831 | +253 |
- setMethod(+ ) |
|||
| 1832 | +254 |
- "length", "CellValue",- |
- |||
| 1833 | -! | -
- function(x) 1L+ } |
|||
| 1834 | +255 |
- )+ |
|||
| 1835 | -+ | ||||
| 256 | +309x |
-
+ counts_df_name <- "alt_counts_df" |
|||
| 1836 | -+ | ||||
| 257 | +309x |
- setClass("RefFootnote", representation(
+ if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
|
|||
| 1837 | -+ | ||||
| 258 | +294x |
- value = "character",+ alt_counts_df <- df |
|||
| 1838 | -+ | ||||
| 259 | +294x |
- index = "integer",+ counts_df_name <- "df" |
|||
| 1839 | +260 |
- symbol = "character"+ } |
|||
| 1840 | -+ | ||||
| 261 | +309x |
- ))+ calcpos <- is.na(counts) |
|||
| 1841 | +262 | ||||
| 1842 | -+ | ||||
| 263 | +309x |
- RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
+ calccounts <- sapply(cexprs, function(ex) {
|
|||
| 1843 | -168x | +264 | +998x |
- if (is(note, "RefFootnote")) {
+ if (identical(ex, expression(TRUE))) {
|
|
| 1844 | -66x | +265 | +137x |
- return(note)+ nrow(alt_counts_df) |
|
| 1845 | -102x | +266 | +861x |
- } else if (length(note) == 0) {
+ } else if (identical(ex, expression(FALSE))) {
|
|
| 1846 | +267 | ! |
- return(NULL)+ 0L |
||
| 1847 | +268 |
- }+ } else {
|
|||
| 1848 | -102x | +269 | +861x |
- if (length(symbol) != 1L) {
+ vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE) |
|
| 1849 | -! | +||||
| 270 | +861x |
- stop(+ if (is(vec, "numeric")) {
|
|||
| 1850 | +271 | ! |
- "Referential footnote can only have a single string as its index.",+ length(vec) |
||
| 1851 | -! | +||||
| 272 | +861x |
- " Got char vector of length ", length(index)+ } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
+ |
+ |||
| 273 | +861x | +
+ sum(vec, na.rm = TRUE) |
|||
| 1852 | +274 |
- )+ } |
|||
| 1853 | +275 |
- }+ }+ |
+ |||
| 276 | ++ |
+ }) |
|||
| 1854 | -102x | +277 | +309x |
- if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) {
+ counts[calcpos] <- calccounts[calcpos] |
|
| 1855 | -! | +||||
| 278 | +309x |
- stop(+ counts <- as.integer(counts) |
|||
| 1856 | -! | +||||
| 279 | +309x |
- "The string 'NA' and strings containing '{' or '}' cannot be used as ",
+ if (is.null(total)) {
|
|||
| 1857 | +280 | ! |
- "referential footnote index symbols. Got string '", index, "'."+ total <- sum(counts) |
||
| 1858 | +281 |
- )+ } |
|||
| 1859 | +282 |
- }+ |
|||
| 1860 | -+ | ||||
| 283 | +309x |
-
+ cpths <- col_paths(ctree) |
|||
| 1861 | -102x | +284 | +309x |
- new("RefFootnote", value = note, index = index, symbol = symbol)
+ for (i in seq_along(cpths)) {
|
|
| 1862 | -+ | ||||
| 285 | +998x |
- }+ facet_colcount(ctree, cpths[[i]]) <- counts[i] |
|||
| 1863 | +286 |
-
+ } |
|||
| 1864 | -+ | ||||
| 287 | +309x |
- #' Constructor for Cell Value+ InstantiatedColumnInfo( |
|||
| 1865 | -+ | ||||
| 288 | +309x |
- #'+ treelyt = ctree,+ |
+ |||
| 289 | +309x | +
+ csubs = cexprs,+ |
+ |||
| 290 | +309x | +
+ extras = colextras,+ |
+ |||
| 291 | +309x | +
+ cnts = counts,+ |
+ |||
| 292 | +309x | +
+ dispcounts = disp_ccounts(lyt),+ |
+ |||
| 293 | +309x | +
+ countformat = cc_format,+ |
+ |||
| 294 | +309x | +
+ total_cnt = total,+ |
+ |||
| 295 | +309x | +
+ topleft = topleft |
|||
| 1866 | +296 |
- #' @inheritParams lyt_args+ ) |
|||
| 1867 | +297 |
- #' @inheritParams rcell+ } |
| 1868 | +1 |
- #' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted.+ match_extra_args <- function(f, |
||
| 1869 | +2 |
- #'+ .N_col, |
||
| 1870 | +3 |
- #' @return An object representing the value within a single cell within a populated table. The underlying structure+ .N_total, |
||
| 1871 | +4 |
- #' of this object is an implementation detail and should not be relied upon beyond calling accessors for the class.+ .all_col_exprs, |
||
| 1872 | +5 |
- #'+ .all_col_counts, |
||
| 1873 | +6 |
- #' @export+ .var, |
||
| 1874 | +7 |
-
+ .ref_group = NULL, |
||
| 1875 | +8 |
- ## Class definition+ .alt_df_row = NULL, |
||
| 1876 | +9 |
- ## [[1]] list: cell value+ .alt_df = NULL, |
||
| 1877 | +10 |
- ## format : format for cell+ .ref_full = NULL, |
||
| 1878 | +11 |
- ## colspan: column span info for cell+ .in_ref_col = NULL, |
||
| 1879 | +12 |
- ## label: row label to be used for parent row+ .spl_context = NULL, |
||
| 1880 | +13 |
- ## indent_mod: indent modifier to be used for parent row+ .N_row, |
||
| 1881 | +14 |
- CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,+ .df_row, |
||
| 1882 | +15 |
- indent_mod = NULL, footnotes = NULL,+ extras) {
|
||
| 1883 | +16 |
- align = NULL, format_na_str = NULL) {
+ # This list is always present |
||
| 1884 | -12349x | +17 | +5881x |
- if (is.null(colspan)) {
+ possargs <- c( |
| 1885 | -! | +|||
| 18 | +5881x |
- colspan <- 1L+ list( |
||
| 1886 | -+ | |||
| 19 | +5881x |
- }+ .N_col = .N_col, |
||
| 1887 | -12349x | +20 | +5881x |
- if (!is.null(colspan) && !is(colspan, "integer")) {
+ .N_total = .N_total, |
| 1888 | -10x | +21 | +5881x |
- colspan <- as.integer(colspan)+ .N_row = .N_row,+ |
+
| 22 | +5881x | +
+ .df_row = .df_row,+ |
+ ||
| 23 | +5881x | +
+ .all_col_exprs = .all_col_exprs,+ |
+ ||
| 24 | +5881x | +
+ .all_col_counts = .all_col_counts |
||
| 1889 | +25 |
- }+ ),+ |
+ ||
| 26 | +5881x | +
+ extras |
||
| 1890 | +27 |
- ## if we're not given a label but the value has one associated with+ ) |
||
| 1891 | +28 |
- ## it we use that.+ |
||
| 1892 | +29 |
- ## NB: we need to be able to override a non-empty label with an empty one+ ## specialized arguments that must be named in formals, cannot go |
||
| 1893 | +30 |
- ## so we can't have "" mean "not given a label" here+ ## anonymously into ... |
||
| 1894 | -12349x | +31 | +5881x |
- if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
+ if (!is.null(.var) && nzchar(.var)) {
|
| 1895 | -2x | +32 | +4636x |
- label <- obj_label(val)+ possargs <- c(possargs, list(.var = .var)) |
| 1896 | +33 |
} |
||
| 1897 | -12349x | +34 | +5881x |
- if (!is.list(footnotes)) {
+ if (!is.null(.ref_group)) {
|
| 1898 | -9x | +35 | +1834x |
- footnotes <- lapply(footnotes, RefFootnote)+ possargs <- c(possargs, list(.ref_group = .ref_group)) |
| 1899 | +36 |
} |
||
| 1900 | -12349x | +37 | +5881x |
- check_ok_label(label)+ if (!is.null(.alt_df_row)) {
|
| 1901 | -12349x | +38 | +105x |
- ret <- structure(list(val),+ possargs <- c(possargs, list(.alt_df_row = .alt_df_row)) |
| 1902 | -12349x | +|||
| 39 | +
- format = format, colspan = colspan,+ } |
|||
| 1903 | -12349x | +40 | +5881x |
- label = label,+ if (!is.null(.alt_df)) {
|
| 1904 | -12349x | +41 | +105x |
- indent_mod = indent_mod, footnotes = footnotes,+ possargs <- c(possargs, list(.alt_df = .alt_df)) |
| 1905 | -12349x | +|||
| 42 | +
- align = align,+ } |
|||
| 1906 | -12349x | +43 | +5881x |
- format_na_str = format_na_str,+ if (!is.null(.ref_full)) {
|
| 1907 | -12349x | +44 | +141x |
- class = "CellValue"+ possargs <- c(possargs, list(.ref_full = .ref_full)) |
| 1908 | +45 |
- )+ } |
||
| 1909 | -12349x | +46 | +5881x |
- ret+ if (!is.null(.in_ref_col)) {
|
| 1910 | -+ | |||
| 47 | +141x |
- }+ possargs <- c(possargs, list(.in_ref_col = .in_ref_col)) |
||
| 1911 | +48 |
-
+ } |
||
| 1912 | +49 |
- #' @method print CellValue+ |
||
| 1913 | +50 |
- #'+ # Special case: .spl_context |
||
| 1914 | -+ | |||
| 51 | +5881x |
- #' @export+ if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
|
||
| 1915 | -+ | |||
| 52 | +5881x |
- print.CellValue <- function(x, ...) {
+ possargs <- c(possargs, list(.spl_context = .spl_context)) |
||
| 1916 | -! | +|||
| 53 | +
- cat(paste("rcell:", format_rcell(x), "\n"))
+ } else {
|
|||
| 1917 | +54 | ! |
- invisible(x)+ possargs$.spl_context <- NULL |
|
| 1918 | +55 |
- }+ } |
||
| 1919 | +56 | |||
| 1920 | +57 |
- ## too slow+ # Extra args handling |
||
| 1921 | -+ | |||
| 58 | +5881x |
- # setClass("RowsVerticalSection", contains = "list",
+ formargs <- formals(f) |
||
| 1922 | -+ | |||
| 59 | +5881x |
- # representation = list(row_names = "characterOrNULL",+ formnms <- names(formargs) |
||
| 1923 | -+ | |||
| 60 | +5881x |
- # row_labels = "characterOrNULL",+ exnms <- names(extras)+ |
+ ||
| 61 | +5881x | +
+ if (is.null(formargs)) {
+ |
+ ||
| 62 | +206x | +
+ return(NULL)+ |
+ ||
| 63 | +5675x | +
+ } else if ("..." %in% names(formargs)) {
+ |
+ ||
| 64 | +4966x | +
+ formnms <- c(formnms, exnms[nzchar(exnms)]) |
||
| 1924 | +65 |
- # row_formats = "ANY",+ }+ |
+ ||
| 66 | +5675x | +
+ possargs[names(possargs) %in% formnms] |
||
| 1925 | +67 |
- # indent_mods = "integerOrNULL"))+ } |
||
| 1926 | +68 | |||
| 1927 | +69 |
- setOldClass("RowsVerticalSection")
+ #' @noRd |
||
| 1928 | +70 |
- RowsVerticalSection <- function(values,+ #' @return A `RowsVerticalSection` object representing the `k x 1` section of the |
||
| 1929 | +71 |
- names = names(values),+ #' table being generated, with `k` the number of rows the analysis function |
||
| 1930 | +72 |
- labels = NULL,+ #' generates. |
||
| 1931 | +73 |
- indent_mods = NULL,+ gen_onerv <- function(csub, col, count, cextr, cpath, |
||
| 1932 | +74 |
- formats = NULL,+ dfpart, func, totcount, splextra, |
||
| 1933 | +75 |
- footnotes = NULL,+ all_col_exprs, |
||
| 1934 | +76 |
- format_na_strs = NULL) {
+ all_col_counts, |
||
| 1935 | -5819x | +|||
| 77 | +
- stopifnot(is(values, "list"))+ takesdf = .takes_df(func), |
|||
| 1936 | +78 |
- ## innernms <- value_names(values)+ baselinedf, |
||
| 1937 | +79 |
-
+ alt_dfpart, |
||
| 1938 | -5819x | +|||
| 80 | +
- if (is.null(labels)) {
+ inclNAs, |
|||
| 1939 | -2550x | +|||
| 81 | +
- labels <- names(values)+ col_parent_inds, |
|||
| 1940 | +82 |
- }+ spl_context) {
|
||
| 1941 | -5819x | +83 | +5881x |
- if (is.null(names) && all(nzchar(labels))) {
+ if (NROW(spl_context) > 0) {
|
| 1942 | -3309x | +84 | +5860x |
- names <- labels+ spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".") |
| 1943 | -2510x | +85 | +5860x |
- } else if (is.null(labels) && !is.null(names)) {
+ spl_context$cur_col_subset <- col_parent_inds |
| 1944 | -15x | -
- labels <- names- |
- ||
| 1945 | -+ | 86 | +5860x |
- }+ spl_context$cur_col_expr <- list(csub) |
| 1946 | -+ | |||
| 87 | +5860x |
-
+ spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L) |
||
| 1947 | -5819x | +88 | +5860x |
- if (!is.null(indent_mods)) {
+ spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)]) |
| 1948 | -68x | +89 | +5860x |
- indent_mods <- as.integer(indent_mods)+ spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)]) |
| 1949 | +90 |
} |
||
| 1950 | -5819x | +|||
| 91 | +
- check_ok_label(labels, multi_ok = TRUE)+ |
|||
| 1951 | -5818x | +|||
| 92 | +
- structure(values,+ # Making .alt_df from alt_dfpart (i.e. .alt_df_row) |
|||
| 1952 | -5818x | +93 | +5881x |
- class = "RowsVerticalSection", row_names = names,+ if (NROW(alt_dfpart) > 0) {
|
| 1953 | -5818x | +94 | +105x |
- row_labels = labels, indent_mods = indent_mods,+ alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE] |
| 1954 | -5818x | +95 | +105x |
- row_formats = formats,+ if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
|
| 1955 | -5818x | +96 | +99x |
- row_na_strs = format_na_strs,+ alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), , |
| 1956 | -5818x | +97 | +99x |
- row_footnotes = lapply(+ drop = FALSE |
| 1957 | -5818x | +|||
| 98 | +
- footnotes,+ ] |
|||
| 1958 | +99 |
- ## cause each row needs to accept+ } |
||
| 1959 | +100 |
- ## a *list* of row footnotes+ } else {
|
||
| 1960 | -5818x | +101 | +5776x |
- function(fns) lapply(fns, RefFootnote)+ alt_dfpart_fil <- alt_dfpart |
| 1961 | +102 |
- )+ } |
||
| 1962 | +103 |
- )+ |
||
| 1963 | +104 |
- }+ ## workaround for https://github.com/insightsengineering/rtables/issues/159 |
||
| 1964 | -+ | |||
| 105 | +5881x |
-
+ if (NROW(dfpart) > 0) {
|
||
| 1965 | -+ | |||
| 106 | +5007x |
- #' @method print RowsVerticalSection+ inds <- eval(csub, envir = dfpart) |
||
| 1966 | -+ | |||
| 107 | +5007x |
- #'+ dat <- dfpart[inds, , drop = FALSE] |
||
| 1967 | +108 |
- #' @export+ } else {
|
||
| 1968 | -+ | |||
| 109 | +874x |
- print.RowsVerticalSection <- function(x, ...) {
+ dat <- dfpart |
||
| 1969 | -1x | +|||
| 110 | +
- cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
+ } |
|||
| 1970 | -1x | +111 | +5881x |
- "---------\n",+ if (!is.null(col) && !inclNAs) {
|
| 1971 | -1x | +112 | +4610x |
- sep = ""+ dat <- dat[!is.na(dat[[col]]), , drop = FALSE] |
| 1972 | +113 |
- )- |
- ||
| 1973 | -1x | -
- print(data.frame(+ } |
||
| 1974 | -1x | +|||
| 114 | +
- row_name = attr(x, "row_names", exact = TRUE),+ |
|||
| 1975 | -1x | +115 | +5881x |
- formatted_cell = vapply(x, format_rcell, character(1)),+ fullrefcoldat <- cextr$.ref_full |
| 1976 | -1x | +116 | +5881x |
- indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)),+ if (!is.null(fullrefcoldat)) {
|
| 1977 | -1x | +117 | +141x |
- row_label = attr(x, "row_labels", exact = TRUE),+ cextr$.ref_full <- NULL |
| 1978 | -1x | +|||
| 118 | +
- stringsAsFactors = FALSE,+ } |
|||
| 1979 | -1x | +119 | +5881x |
- row.names = NULL+ inrefcol <- cextr$.in_ref_col |
| 1980 | -1x | +120 | +5881x |
- ), row.names = TRUE)+ if (!is.null(fullrefcoldat)) {
|
| 1981 | -1x | +121 | +141x |
- invisible(x)+ cextr$.in_ref_col <- NULL |
| 1982 | +122 |
- }+ } |
||
| 1983 | +123 | |||
| 1984 | -- |
- #### Empty default objects to avoid repeated calls- |
- ||
| 1985 | -- |
- ## EmptyColInfo <- InstantiatedColumnInfo()- |
- ||
| 1986 | -+ | |||
| 124 | +5881x |
- ## EmptyElTable <- ElementaryTable()+ exargs <- c(cextr, splextra) |
||
| 1987 | +125 |
- ## EmptyRootSplit <- RootSplit()+ |
||
| 1988 | +126 |
- ## EmptyAllSplit <- AllSplit()+ ## behavior for x/df and ref-data (full and group) |
| 1 | +127 |
- #' Create an `rtable` row+ ## match |
||
| 2 | -+ | |||
| 128 | +5881x |
- #'+ if (!is.null(col) && !takesdf) {
|
||
| 3 | -+ | |||
| 129 | +3693x |
- #' @inheritParams compat_args+ dat <- dat[[col]] |
||
| 4 | -+ | |||
| 130 | +3693x |
- #' @param ... cell values.+ fullrefcoldat <- fullrefcoldat[[col]] |
||
| 5 | -+ | |||
| 131 | +3693x |
- #'+ baselinedf <- baselinedf[[col]] |
||
| 6 | +132 |
- #' @return A row object of the context-appropriate type (label or data).+ } |
||
| 7 | -+ | |||
| 133 | +5881x |
- #'+ args <- list(dat) |
||
| 8 | +134 |
- #' @examples+ |
||
| 9 | -+ | |||
| 135 | +5881x |
- #' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
+ names(all_col_counts) <- names(all_col_exprs) |
||
| 10 | +136 |
- #' rrow("")
+
|
||
| 11 | -+ | |||
| 137 | +5881x |
- #'+ exargs <- match_extra_args(func, |
||
| 12 | -+ | |||
| 138 | +5881x |
- #' @family compatibility+ .N_col = count, |
||
| 13 | -+ | |||
| 139 | +5881x |
- #' @export+ .N_total = totcount, |
||
| 14 | -+ | |||
| 140 | +5881x |
- rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L) {
+ .all_col_exprs = all_col_exprs, |
||
| 15 | -258x | +141 | +5881x |
- vals <- list(...)+ .all_col_counts = all_col_counts, |
| 16 | -258x | +142 | +5881x |
- if (is.null(row.name)) {
+ .var = col, |
| 17 | -40x | +143 | +5881x |
- row.name <- ""+ .ref_group = baselinedf, |
| 18 | -218x | +144 | +5881x |
- } else if (!is(row.name, "character")) {
+ .alt_df_row = alt_dfpart, |
| 19 | -! | +|||
| 145 | +5881x |
- stop("row.name must be NULL or a character string")
+ .alt_df = alt_dfpart_fil, |
||
| 20 | -+ | |||
| 146 | +5881x |
- }+ .ref_full = fullrefcoldat, |
||
| 21 | -258x | +147 | +5881x |
- if (length(vals) == 0L) {
+ .in_ref_col = inrefcol, |
| 22 | -22x | +148 | +5881x |
- LabelRow(+ .N_row = NROW(dfpart), |
| 23 | -22x | +149 | +5881x |
- lev = as.integer(indent),+ .df_row = dfpart, |
| 24 | -22x | +150 | +5881x |
- label = row.name,+ .spl_context = spl_context, |
| 25 | -22x | +151 | +5881x |
- name = row.name,+ extras = c( |
| 26 | -22x | +152 | +5881x |
- vis = TRUE,+ cextr, |
| 27 | -22x | +153 | +5881x |
- table_inset = 0L+ splextra |
| 28 | +154 |
) |
||
| 29 | +155 |
- } else {
+ ) |
||
| 30 | -236x | +|||
| 156 | +
- csps <- as.integer(sapply(vals, function(x) {
+
|
|||
| 31 | -1391x | +157 | +5881x |
- attr(x, "colspan", exact = TRUE) %||% 1L+ args <- c(args, exargs) |
| 32 | +158 |
- }))+ |
||
| 33 | -+ | |||
| 159 | +5881x |
- ## we have to leave the formats on the cells and NOT the row unless we were+ val <- do.call(func, args) |
||
| 34 | -+ | |||
| 160 | +5878x |
- ## already told to do so, because row formats get clobbered when cbinding+ if (!is(val, "RowsVerticalSection")) {
|
||
| 35 | -+ | |||
| 161 | +3796x |
- ## but cell formats do not.+ if (!is(val, "list")) {
|
||
| 36 | -+ | |||
| 162 | +3307x |
- ## formats = sapply(vals, obj_format)+ val <- list(val) |
||
| 37 | +163 |
- ## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format))+ } |
||
| 38 | -+ | |||
| 164 | +3796x |
- ## format = unique(formats)+ ret <- in_rows( |
||
| 39 | -236x | +165 | +3796x |
- DataRow(+ .list = val, |
| 40 | -236x | +166 | +3796x |
- vals = vals, lev = as.integer(indent), label = row.name,+ .labels = unlist(value_labels(val)), |
| 41 | -236x | +167 | +3796x |
- name = row.name, ## XXX TODO+ .names = names(val) |
| 42 | -236x | +|||
| 168 | +
- cspan = csps,+ ) |
|||
| 43 | -236x | +|||
| 169 | +
- format = format,+ } else {
|
|||
| 44 | -236x | +170 | +2082x |
- table_inset = as.integer(inset)+ ret <- val |
| 45 | +171 |
- )+ } |
||
| 46 | -+ | |||
| 172 | +5878x |
- }+ ret |
||
| 47 | +173 |
} |
||
| 48 | +174 | |||
| 49 | +175 |
- #' Create an `rtable` row from a vector or list of values+ strip_multivar_suffix <- function(x) {
|
||
| 50 | -+ | |||
| 176 | +228x |
- #'+ gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
|
||
| 51 | +177 |
- #' @inheritParams compat_args+ } |
||
| 52 | +178 |
- #' @param ... values in vector/list form.+ |
||
| 53 | +179 |
- #'+ ## Generate all values (one for each column) for one or more rows |
||
| 54 | +180 |
- #' @inherit rrow return+ ## by calling func once per column (as defined by cinfo) |
||
| 55 | +181 |
- #'+ #' @noRd |
||
| 56 | +182 |
- #' @examples+ #' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table. |
||
| 57 | +183 |
- #' rrowl("a", c(1, 2, 3), format = "xx")
+ gen_rowvalues <- function(dfpart, |
||
| 58 | +184 |
- #' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
+ datcol, |
||
| 59 | +185 |
- #'+ cinfo, |
||
| 60 | +186 |
- #'+ func, |
||
| 61 | +187 |
- #' rrowl("N", table(iris$Species))
+ splextra, |
||
| 62 | +188 |
- #' rrowl("N", table(iris$Species), format = "xx")
+ takesdf = NULL, |
||
| 63 | +189 |
- #'+ baselines, |
||
| 64 | +190 |
- #' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE)+ alt_dfpart, |
||
| 65 | +191 |
- #'+ inclNAs, |
||
| 66 | +192 |
- #' rrow(row.name = "row 1", x)+ spl_context = spl_context) {
|
||
| 67 | -+ | |||
| 193 | +1590x |
- #' rrow("ABC", 2, 3)
+ colexprs <- col_exprs(cinfo) |
||
| 68 | -+ | |||
| 194 | +1590x |
- #'+ colcounts <- col_counts(cinfo) |
||
| 69 | -+ | |||
| 195 | +1590x |
- #' rrowl(row.name = "row 1", c(1, 2), c(3, 4))+ colextras <- col_extra_args(cinfo, NULL) |
||
| 70 | -+ | |||
| 196 | +1590x |
- #' rrow(row.name = "row 2", c(1, 2), c(3, 4))+ cpaths <- col_paths(cinfo) |
||
| 71 | +197 |
- #'+ ## XXX I don't think this is used anywhere??? |
||
| 72 | +198 |
- #' @family compatibility+ ## splextra = c(splextra, list(.spl_context = spl_context)) |
||
| 73 | -+ | |||
| 199 | +1590x |
- #' @export+ totcount <- col_total(cinfo) |
||
| 74 | +200 |
- rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) {
+
|
||
| 75 | -38x | +201 | +1590x |
- dots <- list(...)+ colleaves <- collect_leaves(cinfo@tree_layout) |
| 76 | -38x | +|||
| 202 | +
- args_list <- c(list(+ |
|||
| 77 | -38x | +203 | +1590x |
- row.name = row.name, format = format,+ gotflist <- is.list(func) |
| 78 | -38x | +|||
| 204 | +
- indent = indent, inset = inset+ |
|||
| 79 | -38x | +|||
| 205 | +
- ), val = unlist(lapply(dots, as.list), recursive = FALSE))+ ## one set of named args to be applied to all columns |
|||
| 80 | -38x | +206 | +1590x |
- do.call(rrow, args_list)+ if (!is.null(names(splextra))) {
|
| 81 | -+ | |||
| 207 | +25x |
- }+ splextra <- list(splextra) |
||
| 82 | +208 |
-
+ } else {
|
||
| 83 | -+ | |||
| 209 | +1565x |
- ## rcell moved to tt_afun_utils.R+ length(splextra) <- ncol(cinfo) |
||
| 84 | +210 |
-
+ } |
||
| 85 | +211 |
- ## inefficient trash+ |
||
| 86 | -+ | |||
| 212 | +1590x |
- paste_em_n <- function(lst, n, sep = ".") {
+ if (!gotflist) {
|
||
| 87 | -9x | +213 | +1077x |
- ret <- lst[[1]]+ func <- list(func) |
| 88 | -9x | +214 | +513x |
- if (n > 1) {
+ } else if (length(splextra) == 1) {
|
| 89 | -4x | +215 | +88x |
- for (i in 2:n) {
+ splextra <- rep(splextra, length.out = length(func)) |
| 90 | -4x | +|||
| 216 | +
- ret <- paste(ret, lst[[i]], sep = sep)+ } |
|||
| 91 | +217 |
- }+ ## if(length(func)) == 1 && names(spl) |
||
| 92 | +218 |
- }+ ## splextra = list(splextra) |
||
| 93 | -9x | +|||
| 219 | +
- ret+ |
|||
| 94 | +220 |
- }+ ## we are in analyze_colvars, so we have to match |
||
| 95 | +221 |
-
+ ## the exargs value by position for each column repeatedly |
||
| 96 | +222 |
- hrows_to_colinfo <- function(rows) {
+ ## across the higher level col splits. |
||
| 97 | -34x | +223 | +1590x |
- nr <- length(rows)+ if (!is.null(datcol) && is.na(datcol)) {
|
| 98 | -34x | +224 | +54x |
- stopifnot(nr > 0)+ datcol <- character(length(colleaves)) |
| 99 | -34x | +225 | +54x |
- cspans <- lapply(rows, row_cspans)+ exargs <- vector("list", length(colleaves))
|
| 100 | -34x | +226 | +54x |
- vals <- lapply(rows, function(x) unlist(row_values(x)))+ for (i in seq_along(colleaves)) {
|
| 101 | -34x | +227 | +228x |
- unqvals <- lapply(vals, unique)+ x <- colleaves[[i]] |
| 102 | -34x | +|||
| 228 | +
- formats <- lapply(rows, obj_format)+ |
|||
| 103 | -34x | +229 | +228x |
- counts <- NULL+ pos <- tree_pos(x) |
| 104 | -34x | +230 | +228x |
- if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
+ spls <- pos_splits(pos) |
| 105 | -1x | +|||
| 231 | +
- counts <- vals[[nr]]+ ## values have the suffix but we are populating datacol+ |
+ |||
| 232 | ++ |
+ ## so it has to match var numbers so strip the suffixes back off |
||
| 106 | -1x | +233 | +228x |
- vals <- vals[-nr]+ splvals <- strip_multivar_suffix(rawvalues(pos)) |
| 107 | -1x | +234 | +228x |
- cspans <- cspans[-nr]+ n <- length(spls) |
| 108 | -1x | +235 | +228x |
- nr <- nr - 1+ datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
|
| 109 | -+ | |||
| 236 | +228x |
- }+ splvals[n] |
||
| 110 | +237 |
- ## easiest case, one header row no counts. we're done+ } else {
|
||
| 111 | -+ | |||
| 238 | +228x |
- ## XXX could one row but cspan ever make sense????+ NA_character_ |
||
| 112 | +239 |
- ## I don't think so?+ } |
||
| 113 | -34x | +240 | +228x |
- if (nr == 1) { ## && all(cspans == 1L)) {
+ argpos <- match(datcol[i], spl_payload(spls[[n]])) |
| 114 | -29x | +|||
| 241 | +
- ret <- manual_cols(unlist(vals[[1]]))+ ## single bracket here because assigning NULL into a list removes |
|||
| 115 | -29x | +|||
| 242 | +
- if (!is.null(counts)) {
+ ## the position entirely |
|||
| 116 | -1x | +243 | +228x |
- col_counts(ret) <- counts+ exargs[i] <- if (argpos <= length(splextra)) {
|
| 117 | -1x | +244 | +228x |
- disp_ccounts(ret) <- TRUE+ splextra[argpos] |
| 118 | +245 |
- }+ } else {
|
||
| 119 | -29x | +|||
| 246 | +! |
- return(ret)+ list(NULL) |
||
| 120 | +247 |
- }+ } |
||
| 121 | +248 |
- ## second easiest case full repeated nestin+ }+ |
+ ||
| 249 | ++ |
+ ## }) |
||
| 122 | -5x | +250 | +54x |
- repvals <- mapply(function(v, csp) rep(v, times = csp),+ if (all(is.na(datcol))) {
+ |
+
| 251 | +! | +
+ datcol <- list(NULL) |
||
| 123 | -5x | +252 | +54x |
- v = vals, csp = cspans, SIMPLIFY = FALSE+ } else if (any(is.na(datcol))) {
|
| 124 | -+ | |||
| 253 | +! |
- )+ stop("mix of var and non-var columns with NA analysis rowvara")
|
||
| 125 | +254 |
-
+ } |
||
| 126 | +255 |
- ## nr > 1 here+ } else {
|
||
| 127 | -5x | +256 | +1536x |
- fullnest <- TRUE+ exargs <- splextra |
| 128 | -5x | +257 | +1536x |
- for (i in 2:nr) {
+ if (is.null(datcol)) {
|
| 129 | -5x | +258 | +316x |
- psted <- paste_em_n(repvals, i - 1)+ datcol <- list(NULL) |
| 130 | -5x | +|||
| 259 | +
- spl <- split(repvals[[i]], psted)+ } |
|||
| 131 | -5x | +260 | +1536x |
- if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
+ datcol <- rep(datcol, length(colexprs)) |
| 132 | -4x | +|||
| 261 | +
- fullnest <- FALSE+ ## if(gotflist) |
|||
| 133 | -4x | +|||
| 262 | +
- break+ ## length(exargs) <- length(func) ## func is a list |
|||
| 134 | -+ | |||
| 263 | +1536x |
- }+ exargs <- rep(exargs, length.out = length(colexprs)) |
||
| 135 | +264 |
} |
||
| 265 | +1590x | +
+ allfuncs <- rep(func, length.out = length(colexprs))+ |
+ ||
| 136 | +266 | |||
| 267 | +1590x | +
+ if (is.null(takesdf)) {
+ |
+ ||
| 268 | +1131x | +
+ takesdf <- .takes_df(allfuncs)+ |
+ ||
| 137 | +269 |
- ## if its full nesting we're done, so put+ } |
||
| 138 | +270 |
- ## the counts on as necessary and return.+ |
||
| 139 | -5x | +271 | +1590x |
- if (fullnest) {
+ rawvals <- mapply(gen_onerv, |
| 140 | -1x | +272 | +1590x |
- ret <- manual_cols(.lst = unqvals)+ csub = colexprs, |
| 141 | -1x | +273 | +1590x |
- if (!is.null(counts)) {
+ col = datcol, |
| 142 | -! | +|||
| 274 | +1590x |
- col_counts(ret) <- counts+ count = colcounts, |
||
| 143 | -! | +|||
| 275 | +1590x |
- disp_ccounts(ret) <- TRUE+ cextr = colextras, |
||
| 144 | -+ | |||
| 276 | +1590x |
- }+ cpath = cpaths, |
||
| 145 | -1x | +277 | +1590x |
- return(ret)+ baselinedf = baselines, |
| 146 | -+ | |||
| 278 | +1590x |
- }+ alt_dfpart = list(alt_dfpart), |
||
| 147 | -+ | |||
| 279 | +1590x |
-
+ func = allfuncs, |
||
| 148 | -+ | |||
| 280 | +1590x |
- ## booo. the fully complex case where the multiple rows+ takesdf = takesdf, |
||
| 149 | -+ | |||
| 281 | +1590x |
- ## really don't represent nesting at all, each top level+ col_parent_inds = spl_context[, names(colexprs), |
||
| 150 | -+ | |||
| 282 | +1590x |
- ## can have different sub labels+ drop = FALSE |
||
| 151 | +283 |
-
+ ], |
||
| 152 | -+ | |||
| 284 | +1590x |
- ## we will build it up as if it were full nesting and then prune+ all_col_exprs = list(colexprs), |
||
| 153 | -+ | |||
| 285 | +1590x |
- ## based on the columns we actually want.+ all_col_counts = list(colcounts), |
||
| 154 | -+ | |||
| 286 | +1590x |
-
+ splextra = exargs, |
||
| 155 | -4x | +287 | +1590x |
- fullcolinfo <- manual_cols(.lst = unqvals)+ MoreArgs = list( |
| 156 | -4x | +288 | +1590x |
- fullbusiness <- names(collect_leaves(coltree(fullcolinfo)))+ dfpart = dfpart, |
| 157 | -4x | +289 | +1590x |
- wanted <- paste_em_n(repvals, nr)+ totcount = totcount, |
| 158 | -4x | +290 | +1590x |
- wantcols <- match(wanted, fullbusiness)+ inclNAs = inclNAs, |
| 159 | -4x | +291 | +1590x |
- stopifnot(all(!is.na(wantcols)))+ spl_context = spl_context |
| 160 | +292 |
-
+ ), |
||
| 161 | -4x | +293 | +1590x |
- subset_cols(fullcolinfo, wantcols)+ SIMPLIFY = FALSE |
| 162 | +294 |
- }+ ) |
||
| 163 | +295 | |||
| 164 | -+ | |||
| 296 | +1587x |
- #' Create a header+ names(rawvals) <- names(colexprs)+ |
+ ||
| 297 | +1587x | +
+ rawvals |
||
| 165 | +298 |
- #'+ } |
||
| 166 | +299 |
- #' @inheritParams compat_args+ |
||
| 167 | +300 |
- #' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()],+ .strip_lst_rvals <- function(lst) {
+ |
+ ||
| 301 | +! | +
+ lapply(lst, rawvalues) |
||
| 168 | +302 |
- #' [LabelRow()], etc.+ } |
||
| 169 | +303 |
- #'+ |
||
| 170 | +304 |
- #' @return A `InstantiatedColumnInfo` object.+ #' @noRd |
||
| 171 | +305 |
- #'+ #' @return A list of table rows, even when only one is generated. |
||
| 172 | +306 |
- #' @examples+ .make_tablerows <- function(dfpart, |
||
| 173 | +307 |
- #' h1 <- rheader(c("A", "B", "C"))
+ alt_dfpart, |
||
| 174 | +308 |
- #' h1+ func, |
||
| 175 | +309 |
- #'+ cinfo, |
||
| 176 | +310 |
- #' h2 <- rheader(+ datcol = NULL, |
||
| 177 | +311 |
- #' rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
+ lev = 1L, |
||
| 178 | +312 |
- #' rrow(NULL, "A", "B", "A", "B")+ rvlab = NA_character_, |
||
| 179 | +313 |
- #' )+ format = NULL, |
||
| 180 | +314 |
- #' h2+ defrowlabs = NULL, |
||
| 181 | +315 |
- #'+ rowconstr = DataRow, |
||
| 182 | +316 |
- #' @family compatibility+ splextra = list(), |
||
| 183 | +317 |
- #' @export+ takesdf = NULL, |
||
| 184 | +318 |
- rheader <- function(..., format = "xx", .lst = NULL) {
+ baselines = replicate( |
||
| 185 | -3x | +|||
| 319 | +
- if (!is.null(.lst)) {
+ length(col_exprs(cinfo)), |
|||
| 186 | -! | +|||
| 320 | +
- args <- .lst+ list(dfpart[0, ]) |
|||
| 187 | +321 |
- } else {
+ ), |
||
| 188 | -3x | +|||
| 322 | +
- args <- list(...)+ inclNAs, |
|||
| 189 | +323 |
- }+ spl_context = context_df_row(cinfo = cinfo)) {
|
||
| 190 | -3x | +324 | +1590x |
- rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
+ if (is.null(datcol) && !is.na(rvlab)) {
|
| 191 | +325 | ! |
- list(rrowl(row.name = NULL, val = args[[1]], format = format))+ stop("NULL datcol but non-na rowvar label")
+ |
+ |
| 326 | ++ |
+ } |
||
| 192 | -3x | +327 | +1590x |
- } else if (are(args, "TableRow")) {
+ if (!is.null(datcol) && !is.na(datcol)) {
|
| 193 | -3x | +328 | +1220x |
- args+ if (!all(datcol %in% names(dfpart))) {
|
| 194 | -+ | |||
| 329 | +! |
- }+ stop( |
||
| 195 | -+ | |||
| 330 | +! |
-
+ "specified analysis variable (", datcol,
|
||
| 196 | -3x | +|||
| 331 | +! |
- hrows_to_colinfo(rrows)+ ") not present in data" |
||
| 197 | +332 |
- }+ ) |
||
| 198 | +333 |
-
+ } |
||
| 199 | +334 |
- .char_to_hrows <- function(hdr) {
+
|
||
| 200 | -31x | +335 | +1220x |
- nlfnd <- grep("\n", hdr, fixed = TRUE)
+ rowvar <- datcol |
| 201 | -31x | +|||
| 336 | +
- if (length(nlfnd) == 0) {
+ } else {
|
|||
| 202 | -27x | +337 | +370x |
- return(list(rrowl(NULL, hdr)))+ rowvar <- NA_character_ |
| 203 | +338 |
} |
||
| 204 | +339 | |||
| 205 | -4x | +340 | +1590x |
- stopifnot(length(nlfnd) == length(hdr))+ rawvals <- gen_rowvalues(dfpart, |
| 206 | -4x | +341 | +1590x |
- raw <- strsplit(hdr, "\n", fixed = TRUE)+ alt_dfpart = alt_dfpart, |
| 207 | -4x | +342 | +1590x |
- lens <- unique(sapply(raw, length))+ datcol = datcol, |
| 208 | -4x | +343 | +1590x |
- stopifnot(length(lens) == 1L)+ cinfo = cinfo, |
| 209 | -4x | +344 | +1590x |
- lapply(+ func = func, |
| 210 | -4x | +345 | +1590x |
- seq(1, lens),+ splextra = splextra, |
| 211 | -4x | +346 | +1590x |
- function(i) {
+ takesdf = takesdf, |
| 212 | -8x | +347 | +1590x |
- rrowl(NULL, vapply(raw, `[`, NA_character_, i = i))+ baselines = baselines, |
| 213 | -+ | |||
| 348 | +1590x |
- }+ inclNAs = inclNAs,+ |
+ ||
| 349 | +1590x | +
+ spl_context = spl_context |
||
| 214 | +350 |
) |
||
| 215 | +351 |
- }+ |
||
| 216 | +352 |
-
+ ## if(is.null(rvtypes)) |
||
| 217 | +353 |
- #' Create a table+ ## rvtypes = rep(NA_character_, length(rawvals)) |
||
| 218 | -+ | |||
| 354 | +1587x |
- #'+ lens <- vapply(rawvals, length, NA_integer_) |
||
| 219 | -+ | |||
| 355 | +1587x |
- #' @inheritParams compat_args+ unqlens <- unique(lens) |
||
| 220 | +356 |
- #' @inheritParams gen_args+ ## length 0 returns are ok to not match cause they are |
||
| 221 | +357 |
- #' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header+ ## just empty space we can fill in as needed. |
||
| 222 | -+ | |||
| 358 | +1587x |
- #' (column structure) of the table. This can be as row objects (legacy), character vectors, or an+ if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
|
||
| 223 | +359 |
- #' `InstantiatedColumnInfo` object.+ ## (0 %in% unqlens && length(unqlens) != 2)) {
|
||
| 224 | -+ | |||
| 360 | +1x |
- #' @param ... rows to place in the table.+ stop( |
||
| 225 | -+ | |||
| 361 | +1x |
- #'+ "Number of rows generated by analysis function do not match ", |
||
| 226 | -+ | |||
| 362 | +1x |
- #' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`).+ "across all columns. ", |
||
| 227 | -+ | |||
| 363 | +1x |
- #'+ if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
|
||
| 228 | -+ | |||
| 364 | +! |
- #' @examples+ paste( |
||
| 229 | -+ | |||
| 365 | +! |
- #' rtable(+ "\nPerhaps convert analysis variable", datcol, |
||
| 230 | -+ | |||
| 366 | +! |
- #' header = LETTERS[1:3],+ "to a factor?" |
||
| 231 | +367 |
- #' rrow("one to three", 1, 2, 3),
+ ) |
||
| 232 | +368 |
- #' rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
+ } |
||
| 233 | +369 |
- #' )+ ) |
||
| 234 | +370 |
- #'+ } |
||
| 235 | -+ | |||
| 371 | +1586x |
- #' # Table with multirow header+ maxind <- match(max(unqlens), lens) |
||
| 236 | +372 |
- #'+ |
||
| 237 | +373 |
- #' sel <- iris$Species == "setosa"+ ## look if we got labels, if not apply the |
||
| 238 | +374 |
- #' mtbl <- rtable(+ ## default row labels |
||
| 239 | +375 |
- #' header = rheader(+ ## this is guaranteed to be a RowsVerticalSection object. |
||
| 240 | -+ | |||
| 376 | +1586x |
- #' rrow(+ rv1col <- rawvals[[maxind]] |
||
| 241 | +377 |
- #' row.name = NULL, rcell("Sepal.Length", colspan = 2),
+ ## nocov start |
||
| 242 | +378 |
- #' rcell("Petal.Length", colspan = 2)
+ if (!is(rv1col, "RowsVerticalSection")) {
|
||
| 243 | +379 |
- #' ),+ stop( |
||
| 244 | +380 |
- #' rrow(NULL, "mean", "median", "mean", "median")+ "gen_rowvalues appears to have generated something that was not ", |
||
| 245 | +381 |
- #' ),+ "a RowsVerticalSection object. Please contact the maintainer." |
||
| 246 | +382 |
- #' rrow(+ ) |
||
| 247 | +383 |
- #' row.name = "All Species",+ } |
||
| 248 | +384 |
- #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ # nocov end |
||
| 249 | +385 |
- #' mean(iris$Petal.Length), median(iris$Petal.Length),+ |
||
| 250 | -+ | |||
| 386 | +1586x |
- #' format = "xx.xx"+ labels <- value_labels(rv1col) |
||
| 251 | +387 |
- #' ),+ |
||
| 252 | -+ | |||
| 388 | +1586x |
- #' rrow(+ ncrows <- max(unqlens) |
||
| 253 | -+ | |||
| 389 | +1586x |
- #' row.name = "Setosa",+ if (ncrows == 0) {
|
||
| 254 | -+ | |||
| 390 | +! |
- #' mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]),+ return(list()) |
||
| 255 | +391 |
- #' mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel])+ } |
||
| 256 | -+ | |||
| 392 | +1586x |
- #' )+ stopifnot(ncrows > 0) |
||
| 257 | +393 |
- #' )+ |
||
| 258 | -+ | |||
| 394 | +1586x |
- #'+ if (is.null(labels)) {
|
||
| 259 | -+ | |||
| 395 | +211x |
- #' mtbl+ if (length(rawvals[[maxind]]) == length(defrowlabs)) {
|
||
| 260 | -+ | |||
| 396 | +203x |
- #'+ labels <- defrowlabs |
||
| 261 | +397 |
- #' names(mtbl) # always first row of header+ } else {
|
||
| 262 | -+ | |||
| 398 | +8x |
- #'+ labels <- rep("", ncrows)
|
||
| 263 | +399 |
- #' # Single row header+ } |
||
| 264 | +400 |
- #'+ } |
||
| 265 | +401 |
- #' tbl <- rtable(+ |
||
| 266 | -+ | |||
| 402 | +1586x |
- #' header = c("Treatement\nN=100", "Comparison\nN=300"),
+ rfootnotes <- rep(list(list(), length(rv1col))) |
||
| 267 | -+ | |||
| 403 | +1586x |
- #' format = "xx (xx.xx%)",+ nms <- value_names(rv1col) |
||
| 268 | -+ | |||
| 404 | +1586x |
- #' rrow("A", c(104, .2), c(100, .4)),
+ rfootnotes <- row_footnotes(rv1col) |
||
| 269 | +405 |
- #' rrow("B", c(23, .4), c(43, .5)),
+
|
||
| 270 | -+ | |||
| 406 | +1586x |
- #' rrow(""),
+ imods <- indent_mod(rv1col) ## rv1col@indent_mods |
||
| 271 | -+ | |||
| 407 | +1586x |
- #' rrow("this is a very long section header"),
+ unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE) |
||
| 272 | +408 |
- #' rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
+
|
||
| 273 | -+ | |||
| 409 | +1586x |
- #' rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
+ formatvec <- NULL |
||
| 274 | -+ | |||
| 410 | +1586x |
- #' )+ if (!is.null(format)) {
|
||
| 275 | -+ | |||
| 411 | +208x |
- #' tbl+ if (is.function(format)) {
|
||
| 276 | -+ | |||
| 412 | +1x |
- #'+ format <- list(format) |
||
| 277 | +413 |
- #' row.names(tbl)+ } |
||
| 278 | -+ | |||
| 414 | +208x |
- #' names(tbl)+ formatvec <- rep(format, length.out = ncrows) |
||
| 279 | +415 |
- #'+ } |
||
| 280 | +416 |
- #' # Subsetting+ |
||
| 281 | -+ | |||
| 417 | +1586x |
- #'+ trows <- lapply(1:ncrows, function(i) {
|
||
| 282 | -+ | |||
| 418 | +2559x |
- #' tbl[1, ]+ rowvals <- lapply(unwrapped_vals, function(colvals) {
|
||
| 283 | -+ | |||
| 419 | +9240x |
- #' tbl[, 1]+ colvals[[i]] |
||
| 284 | +420 |
- #'+ }) |
||
| 285 | -+ | |||
| 421 | +2559x |
- #' tbl[1, 2]+ imod <- unique(vapply(rowvals, indent_mod, 0L)) |
||
| 286 | -+ | |||
| 422 | +2559x |
- #' tbl[2, 1]+ if (length(imod) != 1) {
|
||
| 287 | -+ | |||
| 423 | +! |
- #'+ stop( |
||
| 288 | -+ | |||
| 424 | +! |
- #' tbl[3, 2]+ "Different cells in the same row appear to have been given ", |
||
| 289 | -+ | |||
| 425 | +! |
- #' tbl[5, 1]+ "different indent_mod values" |
||
| 290 | +426 |
- #' tbl[5, 2]+ ) |
||
| 291 | +427 |
- #'+ } |
||
| 292 | -+ | |||
| 428 | +2559x |
- #' # Data Structure methods+ rowconstr( |
||
| 293 | -+ | |||
| 429 | +2559x |
- #'+ vals = rowvals, |
||
| 294 | -+ | |||
| 430 | +2559x |
- #' dim(tbl)+ cinfo = cinfo, |
||
| 295 | -+ | |||
| 431 | +2559x |
- #' nrow(tbl)+ lev = lev, |
||
| 296 | -+ | |||
| 432 | +2559x |
- #' ncol(tbl)+ label = labels[i], |
||
| 297 | -+ | |||
| 433 | +2559x |
- #' names(tbl)+ name = nms[i], ## labels[i], ## XXX this is probably wrong?! |
||
| 298 | -+ | |||
| 434 | +2559x |
- #'+ var = rowvar, |
||
| 299 | -+ | |||
| 435 | +2559x |
- #' # Colspans+ format = formatvec[[i]], |
||
| 300 | -+ | |||
| 436 | +2559x |
- #'+ indent_mod = imods[[i]] %||% 0L, |
||
| 301 | -+ | |||
| 437 | +2559x |
- #' tbl2 <- rtable(+ footnotes = rfootnotes[[i]] ## one bracket so list |
||
| 302 | +438 |
- #' c("A", "B", "C", "D", "E"),
+ ) |
||
| 303 | +439 |
- #' format = "xx",+ }) |
||
| 304 | -+ | |||
| 440 | +1586x |
- #' rrow("r1", 1, 2, 3, 4, 5),
+ trows |
||
| 305 | +441 |
- #' rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
+ } |
||
| 306 | +442 |
- #' )+ |
||
| 307 | +443 |
- #' tbl2+ .make_caller <- function(parent_cfun, clabelstr = "") {
|
||
| 308 | -+ | |||
| 444 | +470x |
- #'+ formalnms <- names(formals(parent_cfun)) |
||
| 309 | +445 |
- #' @family compatibility+ ## note the <- here |
||
| 310 | -+ | |||
| 446 | +470x |
- #' @export+ if (!is.na(dotspos <- match("...", formalnms))) {
|
||
| 311 | -+ | |||
| 447 | +1x |
- rtable <- function(header, ..., format = NULL, hsep = default_hsep(),+ toremove <- dotspos |
||
| 312 | +448 |
- inset = 0L) {
- |
- ||
| 313 | -34x | -
- if (is.character(header)) {
+ } else {
|
||
| 314 | -31x | +449 | +469x |
- header <- .char_to_hrows(header)+ toremove <- NULL |
| 315 | +450 |
- } # list(rrowl(NULL, header))+ } |
||
| 316 | -34x | +|||
| 451 | +
- if (is.list(header)) {
+
|
|||
| 317 | -31x | +452 | +470x |
- if (are(header, "TableRow")) {
+ labelstrpos <- match("labelstr", names(formals(parent_cfun)))
|
| 318 | -31x | -
- colinfo <- hrows_to_colinfo(header)- |
- ||
| 319 | -! | +453 | +470x |
- } else if (are(header, "list")) {
+ if (is.na(labelstrpos)) {
|
| 320 | +454 | ! |
- colinfo <- do.call(rheader, header)- |
- |
| 321 | -- |
- }- |
- ||
| 322 | -3x | -
- } else if (is(header, "InstantiatedColumnInfo")) {
- |
- ||
| 323 | -3x | -
- colinfo <- header+ stop( |
||
| 324 | +455 | ! |
- } else if (is(header, "TableRow")) {
+ "content function does not appear to accept the labelstr", |
|
| 325 | +456 | ! |
- colinfo <- hrows_to_colinfo(list(header))+ "arguent" |
|
| 326 | +457 |
- } else {
- |
- ||
| 327 | -! | -
- stop("problems")
+ ) |
||
| 328 | +458 |
} |
||
| 329 | -+ | |||
| 459 | +470x |
-
+ toremove <- c(toremove, labelstrpos) |
||
| 330 | -34x | +460 | +470x |
- body <- list(...)+ formalnms <- formalnms[-1 * toremove] |
| 331 | +461 |
- ## XXX this shouldn't be needed. hacky+ |
||
| 332 | -34x | -
- if (length(body) == 1 && is.list(body[[1]])) {
- |
- ||
| 333 | -! | +462 | +470x |
- body <- body[[1]]+ caller <- eval(parser_helper(text = paste( |
| 334 | -+ | |||
| 463 | +470x |
- }+ "function() { parent_cfun(",
|
||
| 335 | -34x | +464 | +470x |
- if (are(body, "ElementaryTable") &&+ paste(formalnms, "=", |
| 336 | -34x | +465 | +470x |
- all(sapply(body, function(tb) {
+ formalnms, |
| 337 | -! | +|||
| 466 | +470x |
- nrow(tb) == 1 && obj_name(tb) == ""+ collapse = ", " |
||
| 338 | +467 |
- }))) {
+ ), |
||
| 339 | -1x | +468 | +470x |
- body <- lapply(body, function(tb) tree_children(tb)[[1]])+ ", labelstr = clabelstr, ...)}" |
| 340 | +469 |
- }+ ))) |
||
| 341 | -+ | |||
| 470 | +470x |
-
+ formals(caller) <- c( |
||
| 342 | -34x | +471 | +470x |
- TableTree(+ formals(parent_cfun)[-labelstrpos], |
| 343 | -34x | +472 | +470x |
- kids = body, format = format, cinfo = colinfo,+ alist("..." = )
|
| 344 | -34x | +473 | +470x |
- labelrow = LabelRow(lev = 0L, label = "", vis = FALSE),+ ) # nolint |
| 345 | -34x | +474 | +470x |
- hsep = hsep, inset = inset+ caller |
| 346 | +475 |
- )+ } |
||
| 347 | +476 |
- }+ |
||
| 348 | +477 |
-
+ # Makes content table xxx renaming |
||
| 349 | +478 |
- #' @rdname rtable+ .make_ctab <- function(df, |
||
| 350 | +479 |
- #' @export+ lvl, ## treepos, |
||
| 351 | +480 |
- rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
+ name, |
||
| 352 | -1x | +|||
| 481 | +
- dots <- list(...)+ label, |
|||
| 353 | -1x | +|||
| 482 | +
- args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply(+ cinfo, |
|||
| 354 | -1x | +|||
| 483 | +
- dots,+ parent_cfun = NULL, |
|||
| 355 | -1x | +|||
| 484 | +
- as.list+ format = NULL, |
|||
| 356 | -1x | +|||
| 485 | +
- ), recursive = FALSE))+ na_str = NA_character_, |
|||
| 357 | -1x | +|||
| 486 | +
- do.call(rtable, args_list)+ indent_mod = 0L, |
|||
| 358 | +487 |
- }+ cvar = NULL, |
||
| 359 | +488 |
-
+ inclNAs, |
||
| 360 | +489 |
- # All object annotations are identical (and exist)+ alt_df, |
||
| 361 | +490 |
- all_annots_identical <- function(all_annots) {
+ extra_args, |
||
| 362 | -60x | +|||
| 491 | +
- if (!is.list(all_annots)) {
+ spl_context = context_df_row(cinfo = cinfo)) {
|
|||
| 363 | -15x | -
- all_annots[1] != "" && length(unique(all_annots)) == 1- |
- ||
| 364 | -+ | 492 | +1831x |
- } else {
+ if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
|
| 365 | -45x | +493 | +1655x |
- length(all_annots[[1]]) > 0 && Reduce(identical, all_annots)+ cvar <- NULL |
| 366 | +494 |
} |
||
| 367 | -+ | |||
| 495 | +1831x |
- }+ if (!is.null(parent_cfun)) {
|
||
| 368 | +496 |
-
+ ## cfunc <- .make_caller(parent_cfun, label) |
||
| 369 | -+ | |||
| 497 | +459x |
- # Only first object has annotations+ cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label) |
||
| 370 | -+ | |||
| 498 | +459x |
- only_first_annot <- function(all_annots) {
+ contkids <- tryCatch( |
||
| 371 | -56x | +499 | +459x |
- if (!is.list(all_annots)) {
+ .make_tablerows(df, |
| 372 | -14x | +500 | +459x |
- all_annots[1] != "" && all(all_annots[-1] == "")+ lev = lvl, |
| 373 | -+ | |||
| 501 | +459x |
- } else {
+ func = cfunc, |
||
| 374 | -42x | +502 | +459x |
- length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0)+ cinfo = cinfo, |
| 375 | -+ | |||
| 503 | +459x |
- }+ rowconstr = ContentRow, |
||
| 376 | -+ | |||
| 504 | +459x |
- }+ datcol = cvar, |
||
| 377 | -+ | |||
| 505 | +459x |
-
+ takesdf = rep(.takes_df(cfunc), |
||
| 378 | -+ | |||
| 506 | +459x |
- #' @param gap `r lifecycle::badge("deprecated")` ignored.
+ length.out = ncol(cinfo) |
||
| 379 | +507 |
- #' @param check_headers `r lifecycle::badge("deprecated")` ignored.
+ ), |
||
| 380 | -+ | |||
| 508 | +459x |
- #'+ inclNAs = FALSE, |
||
| 381 | -+ | |||
| 509 | +459x |
- #' @return A formal table object.+ alt_dfpart = alt_df, |
||
| 382 | -+ | |||
| 510 | +459x |
- #'+ splextra = extra_args, |
||
| 383 | -+ | |||
| 511 | +459x |
- #' @rdname rbind+ spl_context = spl_context |
||
| 384 | +512 |
- #' @aliases rbind+ ), |
||
| 385 | -+ | |||
| 513 | +459x |
- #' @export+ error = function(e) e |
||
| 386 | +514 |
- rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
+ ) |
||
| 387 | -16x | +515 | +459x |
- if (lifecycle::is_present(gap)) {
+ if (is(contkids, "error")) {
|
| 388 | -! | +|||
| 516 | +1x |
- lifecycle::deprecate_warn(+ stop("Error in content (summary) function: ", contkids$message,
|
||
| 389 | -! | +|||
| 517 | +1x |
- when = "0.3.2",+ "\n\toccured at path: ", |
||
| 390 | -! | +|||
| 518 | +1x |
- what = "rbindl_rtables(gap)"+ spl_context_to_disp_path(spl_context), |
||
| 391 | -+ | |||
| 519 | +1x |
- )+ call. = FALSE |
||
| 392 | +520 |
- }- |
- ||
| 393 | -16x | -
- if (lifecycle::is_present(check_headers)) {
- |
- ||
| 394 | -! | -
- lifecycle::deprecate_warn(- |
- ||
| 395 | -! | -
- when = "0.3.2",+ ) |
||
| 396 | -! | +|||
| 521 | +
- what = "rbindl_rtables(check_headers)"+ } |
|||
| 397 | +522 |
- )+ } else {
|
||
| 398 | -+ | |||
| 523 | +1372x |
- }+ contkids <- list() |
||
| 399 | +524 |
-
+ } |
||
| 400 | -16x | +525 | +1830x |
- firstcols <- col_info(x[[1]])+ ctab <- ElementaryTable( |
| 401 | -16x | +526 | +1830x |
- i <- 1+ kids = contkids, |
| 402 | -16x | +527 | +1830x |
- while (no_colinfo(firstcols) && i <= length(x)) {
+ name = paste0(name, "@content"), |
| 403 | -2x | +528 | +1830x |
- firstcols <- col_info(x[[i]])+ lev = lvl, |
| 404 | -2x | +529 | +1830x |
- i <- i + 1+ labelrow = LabelRow(), |
| 405 | -+ | |||
| 530 | +1830x |
- }+ cinfo = cinfo, |
||
| 406 | -+ | |||
| 531 | +1830x |
-
+ iscontent = TRUE, |
||
| 407 | -16x | +532 | +1830x |
- lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi)))+ format = format, |
| 408 | -+ | |||
| 533 | +1830x |
-
+ indent_mod = indent_mod, |
||
| 409 | -15x | +534 | +1830x |
- rbind_annot <- list(+ na_str = na_str |
| 410 | -15x | +|||
| 535 | +
- main_title = "",+ ) |
|||
| 411 | -15x | +536 | +1830x |
- subtitles = character(),+ ctab |
| 412 | -15x | +|||
| 537 | +
- main_footer = character(),+ } |
|||
| 413 | -15x | +|||
| 538 | +
- prov_footer = character()+ |
|||
| 414 | +539 |
- )+ .make_analyzed_tab <- function(df, |
||
| 415 | +540 |
-
+ alt_df, |
||
| 416 | +541 |
- # Titles/footer info are (independently) retained from first object if+ spl, |
||
| 417 | +542 |
- # identical or missing in all other objects+ cinfo, |
||
| 418 | -15x | +|||
| 543 | +
- all_titles <- sapply(x, main_title)+ partlabel = "", |
|||
| 419 | -15x | +|||
| 544 | +
- if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
+ dolab = TRUE, |
|||
| 420 | -2x | +|||
| 545 | +
- rbind_annot[["main_title"]] <- all_titles[[1]]+ lvl, |
|||
| 421 | +546 |
- }+ baselines, |
||
| 422 | +547 |
-
+ spl_context) {
|
||
| 423 | -15x | +548 | +1132x |
- all_sts <- lapply(x, subtitles)+ stopifnot(is(spl, "VAnalyzeSplit")) |
| 424 | -15x | +549 | +1132x |
- if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
+ check_validsplit(spl, df) |
| 425 | -2x | +550 | +1131x |
- rbind_annot[["subtitles"]] <- all_sts[[1]]+ defrlabel <- spl@default_rowlabel |
| 426 | -+ | |||
| 551 | +1131x |
- }+ if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
+ |
+ ||
| 552 | +! | +
+ defrlabel <- partlabel |
||
| 427 | +553 |
-
+ } |
||
| 428 | -15x | +554 | +1131x |
- all_ftrs <- lapply(x, main_footer)+ kids <- tryCatch( |
| 429 | -15x | +555 | +1131x |
- if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) {
+ .make_tablerows(df, |
| 430 | -2x | +556 | +1131x |
- rbind_annot[["main_footer"]] <- all_ftrs[[1]]+ func = analysis_fun(spl), |
| 431 | -+ | |||
| 557 | +1131x |
- }+ defrowlabs = defrlabel, # XXX |
||
| 432 | -+ | |||
| 558 | +1131x |
-
+ cinfo = cinfo, |
||
| 433 | -15x | +559 | +1131x |
- all_pfs <- lapply(x, prov_footer)+ datcol = spl_payload(spl), |
| 434 | -15x | +560 | +1131x |
- if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
+ lev = lvl + 1L, |
| 435 | -2x | +561 | +1131x |
- rbind_annot[["prov_footer"]] <- all_pfs[[1]]+ format = obj_format(spl), |
| 436 | -+ | |||
| 562 | +1131x |
- }+ splextra = split_exargs(spl), |
||
| 437 | -+ | |||
| 563 | +1131x |
-
+ baselines = baselines, |
||
| 438 | -+ | |||
| 564 | +1131x |
- ## if we got only ElementaryTable and+ alt_dfpart = alt_df, |
||
| 439 | -+ | |||
| 565 | +1131x |
- ## TableRow objects, construct a new+ inclNAs = avar_inclNAs(spl), |
||
| 440 | -+ | |||
| 566 | +1131x |
- ## elementary table with all the rows+ spl_context = spl_context |
||
| 441 | +567 |
- ## instead of adding nesting.+ ), |
||
| 442 | -+ | |||
| 568 | +1131x |
-
+ error = function(e) e |
||
| 443 | +569 |
- ## we used to check for xi not being a lable row, why?? XXX+ ) |
||
| 444 | -15x | +|||
| 570 | +
- if (all(sapply(x, function(xi) {
+
|
|||
| 445 | -30x | +|||
| 571 | +
- (is(xi, "ElementaryTable") && !labelrow_visible(xi)) ||+ # Adding section_div for DataRows (analyze leaves) |
|||
| 446 | -30x | +572 | +1131x |
- is(xi, "TableRow")+ kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow") |
| 447 | -15x | +|||
| 573 | +
- }))) { ## && !is(xi, "LabelRow")}))) {
+
|
|||
| 448 | -8x | +574 | +1131x |
- x <- unlist(lapply(x, function(xi) {
+ if (is(kids, "error")) {
|
| 449 | -16x | +575 | +3x |
- if (is(xi, "TableRow")) {
+ stop("Error applying analysis function (var - ",
|
| 450 | -4x | -
- xi- |
- ||
| 451 | -+ | 576 | +3x |
- } else {
+ spl_payload(spl) %||% "colvars", "): ", kids$message, |
| 452 | -12x | +577 | +3x |
- lst <- tree_children(xi)+ "\n\toccured at (row) path: ", |
| 453 | -12x | +578 | +3x |
- lapply(lst, indent,+ spl_context_to_disp_path(spl_context), |
| 454 | -12x | -
- by = indent_mod(xi)- |
- ||
| 455 | -- |
- )- |
- ||
| 456 | -+ | 579 | +3x |
- }+ call. = FALSE |
| 457 | +580 |
- }))+ ) |
||
| 458 | +581 |
} |
||
| 459 | -+ | |||
| 582 | +1128x |
-
+ lab <- obj_label(spl) |
||
| 460 | -15x | +583 | +1128x |
- TableTree(+ ret <- TableTree( |
| 461 | -15x | +584 | +1128x |
- kids = x,+ kids = kids, |
| 462 | -15x | +585 | +1128x |
- cinfo = firstcols,+ name = obj_name(spl), |
| 463 | -15x | +586 | +1128x |
- name = "rbind_root",+ label = lab, |
| 464 | -15x | +587 | +1128x |
- label = "",+ lev = lvl, |
| 465 | -15x | +588 | +1128x |
- title = rbind_annot[["main_title"]],+ cinfo = cinfo, |
| 466 | -15x | +589 | +1128x |
- subtitles = rbind_annot[["subtitles"]],+ format = obj_format(spl), |
| 467 | -15x | +590 | +1128x |
- main_footer = rbind_annot[["main_footer"]],+ na_str = obj_na_str(spl), |
| 468 | -15x | +591 | +1128x |
- prov_footer = rbind_annot[["prov_footer"]]+ indent_mod = indent_mod(spl) |
| 469 | +592 |
) |
||
| 470 | -- |
- }- |
- ||
| 471 | +593 | |||
| 472 | -+ | |||
| 594 | +1128x |
- #' Row-bind `TableTree` and related objects+ labelrow_visible(ret) <- dolab |
||
| 473 | -+ | |||
| 595 | +1128x |
- #'+ ret |
||
| 474 | +596 |
- #' @param deparse.level (`numeric(1)`)\cr currently ignored.+ } |
||
| 475 | +597 |
- #' @param ... (`ANY`)\cr elements to be stacked.+ |
||
| 476 | +598 |
- #'+ #' @param ... all arguments to `recurse_applysplit`, methods may only use some of them. |
||
| 477 | +599 |
- #' @note+ #' @return A `list` of children to place at this level. |
||
| 478 | +600 |
- #' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all+ #' |
||
| 479 | +601 |
- #' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed+ #' @noRd |
||
| 480 | +602 |
- #' and must be set for the bound table via the [main_title()], [subtitles()], [main_footer()], and [prov_footer()]+ setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
|
||
| 481 | -+ | |||
| 603 | +1659x |
- #' functions.+ standardGeneric(".make_split_kids")
|
||
| 482 | +604 |
- #'+ }) |
||
| 483 | +605 |
- #' @examples+ |
||
| 484 | +606 |
- #' mtbl <- rtable(+ ## single AnalyzeSplit |
||
| 485 | +607 |
- #' header = rheader(+ setMethod( |
||
| 486 | +608 |
- #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ ".make_split_kids", "VAnalyzeSplit", |
||
| 487 | +609 |
- #' rrow(NULL, "mean", "median", "mean", "median")+ function(spl, |
||
| 488 | +610 |
- #' ),+ have_controws, ## unused here |
||
| 489 | +611 |
- #' rrow(+ make_lrow, ## unused here |
||
| 490 | +612 |
- #' row.name = "All Species",+ ..., |
||
| 491 | +613 |
- #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ df, |
||
| 492 | +614 |
- #' mean(iris$Petal.Length), median(iris$Petal.Length),+ alt_df, |
||
| 493 | +615 |
- #' format = "xx.xx"+ lvl, |
||
| 494 | +616 |
- #' )+ name, |
||
| 495 | +617 |
- #' )+ cinfo, |
||
| 496 | +618 |
- #'+ baselines, |
||
| 497 | +619 |
- #' mtbl2 <- with(subset(iris, Species == "setosa"), rtable(+ spl_context, |
||
| 498 | +620 |
- #' header = rheader(+ nsibs = 0) {
|
||
| 499 | -+ | |||
| 621 | +1132x |
- #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ spvis <- labelrow_visible(spl) |
||
| 500 | -+ | |||
| 622 | +1132x |
- #' rrow(NULL, "mean", "median", "mean", "median")+ if (is.na(spvis)) {
|
||
| 501 | -+ | |||
| 623 | +190x |
- #' ),+ spvis <- nsibs > 0 |
||
| 502 | +624 |
- #' rrow(+ } |
||
| 503 | +625 |
- #' row.name = "Setosa",+ |
||
| 504 | -+ | |||
| 626 | +1132x |
- #' mean(Sepal.Length), median(Sepal.Length),+ ret <- .make_analyzed_tab( |
||
| 505 | -+ | |||
| 627 | +1132x |
- #' mean(Petal.Length), median(Petal.Length),+ df = df, |
||
| 506 | -+ | |||
| 628 | +1132x |
- #' format = "xx.xx"+ alt_df, |
||
| 507 | -+ | |||
| 629 | +1132x |
- #' )+ spl = spl, |
||
| 508 | -+ | |||
| 630 | +1132x |
- #' ))+ cinfo = cinfo, |
||
| 509 | -+ | |||
| 631 | +1132x |
- #'+ lvl = lvl + 1L, |
||
| 510 | -+ | |||
| 632 | +1132x |
- #' rbind(mtbl, mtbl2)+ dolab = spvis, |
||
| 511 | -+ | |||
| 633 | +1132x |
- #' rbind(mtbl, rrow(), mtbl2)+ partlabel = obj_label(spl), |
||
| 512 | -+ | |||
| 634 | +1132x |
- #' rbind(mtbl, rrow("aaa"), indent(mtbl2))
+ baselines = baselines, |
||
| 513 | -+ | |||
| 635 | +1132x |
- #'+ spl_context = spl_context |
||
| 514 | +636 |
- #' @exportMethod rbind+ ) |
||
| 515 | -+ | |||
| 637 | +1128x |
- #' @rdname rbind+ indent_mod(ret) <- indent_mod(spl) |
||
| 516 | +638 |
- setMethod(+ |
||
| 517 | -+ | |||
| 639 | +1128x |
- "rbind", "VTableNodeInfo",+ kids <- list(ret) |
||
| 518 | -+ | |||
| 640 | +1128x |
- function(..., deparse.level = 1) {
+ names(kids) <- obj_name(ret) |
||
| 519 | -! | +|||
| 641 | +1128x |
- rbindl_rtables(list(...))+ kids |
||
| 520 | +642 |
} |
||
| 521 | +643 |
) |
||
| 522 | +644 | |||
| 523 | +645 |
- #' @param y (`ANY`)\cr second element to be row-bound via `rbind2`.+ # Adding section_divisors to TableRow |
||
| 524 | +646 |
- #'+ .set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
|
||
| 525 | -+ | |||
| 647 | +1639x |
- #' @exportMethod rbind2+ if (!is.na(trailing_section_div_char)) {
|
||
| 526 | -+ | |||
| 648 | +29x |
- #' @rdname int_methods+ lst <- lapply( |
||
| 527 | -+ | |||
| 649 | +29x |
- setMethod(+ lst, |
||
| 528 | -+ | |||
| 650 | +29x |
- "rbind2", c("VTableNodeInfo", "missing"),
+ function(k) {
|
||
| 529 | -+ | |||
| 651 | +70x |
- function(x, y) {
+ if (is(k, allowed_class)) {
|
||
| 530 | -2x | +652 | +70x |
- TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "")+ trailing_section_div(k) <- trailing_section_div_char |
| 531 | +653 |
- }+ } |
||
| 532 | -+ | |||
| 654 | +70x |
- )+ k |
||
| 533 | +655 |
-
+ } |
||
| 534 | +656 |
- #' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.+ ) |
||
| 535 | +657 |
- #' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.+ } |
||
| 536 | -+ | |||
| 658 | +1639x |
- #'+ lst |
||
| 537 | +659 |
- #' @exportMethod rbind2+ } |
||
| 538 | +660 |
- #' @rdname rbind+ |
||
| 539 | +661 |
- setMethod(+ ## 1 or more AnalyzeSplits |
||
| 540 | +662 |
- "rbind2", "VTableNodeInfo",+ setMethod( |
||
| 541 | +663 |
- function(x, y) {
- |
- ||
| 542 | -12x | -
- rbindl_rtables(list(x, y))+ ".make_split_kids", "AnalyzeMultiVars", |
||
| 543 | +664 |
- }+ function(spl, |
||
| 544 | +665 |
- )+ have_controws, |
||
| 545 | +666 |
-
+ make_lrow, ## used here |
||
| 546 | +667 |
- combine_cinfo <- function(..., new_total = NULL) {
+ spl_context, |
||
| 547 | -10x | +|||
| 668 | +
- tabs <- list(...)+ ...) { ## all passed directly down to VAnalyzeSplit method
|
|||
| 548 | -10x | +669 | +102x |
- chk_cbindable_many(tabs)+ avspls <- spl_payload(spl) |
| 549 | -8x | +|||
| 670 | +
- cinfs <- lapply(tabs, col_info)+ |
|||
| 550 | -8x | +671 | +102x |
- stopifnot(are(cinfs, "InstantiatedColumnInfo"))+ nspl <- length(avspls) |
| 551 | +672 | |||
| 552 | -8x | +673 | +102x |
- ctrees <- lapply(cinfs, coltree)+ kids <- unlist(lapply(avspls, |
| 553 | -+ | |||
| 674 | +102x |
-
+ .make_split_kids, |
||
| 554 | -8x | +675 | +102x |
- newctree <- LayoutColTree(kids = ctrees)+ nsibs = nspl - 1, |
| 555 | -8x | +676 | +102x |
- newcounts <- unlist(lapply(cinfs, col_counts))+ have_controws = have_controws, |
| 556 | -8x | +677 | +102x |
- if (is.null(new_total)) {
+ make_lrow = make_lrow, |
| 557 | -8x | +678 | +102x |
- new_total <- sum(newcounts)+ spl_context = spl_context, |
| 558 | +679 |
- }- |
- ||
| 559 | -8x | -
- newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE)+ ... |
||
| 560 | -8x | +|||
| 680 | +
- newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
+ )) |
|||
| 561 | -8x | +|||
| 681 | +
- newdisp <- any(vapply(cinfs, disp_ccounts, NA))+ |
|||
| 562 | -8x | +682 | +102x |
- alltls <- lapply(cinfs, top_left)+ kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree") |
| 563 | -8x | +|||
| 683 | +
- newtl <- character()+ |
|||
| 564 | -8x | +|||
| 684 | +
- if (!are(tabs, "TableRow")) {
+ ## XXX this seems like it should be identical not !identical |
|||
| 565 | -8x | +|||
| 685 | +
- alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same+ ## TODO FIXME |
|||
| 566 | -8x | +686 | +102x |
- if (length(alltls) > 0) {
+ if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
|
| 567 | -! | +|||
| 687 | +
- newtl <- alltls[[1]]+ ## we only analyzed one var so |
|||
| 568 | +688 |
- }+ ## we don't need an extra wrapper table |
||
| 569 | +689 |
- }+ ## in the structure |
||
| 570 | -8x | -
- InstantiatedColumnInfo(- |
- ||
| 571 | -8x | +|||
| 690 | +! |
- treelyt = newctree,+ stopifnot(identical( |
||
| 572 | -8x | +|||
| 691 | +! |
- csubs = newexprs,+ obj_name(kids[[1]]), |
||
| 573 | -8x | +|||
| 692 | +! |
- extras = newexargs,+ spl_payload(spl) |
||
| 574 | -8x | +|||
| 693 | +
- cnts = newcounts,+ )) |
|||
| 575 | -8x | +|||
| 694 | +! |
- dispcounts = newdisp,+ return(kids[[1]]) |
||
| 576 | -8x | +|||
| 695 | +
- countformat = colcount_format(cinfs[[1]]),+ } |
|||
| 577 | -8x | +|||
| 696 | +
- total_cnt = new_total,+ ## this will be the variables |
|||
| 578 | -8x | +|||
| 697 | +
- topleft = newtl+ ## nms = sapply(spl_payload(spl), spl_payload) |
|||
| 579 | +698 |
- )+ |
||
| 580 | -+ | |||
| 699 | +102x |
- }+ nms <- vapply(kids, obj_name, "") |
||
| 581 | -+ | |||
| 700 | +102x |
-
+ labs <- vapply(kids, obj_label, "") |
||
| 582 | -+ | |||
| 701 | +102x |
- nz_len_els <- function(lst) {
+ if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
|
||
| 583 | -104x | +702 | +1x |
- if (is(lst, "list")) {
+ warning("Non-unique sibling analysis table names. Using Labels ",
|
| 584 | -13x | +703 | +1x |
- lst[vapply(lst, function(x) length(x) > 0, NA)]+ "instead. Use the table_names argument to analyze to avoid ", |
| 585 | -91x | +704 | +1x |
- } else if (is(lst, "character")) {
+ "this when analyzing the same variable multiple times.", |
| 586 | -78x | +705 | +1x |
- lst[nzchar(lst)]+ "\n\toccured at (row) path: ", |
| 587 | -+ | |||
| 706 | +1x |
- } else {
+ spl_context_to_disp_path(spl_context), |
||
| 588 | -13x | +707 | +1x |
- lst+ call. = FALSE |
| 589 | +708 |
- }+ ) |
||
| 590 | -+ | |||
| 709 | +1x |
- }+ kids <- mapply(function(k, nm) {
|
||
| 591 | -+ | |||
| 710 | +2x |
-
+ obj_name(k) <- nm |
||
| 592 | -+ | |||
| 711 | +2x |
- has_one_unq <- function(x) {
+ k |
||
| 593 | -104x | +712 | +1x |
- length(unique(nz_len_els(x))) <= 1+ }, k = kids, nm = labs, SIMPLIFY = FALSE)+ |
+
| 713 | +1x | +
+ nms <- labs |
||
| 594 | +714 |
- }+ } |
||
| 595 | +715 | |||
| 716 | +102x | +
+ nms[is.na(nms)] <- ""+ |
+ ||
| 596 | +717 |
- classvec <- function(lst, enforce_one = TRUE) {
+
|
||
| 597 | -24x | +718 | +102x |
- if (enforce_one) {
+ names(kids) <- nms |
| 598 | -24x | +719 | +102x |
- vapply(lst, class, "")+ kids |
| 599 | +720 |
- } else {
+ } |
||
| 600 | -! | +|||
| 721 | +
- lapply(lst, class)+ ) |
|||
| 601 | +722 |
- }+ |
||
| 602 | +723 |
- }+ setMethod( |
||
| 603 | +724 |
-
+ ".make_split_kids", "Split", |
||
| 604 | +725 |
- chk_cbindable_many <- function(lst) {
+ function(spl, |
||
| 605 | +726 |
- ## we actually want is/inherits there but no easy way+ have_controws, |
||
| 606 | +727 |
- ## to figure out what the lowest base class is+ make_lrow, |
||
| 607 | +728 |
- ## that I can think of right now, so we do the+ ..., |
||
| 608 | +729 |
- ## broken wrong thing instead :(+ splvec, ## passed to recursive_applysplit |
||
| 609 | -15x | +|||
| 730 | +
- if (are(lst, "TableRow")) {
+ df, ## used to apply split |
|||
| 610 | -2x | +|||
| 731 | +
- if (!has_one_unq(classvec(lst))) {
+ alt_df, ## used to apply split for alternative df |
|||
| 611 | -1x | +|||
| 732 | +
- stop("Cannot cbind different types of TableRow objects together")
+ lvl, ## used to calculate innerlev |
|||
| 612 | +733 |
- }+ cinfo, ## used for sanity check |
||
| 613 | -1x | +|||
| 734 | +
- return(TRUE)+ baselines, ## used to calc new baselines |
|||
| 614 | +735 |
- }+ spl_context) {
|
||
| 615 | +736 |
- ## if(!are(lst, "VTableTree")+ ## do the core splitting of data into children for this split |
||
| 616 | -+ | |||
| 737 | +425x |
- ## stop("Not all elements to be bound are TableTrees or TableRows")
+ rawpart <- do_split(spl, df, spl_context = spl_context)+ |
+ ||
| 738 | +421x | +
+ dataspl <- rawpart[["datasplit"]] |
||
| 617 | +739 |
-
+ ## these are SplitValue objects |
||
| 618 | -13x | +740 | +421x |
- nrs <- vapply(lst, NROW, 1L)+ splvals <- rawpart[["values"]] |
| 619 | -13x | +741 | +421x |
- if (!has_one_unq(nrs)) {
+ partlabels <- rawpart[["labels"]] |
| 620 | -! | +|||
| 742 | +421x |
- stop("Not all elements to be bound have matching numbers of rows")
+ if (is.factor(partlabels)) {
|
||
| 621 | -+ | |||
| 743 | +! |
- }+ partlabels <- as.character(partlabels) |
||
| 622 | +744 |
-
+ } |
||
| 623 | -13x | +745 | +421x |
- tls <- lapply(lst, top_left)+ nms <- unlist(value_names(splvals)) |
| 624 | -13x | +746 | +421x |
- if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
+ if (is.factor(nms)) {
|
| 625 | -2x | +|||
| 747 | +! |
- stop(+ nms <- as.character(nms) |
||
| 626 | -2x | +|||
| 748 | +
- "Elements to be bound have differing top-left content: ",+ } |
|||
| 627 | -2x | +|||
| 749 | +
- paste(which(!duplicated(tls)), collapse = " ")+ |
|||
| 628 | +750 |
- )+ ## Get new baseline values |
||
| 629 | +751 |
- }+ ## |
||
| 630 | +752 |
-
+ ## XXX this is a lot of data churn, if it proves too slow |
||
| 631 | -11x | +|||
| 753 | +
- if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
+ ## we can |
|||
| 632 | -1x | +|||
| 754 | +
- return(TRUE)+ ## a) check if any of the analyses (i.e. the afuns) need the baseline in this |
|||
| 633 | +755 |
- }+ ## splitvec and not do any of this if not, or |
||
| 634 | +756 |
-
+ ## b) refactor row splitting to behave like column splitting |
||
| 635 | -10x | +|||
| 757 | +
- rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
+ ## |
|||
| 636 | -10x | +|||
| 758 | +
- nrow = nrs[[1]]+ ## (b) seems the better design but is a major reworking of the guts of how |
|||
| 637 | +759 |
- )+ ## rtables tabulation works |
||
| 638 | -10x | +|||
| 760 | +
- rnsok <- apply(rns, 1, has_one_unq)+ ## (a) will only help if analyses that use baseline |
|||
| 639 | -10x | +|||
| 761 | +
- if (!all(rnsok)) {
+ ## info are mixed with those who don't. |
|||
| 640 | -1x | +762 | +421x |
- stop(+ newbl_raw <- lapply(baselines, function(dat) {
|
| 641 | -1x | +|||
| 763 | +
- "Mismatching, non-empty row names detected in rows ",+ # If no ref_group is specified |
|||
| 642 | -1x | +764 | +1527x |
- paste(which(!rnsok), collapse = " ")+ if (is.null(dat)) {
|
| 643 | -+ | |||
| 765 | +1507x |
- )+ return(NULL) |
||
| 644 | +766 |
- }+ } |
||
| 645 | +767 | |||
| 646 | -9x | +|||
| 768 | +
- rws <- lapply(lst, collect_leaves, add.labrows = TRUE)+ ## apply the same splitting on the |
|||
| 647 | -9x | +769 | +20x |
- rwclsmat <- matrix(unlist(lapply(rws, classvec)),+ bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]], |
| 648 | -9x | +770 | +20x |
- ncol = length(lst)+ error = function(e) e |
| 649 | +771 |
- )+ ) |
||
| 650 | +772 | |||
| 651 | -9x | +|||
| 773 | +
- rwsok <- apply(rwclsmat, 1, has_one_unq)+ # Error localization |
|||
| 652 | -9x | +774 | +20x |
- if (!all(rwsok)) {
+ if (is(bldataspl, "error")) {
|
| 653 | +775 | ! |
- stop(+ stop("Following error encountered in splitting .ref_group (baselines): ",
|
|
| 654 | +776 | ! |
- "Mismatching row classes found for rows: ",+ bldataspl$message, |
|
| 655 | +777 | ! |
- paste(which(!rwsok), collapse = " ")+ call. = FALSE |
|
| 656 | +778 |
- )+ ) |
||
| 657 | +779 |
- }+ } |
||
| 658 | -9x | +|||
| 780 | +
- TRUE+ |
|||
| 659 | +781 |
- }+ ## we only keep the ones corresponding with actual data splits |
||
| 660 | -+ | |||
| 782 | +20x |
-
+ res <- lapply( |
||
| 661 | -+ | |||
| 783 | +20x |
- #' Column-bind two `TableTree` objects+ names(dataspl), |
||
| 662 | -+ | |||
| 784 | +20x |
- #'+ function(nm) {
|
||
| 663 | -+ | |||
| 785 | +52x |
- #' @param x (`TableTree` or `TableRow`)\cr a table or row object.+ if (nm %in% names(bldataspl)) {
|
||
| 664 | -+ | |||
| 786 | +52x |
- #' @param ... one or more further objects of the same class as `x`.+ bldataspl[[nm]] |
||
| 665 | +787 |
- #'+ } else {
|
||
| 666 | -+ | |||
| 788 | +! |
- #' @inherit rbindl_rtables return+ dataspl[[1]][0, ] |
||
| 667 | +789 |
- #'+ } |
||
| 668 | +790 |
- #' @examples+ } |
||
| 669 | +791 |
- #' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
+ ) |
||
| 670 | +792 |
- #' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
+
|
||
| 671 | -+ | |||
| 793 | +20x |
- #' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
+ names(res) <- names(dataspl) |
||
| 672 | -+ | |||
| 794 | +20x |
- #'+ res |
||
| 673 | +795 |
- #' t1 <- cbind_rtables(x, y)+ }) |
||
| 674 | +796 |
- #' t1+ |
||
| 675 | -+ | |||
| 797 | +421x |
- #'+ newbaselines <- lapply(names(dataspl), function(nm) {
|
||
| 676 | -+ | |||
| 798 | +1245x |
- #' t2 <- cbind_rtables(x, y, z)+ lapply(newbl_raw, function(rawdat) {
|
||
| 677 | -+ | |||
| 799 | +4502x |
- #' t2+ if (nm %in% names(rawdat)) {
|
||
| 678 | -+ | |||
| 800 | +52x |
- #'+ rawdat[[nm]] |
||
| 679 | +801 |
- #' col_paths_summary(t1)+ } else {
+ |
+ ||
| 802 | +4450x | +
+ rawdat[[1]][0, ] |
||
| 680 | +803 |
- #' col_paths_summary(t2)+ } |
||
| 681 | +804 |
- #'+ }) |
||
| 682 | +805 |
- #' @export+ }) |
||
| 683 | +806 |
- cbind_rtables <- function(x, ...) {
+
|
||
| 684 | -10x | +807 | +421x |
- lst <- list(...)+ if (length(newbaselines) != length(dataspl)) {
|
| 685 | -10x | +|||
| 808 | +! |
- newcinfo <- combine_cinfo(x, ...)+ stop( |
||
| 686 | -8x | +|||
| 809 | +! |
- recurse_cbindl(x, cinfo = newcinfo, .list = lst)+ "Baselines (ref_group) after row split does not have", |
||
| 687 | -+ | |||
| 810 | +! |
- }+ " the same number of levels of input data split. ", |
||
| 688 | -+ | |||
| 811 | +! |
-
+ "Contact the maintainer." |
||
| 689 | -98x | +|||
| 812 | +! |
- setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))
+ ) # nocov |
||
| 690 | +813 |
-
+ } |
||
| 691 | -+ | |||
| 814 | +421x |
- setMethod(+ if (!(length(newbaselines) == 0 || |
||
| 692 | -+ | |||
| 815 | +421x |
- "recurse_cbindl", c(+ identical( |
||
| 693 | -+ | |||
| 816 | +421x |
- x = "VTableNodeInfo",+ unique(sapply(newbaselines, length)), |
||
| 694 | -+ | |||
| 817 | +421x |
- cinfo = "NULL"+ length(col_exprs(cinfo)) |
||
| 695 | +818 |
- ),+ ))) {
|
||
| 696 | -+ | |||
| 819 | +! |
- function(x, cinfo, .list = NULL) {
+ stop( |
||
| 697 | +820 | ! |
- recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list)+ "Baselines (ref_group) do not have the same number of columns", |
|
| 698 | -+ | |||
| 821 | +! |
- }+ " in each split. Contact the maintainer."+ |
+ ||
| 822 | +! | +
+ ) # nocov |
||
| 699 | +823 |
- )+ } |
||
| 700 | +824 | |||
| 701 | +825 |
- setMethod(+ # If params are not present do not do the calculation |
||
| 702 | -+ | |||
| 826 | +421x |
- "recurse_cbindl", c(+ acdf_param <- check_afun_cfun_params( |
||
| 703 | -+ | |||
| 827 | +421x |
- x = "TableTree",+ SplitVector(spl, splvec),+ |
+ ||
| 828 | +421x | +
+ c(".alt_df", ".alt_df_row")
|
||
| 704 | +829 |
- cinfo = "InstantiatedColumnInfo"+ ) |
||
| 705 | +830 |
- ),+ |
||
| 706 | +831 |
- function(x, cinfo, .list = NULL) {
+ # Apply same split for alt_counts_df |
||
| 707 | -21x | +832 | +421x |
- stopifnot(are(.list, "VTableTree"))+ if (!is.null(alt_df) && any(acdf_param)) {
|
| 708 | -+ | |||
| 833 | +17x |
- ## chk_cbindable(x, y)+ alt_dfpart <- tryCatch( |
||
| 709 | -21x | +834 | +17x |
- xcont <- content_table(x)+ do_split(spl, alt_df, |
| 710 | -21x | +835 | +17x |
- lstconts <- lapply(.list, content_table)+ spl_context = spl_context |
| 711 | -21x | +836 | +17x |
- lcontnrows <- vapply(lstconts, NROW, 1L)+ )[["datasplit"]], |
| 712 | -21x | +837 | +17x |
- unqnrcont <- unique(c(NROW(xcont), lcontnrows))+ error = function(e) e |
| 713 | -21x | +|||
| 838 | +
- if (length(unqnrcont) > 1) {
+ ) |
|||
| 714 | -! | +|||
| 839 | +
- stop(+ |
|||
| 715 | -! | +|||
| 840 | +
- "Got differing numbers of content rows [",+ # Removing NA rows - to explore why this happens at all in a split |
|||
| 716 | -! | +|||
| 841 | +
- paste(unqnrcont, collapse = ", "),+ # This would be a fix but it is done in post-processing instead of pre-proc -> xxx |
|||
| 717 | -! | +|||
| 842 | +
- "]. Unable to cbind these rtables"+ # x alt_dfpart <- lapply(alt_dfpart, function(data) {
|
|||
| 718 | +843 |
- )+ # x data[!apply(is.na(data), 1, all), ] |
||
| 719 | +844 |
- }+ # x }) |
||
| 720 | +845 | |||
| 721 | -21x | +|||
| 846 | +
- if (unqnrcont == 0) {
+ # Error localization |
|||
| 722 | -20x | +847 | +17x |
- cont <- ElementaryTable(cinfo = cinfo)+ if (is(alt_dfpart, "error")) {
|
| 723 | -+ | |||
| 848 | +2x |
- } else {
+ stop("Following error encountered in splitting alt_counts_df: ",
|
||
| 724 | -1x | +849 | +2x |
- cont <- recurse_cbindl(xcont,+ alt_dfpart$message, |
| 725 | -1x | +850 | +2x |
- .list = lstconts,+ call. = FALSE |
| 726 | -1x | +|||
| 851 | +
- cinfo = cinfo+ ) |
|||
| 727 | +852 |
- )+ } |
||
| 728 | +853 |
- }+ # Error if split does not have the same values in the alt_df (and order) |
||
| 729 | +854 |
-
+ # The following breaks if there are different levels (do_split returns empty list) |
||
| 730 | -21x | +|||
| 855 | +
- kids <- lapply(+ # or if there are different number of the same levels. Added handling of NAs |
|||
| 731 | -21x | +|||
| 856 | +
- seq_along(tree_children(x)),+ # in the values of the factor when is all only NAs |
|||
| 732 | -21x | +857 | +15x |
- function(i) {
+ is_all_na <- all(is.na(alt_df[[spl_payload(spl)]])) |
| 733 | -31x | +|||
| 858 | +
- recurse_cbindl(+ |
|||
| 734 | -31x | +859 | +15x |
- x = tree_children(x)[[i]],+ if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) {
|
| 735 | -31x | +860 | +5x |
- cinfo = cinfo,+ alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]]) |
| 736 | -31x | +861 | +5x |
- .list = lapply(.list, function(tt) tree_children(tt)[[i]])+ end_part <- "" |
| 737 | +862 |
- )+ |
||
| 738 | -+ | |||
| 863 | +5x |
- }+ if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
|
||
| 739 | -+ | |||
| 864 | +2x |
- )+ end_part <- paste0( |
||
| 740 | -21x | +865 | +2x |
- names(kids) <- names(tree_children(x))+ " and following levels: ", |
| 741 | -21x | +866 | +2x |
- TableTree(+ paste_vec(levels(alt_df_spl_vals)) |
| 742 | -21x | +|||
| 867 | +
- kids = kids, labelrow = recurse_cbindl(tt_labelrow(x),+ )+ |
+ |||
| 868 | ++ |
+ }+ |
+ ||
| 869 | ++ | + | ||
| 743 | -21x | +870 | +5x |
- cinfo = cinfo,+ if (is_all_na) {
|
| 744 | -21x | +871 | +2x |
- .list = lapply(.list, tt_labelrow)+ end_part <- ". Found only NAs in alt_counts_df split" |
| 745 | +872 |
- ),+ } |
||
| 746 | -21x | +|||
| 873 | +
- cont = cont,+ |
|||
| 747 | -21x | +874 | +5x |
- name = obj_name(x),+ stop( |
| 748 | -21x | +875 | +5x |
- lev = tt_level(x),+ "alt_counts_df split variable(s) [", spl_payload(spl), |
| 749 | -21x | +876 | +5x |
- cinfo = cinfo,+ "] (in split ", as.character(class(spl)), |
| 750 | -21x | +877 | +5x |
- format = obj_format(x)+ ") does not have the same factor levels of df.\ndf has c(", '"',
|
| 751 | -+ | |||
| 878 | +5x |
- )+ paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ", |
||
| 752 | -+ | |||
| 879 | +5x |
- }+ ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""), |
||
| 753 | -+ | |||
| 880 | +5x |
- )+ " unique values", end_part |
||
| 754 | +881 |
-
+ ) |
||
| 755 | +882 |
- setMethod(+ } |
||
| 756 | +883 |
- "recurse_cbindl", c(+ } else {
|
||
| 757 | -+ | |||
| 884 | +404x |
- x = "ElementaryTable",+ alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl)) |
||
| 758 | +885 |
- cinfo = "InstantiatedColumnInfo"+ } |
||
| 759 | +886 |
- ),+ |
||
| 760 | +887 |
- function(x, cinfo, .list) {
+
|
||
| 761 | -19x | +888 | +414x |
- stopifnot(are(.list, class(x)))+ innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow) |
| 762 | +889 |
- ## chk_cbindable(x,y)+ ## do full recursive_applysplit on each part of the split defined by spl |
||
| 763 | -19x | +890 | +414x |
- if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
+ inner <- unlist(mapply( |
| 764 | -1x | +891 | +414x |
- col_info(x) <- cinfo+ function(dfpart, alt_dfpart, nm, label, baselines, splval) {
|
| 765 | -1x | -
- return(x) ## this needs testing... I was right, it did #136- |
- ||
| 766 | -+ | 892 | +1203x |
- }+ rsplval <- context_df_row( |
| 767 | -18x | +893 | +1203x |
- kids <- lapply(+ split = obj_name(spl), |
| 768 | -18x | +894 | +1203x |
- seq_along(tree_children(x)),+ value = value_names(splval), |
| 769 | -18x | +895 | +1203x |
- function(i) {
+ full_parent_df = list(dfpart), |
| 770 | -19x | +896 | +1203x |
- recurse_cbindl(+ cinfo = cinfo |
| 771 | -19x | +|||
| 897 | +
- x = tree_children(x)[[i]],+ ) |
|||
| 772 | -19x | +|||
| 898 | +
- cinfo = cinfo,+ |
|||
| 773 | -19x | +|||
| 899 | +
- .list = lapply(.list, function(tt) tree_children(tt)[[i]])+ ## if(length(rsplval) > 0) |
|||
| 774 | +900 |
- )+ ## rsplval <- setNames(rsplval, obj_name(spl)) |
||
| 775 | -+ | |||
| 901 | +1203x |
- }+ recursive_applysplit( |
||
| 776 | -+ | |||
| 902 | +1203x |
- )+ df = dfpart, |
||
| 777 | -18x | +903 | +1203x |
- names(kids) <- names(tree_children(x))+ alt_df = alt_dfpart, |
| 778 | -+ | |||
| 904 | +1203x |
-
+ name = nm, |
||
| 779 | -18x | +905 | +1203x |
- ElementaryTable(+ lvl = innerlev, |
| 780 | -18x | +906 | +1203x |
- kids = kids,+ splvec = splvec, |
| 781 | -18x | +907 | +1203x |
- labelrow = recurse_cbindl(tt_labelrow(x),+ cinfo = cinfo, |
| 782 | -18x | +908 | +1203x |
- .list = lapply(.list, tt_labelrow),+ make_lrow = label_kids(spl), |
| 783 | -18x | +909 | +1203x |
- cinfo+ parent_cfun = content_fun(spl), |
| 784 | -+ | |||
| 910 | +1203x |
- ),+ cformat = content_format(spl), |
||
| 785 | -18x | +911 | +1203x |
- name = obj_name(x),+ cna_str = content_na_str(spl), |
| 786 | -18x | +912 | +1203x |
- lev = tt_level(x),+ partlabel = label, |
| 787 | -18x | +913 | +1203x |
- cinfo = cinfo,+ cindent_mod = content_indent_mod(spl), |
| 788 | -18x | +914 | +1203x |
- format = obj_format(x),+ cvar = content_var(spl), |
| 789 | -18x | +915 | +1203x |
- var = obj_avar(x)+ baselines = baselines, |
| 790 | -+ | |||
| 916 | +1203x |
- )+ cextra_args = content_extra_args(spl), |
||
| 791 | +917 |
- }+ ## splval should still be retaining its name |
||
| 792 | -+ | |||
| 918 | +1203x |
- )+ spl_context = rbind(spl_context, rsplval) |
||
| 793 | +919 |
-
+ ) |
||
| 794 | +920 |
- .combine_rows <- function(x, cinfo = NULL, .list) {
+ }, |
||
| 795 | -19x | +921 | +414x |
- stopifnot(are(.list, class(x)))+ dfpart = dataspl, |
| 796 | -+ | |||
| 922 | +414x |
-
+ alt_dfpart = alt_dfpart, |
||
| 797 | -19x | +923 | +414x |
- avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE))+ label = partlabels, |
| 798 | -19x | +924 | +414x |
- avars <- avars[!is.na(avars)]+ nm = nms, |
| 799 | -+ | |||
| 925 | +414x |
-
+ baselines = newbaselines, |
||
| 800 | -19x | +926 | +414x |
- if (length(unique(avars)) > 1) {
+ splval = splvals, |
| 801 | -! | +|||
| 927 | +414x |
- stop("Got rows that don't analyze the same variable")
+ SIMPLIFY = FALSE |
||
| 802 | +928 |
- }+ )) |
||
| 803 | +929 | |||
| 804 | -19x | -
- xlst <- c(list(x), .list)- |
- ||
| 805 | +930 |
-
+ # Setting the kids section separator if they inherits VTableTree |
||
| 806 | -19x | +931 | +406x |
- ncols <- vapply(xlst, ncol, 1L)+ inner <- .set_kids_section_div( |
| 807 | -19x | +932 | +406x |
- totcols <- sum(ncols)+ inner, |
| 808 | -19x | +933 | +406x |
- cumncols <- cumsum(ncols)+ trailing_section_div_char = spl_section_div(spl), |
| 809 | -19x | +934 | +406x |
- strtncols <- c(0L, head(cumncols, -1)) + 1L+ allowed_class = "VTableTree" |
| 810 | -19x | +|||
| 935 | +
- vals <- vector("list", totcols)
+ ) |
|||
| 811 | -19x | +|||
| 936 | +
- cspans <- integer(totcols)+ |
|||
| 812 | +937 |
- ## vals[1:ncol(x)] <- row_values(x)+ ## This is where we need to build the structural tables |
||
| 813 | +938 |
- ## cpans[1:ncol(x)] <- row_cspans(x)+ ## even if they are invisible because their labels are not |
||
| 814 | +939 |
-
+ ## not shown. |
||
| 815 | -19x | +940 | +406x |
- for (i in seq_along(xlst)) {
+ innertab <- TableTree( |
| 816 | -39x | +941 | +406x |
- strt <- strtncols[i]+ kids = inner, |
| 817 | -39x | +942 | +406x |
- end <- cumncols[i]+ name = obj_name(spl), |
| 818 | -+ | |||
| 943 | +406x |
- ## full vars are here for debugging purposes+ labelrow = LabelRow( |
||
| 819 | -39x | +944 | +406x |
- fullvy <- vy <- row_cells(xlst[[i]]) # nolint+ label = obj_label(spl), |
| 820 | -39x | +945 | +406x |
- fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint+ vis = isTRUE(vis_label(spl)) |
| 821 | +946 |
-
+ ), |
||
| 822 | -+ | |||
| 947 | +406x |
- if (+ cinfo = cinfo, |
||
| 823 | -39x | +948 | +406x |
- i > 1 &&+ iscontent = FALSE, |
| 824 | -39x | +949 | +406x |
- identical(rawvalues(vy[[1]]), rawvalues(lastval)) &&+ indent_mod = indent_mod(spl),+ |
+
| 950 | +406x | +
+ page_title = ptitle_prefix(spl) |
||
| 825 | +951 |
- ## cspy[1] == lastspn &&+ )+ |
+ ||
| 952 | ++ |
+ ## kids = inner |
||
| 826 | -39x | +953 | +406x |
- lastspn > 1+ kids <- list(innertab)+ |
+
| 954 | +406x | +
+ kids |
||
| 827 | +955 |
- ) {
+ } |
||
| 828 | -! | +|||
| 956 | +
- vy <- vy[-1]+ ) |
|||
| 829 | -! | +|||
| 957 | +
- cspans[strt - 1L] <- lastspn + cspy[1]+ |
|||
| 830 | -! | +|||
| 958 | +
- cspy <- cspy[-1]+ context_df_row <- function(split = character(), |
|||
| 831 | -! | +|||
| 959 | +
- strt <- strt + 1L+ value = character(), |
|||
| 832 | +960 |
- }+ full_parent_df = list(), |
||
| 833 | -39x | +|||
| 961 | +
- if (length(vy) > 0) {
+ cinfo = NULL) {
|
|||
| 834 | -39x | +962 | +2903x |
- vals[strt:end] <- vy+ ret <- data.frame( |
| 835 | -39x | +963 | +2903x |
- cspans[strt:end] <- cspy+ split = split, |
| 836 | -39x | +964 | +2903x |
- lastval <- vy[[length(vy)]]+ value = value, |
| 837 | -39x | +965 | +2903x |
- lastspn <- cspy[[length(cspy)]]+ full_parent_df = I(full_parent_df), |
| 838 | +966 |
- } else {
+ # parent_cold_inds = I(parent_col_inds),+ |
+ ||
| 967 | +2903x | +
+ stringsAsFactors = FALSE |
||
| 839 | +968 |
- ## lastval stays the same+ ) |
||
| 840 | -! | +|||
| 969 | +2903x |
- lastspn <- cspans[strtncols[i] - 1] ## already updated+ if (nrow(ret) > 0) {
+ |
+ ||
| 970 | +2890x | +
+ ret$all_cols_n <- nrow(full_parent_df[[1]]) |
||
| 841 | +971 |
- }+ } else {
+ |
+ ||
| 972 | +13x | +
+ ret$all_cols_n <- integer() ## should this be numeric??? This never happens |
||
| 842 | +973 |
} |
||
| 843 | +974 | |||
| 844 | -+ | |||
| 975 | +2903x |
- ## Could be DataRow or ContentRow+ if (!is.null(cinfo)) {
|
||
| 845 | -+ | |||
| 976 | +1523x |
- ## This is ok because LabelRow is special cased+ if (nrow(ret) > 0) {
|
||
| 846 | -19x | +977 | +1514x |
- constr_fun <- get(class(x), mode = "function")+ colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
|
| 847 | -19x | +978 | +5481x |
- constr_fun(+ vals <- eval(e, envir = full_parent_df[[1]]) |
| 848 | -19x | +979 | +5481x |
- vals = vals,+ if (identical(vals, TRUE)) {
|
| 849 | -19x | +980 | +508x |
- cspan = cspans,+ vals <- rep(vals, length.out = nrow(full_parent_df[[1]])) |
| 850 | -19x | +|||
| 981 | +
- cinfo = cinfo,+ } |
|||
| 851 | -19x | +982 | +5481x |
- var = obj_avar(x),+ I(list(vals))+ |
+
| 983 | ++ |
+ }))+ |
+ ||
| 984 | ++ |
+ } else {
|
||
| 852 | -19x | +985 | +9x |
- format = obj_format(x),+ colcols <- as.data.frame(rep(list(logical()), ncol(cinfo)))+ |
+
| 986 | ++ |
+ } |
||
| 853 | -19x | +987 | +1523x |
- name = obj_name(x),+ names(colcols) <- names(col_exprs(cinfo)) |
| 854 | -19x | +988 | +1523x |
- label = obj_label(x)+ ret <- cbind(ret, colcols) |
| 855 | +989 |
- )+ }+ |
+ ||
| 990 | +2903x | +
+ ret |
||
| 856 | +991 |
} |
||
| 857 | +992 | |||
| 858 | +993 |
- setMethod(+ recursive_applysplit <- function(df, |
||
| 859 | +994 |
- "recurse_cbindl", c(+ lvl = 0L, |
||
| 860 | +995 |
- "TableRow",+ alt_df, |
||
| 861 | +996 |
- "InstantiatedColumnInfo"+ splvec, |
||
| 862 | +997 |
- ),+ name, |
||
| 863 | +998 |
- function(x, cinfo = NULL, .list) {
+ # label, |
||
| 864 | -19x | +|||
| 999 | +
- .combine_rows(x, cinfo, .list)+ make_lrow = NA, |
|||
| 865 | +1000 |
- }+ partlabel = "", |
||
| 866 | +1001 |
- )+ cinfo, |
||
| 867 | +1002 |
-
+ parent_cfun = NULL, |
||
| 868 | +1003 |
- setMethod(+ cformat = NULL, |
||
| 869 | +1004 |
- "recurse_cbindl", c(+ cna_str = NA_character_, |
||
| 870 | +1005 |
- x = "LabelRow",+ cindent_mod = 0L, |
||
| 871 | +1006 |
- cinfo = "InstantiatedColumnInfo"+ cextra_args = list(), |
||
| 872 | +1007 |
- ),+ cvar = NULL, |
||
| 873 | +1008 |
- function(x, cinfo = NULL, .list) {
+ baselines = lapply( |
||
| 874 | -39x | +|||
| 1009 | +
- col_info(x) <- cinfo+ col_extra_args(cinfo), |
|||
| 875 | -39x | +|||
| 1010 | +
- x+ function(x) x$.ref_full |
|||
| 876 | +1011 |
- }+ ), |
||
| 877 | +1012 |
- )+ spl_context = context_df_row(cinfo = cinfo), |
||
| 878 | +1013 |
-
+ no_outer_tbl = FALSE, |
||
| 879 | +1014 |
- ## we don't care about the following discrepencies:+ parent_sect_split = NA_character_) {
|
||
| 880 | +1015 |
- ## - ci2 having NA counts when ci1 doesn't+ ## pre-existing table was added to the layout+ |
+ ||
| 1016 | +1523x | +
+ if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
+ |
+ ||
| 1017 | +1x | +
+ return(splvec[[1]]) |
||
| 881 | +1018 |
- ## - mismatching display_ccounts values+ } |
||
| 882 | +1019 |
- ## - mismatching colcount formats+ |
||
| 883 | +1020 |
- ##+ ## the content function is the one from the PREVIOUS |
||
| 884 | +1021 |
-
+ ## split, i.e. the one whose children we are now constructing |
||
| 885 | +1022 |
- # chk_compat_cinfos <- function(ci1, ci2) {
+ ## this is a bit annoying but makes the semantics for |
||
| 886 | +1023 |
- chk_compat_cinfos <- function(tt1, tt2) {
+ ## declaring layouts much more sane. |
||
| 887 | -41x | +1024 | +1522x |
- nc1 <- ncol(tt1)+ ctab <- .make_ctab(df, |
| 888 | -41x | +1025 | +1522x |
- nc2 <- ncol(tt2)+ lvl = lvl, |
| 889 | -41x | +1026 | +1522x |
- if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
+ name = name, |
| 890 | -1x | +1027 | +1522x |
- stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
+ label = partlabel, |
| 891 | -+ | |||
| 1028 | +1522x |
- }+ cinfo = cinfo, |
||
| 892 | -40x | +1029 | +1522x |
- if (no_colinfo(tt1) || no_colinfo(tt2)) {
+ parent_cfun = parent_cfun, |
| 893 | -10x | +1030 | +1522x |
- return(TRUE)+ format = cformat, |
| 894 | -+ | |||
| 1031 | +1522x |
- }+ na_str = cna_str, |
||
| 895 | -30x | +1032 | +1522x |
- ci1 <- col_info(tt1)+ indent_mod = cindent_mod, |
| 896 | -30x | +1033 | +1522x |
- ci2 <- col_info(tt2)+ cvar = cvar, |
| 897 | -+ | |||
| 1034 | +1522x |
- ## this will enforce same length and+ alt_df = alt_df,+ |
+ ||
| 1035 | +1522x | +
+ extra_args = cextra_args,+ |
+ ||
| 1036 | +1522x | +
+ spl_context = spl_context |
||
| 898 | +1037 |
- ## same names, in addition to same+ ) |
||
| 899 | +1038 |
- ## expressions so we dont need+ + |
+ ||
| 1039 | +1521x | +
+ nonroot <- lvl != 0L |
||
| 900 | +1040 |
- ## to check those separateley+ |
||
| 901 | -30x | +1041 | +1521x |
- if (!identical(col_exprs(ci1), col_exprs(ci2))) {
+ if (is.na(make_lrow)) {
|
| 902 | -! | +|||
| 1042 | +1214x |
- stop("Column structures not compatible: subset expression lists not identical")
+ make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE |
||
| 903 | +1043 |
} |
||
| 904 | +1044 | ++ |
+ ## never print an empty row label for root.+ |
+ |
| 1045 | +1521x | +
+ if (make_lrow && partlabel == "" && !nonroot) {
+ |
+ ||
| 1046 | +6x | +
+ make_lrow <- FALSE+ |
+ ||
| 1047 | ++ |
+ }+ |
+ ||
| 1048 | ||||
| 905 | -30x | +1049 | +1521x |
- if (any(!is.na(col_counts(ci2))) &&+ if (length(splvec) == 0L) {
|
| 906 | -30x | +1050 | +79x |
- !identical(+ kids <- list() |
| 907 | -30x | +1051 | +79x |
- col_counts(ci1),+ imod <- 0L |
| 908 | -30x | +1052 | +79x |
- col_counts(ci2)+ spl <- NULL |
| 909 | +1053 |
- )) {
+ } else {
|
||
| 910 | -! | +|||
| 1054 | +1442x |
- stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
+ spl <- splvec[[1]] |
||
| 911 | -+ | |||
| 1055 | +1442x |
- }+ splvec <- splvec[-1] |
||
| 912 | +1056 | |||
| 913 | -30x | +|||
| 1057 | +
- if (any(sapply(+ ## we pass this everything recursive_applysplit received and |
|||
| 914 | -30x | +|||
| 1058 | +
- col_extra_args(ci2),+ ## it all gets passed around through ... as needed |
|||
| 915 | -30x | +|||
| 1059 | +
- function(x) length(x) > 0+ ## to the various methods of .make_split_kids |
|||
| 916 | -+ | |||
| 1060 | +1442x |
- )) &&+ kids <- .make_split_kids( |
||
| 917 | -30x | +1061 | +1442x |
- !identical(+ spl = spl, |
| 918 | -30x | +1062 | +1442x |
- col_extra_args(ci1),+ df = df, |
| 919 | -30x | +1063 | +1442x |
- col_extra_args(ci2)+ alt_df = alt_df, |
| 920 | -+ | |||
| 1064 | +1442x |
- )) {
+ lvl = lvl, |
||
| 921 | -! | +|||
| 1065 | +1442x |
- stop(+ splvec = splvec, |
||
| 922 | -! | +|||
| 1066 | +1442x |
- "Column structures not compatible: 2nd column structure has ",+ name = name, |
||
| 923 | -! | +|||
| 1067 | +1442x |
- "non-matching, non-null extra args"+ make_lrow = make_lrow, |
||
| 924 | -+ | |||
| 1068 | +1442x |
- )+ partlabel = partlabel, |
||
| 925 | -+ | |||
| 1069 | +1442x |
- }+ cinfo = cinfo, |
||
| 926 | -+ | |||
| 1070 | +1442x |
-
+ parent_cfun = parent_cfun, |
||
| 927 | -30x | +1071 | +1442x |
- if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
+ cformat = cformat, |
| 928 | -1x | +1072 | +1442x |
- stop(+ cindent_mod = cindent_mod, |
| 929 | -1x | +1073 | +1442x |
- "Top-left materials not compatible: Got non-empty, non-matching ",+ cextra_args = cextra_args, cvar = cvar, |
| 930 | -1x | +1074 | +1442x |
- "top-left materials. Clear them using top_left(x)<-character() ",+ baselines = baselines, |
| 931 | -1x | +1075 | +1442x |
- "before binding to force compatibility."+ spl_context = spl_context, |
| 932 | -+ | |||
| 1076 | +1442x |
- )+ have_controws = nrow(ctab) > 0 |
||
| 933 | +1077 |
- }+ ) |
||
| 934 | -29x | +1078 | +1419x |
- TRUE+ imod <- 0L |
| 935 | +1079 |
- }+ } ## end length(splvec) |
||
| 936 | +1080 | |||
| 937 | -+ | |||
| 1081 | +1498x |
-
+ if (is.na(make_lrow)) {
|
||
| 938 | -+ | |||
| 1082 | +! |
- #' Insert `rrow`s at (before) a specific location+ make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE |
||
| 939 | +1083 |
- #'+ } |
||
| 940 | +1084 |
- #' `r lifecycle::badge("deprecated")`
+ ## never print an empty row label for root. |
||
| 941 | -+ | |||
| 1085 | +1498x |
- #'+ if (make_lrow && partlabel == "" && !nonroot) {
+ |
+ ||
| 1086 | +! | +
+ make_lrow <- FALSE |
||
| 942 | +1087 |
- #' This function is deprecated and will be removed in a future release of `rtables`. Please use+ } |
||
| 943 | +1088 |
- #' [insert_row_at_path()] or [label_at_path()] instead.+ |
||
| 944 | +1089 |
- #'+ ## this is only true when called from build_table and the first split |
||
| 945 | +1090 |
- #' @param tbl (`VTableTree`)\cr a `rtable` object.+ ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split. |
||
| 946 | +1091 |
- #' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`.+ ## in that case we would be "double creating" the structural |
||
| 947 | +1092 |
- #' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1).+ ## subtable+ |
+ ||
| 1093 | +1498x | +
+ if (no_outer_tbl) {
+ |
+ ||
| 1094 | +278x | +
+ ret <- kids[[1]]+ |
+ ||
| 1095 | +278x | +
+ indent_mod(ret) <- indent_mod(spl)+ |
+ ||
| 1096 | +1220x | +
+ } else if (nrow(ctab) > 0L || length(kids) > 0L) {
|
||
| 948 | +1097 |
- #' @param ascontent (`flag`)\cr currently ignored.+ ## previously we checked if the child had an identical label |
||
| 949 | +1098 |
- #'+ ## but I don't think thats needed anymore.+ |
+ ||
| 1099 | +1220x | +
+ tlabel <- partlabel+ |
+ ||
| 1100 | +1220x | +
+ ret <- TableTree(+ |
+ ||
| 1101 | +1220x | +
+ cont = ctab,+ |
+ ||
| 1102 | +1220x | +
+ kids = kids,+ |
+ ||
| 1103 | +1220x | +
+ name = name,+ |
+ ||
| 1104 | +1220x | +
+ label = tlabel, # partlabel,+ |
+ ||
| 1105 | +1220x | +
+ lev = lvl,+ |
+ ||
| 1106 | +1220x | +
+ iscontent = FALSE,+ |
+ ||
| 1107 | +1220x | +
+ labelrow = LabelRow(+ |
+ ||
| 1108 | +1220x | +
+ lev = lvl,+ |
+ ||
| 1109 | +1220x | +
+ label = tlabel,+ |
+ ||
| 1110 | +1220x | +
+ cinfo = cinfo,+ |
+ ||
| 1111 | +1220x | +
+ vis = make_lrow |
||
| 950 | +1112 |
- #' @return A `TableTree` of the same specific class as `tbl`.+ ),+ |
+ ||
| 1113 | +1220x | +
+ cinfo = cinfo,+ |
+ ||
| 1114 | +1220x | +
+ indent_mod = imod |
||
| 951 | +1115 |
- #'+ ) |
||
| 952 | +1116 |
- #' @note+ } else {
+ |
+ ||
| 1117 | +! | +
+ ret <- NULL |
||
| 953 | +1118 |
- #' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do+ } |
||
| 954 | +1119 |
- #' not already contain a label row when there is a non-trivial nested row structure in `tbl`.+ |
||
| 955 | +1120 |
- #'+ ## if(!is.null(spl) && !is.na(spl_section_sep(spl))) |
||
| 956 | +1121 |
- #' @examples+ ## ret <- apply_kids_section_sep(ret, spl_section_sep(spl)) |
||
| 957 | +1122 |
- #' o <- options(warn = 0)+ ## ## message(sprintf("indent modifier: %d", indentmod))
|
||
| 958 | +1123 |
- #' lyt <- basic_table() %>%+ ## if(!is.null(ret)) |
||
| 959 | +1124 |
- #' split_cols_by("Species") %>%
+ ## indent_mod(ret) = indentmod+ |
+ ||
| 1125 | +1498x | +
+ ret |
||
| 960 | +1126 |
- #' analyze("Sepal.Length")
+ } |
||
| 961 | +1127 |
- #'+ |
||
| 962 | +1128 |
- #' tbl <- build_table(lyt, iris)+ #' Create a table from a layout and data |
||
| 963 | +1129 |
#' |
||
| 964 | +1130 |
- #' insert_rrow(tbl, rrow("Hello World"))
+ #' Layouts are used to describe a table pre-data. `build_table` is used to create a table |
||
| 965 | +1131 |
- #' insert_rrow(tbl, rrow("Hello World"), at = 2)
+ #' using a layout and a dataset. |
||
| 966 | +1132 |
#' |
||
| 967 | +1133 |
- #' lyt2 <- basic_table() %>%+ #' @inheritParams gen_args |
||
| 968 | +1134 |
- #' split_cols_by("Species") %>%
+ #' @inheritParams lyt_args |
||
| 969 | +1135 |
- #' split_rows_by("Species") %>%
+ #' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
|
||
| 970 | +1136 |
- #' analyze("Sepal.Length")
+ #' *for leaf-columns only* which override those calculated automatically during tabulation. Must specify |
||
| 971 | +1137 |
- #'+ #' "counts" for *all* leaf-columns if non-`NULL`. `NA` elements will be replaced with the automatically |
||
| 972 | +1138 |
- #' tbl2 <- build_table(lyt2, iris)+ #' calculated counts. Turns on display of leaf-column counts when non-`NULL`. |
||
| 973 | +1139 |
- #'+ #' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`. |
||
| 974 | +1140 |
- #' insert_rrow(tbl2, rrow("Hello World"))
+ #' @param ... ignored. |
||
| 975 | +1141 |
- #' insert_rrow(tbl2, rrow("Hello World"), at = 2)
+ #' |
||
| 976 | +1142 |
- #' insert_rrow(tbl2, rrow("Hello World"), at = 4)
+ #' @details |
||
| 977 | +1143 |
- #'+ #' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting |
||
| 978 | +1144 |
- #' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
+ #' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and |
||
| 979 | +1145 |
- #'+ #' counting the observations in each resulting subset. |
||
| 980 | +1146 |
- #' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
+ #' |
||
| 981 | +1147 |
- #'+ #' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have |
||
| 982 | +1148 |
- #' options(o)+ #' been calculated based on `df` and simply re-used for the count calculation. |
||
| 983 | +1149 |
#' |
||
| 984 | +1150 |
- #' @export+ #' @note |
||
| 985 | +1151 |
- insert_rrow <- function(tbl, rrow, at = 1,+ #' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called |
||
| 986 | +1152 |
- ascontent = FALSE) {
+ #' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation |
||
| 987 | -9x | +|||
| 1153 | +
- lifecycle::deprecate_warn(+ #' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the |
|||
| 988 | -9x | +|||
| 1154 | +
- when = "0.4.0",+ #' only way to ensure overridden counts are fully respected. |
|||
| 989 | -9x | +|||
| 1155 | +
- what = "insert_rrow()",+ #' |
|||
| 990 | -9x | +|||
| 1156 | +
- with = I("insert_row_at_path() or label_at_path()")
+ #' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations |
|||
| 991 | +1157 |
- )+ #' declared in `lyt` to the data `df`. |
||
| 992 | -9x | +|||
| 1158 | +
- stopifnot(+ #' |
|||
| 993 | -9x | +|||
| 1159 | +
- is(tbl, "VTableTree"),+ #' @examples |
|||
| 994 | -9x | +|||
| 1160 | +
- is(rrow, "TableRow"),+ #' lyt <- basic_table() %>% |
|||
| 995 | -9x | +|||
| 1161 | +
- at >= 1 && at <= nrow(tbl) + 1+ #' split_cols_by("Species") %>%
|
|||
| 996 | +1162 |
- )+ #' analyze("Sepal.Length", afun = function(x) {
|
||
| 997 | -9x | +|||
| 1163 | +
- chk_compat_cinfos(tbl, rrow)+ #' list( |
|||
| 998 | -8x | +|||
| 1164 | +
- if (no_colinfo(rrow)) {
+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
|||
| 999 | -8x | +|||
| 1165 | +
- col_info(rrow) <- col_info(tbl)+ #' "range" = diff(range(x)) |
|||
| 1000 | +1166 |
- }+ #' ) |
||
| 1001 | +1167 |
-
+ #' }) |
||
| 1002 | -8x | +|||
| 1168 | +
- if (at == 1) {
+ #' lyt |
|||
| 1003 | -4x | +|||
| 1169 | +
- return(rbindl_rtables(list(rrow, tbl)))+ #' |
|||
| 1004 | -4x | +|||
| 1170 | +
- } else if (at == nrow(tbl) + 1) {
+ #' tbl <- build_table(lyt, iris) |
|||
| 1005 | -1x | +|||
| 1171 | +
- return(rbind2(tbl, rrow))+ #' tbl |
|||
| 1006 | +1172 |
- }+ #' |
||
| 1007 | +1173 |
-
+ #' # analyze multiple variables |
||
| 1008 | -3x | +|||
| 1174 | +
- ret <- recurse_insert(tbl, rrow,+ #' lyt2 <- basic_table() %>% |
|||
| 1009 | -3x | +|||
| 1175 | +
- at = at,+ #' split_cols_by("Species") %>%
|
|||
| 1010 | -3x | +|||
| 1176 | +
- pos = 0,+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
|
|||
| 1011 | -3x | +|||
| 1177 | +
- ascontent = ascontent+ #' list( |
|||
| 1012 | +1178 |
- )+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
||
| 1013 | -3x | +|||
| 1179 | +
- ret+ #' "range" = diff(range(x)) |
|||
| 1014 | +1180 |
- }+ #' ) |
||
| 1015 | +1181 |
-
+ #' }) |
||
| 1016 | +1182 |
- .insert_helper <- function(tt, row, at, pos,+ #' |
||
| 1017 | +1183 |
- ascontent = FALSE) {
+ #' tbl2 <- build_table(lyt2, iris) |
||
| 1018 | -9x | +|||
| 1184 | +
- islab <- is(row, "LabelRow")+ #' tbl2 |
|||
| 1019 | -9x | +|||
| 1185 | +
- kids <- tree_children(tt)+ #' |
|||
| 1020 | -9x | +|||
| 1186 | +
- numkids <- length(kids)+ #' # an example more relevant for clinical trials with column counts |
|||
| 1021 | -9x | +|||
| 1187 | +
- kidnrs <- sapply(kids, nrow)+ #' lyt3 <- basic_table(show_colcounts = TRUE) %>% |
|||
| 1022 | -9x | +|||
| 1188 | +
- cumpos <- pos + cumsum(kidnrs)+ #' split_cols_by("ARM") %>%
|
|||
| 1023 | -9x | +|||
| 1189 | +
- contnr <- if (is(tt, "TableTree")) {
+ #' analyze("AGE", afun = function(x) {
|
|||
| 1024 | -6x | +|||
| 1190 | +
- nrow(content_table(tt))+ #' setNames(as.list(fivenum(x)), c( |
|||
| 1025 | +1191 |
- } else {
+ #' "minimum", "lower-hinge", "median", |
||
| 1026 | -3x | +|||
| 1192 | +
- 0+ #' "upper-hinge", "maximum" |
|||
| 1027 | +1193 |
- }+ #' )) |
||
| 1028 | -9x | +|||
| 1194 | +
- contnr <- contnr + as.numeric(labelrow_visible(tt))+ #' }) |
|||
| 1029 | +1195 |
-
+ #' |
||
| 1030 | -9x | +|||
| 1196 | +
- totnr <- nrow(tt)+ #' tbl3 <- build_table(lyt3, DM) |
|||
| 1031 | -9x | +|||
| 1197 | +
- endpos <- pos + totnr+ #' tbl3 |
|||
| 1032 | -9x | +|||
| 1198 | +
- atend <- !islab && endpos == at - 1+ #' |
|||
| 1033 | -9x | +|||
| 1199 | +
- if (at == pos + 1 && islab) {
+ #' tbl4 <- build_table(lyt3, subset(DM, AGE > 40)) |
|||
| 1034 | -2x | +|||
| 1200 | +
- if (labelrow_visible(tt)) {
+ #' tbl4 |
|||
| 1035 | -! | +|||
| 1201 | +
- stop("Inserting a label row at a position that already has a label row is not currently supported")
+ #' |
|||
| 1036 | +1202 |
- }+ #' # with column counts calculated based on different data |
||
| 1037 | -2x | +|||
| 1203 | +
- tt_labelrow(tt) <- row+ #' miniDM <- DM[sample(1:NROW(DM), 100), ] |
|||
| 1038 | -2x | +|||
| 1204 | +
- return(tt)+ #' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM) |
|||
| 1039 | +1205 |
- }+ #' tbl5 |
||
| 1040 | +1206 |
-
+ #' |
||
| 1041 | -7x | +|||
| 1207 | +
- if (numkids == 0) {
+ #' tbl6 <- build_table(lyt3, DM, col_counts = 1:3) |
|||
| 1042 | -! | +|||
| 1208 | +
- kids <- list(row)+ #' tbl6 |
|||
| 1043 | -7x | +|||
| 1209 | +
- } else if (atend) {
+ #' |
|||
| 1044 | -2x | +|||
| 1210 | +
- if (are(kids, "TableRow")) {
+ #' @author Gabriel Becker |
|||
| 1045 | -1x | +|||
| 1211 | +
- kids <- c(kids, list(row))+ #' @export |
|||
| 1046 | +1212 |
- } else {
+ build_table <- function(lyt, df, |
||
| 1047 | -1x | +|||
| 1213 | +
- kids[[numkids]] <- recurse_insert(+ alt_counts_df = NULL, |
|||
| 1048 | -1x | +|||
| 1214 | +
- kids[[numkids]],+ col_counts = NULL, |
|||
| 1049 | -1x | +|||
| 1215 | +
- row = row,+ col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df), |
|||
| 1050 | -1x | +|||
| 1216 | +
- at = at,+ topleft = NULL, |
|||
| 1051 | -1x | +|||
| 1217 | +
- pos = pos + contnr + sum(kidnrs[-numkids]),+ hsep = default_hsep(), |
|||
| 1052 | -1x | +|||
| 1218 | +
- ascontent = ascontent+ ...) {
|
|||
| 1053 | -+ | |||
| 1219 | +329x |
- )+ if (!is(lyt, "PreDataTableLayouts")) {
|
||
| 1054 | -+ | |||
| 1220 | +! |
- }+ stop( |
||
| 1055 | -+ | |||
| 1221 | +! |
- } else { # have >0 kids
+ "lyt must be a PreDataTableLayouts object. Got object of class ", |
||
| 1056 | -5x | +|||
| 1222 | +! |
- kidnrs <- sapply(kids, nrow)+ class(lyt) |
||
| 1057 | -5x | +|||
| 1223 | +
- cumpos <- pos + cumsum(kidnrs)+ ) |
|||
| 1058 | +1224 |
-
+ } |
||
| 1059 | +1225 |
- ## data rows go in the end of the+ |
||
| 1060 | +1226 |
- ## preceding subtable (if applicable)+ ## if no columns are defined (e.g. because lyt is NULL) |
||
| 1061 | +1227 |
- ## label rows go in the beginning of+ ## add a single overall column as the "most basic" |
||
| 1062 | +1228 |
- ## one at at+ ## table column structure that makes sense |
||
| 1063 | -5x | +1229 | +329x |
- ind <- min(+ clyt <- clayout(lyt) |
| 1064 | -5x | +1230 | +329x |
- which((cumpos + !islab) >= at),+ if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
|
| 1065 | -5x | +1231 | +93x |
- numkids+ clyt[[1]] <- add_overall_col(clyt[[1]], "")+ |
+
| 1232 | +93x | +
+ clayout(lyt) <- clyt |
||
| 1066 | +1233 |
- )+ } |
||
| 1067 | -5x | +|||
| 1234 | +
- thekid <- kids[[ind]]+ |
|||
| 1068 | +1235 |
-
+ ## do checks and defensive programming now that we have the data |
||
| 1069 | -5x | +1236 | +329x |
- if (is(thekid, "TableRow")) {
+ lyt <- fix_dyncuts(lyt, df) |
| 1070 | -! | +|||
| 1237 | +329x |
- tt_level(row) <- tt_level(thekid)+ lyt <- set_def_child_ord(lyt, df) |
||
| 1071 | -! | +|||
| 1238 | +328x |
- if (ind == 1) {
+ lyt <- fix_analyze_vis(lyt) |
||
| 1072 | -! | +|||
| 1239 | +328x |
- bef <- integer()+ df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts)) |
||
| 1073 | -! | +|||
| 1240 | +319x |
- aft <- 1:numkids+ alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
|
||
| 1074 | -! | +|||
| 1241 | +319x |
- } else if (ind == numkids) {
+ if (any(alt_params) && is.null(alt_counts_df)) {
|
||
| 1075 | -! | +|||
| 1242 | +2x |
- bef <- 1:(ind - 1)+ stop( |
||
| 1076 | -! | +|||
| 1243 | +2x |
- aft <- ind+ "Layout contains afun/cfun functions that have optional parameters ", |
||
| 1077 | -+ | |||
| 1244 | +2x |
- } else {
+ ".alt_df and/or .alt_df_row, but no alt_counts_df was provided in ", |
||
| 1078 | -! | +|||
| 1245 | +2x |
- bef <- 1:ind+ "build_table()." |
||
| 1079 | -! | +|||
| 1246 | +
- aft <- (ind + 1):numkids+ ) |
|||
| 1080 | +1247 |
- }+ } |
||
| 1081 | -! | +|||
| 1248 | +
- kids <- c(+ |
|||
| 1082 | -! | +|||
| 1249 | +317x |
- kids[bef], list(row),+ rtpos <- TreePos() |
||
| 1083 | -! | +|||
| 1250 | +317x |
- kids[aft]+ cinfo <- create_colinfo(lyt, df, rtpos, |
||
| 1084 | -+ | |||
| 1251 | +317x |
- )+ counts = col_counts, |
||
| 1085 | -+ | |||
| 1252 | +317x |
- } else { # kid is not a table row
+ alt_counts_df = alt_counts_df, |
||
| 1086 | -5x | +1253 | +317x |
- newpos <- if (ind == 1) {
+ total = col_total, |
| 1087 | -4x | +1254 | +317x |
- pos + contnr+ topleft |
| 1088 | +1255 |
- } else {
+ ) |
||
| 1089 | -1x | +1256 | +309x |
- cumpos[ind - 1]+ if (!is.null(col_counts)) {
|
| 1090 | -+ | |||
| 1257 | +3x |
- }+ toreplace <- !is.na(col_counts) |
||
| 1091 | -+ | |||
| 1258 | +3x |
-
+ newccs <- col_counts(cinfo) ## old actual counts |
||
| 1092 | -5x | +1259 | +3x |
- kids[[ind]] <- recurse_insert(thekid,+ newccs[toreplace] <- col_counts[toreplace] |
| 1093 | -5x | +1260 | +3x |
- row,+ col_counts(cinfo) <- newccs |
| 1094 | -5x | +1261 | +3x |
- at,+ leaf_paths <- col_paths(cinfo) |
| 1095 | -5x | +1262 | +3x |
- pos = newpos,+ for (pth in leaf_paths) {
|
| 1096 | -5x | +1263 | +21x |
- ascontent = ascontent+ colcount_visible(cinfo, pth) <- TRUE |
| 1097 | +1264 |
- )+ } |
||
| 1098 | +1265 |
- } # end kid is not table row+ } |
||
| 1099 | -+ | |||
| 1266 | +309x |
- }+ rlyt <- rlayout(lyt) |
||
| 1100 | -7x | +1267 | +309x |
- tree_children(tt) <- kids+ rtspl <- root_spl(rlyt) |
| 1101 | -7x | +1268 | +309x |
- tt+ ctab <- .make_ctab(df, 0L, |
| 1102 | -+ | |||
| 1269 | +309x |
- }+ alt_df = NULL, |
||
| 1103 | -+ | |||
| 1270 | +309x |
-
+ name = "root", |
||
| 1104 | -9x | +1271 | +309x |
- setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))
+ label = "", |
| 1105 | -+ | |||
| 1272 | +309x |
-
+ cinfo = cinfo, ## cexprs, ctree, |
||
| 1106 | -+ | |||
| 1273 | +309x |
- setMethod(+ parent_cfun = content_fun(rtspl),+ |
+ ||
| 1274 | +309x | +
+ format = content_format(rtspl),+ |
+ ||
| 1275 | +309x | +
+ na_str = content_na_str(rtspl),+ |
+ ||
| 1276 | +309x | +
+ indent_mod = 0L,+ |
+ ||
| 1277 | +309x | +
+ cvar = content_var(rtspl),+ |
+ ||
| 1278 | +309x | +
+ extra_args = content_extra_args(rtspl) |
||
| 1107 | +1279 |
- "recurse_insert", "TableTree",+ ) |
||
| 1108 | +1280 |
- function(tt, row, at, pos, ascontent = FALSE) {
+
|
||
| 1109 | -6x | +1281 | +309x |
- ctab <- content_table(tt)+ kids <- lapply(seq_along(rlyt), function(i) {
|
| 1110 | -6x | +1282 | +334x |
- contnr <- nrow(ctab)+ splvec <- rlyt[[i]] |
| 1111 | -6x | +1283 | +334x |
- contpos <- pos + contnr+ if (length(splvec) == 0) {
|
| 1112 | -6x | +1284 | +14x |
- islab <- is(row, "LabelRow")+ return(NULL) |
| 1113 | +1285 |
- ## this will NOT insert it as+ } |
||
| 1114 | -6x | +1286 | +320x |
- if ((contnr > 0 || islab) && contpos > at) {
+ firstspl <- splvec[[1]] |
| 1115 | -! | +|||
| 1287 | +320x |
- content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE)+ nm <- obj_name(firstspl) |
||
| 1116 | -! | +|||
| 1288 | +
- return(tt)+ ## XXX unused, probably shouldn't be? |
|||
| 1117 | +1289 |
- }+ ## this seems to be covered by grabbing the partlabel |
||
| 1118 | +1290 |
-
+ ## TODO confirm this+ |
+ ||
| 1291 | ++ |
+ ## lab <- obj_label(firstspl) |
||
| 1119 | -6x | +1292 | +320x |
- .insert_helper(tt, row,+ recursive_applysplit( |
| 1120 | -6x | +1293 | +320x |
- at = at, pos = pos + contnr,+ df = df, lvl = 0L, |
| 1121 | -6x | +1294 | +320x |
- ascontent = ascontent+ alt_df = alt_counts_df, |
| 1122 | -+ | |||
| 1295 | +320x |
- )+ name = nm, |
||
| 1123 | -+ | |||
| 1296 | +320x |
- }+ splvec = splvec, |
||
| 1124 | -+ | |||
| 1297 | +320x |
- )+ cinfo = cinfo, |
||
| 1125 | +1298 |
-
+ ## XXX are these ALWAYS right? |
||
| 1126 | -+ | |||
| 1299 | +320x |
- setMethod(+ make_lrow = label_kids(firstspl), |
||
| 1127 | -+ | |||
| 1300 | +320x |
- "recurse_insert", "ElementaryTable",+ parent_cfun = NULL, |
||
| 1128 | -+ | |||
| 1301 | +320x |
- function(tt, row, at, pos, ascontent = FALSE) {
+ cformat = content_format(firstspl), |
||
| 1129 | -3x | +1302 | +320x |
- .insert_helper(tt, row,+ cna_str = content_na_str(firstspl), |
| 1130 | -3x | +1303 | +320x |
- at = at, pos = pos,+ cvar = content_var(firstspl), |
| 1131 | -3x | +1304 | +320x |
- ascontent = FALSE+ cextra_args = content_extra_args(firstspl), |
| 1132 | -+ | |||
| 1305 | +320x |
- )+ spl_context = context_df_row( |
||
| 1133 | -+ | |||
| 1306 | +320x |
- }+ split = "root", value = "root", |
||
| 1134 | -+ | |||
| 1307 | +320x |
- )+ full_parent_df = list(df), |
| 1 | -+ | |||
| 1308 | +320x |
- label_pos_values <- c("hidden", "visible", "topleft")
+ cinfo = cinfo |
||
| 2 | +1309 |
-
+ ), |
||
| 3 | +1310 |
- #' @name internal_methods+ ## we DO want the 'outer table' if the first |
||
| 4 | +1311 |
- #' @rdname int_methods+ ## one is a multi-analyze |
||
| 5 | -+ | |||
| 1312 | +320x |
- NULL+ no_outer_tbl = !is(firstspl, "AnalyzeMultiVars") |
||
| 6 | +1313 |
-
+ ) |
||
| 7 | +1314 |
- #' Combine `SplitVector` objects+ }) |
||
| 8 | -+ | |||
| 1315 | +293x |
- #'+ kids <- kids[!sapply(kids, is.null)] |
||
| 9 | -+ | |||
| 1316 | +279x |
- #' @param x (`SplitVector`)\cr a `SplitVector` object.+ if (length(kids) > 0) names(kids) <- sapply(kids, obj_name) |
||
| 10 | +1317 |
- #' @param ... splits or `SplitVector` objects.+ |
||
| 11 | +1318 |
- #'+ # top level divisor |
||
| 12 | -+ | |||
| 1319 | +293x |
- #' @return Various, but should be considered implementation details.+ if (!is.na(top_level_section_div(lyt))) {
|
||
| 13 | -+ | |||
| 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 |
||
| 14 | +1323 |
- #' @rdname int_methods+ }) |
||
| 15 | +1324 |
- #' @exportMethod c+ } |
||
| 16 | +1325 |
- setMethod("c", "SplitVector", function(x, ...) {
+
|
||
| 17 | -377x | +1326 | +293x |
- arglst <- list(...)+ if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
|
| 18 | -377x | +1327 | +248x |
- stopifnot(all(sapply(arglst, is, "Split")))+ tab <- kids[[1]] |
| 19 | -377x | +1328 | +248x |
- tmp <- c(unclass(x), arglst)+ main_title(tab) <- main_title(lyt) |
| 20 | -377x | +1329 | +248x |
- SplitVector(lst = tmp)+ subtitles(tab) <- subtitles(lyt) |
| 21 | -+ | |||
| 1330 | +248x |
- })+ main_footer(tab) <- main_footer(lyt) |
||
| 22 | -+ | |||
| 1331 | +248x |
-
+ prov_footer(tab) <- prov_footer(lyt) |
||
| 23 | -+ | |||
| 1332 | +248x |
- ## split_rows and split_cols are "recursive method stacks" which follow+ header_section_div(tab) <- header_section_div(lyt) |
||
| 24 | +1333 |
- ## the general pattern of accept object -> call add_*_split on slot of object ->+ } else {
|
||
| 25 | -+ | |||
| 1334 | +45x |
- ## update object with value returned from slot method, return object.+ tab <- TableTree( |
||
| 26 | -+ | |||
| 1335 | +45x |
- ##+ cont = ctab, |
||
| 27 | -+ | |||
| 1336 | +45x |
- ## Thus each of the methods is idempotent, returning an updated object of the+ kids = kids, |
||
| 28 | -+ | |||
| 1337 | +45x |
- ## same class it was passed. The exception for idempotency is the NULL method+ lev = 0L, |
||
| 29 | -+ | |||
| 1338 | +45x |
- ## which constructs a PreDataTableLayouts object with the specified split in the+ name = "root", |
||
| 30 | -+ | |||
| 1339 | +45x |
- ## correct place.+ label = "", |
||
| 31 | -+ | |||
| 1340 | +45x |
-
+ iscontent = FALSE, |
||
| 32 | -+ | |||
| 1341 | +45x |
- ## The cascading (by class) in this case is as follows for the row case:+ cinfo = cinfo, |
||
| 33 | -+ | |||
| 1342 | +45x |
- ## PreDataTableLayouts -> PreDataRowLayout -> SplitVector+ format = obj_format(rtspl), |
||
| 34 | -+ | |||
| 1343 | +45x |
- #' @param cmpnd_fun (`function`)\cr intended for internal use.+ na_str = obj_na_str(rtspl), |
||
| 35 | -+ | |||
| 1344 | +45x |
- #' @param pos (`numeric(1)`)\cr intended for internal use.+ title = main_title(lyt), |
||
| 36 | -+ | |||
| 1345 | +45x |
- #' @param spl (`Split`)\cr the split.+ subtitles = subtitles(lyt), |
||
| 37 | -+ | |||
| 1346 | +45x |
- #'+ main_footer = main_footer(lyt), |
||
| 38 | -+ | |||
| 1347 | +45x |
- #' @rdname int_methods+ prov_footer = prov_footer(lyt), |
||
| 39 | -+ | |||
| 1348 | +45x |
- setGeneric(+ header_section_div = header_section_div(lyt) |
||
| 40 | +1349 |
- "split_rows",+ ) |
||
| 41 | +1350 |
- function(lyt = NULL, spl, pos,+ } |
||
| 42 | +1351 |
- cmpnd_fun = AnalyzeMultiVars) {
+
|
||
| 43 | -1601x | +|||
| 1352 | +
- standardGeneric("split_rows")
+ ## This seems to be unneeded, not clear what 'top_left' check it refers to |
|||
| 44 | +1353 |
- }+ ## but both top_left taller than column headers and very long topleft are now |
||
| 45 | +1354 |
- )+ ## allowed, so this is just wasted computation. |
||
| 46 | +1355 | |||
| 47 | +1356 |
- #' @rdname int_methods+ ## ## this is where the top_left check lives right now. refactor later maybe |
||
| 48 | +1357 |
- setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ ## ## but now just call it so the error gets thrown when I want it to |
||
| 49 | -1x | +|||
| 1358 | +
- lifecycle::deprecate_warn(+ ## unused <- matrix_form(tab) |
|||
| 50 | -1x | +1359 | +293x |
- when = "0.3.8",+ tab <- update_ref_indexing(tab) |
| 51 | -1x | +1360 | +293x |
- what = I("split_rows(NULL)"),
+ horizontal_sep(tab) <- hsep |
| 52 | -1x | +1361 | +293x |
- with = "basic_table()",+ if (table_inset(lyt) > 0) {
|
| 53 | +1362 | 1x |
- details = "Initializing layouts via `NULL` is no longer supported."+ table_inset(tab) <- table_inset(lyt) |
|
| 54 | +1363 |
- )- |
- ||
| 55 | -1x | -
- rl <- PreDataRowLayout(SplitVector(spl))+ } |
||
| 56 | -1x | +1364 | +293x |
- cl <- PreDataColLayout()+ tab |
| 57 | -1x | +|||
| 1365 | +
- PreDataTableLayouts(rlayout = rl, clayout = cl)+ } |
|||
| 58 | +1366 |
- })+ |
||
| 59 | +1367 |
-
+ # fix_split_vars ---- |
||
| 60 | +1368 |
- #' @rdname int_methods+ # These checks guarantee that all the split variables are present in the data. |
||
| 61 | +1369 |
- setMethod(+ # No generic is needed because it is not dependent on the input layout but |
||
| 62 | +1370 |
- "split_rows", "PreDataRowLayout",+ # on the df. |
||
| 63 | +1371 |
- function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ fix_one_split_var <- function(spl, df, char_ok = TRUE) {
|
||
| 64 | -542x | +1372 | +549x |
- stopifnot(pos > 0 && pos <= length(lyt) + 1)+ var <- spl_payload(spl) |
| 65 | -542x | +1373 | +549x |
- tmp <- if (pos <= length(lyt)) {
+ if (!(var %in% names(df))) {
|
| 66 | -516x | +1374 | +2x |
- split_rows(lyt[[pos]], spl, pos, cmpnd_fun)+ stop("Split variable [", var, "] not found in data being tabulated.")
|
| 67 | +1375 |
- } else {
+ } |
||
| 68 | -26x | +1376 | +547x |
- if (pos != 1 && has_force_pag(spl)) {
+ varvec <- df[[var]] |
| 69 | -1x | +1377 | +547x |
- stop("page_by splits cannot have top-level siblings",
+ if (!is(varvec, "character") && !is.factor(varvec)) {
|
| 70 | +1378 | 1x |
- call. = FALSE- |
- |
| 71 | -- |
- )- |
- ||
| 72 | -- |
- }+ message(sprintf( |
||
| 73 | -25x | -
- SplitVector(spl)- |
- ||
| 74 | -+ | 1379 | +1x |
- }+ paste( |
| 75 | -540x | +1380 | +1x |
- lyt[[pos]] <- tmp+ "Split var [%s] was not character or factor.", |
| 76 | -540x | +1381 | +1x |
- lyt+ "Converting to factor" |
| 77 | +1382 |
- }+ ), |
||
| 78 | -+ | |||
| 1383 | +1x |
- )+ var |
||
| 79 | +1384 |
-
+ )) |
||
| 80 | -+ | |||
| 1385 | +1x |
- is_analysis_spl <- function(spl) {
+ varvec <- factor(varvec) |
||
| 81 | -! | +|||
| 1386 | +1x |
- is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars")+ df[[var]] <- varvec |
||
| 82 | -+ | |||
| 1387 | +546x |
- }+ } else if (is(varvec, "character") && !char_ok) {
|
||
| 83 | -+ | |||
| 1388 | +1x |
-
+ stop( |
||
| 84 | -+ | |||
| 1389 | +1x |
- ## note "pos" is ignored here because it is for which nest-chain+ "Overriding column counts is not supported when splitting on ", |
||
| 85 | -+ | |||
| 1390 | +1x |
- ## spl should be placed in, NOIT for where in that chain it should go+ "character variables.\n Please convert all column split variables to ", |
||
| 86 | -+ | |||
| 1391 | +1x |
- #' @rdname int_methods+ "factors." |
||
| 87 | +1392 |
- setMethod(+ ) |
||
| 88 | +1393 |
- "split_rows", "SplitVector",+ } |
||
| 89 | +1394 |
- function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+
|
||
| 90 | -+ | |||
| 1395 | +546x |
- ## if(is_analysis_spl(spl) &&+ if (is.factor(varvec)) {
|
||
| 91 | -+ | |||
| 1396 | +384x |
- ## is_analysis_spl(last_rowsplit(lyt))) {
+ levs <- levels(varvec) |
||
| 92 | +1397 |
- ## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun))+ } else {
|
||
| 93 | -+ | |||
| 1398 | +162x |
- ## }+ levs <- unique(varvec) |
||
| 94 | +1399 |
-
+ } |
||
| 95 | -516x | +1400 | +546x |
- if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
+ if (!all(nzchar(levs))) {
|
| 96 | -1x | +1401 | +4x |
- stop("page_by splits cannot be nested within non-page_by splits",
+ stop( |
| 97 | -1x | -
- call. = FALSE- |
- ||
| 98 | -- |
- )- |
- ||
| 99 | -+ | 1402 | +4x |
- }+ "Got empty string level in splitting variable ", var, |
| 100 | -515x | +1403 | +4x |
- tmp <- c(unclass(lyt), spl)+ " This is not supported.\nIf display as an empty level is ", |
| 101 | -515x | +1404 | +4x |
- SplitVector(lst = tmp)+ "desired use a value-labeling variable." |
| 102 | +1405 |
- }+ ) |
||
| 103 | +1406 |
- )+ } |
||
| 104 | +1407 | |||
| 105 | -- |
- #' @rdname int_methods- |
- ||
| 106 | -- |
- setMethod(- |
- ||
| 107 | +1408 |
- "split_rows", "PreDataTableLayouts",+ ## handle label var |
||
| 108 | -+ | |||
| 1409 | +542x |
- function(lyt, spl, pos) {
+ lblvar <- spl_label_var(spl) |
||
| 109 | +1410 | 542x |
- rlyt <- rlayout(lyt)+ have_lblvar <- !identical(var, lblvar) |
|
| 110 | +1411 | 542x |
- addtl <- FALSE+ if (have_lblvar) {
|
|
| 111 | -542x | +1412 | +88x |
- split_label <- obj_label(spl)+ if (!(lblvar %in% names(df))) {
|
| 112 | -+ | |||
| 1413 | +1x |
- if (+ stop( |
||
| 113 | -542x | +1414 | +1x |
- is(spl, "Split") && ## exclude existing tables that are being tacked in+ "Value label variable [", lblvar, |
| 114 | -542x | +1415 | +1x |
- identical(label_position(spl), "topleft") &&+ "] not found in data being tabulated." |
| 115 | -542x | +|||
| 1416 | +
- length(split_label) == 1 && nzchar(split_label)+ ) |
|||
| 116 | +1417 |
- ) {
+ } |
||
| 117 | -19x | +1418 | +87x |
- addtl <- TRUE+ lblvec <- df[[lblvar]] |
| 118 | -+ | |||
| 1419 | +87x |
- ## label_position(spl) <- "hidden"+ tab <- table(varvec, lblvec) |
||
| 119 | +1420 |
- }+ |
||
| 120 | -+ | |||
| 1421 | +87x |
-
+ if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
|
||
| 121 | -542x | +1422 | +1x |
- rlyt <- split_rows(rlyt, spl, pos)+ stop(sprintf( |
| 122 | -540x | +1423 | +1x |
- rlayout(lyt) <- rlyt+ paste( |
| 123 | -540x | +1424 | +1x |
- if (addtl) {
+ "There does not appear to be a 1-1", |
| 124 | -19x | +1425 | +1x |
- lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt)))+ "correspondence between values in split var",+ |
+
| 1426 | +1x | +
+ "[%s] and label var [%s]" |
||
| 125 | +1427 |
- }+ ), |
||
| 126 | -540x | +1428 | +1x |
- lyt+ var, lblvar |
| 127 | +1429 |
- }+ )) |
||
| 128 | +1430 |
- )+ } |
||
| 129 | +1431 | |||
| 130 | -+ | |||
| 1432 | +86x |
- #' @rdname int_methods+ if (!is(lblvec, "character") && !is.factor(lblvec)) {
|
||
| 131 | -+ | |||
| 1433 | +! |
- setMethod(+ message(sprintf(+ |
+ ||
| 1434 | +! | +
+ paste(+ |
+ ||
| 1435 | +! | +
+ "Split label var [%s] was not character or",+ |
+ ||
| 1436 | +! | +
+ "factor. Converting to factor" |
||
| 132 | +1437 |
- "split_rows", "ANY",+ ),+ |
+ ||
| 1438 | +! | +
+ var |
||
| 133 | +1439 |
- function(lyt, spl, pos) {
+ )) |
||
| 134 | +1440 | ! |
- stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
+ lblvec <- factor(lblvec)+ |
+ |
| 1441 | +! | +
+ df[[lblvar]] <- lblvec |
||
| 135 | +1442 |
- }+ } |
||
| 136 | +1443 |
- )+ } |
||
| 137 | +1444 | |||
| 1445 | +540x | +
+ df+ |
+ ||
| 138 | +1446 |
- ## cmpnd_last_rowsplit =====+ } |
||
| 139 | +1447 | |||
| 140 | +1448 |
- #' @rdname int_methods+ fix_split_vars <- function(lyt, df, char_ok) {
|
||
| 141 | -+ | |||
| 1449 | +328x |
- #'+ df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok) |
||
| 142 | -+ | |||
| 1450 | +324x |
- #' @param constructor (`function`)\cr constructor function.+ df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE) |
||
| 143 | -82x | +1451 | +319x |
- setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))
+ df |
| 144 | +1452 | |||
| 145 | +1453 |
- #' @rdname int_methods+ ## clyt <- clayout(lyt) |
||
| 146 | +1454 |
- setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
+ ## rlyt <- rlayout(lyt) |
||
| 147 | +1455 |
- stop("no existing splits to compound with. contact the maintainer") # nocov
+
|
||
| 148 | +1456 |
- })+ ## allspls <- unlist(list(clyt, rlyt)) |
||
| 149 | +1457 |
-
+ ## VarLevelSplit includes sublclass VarLevWBaselineSplit |
||
| 150 | +1458 |
- #' @rdname int_methods+ } |
||
| 151 | +1459 |
- setMethod(+ |
||
| 152 | +1460 |
- "cmpnd_last_rowsplit", "PreDataRowLayout",+ fix_split_vars_inner <- function(lyt, df, char_ok) {
|
||
| 153 | -+ | |||
| 1461 | +652x |
- function(lyt, spl, constructor) {
+ stopifnot(is(lyt, "PreDataAxisLayout")) |
||
| 154 | -27x | +1462 | +652x |
- pos <- length(lyt)+ allspls <- unlist(lyt) |
| 155 | -27x | +1463 | +652x |
- tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor)+ varspls <- allspls[sapply(allspls, is, "VarLevelSplit")] |
| 156 | -27x | +1464 | +652x |
- lyt[[pos]] <- tmp+ unqvarinds <- !duplicated(sapply(varspls, spl_payload)) |
| 157 | -27x | +1465 | +652x |
- lyt+ unqvarspls <- varspls[unqvarinds] |
| 158 | -+ | |||
| 1466 | +549x |
- }+ for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok) |
||
| 159 | +1467 |
- )+ |
||
| 160 | -+ | |||
| 1468 | +643x |
- #' @rdname int_methods+ df |
||
| 161 | +1469 |
- setMethod(+ } |
||
| 162 | +1470 |
- "cmpnd_last_rowsplit", "SplitVector",+ |
||
| 163 | +1471 |
- function(lyt, spl, constructor) {
+ # set_def_child_ord ---- |
||
| 164 | -28x | +|||
| 1472 | +
- pos <- length(lyt)+ ## the table is built by recursively splitting the data and doing things to each |
|||
| 165 | -28x | +|||
| 1473 | +
- lst <- lyt[[pos]]+ ## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to |
|||
| 166 | -28x | +|||
| 1474 | +
- tmp <- if (is(lst, "CompoundSplit")) {
+ ## be the same in all the different partitions. This addresses that. |
|||
| 167 | -3x | +|||
| 1475 | +
- spl_payload(lst) <- c(+ setGeneric( |
|||
| 168 | -3x | +|||
| 1476 | +
- .uncompound(spl_payload(lst)),+ "set_def_child_ord", |
|||
| 169 | -3x | +1477 | +3753x |
- .uncompound(spl)+ function(lyt, df) standardGeneric("set_def_child_ord")
|
| 170 | +1478 |
- )- |
- ||
| 171 | -3x | -
- obj_name(lst) <- make_ma_name(spl = lst)+ ) |
||
| 172 | -3x | +|||
| 1479 | +
- lst+ |
|||
| 173 | +1480 |
- ## XXX never reached because AnalzyeMultiVars inherits from+ setMethod( |
||
| 174 | +1481 |
- ## CompoundSplit???+ "set_def_child_ord", "PreDataTableLayouts", |
||
| 175 | +1482 |
- } else {
+ function(lyt, df) {
|
||
| 176 | -25x | -
- constructor(.payload = list(lst, spl))- |
- ||
| 177 | -+ | 1483 | +329x |
- }+ clayout(lyt) <- set_def_child_ord(clayout(lyt), df) |
| 178 | -28x | +1484 | +328x |
- lyt[[pos]] <- tmp+ rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df) |
| 179 | -28x | +1485 | +328x |
lyt |
| 180 | +1486 |
} |
||
| 181 | +1487 |
) |
||
| 182 | +1488 | |||
| 183 | -- |
- #' @rdname int_methods- |
- ||
| 184 | +1489 |
setMethod( |
||
| 185 | +1490 |
- "cmpnd_last_rowsplit", "PreDataTableLayouts",+ "set_def_child_ord", "PreDataAxisLayout", |
||
| 186 | +1491 |
- function(lyt, spl, constructor) {
- |
- ||
| 187 | -27x | -
- rlyt <- rlayout(lyt)- |
- ||
| 188 | -27x | -
- rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor)+ function(lyt, df) {
|
||
| 189 | -27x | +1492 | +976x |
- rlayout(lyt) <- rlyt+ lyt@.Data <- lapply(lyt, set_def_child_ord, df = df) |
| 190 | -27x | +1493 | +975x |
lyt |
| 191 | +1494 |
} |
||
| 192 | +1495 |
) |
||
| 193 | +1496 |
- #' @rdname int_methods+ |
||
| 194 | +1497 |
setMethod( |
||
| 195 | +1498 |
- "cmpnd_last_rowsplit", "ANY",+ "set_def_child_ord", "SplitVector", |
||
| 196 | +1499 |
- function(lyt, spl, constructor) {
+ function(lyt, df) {
|
||
| 197 | -! | +|||
| 1500 | +1018x |
- stop(+ lyt[] <- lapply(lyt, set_def_child_ord, df = df) |
||
| 198 | -! | +|||
| 1501 | +1017x |
- "nope. can't do cmpnd_last_rowsplit to that (",
+ lyt |
||
| 199 | -! | +|||
| 1502 | +
- class(lyt), "). contact the maintaner."+ } |
|||
| 200 | +1503 |
- )+ ) |
||
| 201 | +1504 |
- }+ |
||
| 202 | +1505 |
- )+ ## for most split types, don't do anything |
||
| 203 | +1506 |
-
+ ## becuause their ordering already isn't data-based |
||
| 204 | +1507 |
- ## split_cols ====+ setMethod( |
||
| 205 | +1508 |
-
+ "set_def_child_ord", "ANY", |
||
| 206 | -+ | |||
| 1509 | +591x |
- #' @rdname int_methods+ function(lyt, df) lyt |
||
| 207 | +1510 |
- setGeneric(+ ) |
||
| 208 | +1511 |
- "split_cols",+ |
||
| 209 | +1512 |
- function(lyt = NULL, spl, pos) {
+ setMethod( |
||
| 210 | -956x | +|||
| 1513 | +
- standardGeneric("split_cols")
+ "set_def_child_ord", "VarLevelSplit", |
|||
| 211 | +1514 |
- }+ function(lyt, df) {
|
||
| 212 | -+ | |||
| 1515 | +822x |
- )+ if (!is.null(spl_child_order(lyt))) {
|
||
| 213 | -+ | |||
| 1516 | +273x |
-
+ return(lyt) |
||
| 214 | +1517 |
- #' @rdname int_methods+ } |
||
| 215 | +1518 |
- setMethod("split_cols", "NULL", function(lyt, spl, pos) {
+
|
||
| 216 | -1x | +1519 | +549x |
- lifecycle::deprecate_warn(+ vec <- df[[spl_payload(lyt)]] |
| 217 | -1x | +1520 | +549x |
- when = "0.3.8",+ vals <- if (is.factor(vec)) {
|
| 218 | -1x | +1521 | +385x |
- what = I("split_cols(NULL)"),
+ levels(vec) |
| 219 | -1x | +|||
| 1522 | +
- with = "basic_table()",+ } else {
|
|||
| 220 | -1x | +1523 | +164x |
- details = "Initializing layouts via `NULL` is no longer supported."+ unique(vec) |
| 221 | +1524 |
- )- |
- ||
| 222 | -1x | -
- cl <- PreDataColLayout(SplitVector(spl))+ } |
||
| 223 | -1x | +1525 | +549x |
- rl <- PreDataRowLayout()+ spl_child_order(lyt) <- vals |
| 224 | -1x | +1526 | +549x |
- PreDataTableLayouts(rlayout = rl, clayout = cl)+ lyt |
| 225 | +1527 |
- })+ } |
||
| 226 | +1528 |
-
+ ) |
||
| 227 | +1529 |
- #' @rdname int_methods+ |
||
| 228 | +1530 |
setMethod( |
||
| 229 | +1531 |
- "split_cols", "PreDataColLayout",+ "set_def_child_ord", "VarLevWBaselineSplit", |
||
| 230 | +1532 |
- function(lyt, spl, pos) {
+ function(lyt, df) {
|
||
| 231 | -289x | +1533 | +17x |
- stopifnot(pos > 0 && pos <= length(lyt) + 1)+ bline <- spl_ref_group(lyt) |
| 232 | -289x | +1534 | +17x |
- tmp <- if (pos <= length(lyt)) {
+ if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
|
| 233 | -284x | +1535 | +6x |
- split_cols(lyt[[pos]], spl, pos)+ return(lyt) |
| 234 | +1536 |
- } else {
+ } |
||
| 235 | -5x | +|||
| 1537 | +
- SplitVector(spl)+ |
|||
| 236 | -+ | |||
| 1538 | +11x |
- }+ if (!is.null(split_fun(lyt))) {
|
||
| 237 | +1539 |
-
+ ## expensive but sadly necessary, I think |
||
| 238 | -289x | +1540 | +3x |
- lyt[[pos]] <- tmp+ pinfo <- do_split(lyt, df, spl_context = context_df_row()) |
| 239 | -289x | +1541 | +3x |
- lyt+ vals <- sort(unlist(value_names(pinfo$values))) |
| 240 | +1542 |
- }+ } else {
|
||
| 241 | -+ | |||
| 1543 | +8x |
- )+ vec <- df[[spl_payload(lyt)]] |
||
| 242 | -+ | |||
| 1544 | +8x |
-
+ vals <- if (is.factor(vec)) {
|
||
| 243 | -+ | |||
| 1545 | +5x |
- #' @rdname int_methods+ levels(vec) |
||
| 244 | +1546 |
- setMethod(+ } else {
+ |
+ ||
| 1547 | +3x | +
+ unique(vec) |
||
| 245 | +1548 |
- "split_cols", "SplitVector",+ } |
||
| 246 | +1549 |
- function(lyt, spl, pos) {
+ } |
||
| 247 | -377x | +1550 | +11x |
- tmp <- c(lyt, spl)+ if (!bline %in% vals) {
|
| 248 | -377x | +1551 | +1x |
- SplitVector(lst = tmp)+ stop(paste0( |
| 249 | -+ | |||
| 1552 | +1x |
- }+ 'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data." |
||
| 250 | +1553 |
- )+ )) |
||
| 251 | +1554 | ++ |
+ }+ |
+ |
| 1555 | +10x | +
+ spl_child_order(lyt) <- vals+ |
+ ||
| 1556 | +10x | +
+ lyt+ |
+ ||
| 1557 | ++ |
+ }+ |
+ ||
| 1558 | ++ |
+ )+ |
+ ||
| 1559 | ||||
| 252 | +1560 |
- #' @rdname int_methods+ splitvec_to_coltree <- function(df, splvec, pos = NULL, |
||
| 253 | +1561 |
- setMethod(+ lvl = 1L, label = "", |
||
| 254 | +1562 |
- "split_cols", "PreDataTableLayouts",+ spl_context = context_df_row(cinfo = NULL), |
||
| 255 | +1563 |
- function(lyt, spl, pos) {
+ alt_counts_df = df, |
||
| 256 | -289x | +|||
| 1564 | +
- rlyt <- lyt@col_layout+ global_cc_format) {
|
|||
| 257 | -289x | +1565 | +1739x |
- rlyt <- split_cols(rlyt, spl, pos)+ stopifnot( |
| 258 | -289x | +1566 | +1739x |
- lyt@col_layout <- rlyt+ lvl <= length(splvec) + 1L, |
| 259 | -289x | +1567 | +1739x |
- lyt+ is(splvec, "SplitVector") |
| 260 | +1568 |
- }+ ) |
||
| 261 | +1569 |
- )+ |
||
| 262 | +1570 | |||
| 263 | -+ | |||
| 1571 | +1739x |
- #' @rdname int_methods+ if (lvl == length(splvec) + 1L) {
|
||
| 264 | +1572 |
- setMethod(+ ## XXX this should be a LayoutColree I Think. |
||
| 265 | -+ | |||
| 1573 | +1139x |
- "split_cols", "ANY",+ nm <- unlist(tail(value_names(pos), 1)) %||% "" |
||
| 266 | -+ | |||
| 1574 | +1139x |
- function(lyt, spl, pos) {
+ spl <- tail(pos_splits(pos), 1)[[1]] |
||
| 267 | -! | +|||
| 1575 | +1139x |
- stop(+ fmt <- colcount_format(spl) %||% global_cc_format |
||
| 268 | -! | +|||
| 1576 | +1139x |
- "nope. can't add a col split to that (", class(lyt),
+ LayoutColLeaf( |
||
| 269 | -! | +|||
| 1577 | +1139x |
- "). contact the maintaner."+ lev = lvl - 1L, |
||
| 270 | -+ | |||
| 1578 | +1139x |
- )+ label = label, |
||
| 271 | -+ | |||
| 1579 | +1139x |
- }+ tpos = pos, |
||
| 272 | -+ | |||
| 1580 | +1139x |
- )+ name = nm, |
||
| 273 | -+ | |||
| 1581 | +1139x |
-
+ colcount = NROW(alt_counts_df), |
||
| 274 | -+ | |||
| 1582 | +1139x |
- # Constructors =====+ disp_ccounts = disp_ccounts(spl), |
||
| 275 | -+ | |||
| 1583 | +1139x |
-
+ colcount_format = fmt |
||
| 276 | +1584 |
- ## Pipe-able functions to add the various types of splits to the current layout+ ) |
||
| 277 | +1585 |
- ## for both row and column. These all act as wrappers to the split_cols and+ } else {
|
||
| 278 | -+ | |||
| 1586 | +600x |
- ## split_rows method stacks.+ spl <- splvec[[lvl]] |
||
| 279 | -+ | |||
| 1587 | +600x |
-
+ nm <- if (is.null(pos) || length(pos_splits(pos)) == 0) {
|
||
| 280 | -+ | |||
| 1588 | +367x |
- #' Declaring a column-split based on levels of a variable+ obj_name(spl) |
||
| 281 | +1589 |
- #'+ } else {
|
||
| 282 | -+ | |||
| 1590 | +233x |
- #' Will generate children for each subset of a categorical variable.+ unlist(tail( |
||
| 283 | -+ | |||
| 1591 | +233x |
- #'+ value_names(pos), |
||
| 284 | -+ | |||
| 1592 | +233x |
- #' @inheritParams lyt_args+ 1 |
||
| 285 | +1593 |
- #' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference.+ )) |
||
| 286 | +1594 |
- #'+ } |
||
| 287 | -+ | |||
| 1595 | +600x |
- #' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()].+ rawpart <- do_split(spl, df, |
||
| 288 | -+ | |||
| 1596 | +600x |
- #'+ trim = FALSE, |
||
| 289 | -+ | |||
| 1597 | +600x |
- #' @inheritSection custom_split_funs Custom Splitting Function Details+ spl_context = spl_context |
||
| 290 | +1598 |
- #'+ ) |
||
| 291 | -+ | |||
| 1599 | +597x |
- #' @examples+ datparts <- rawpart[["datasplit"]] |
||
| 292 | -+ | |||
| 1600 | +597x |
- #' lyt <- basic_table() %>%+ vals <- rawpart[["values"]] |
||
| 293 | -+ | |||
| 1601 | +597x |
- #' split_cols_by("ARM") %>%
+ labs <- rawpart[["labels"]] |
||
| 294 | +1602 |
- #' analyze(c("AGE", "BMRKR2"))
+
|
||
| 295 | -+ | |||
| 1603 | +597x |
- #'+ force(alt_counts_df) |
||
| 296 | -+ | |||
| 1604 | +597x |
- #' tbl <- build_table(lyt, ex_adsl)+ kids <- mapply( |
||
| 297 | -+ | |||
| 1605 | +597x |
- #' tbl+ function(dfpart, value, partlab) {
|
||
| 298 | +1606 |
- #'+ ## we could pass subset expression in here but the spec |
||
| 299 | +1607 |
- #' # Let's look at the splits in more detail+ ## currently doesn't call for it in column space |
||
| 300 | -+ | |||
| 1608 | +1376x |
- #'+ newprev <- context_df_row( |
||
| 301 | -+ | |||
| 1609 | +1376x |
- #' lyt1 <- basic_table() %>% split_cols_by("ARM")
+ split = obj_name(spl), |
||
| 302 | -+ | |||
| 1610 | +1376x |
- #' lyt1+ value = value_names(value), |
||
| 303 | -+ | |||
| 1611 | +1376x |
- #'+ full_parent_df = list(dfpart), |
||
| 304 | -+ | |||
| 1612 | +1376x |
- #' # add an analysis (summary)+ cinfo = NULL |
||
| 305 | +1613 |
- #' lyt2 <- lyt1 %>%+ ) |
||
| 306 | +1614 |
- #' analyze(c("AGE", "COUNTRY"),
+ ## subset expressions handled inside make_child_pos, |
||
| 307 | +1615 |
- #' afun = list_wrap_x(summary),+ ## value is (optionally, for the moment) carrying it around |
||
| 308 | -+ | |||
| 1616 | +1376x |
- #' format = "xx.xx"+ newpos <- make_child_pos(pos, spl, value, partlab) |
||
| 309 | -+ | |||
| 1617 | +1376x |
- #' )+ acdf_subset_expr <- make_subset_expr(spl, value) |
||
| 310 | -+ | |||
| 1618 | +1376x |
- #' lyt2+ new_acdf_subset <- try(eval(acdf_subset_expr, alt_counts_df), silent = TRUE) |
||
| 311 | -+ | |||
| 1619 | +1376x |
- #'+ if (is(new_acdf_subset, "try-error")) {
|
||
| 312 | -+ | |||
| 1620 | +4x |
- #' tbl2 <- build_table(lyt2, DM)+ stop(sprintf( |
||
| 313 | -+ | |||
| 1621 | +4x |
- #' tbl2+ paste( |
||
| 314 | -+ | |||
| 1622 | +4x |
- #'+ ifelse(identical(df, alt_counts_df), "df", "alt_counts_df"), |
||
| 315 | -+ | |||
| 1623 | +4x |
- #' # By default sequentially adding layouts results in nesting+ "appears incompatible with column-split", |
||
| 316 | -+ | |||
| 1624 | +4x |
- #' library(dplyr)+ "structure. Offending column subset", |
||
| 317 | -+ | |||
| 1625 | +4x |
- #'+ "expression: %s\nOriginal error", |
||
| 318 | -+ | |||
| 1626 | +4x |
- #' DM_MF <- DM %>%+ "message: %s" |
||
| 319 | -+ | |||
| 1627 | +4x |
- #' filter(SEX %in% c("M", "F")) %>%
+ ), deparse(acdf_subset_expr[[1]]), |
||
| 320 | -+ | |||
| 1628 | +4x |
- #' mutate(SEX = droplevels(SEX))+ conditionMessage(attr(new_acdf_subset, "condition")) |
||
| 321 | +1629 |
- #'+ )) |
||
| 322 | +1630 |
- #' lyt3 <- basic_table() %>%+ } |
||
| 323 | +1631 |
- #' split_cols_by("ARM") %>%
+
|
||
| 324 | -+ | |||
| 1632 | +1372x |
- #' split_cols_by("SEX") %>%
+ splitvec_to_coltree(dfpart, splvec, newpos, |
||
| 325 | -+ | |||
| 1633 | +1372x |
- #' analyze(c("AGE", "COUNTRY"),
+ lvl + 1L, partlab, |
||
| 326 | -+ | |||
| 1634 | +1372x |
- #' afun = list_wrap_x(summary),+ spl_context = rbind(spl_context, newprev), |
||
| 327 | -+ | |||
| 1635 | +1372x |
- #' format = "xx.xx"+ alt_counts_df = alt_counts_df[new_acdf_subset, , drop = FALSE], |
||
| 328 | -+ | |||
| 1636 | +1372x |
- #' )+ global_cc_format = global_cc_format |
||
| 329 | +1637 |
- #' lyt3+ ) |
||
| 330 | +1638 |
- #'+ }, |
||
| 331 | -+ | |||
| 1639 | +597x |
- #' tbl3 <- build_table(lyt3, DM_MF)+ dfpart = datparts, value = vals, |
||
| 332 | -+ | |||
| 1640 | +597x |
- #' tbl3+ partlab = labs, SIMPLIFY = FALSE |
||
| 333 | +1641 |
- #'+ ) |
||
| 334 | -+ | |||
| 1642 | +591x |
- #' # nested=TRUE vs not+ disp_cc <- FALSE |
||
| 335 | -+ | |||
| 1643 | +591x |
- #' lyt4 <- basic_table() %>%+ cc_format <- global_cc_format # this doesn't matter probably, but its technically more correct |
||
| 336 | -+ | |||
| 1644 | +591x |
- #' split_cols_by("ARM") %>%
+ if (lvl > 1) {
|
||
| 337 | -+ | |||
| 1645 | +231x |
- #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ disp_cc <- disp_ccounts(splvec[[lvl - 1]]) |
||
| 338 | -+ | |||
| 1646 | +231x |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ cc_format <- colcount_format(splvec[[lvl - 1]]) %||% global_cc_format |
||
| 339 | +1647 |
- #' analyze("AGE")
+ } |
||
| 340 | +1648 |
- #' lyt4+ |
||
| 341 | -+ | |||
| 1649 | +591x |
- #'+ names(kids) <- value_names(vals) |
||
| 342 | -+ | |||
| 1650 | +591x |
- #' tbl4 <- build_table(lyt4, DM)+ LayoutColTree( |
||
| 343 | -+ | |||
| 1651 | +591x |
- #' tbl4+ lev = lvl, label = label, |
||
| 344 | -+ | |||
| 1652 | +591x |
- #'+ spl = spl, |
||
| 345 | -+ | |||
| 1653 | +591x |
- #' lyt5 <- basic_table() %>%+ kids = kids, tpos = pos, |
||
| 346 | -+ | |||
| 1654 | +591x |
- #' split_cols_by("ARM") %>%
+ name = nm, |
||
| 347 | -+ | |||
| 1655 | +591x |
- #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ summary_function = content_fun(spl), |
||
| 348 | -+ | |||
| 1656 | +591x |
- #' analyze("AGE") %>%
+ colcount = NROW(alt_counts_df), |
||
| 349 | -+ | |||
| 1657 | +591x |
- #' split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
+ disp_ccounts = disp_cc, |
||
| 350 | -+ | |||
| 1658 | +591x |
- #' analyze("AGE")
+ colcount_format = cc_format |
||
| 351 | +1659 |
- #' lyt5+ ) |
||
| 352 | +1660 |
- #'+ } |
||
| 353 | +1661 |
- #' tbl5 <- build_table(lyt5, DM)+ } |
||
| 354 | +1662 |
- #' tbl5+ |
||
| 355 | +1663 |
- #'+ # fix_analyze_vis ---- |
||
| 356 | +1664 |
- #' @author Gabriel Becker+ ## now that we know for sure the number of siblings |
||
| 357 | +1665 |
- #' @export+ ## collaplse NAs to TRUE/FALSE for whether |
||
| 358 | +1666 |
- split_cols_by <- function(lyt,+ ## labelrows should be visible for ElementaryTables |
||
| 359 | +1667 |
- var,+ ## generatead from analyzing a single variable |
||
| 360 | -+ | |||
| 1668 | +1009x |
- labels_var = var,+ setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))
|
||
| 361 | +1669 |
- split_label = var,+ |
||
| 362 | +1670 |
- split_fun = NULL,+ setMethod( |
||
| 363 | +1671 |
- format = NULL,+ "fix_analyze_vis", "PreDataTableLayouts", |
||
| 364 | +1672 |
- nested = TRUE,+ function(lyt) {
|
||
| 365 | -+ | |||
| 1673 | +328x |
- child_labels = c("default", "visible", "hidden"),
+ rlayout(lyt) <- fix_analyze_vis(rlayout(lyt))+ |
+ ||
| 1674 | +328x | +
+ lyt |
||
| 366 | +1675 |
- extra_args = list(),+ } |
||
| 367 | +1676 |
- ref_group = NULL) { ## ,
+ ) |
||
| 368 | -254x | +|||
| 1677 | +
- if (is.null(ref_group)) {
+
|
|||
| 369 | -245x | +|||
| 1678 | +
- spl <- VarLevelSplit(+ setMethod( |
|||
| 370 | -245x | +|||
| 1679 | +
- var = var,+ "fix_analyze_vis", "PreDataRowLayout", |
|||
| 371 | -245x | +|||
| 1680 | +
- split_label = split_label,+ function(lyt) {
|
|||
| 372 | -245x | +1681 | +328x |
- labels_var = labels_var,+ splvecs <- lapply(lyt, fix_analyze_vis) |
| 373 | -245x | +1682 | +328x |
- split_format = format,+ PreDataRowLayout( |
| 374 | -245x | +1683 | +328x |
- child_labels = child_labels,+ root = root_spl(lyt), |
| 375 | -245x | +1684 | +328x |
- split_fun = split_fun,+ lst = splvecs |
| 376 | -245x | +|||
| 1685 | +
- extra_args = extra_args+ ) |
|||
| 377 | +1686 |
- )+ } |
||
| 378 | +1687 |
- } else {
+ ) |
||
| 379 | -9x | +|||
| 1688 | +
- spl <- VarLevWBaselineSplit(+ |
|||
| 380 | -9x | +|||
| 1689 | +
- var = var,+ setMethod( |
|||
| 381 | -9x | +|||
| 1690 | +
- ref_group = ref_group,+ "fix_analyze_vis", "SplitVector", |
|||
| 382 | -9x | +|||
| 1691 | +
- split_label = split_label,+ function(lyt) {
|
|||
| 383 | -9x | +1692 | +353x |
- split_fun = split_fun,+ len <- length(lyt) |
| 384 | -9x | +1693 | +353x |
- labels_var = labels_var,+ if (len == 0) {
|
| 385 | -9x | +1694 | +14x |
- split_format = format+ return(lyt) |
| 386 | +1695 |
- )+ } |
||
| 387 | -+ | |||
| 1696 | +339x |
- }+ lastspl <- lyt[[len]] |
||
| 388 | -254x | +1697 | +339x |
- pos <- next_cpos(lyt, nested)+ if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
|
| 389 | -254x | +1698 | +62x |
- split_cols(lyt, spl, pos)+ return(lyt) |
| 390 | +1699 |
- }+ } |
||
| 391 | +1700 | |||
| 392 | -+ | |||
| 1701 | +277x |
- ## .tl_indent ====+ if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
|
||
| 393 | +1702 |
-
+ ## labelrow_visible(lastspl) = FALSE |
||
| 394 | -57x | +1703 | +271x |
- setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))
+ labelrow_visible(lastspl) <- "hidden" |
| 395 | -+ | |||
| 1704 | +6x |
-
+ } else if (is(lastspl, "AnalyzeMultiVar")) {
|
||
| 396 | -+ | |||
| 1705 | +! |
- setMethod(+ pld <- spl_payload(lastspl) |
||
| 397 | -+ | |||
| 1706 | +! |
- ".tl_indent_inner", "PreDataTableLayouts",+ newpld <- lapply(pld, function(sp, havesibs) {
|
||
| 398 | -19x | +|||
| 1707 | +! |
- function(lyt) .tl_indent_inner(rlayout(lyt))+ if (is.na(labelrow_visible(sp))) {
|
||
| 399 | -+ | |||
| 1708 | +! |
- )+ labelrow_visible(sp) <- havesibs |
||
| 400 | +1709 |
- setMethod(+ } |
||
| 401 | -+ | |||
| 1710 | +! |
- ".tl_indent_inner", "PreDataRowLayout",+ }, havesibs = len > 1)+ |
+ ||
| 1711 | +! | +
+ spl_payload(lastspl) <- newpld |
||
| 402 | +1712 |
- function(lyt) {
+ ## pretty sure this isn't needed... |
||
| 403 | -19x | +|||
| 1713 | +! |
- if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
+ if (is.na(label_kids(lastspl))) {
|
||
| 404 | +1714 | ! |
- 0L+ label_kids(lastspl) <- len > 1 |
|
| 405 | +1715 |
- } else {
+ }+ |
+ ||
| 1716 | ++ |
+ } |
||
| 406 | -19x | +1717 | +277x |
- .tl_indent_inner(lyt[[length(lyt)]])+ lyt[[len]] <- lastspl |
| 407 | -+ | |||
| 1718 | +277x |
- }+ lyt |
||
| 408 | +1719 |
} |
||
| 409 | +1720 |
) |
||
| 410 | +1721 | |||
| 411 | +1722 |
- setMethod(+ # check_afun_cfun_params ---- |
||
| 412 | +1723 |
- ".tl_indent_inner", "SplitVector",+ |
||
| 413 | +1724 |
- function(lyt) {
+ # This checks if the input params are used anywhere in cfun/afun+ |
+ ||
| 1725 | ++ |
+ setGeneric("check_afun_cfun_params", function(lyt, params) {
|
||
| 414 | -19x | +1726 | +3188x |
- sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L+ standardGeneric("check_afun_cfun_params")
|
| 415 | +1727 |
- }+ }) |
||
| 416 | +1728 |
- ) ## length(lyt) - 1L)+ |
||
| 417 | +1729 |
-
+ setMethod( |
||
| 418 | +1730 |
- .tl_indent <- function(lyt, nested = TRUE) {
+ "check_afun_cfun_params", "PreDataTableLayouts", |
||
| 419 | -19x | +|||
| 1731 | +
- if (!nested) {
- |
- |||
| 420 | -! | -
- 0L+ function(lyt, params) {
|
||
| 421 | +1732 |
- } else {
+ # clayout does not have analysis functions |
||
| 422 | -19x | +1733 | +319x |
- .tl_indent_inner(lyt)+ check_afun_cfun_params(rlayout(lyt), params) |
| 423 | +1734 |
} |
||
| 424 | +1735 |
- }+ ) |
||
| 425 | +1736 | |||
| 426 | +1737 |
- #' Add rows according to levels of a variable+ setMethod( |
||
| 427 | +1738 |
- #'+ "check_afun_cfun_params", "PreDataRowLayout", |
||
| 428 | +1739 |
- #' @inheritParams lyt_args+ function(lyt, params) {
|
||
| 429 | -+ | |||
| 1740 | +319x |
- #'+ ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params) |
||
| 430 | -+ | |||
| 1741 | +319x |
- #' @inherit split_cols_by return+ r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params) |
||
| 431 | -+ | |||
| 1742 | +319x |
- #'+ Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l)) |
||
| 432 | +1743 |
- #' @inheritSection custom_split_funs Custom Splitting Function Details+ } |
||
| 433 | +1744 |
- #'+ ) |
||
| 434 | +1745 |
- #' @note+ |
||
| 435 | +1746 |
- #' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor+ # Main function for checking parameters |
||
| 436 | +1747 |
- #' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very+ setMethod( |
||
| 437 | +1748 |
- #' informative, but that will change in the future.+ "check_afun_cfun_params", "SplitVector", |
||
| 438 | +1749 |
- #'+ function(lyt, params) {
|
||
| 439 | -+ | |||
| 1750 | +765x |
- #' @examples+ param_l <- lapply(lyt, check_afun_cfun_params, params = params) |
||
| 440 | -+ | |||
| 1751 | +765x |
- #' lyt <- basic_table() %>%+ Reduce(`|`, param_l) |
||
| 441 | +1752 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 442 | +1753 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ ) |
||
| 443 | +1754 |
- #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
+
|
||
| 444 | +1755 |
- #'+ # Helper function for check_afun_cfun_params |
||
| 445 | +1756 |
- #' tbl <- build_table(lyt, DM)+ .afun_cfun_switch <- function(spl_i) {
|
||
| 446 | -+ | |||
| 1757 | +1784x |
- #' tbl+ if (is(spl_i, "VAnalyzeSplit")) {
|
||
| 447 | -+ | |||
| 1758 | +607x |
- #'+ analysis_fun(spl_i) |
||
| 448 | +1759 |
- #' lyt2 <- basic_table() %>%+ } else {
|
||
| 449 | -+ | |||
| 1760 | +1177x |
- #' split_cols_by("ARM") %>%
+ content_fun(spl_i) |
||
| 450 | +1761 |
- #' split_rows_by("RACE") %>%
+ } |
||
| 451 | +1762 |
- #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
+ } |
||
| 452 | +1763 |
- #'+ |
||
| 453 | +1764 |
- #' tbl2 <- build_table(lyt2, DM)+ # Extreme case that happens only when using add_existing_table |
||
| 454 | +1765 |
- #' tbl2+ setMethod( |
||
| 455 | +1766 |
- #'+ "check_afun_cfun_params", "VTableTree", |
||
| 456 | +1767 |
- #' lyt3 <- basic_table() %>%+ function(lyt, params) {
|
||
| 457 | -+ | |||
| 1768 | +1x |
- #' split_cols_by("ARM") %>%
+ setNames(logical(length(params)), params) # All FALSE |
||
| 458 | +1769 |
- #' split_cols_by("SEX") %>%
+ } |
||
| 459 | +1770 |
- #' summarize_row_groups(label_fstr = "Overall (N)") %>%+ ) |
||
| 460 | +1771 |
- #' split_rows_by("RACE",
+
|
||
| 461 | +1772 |
- #' split_label = "Ethnicity", labels_var = "ethn_lab",+ setMethod( |
||
| 462 | +1773 |
- #' split_fun = drop_split_levels+ "check_afun_cfun_params", "Split", |
||
| 463 | +1774 |
- #' ) %>%+ function(lyt, params) {
|
||
| 464 | +1775 |
- #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
+ # Extract function in the split |
||
| 465 | -+ | |||
| 1776 | +1784x |
- #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
+ fnc <- .afun_cfun_switch(lyt) |
||
| 466 | +1777 |
- #'+ |
||
| 467 | +1778 |
- #' lyt3+ # For each parameter, check if it is called |
||
| 468 | -+ | |||
| 1779 | +1784x |
- #'+ sapply(params, function(pai) any(unlist(func_takes(fnc, pai)))) |
||
| 469 | +1780 |
- #' library(dplyr)+ } |
||
| 470 | +1781 |
- #'+ ) |
||
| 471 | +1782 |
- #' DM2 <- DM %>%+ |
||
| 472 | +1783 |
- #' filter(SEX %in% c("M", "F")) %>%
+ # Helper functions ---- |
||
| 473 | +1784 |
- #' mutate(+ |
||
| 474 | -+ | |||
| 1785 | +231x |
- #' SEX = droplevels(SEX),+ count <- function(df, ...) NROW(df) |
||
| 475 | +1786 |
- #' gender_lab = c(+ |
||
| 476 | +1787 |
- #' "F" = "Female", "M" = "Male",+ guess_format <- function(val) {
|
||
| 477 | -+ | |||
| 1788 | +1054x |
- #' "U" = "Unknown",+ if (length(val) == 1) {
|
||
| 478 | -+ | |||
| 1789 | +1042x |
- #' "UNDIFFERENTIATED" = "Undifferentiated"+ if (is.integer(val) || !is.numeric(val)) {
|
||
| 479 | -+ | |||
| 1790 | +226x |
- #' )[SEX],+ "xx" |
||
| 480 | +1791 |
- #' ethn_lab = c(+ } else {
|
||
| 481 | -+ | |||
| 1792 | +816x |
- #' "ASIAN" = "Asian",+ "xx.xx" |
||
| 482 | +1793 |
- #' "BLACK OR AFRICAN AMERICAN" = "Black or African American",+ } |
||
| 483 | -+ | |||
| 1794 | +12x |
- #' "WHITE" = "White",+ } else if (length(val) == 2) {
|
||
| 484 | -+ | |||
| 1795 | +12x |
- #' "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native",+ "xx.x / xx.x" |
||
| 485 | -+ | |||
| 1796 | +! |
- #' "MULTIPLE" = "Multiple",+ } else if (length(val) == 3) {
|
||
| 486 | -+ | |||
| 1797 | +! |
- #' "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" =+ "xx.x (xx.x - xx.x)" |
||
| 487 | +1798 |
- #' "Native Hawaiian or Other Pacific Islander",+ } else {
|
||
| 488 | -+ | |||
| 1799 | +! |
- #' "OTHER" = "Other", "UNKNOWN" = "Unknown"+ stop("got value of length > 3")
|
||
| 489 | +1800 |
- #' )[RACE]+ } |
||
| 490 | +1801 |
- #' )+ } |
||
| 491 | +1802 |
- #'+ |
||
| 492 | +1803 |
- #' tbl3 <- build_table(lyt3, DM2)+ .quick_afun <- function(afun, lbls) {
|
||
| 493 | -+ | |||
| 1804 | +14x |
- #' tbl3+ if (.takes_df(afun)) {
|
||
| 494 | -+ | |||
| 1805 | +5x |
- #'+ function(df, .spl_context, ...) {
|
||
| 495 | -+ | |||
| 1806 | +226x |
- #' @author Gabriel Becker+ if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
|
||
| 496 | -+ | |||
| 1807 | +222x |
- #' @export+ lbls <- tail(.spl_context$value, 1) |
||
| 497 | +1808 |
- split_rows_by <- function(lyt,+ } |
||
| 498 | -+ | |||
| 1809 | +226x |
- var,+ if (".spl_context" %in% names(formals(afun))) {
|
||
| 499 | -+ | |||
| 1810 | +! |
- labels_var = var,+ res <- afun(df = df, .spl_context = .spl_context, ...) |
||
| 500 | +1811 |
- split_label = var,+ } else {
|
||
| 501 | -+ | |||
| 1812 | +226x |
- split_fun = NULL,+ res <- afun(df = df, ...) |
||
| 502 | +1813 |
- format = NULL,+ } |
||
| 503 | -+ | |||
| 1814 | +226x |
- na_str = NA_character_,+ if (is(res, "RowsVerticalSection")) {
|
||
| 504 | -+ | |||
| 1815 | +! |
- nested = TRUE,+ ret <- res |
||
| 505 | +1816 |
- child_labels = c("default", "visible", "hidden"),
+ } else {
|
||
| 506 | -+ | |||
| 1817 | +226x |
- label_pos = "hidden",+ if (!is.list(res)) {
|
||
| 507 | -+ | |||
| 1818 | +226x |
- indent_mod = 0L,+ ret <- rcell(res, label = lbls, format = guess_format(res)) |
||
| 508 | +1819 |
- page_by = FALSE,+ } else {
+ |
+ ||
| 1820 | +! | +
+ if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ |
+ ||
| 1821 | +! | +
+ names(res) <- lbls |
||
| 509 | +1822 |
- page_prefix = split_label,+ }+ |
+ ||
| 1823 | +! | +
+ ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, "")) |
||
| 510 | +1824 |
- section_div = NA_character_) {
+ } |
||
| 511 | -243x | +|||
| 1825 | +
- label_pos <- match.arg(label_pos, label_pos_values)+ } |
|||
| 512 | -243x | +1826 | +226x |
- child_labels <- match.arg(child_labels)+ ret |
| 513 | -243x | +|||
| 1827 | +
- spl <- VarLevelSplit(+ } |
|||
| 514 | -243x | +|||
| 1828 | +
- var = var,+ } else {
|
|||
| 515 | -243x | +1829 | +9x |
- split_label = split_label,+ function(x, .spl_context, ...) {
|
| 516 | -243x | +1830 | +387x |
- label_pos = label_pos,+ if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
|
| 517 | -243x | +1831 | +225x |
- labels_var = labels_var,+ lbls <- tail(.spl_context$value, 1) |
| 518 | -243x | +|||
| 1832 | +
- split_fun = split_fun,+ } |
|||
| 519 | -243x | +1833 | +387x |
- split_format = format,+ if (".spl_context" %in% names(formals(afun))) {
|
| 520 | -243x | +|||
| 1834 | +! |
- split_na_str = na_str,+ res <- afun(x = x, .spl_context = .spl_context, ...) |
||
| 521 | -243x | +|||
| 1835 | +
- child_labels = child_labels,+ } else {
|
|||
| 522 | -243x | +1836 | +387x |
- indent_mod = indent_mod,+ res <- afun(x = x, ...) |
| 523 | -243x | +|||
| 1837 | +
- page_prefix = if (page_by) page_prefix else NA_character_,+ } |
|||
| 524 | -243x | +1838 | +387x |
- section_div = section_div+ if (is(res, "RowsVerticalSection")) {
|
| 525 | -+ | |||
| 1839 | +! |
- )+ ret <- res |
||
| 526 | +1840 |
-
+ } else {
|
||
| 527 | -243x | +1841 | +387x |
- pos <- next_rpos(lyt, nested)+ if (!is.list(res)) {
|
| 528 | -243x | +1842 | +297x |
- ret <- split_rows(lyt, spl, pos)+ ret <- rcell(res, label = lbls, format = guess_format(res)) |
| 529 | +1843 |
-
+ } else {
|
||
| 530 | -241x | +1844 | +90x |
- ret+ if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
|
| 531 | -+ | |||
| 1845 | +9x |
- }+ names(res) <- lbls |
||
| 532 | +1846 |
-
+ } |
||
| 533 | -+ | |||
| 1847 | +90x |
- #' Associate multiple variables with columns+ ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, "")) |
||
| 534 | +1848 |
- #'+ } |
||
| 535 | +1849 |
- #' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis.+ } |
||
| 536 | -+ | |||
| 1850 | +387x |
- #' When we need columns to reflect different variables entirely, rather than different levels of a single+ ret |
||
| 537 | +1851 |
- #' variable, we use `split_cols_by_multivar`.+ } |
||
| 538 | +1852 |
- #'+ } |
||
| 539 | +1853 |
- #' @inheritParams lyt_args+ } |
||
| 540 | +1854 |
- #'+ |
||
| 541 | +1855 |
- #' @inherit split_cols_by return+ # qtable ---- |
||
| 542 | +1856 |
- #'+ |
||
| 543 | +1857 |
- #' @seealso [analyze_colvars()]+ n_cells_res <- function(res) {
|
||
| 544 | -+ | |||
| 1858 | +8x |
- #'+ ans <- 1L |
||
| 545 | -+ | |||
| 1859 | +8x |
- #' @examples+ if (is.list(res)) {
|
||
| 546 | -+ | |||
| 1860 | +4x |
- #' library(dplyr)+ ans <- length(res) |
||
| 547 | -+ | |||
| 1861 | +4x |
- #'+ } else if (is(res, "RowsVerticalSection")) {
|
||
| 548 | -+ | |||
| 1862 | +! |
- #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))+ ans <- length(res$values) |
||
| 549 | +1863 |
- #'+ } # XXX penetrating the abstraction |
||
| 550 | -+ | |||
| 1864 | +8x |
- #' ## toy example where we take the mean of the first variable and the+ ans |
||
| 551 | +1865 |
- #' ## count of >.5 for the second.+ } |
||
| 552 | +1866 |
- #' colfuns <- list(+ |
||
| 553 | +1867 |
- #' function(x) in_rows(mean = mean(x), .formats = "xx.x"),+ #' Generalized frequency table |
||
| 554 | +1868 |
- #' function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
+ #' |
||
| 555 | +1869 |
- #' )+ #' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and |
||
| 556 | +1870 |
- #'+ #' column space can be facetted by variables, and an analysis function can be specified. The function then builds a |
||
| 557 | +1871 |
- #' lyt <- basic_table() %>%+ #' layout with the specified layout and applies it to the data provided. |
||
| 558 | +1872 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 559 | +1873 |
- #' split_cols_by_multivar(c("value", "pctdiff")) %>%
+ #' @inheritParams constr_args |
||
| 560 | +1874 |
- #' split_rows_by("RACE",
+ #' @inheritParams basic_table |
||
| 561 | +1875 |
- #' split_label = "ethnicity",+ #' @param row_vars (`character`)\cr the names of variables to be used in row facetting. |
||
| 562 | +1876 |
- #' split_fun = drop_split_levels+ #' @param col_vars (`character`)\cr the names of variables to be used in column facetting. |
||
| 563 | +1877 |
- #' ) %>%+ #' @param data (`data.frame`)\cr the data to tabulate. |
||
| 564 | +1878 |
- #' summarize_row_groups() %>%+ #' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`. |
||
| 565 | +1879 |
- #' analyze_colvars(afun = colfuns)+ #' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must |
||
| 566 | +1880 |
- #' lyt+ #' match the number of rows generated by `afun`. |
||
| 567 | +1881 |
- #'+ #' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis |
||
| 568 | +1882 |
- #' tbl <- build_table(lyt, ANL)+ #' function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas |
||
| 569 | +1883 |
- #' tbl+ #' lists are interpreted as multiple cells. |
||
| 570 | +1884 |
- #'+ #' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to |
||
| 571 | +1885 |
- #' @author Gabriel Becker+ #' `TRUE`. |
||
| 572 | +1886 |
- #' @export+ #' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to |
||
| 573 | +1887 |
- split_cols_by_multivar <- function(lyt,+ #' `FALSE`. |
||
| 574 | +1888 |
- vars,+ #' @param ... additional arguments passed to `afun`. |
||
| 575 | +1889 |
- split_fun = NULL,+ #' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users. |
||
| 576 | +1890 |
- varlabels = vars,+ #' |
||
| 577 | +1891 |
- varnames = NULL,+ #' @details |
||
| 578 | +1892 |
- nested = TRUE,+ #' This function creates a table with a single top-level structure in both row and column dimensions involving faceting |
||
| 579 | +1893 |
- extra_args = list()) {
- |
- ||
| 580 | -24x | -
- spl <- MultiVarSplit(+ #' by 0 or more variables in each dimension. |
||
| 581 | -24x | +|||
| 1894 | +
- vars = vars, split_label = "",+ #' |
|||
| 582 | -24x | +|||
| 1895 | +
- varlabels = varlabels,+ #' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a |
|||
| 583 | -24x | +|||
| 1896 | +
- varnames = varnames,+ #' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row |
|||
| 584 | -24x | +|||
| 1897 | +
- split_fun = split_fun,+ #' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun` |
|||
| 585 | -24x | +|||
| 1898 | +
- extra_args = extra_args+ #' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row |
|||
| 586 | +1899 |
- )+ #' labels and the deepest-nested facet row labels will be visible. |
||
| 587 | -24x | +|||
| 1900 | +
- pos <- next_cpos(lyt, nested)+ #' |
|||
| 588 | -24x | +|||
| 1901 | +
- split_cols(lyt, spl, pos)+ #' The table will be annotated in the top-left area with an informative label displaying the analysis variable |
|||
| 589 | +1902 |
- }+ #' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception |
||
| 590 | +1903 |
-
+ #' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and |
||
| 591 | +1904 |
- #' Associate multiple variables with rows+ #' an `afun` which returns a single row. |
||
| 592 | +1905 |
#' |
||
| 593 | +1906 |
- #' When we need rows to reflect different variables rather than different+ #' @return |
||
| 594 | +1907 |
- #' levels of a single variable, we use `split_rows_by_multivar`.+ #' * `qtable` returns a built `TableTree` object representing the desired table |
||
| 595 | +1908 |
- #'+ #' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for |
||
| 596 | +1909 |
- #' @inheritParams lyt_args+ #' passing to [build_table()]. |
||
| 597 | +1910 |
#' |
||
| 598 | +1911 |
- #' @inherit split_rows_by return+ #' @examples |
||
| 599 | +1912 |
- #'+ #' qtable(ex_adsl) |
||
| 600 | +1913 |
- #' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of+ #' qtable(ex_adsl, row_vars = "ARM") |
||
| 601 | +1914 |
- #' split on a column basis.+ #' qtable(ex_adsl, col_vars = "ARM") |
||
| 602 | +1915 |
- #'+ #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM") |
||
| 603 | +1916 |
- #' @examples+ #' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
|
||
| 604 | +1917 |
- #' lyt <- basic_table() %>%+ #' qtable(ex_adsl, |
||
| 605 | +1918 |
- #' split_cols_by("ARM") %>%
+ #' row_vars = c("COUNTRY", "SEX"),
|
||
| 606 | +1919 |
- #' split_rows_by_multivar(c("SEX", "STRATA1")) %>%
+ #' col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
|
||
| 607 | +1920 |
- #' summarize_row_groups() %>%+ #' ) |
||
| 608 | +1921 |
- #' analyze(c("AGE", "SEX"))
+ #' summary_list <- function(x, ...) as.list(summary(x)) |
||
| 609 | +1922 |
- #'+ #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list) |
||
| 610 | +1923 |
- #' tbl <- build_table(lyt, DM)+ #' suppressWarnings(qtable(ex_adsl, |
||
| 611 | +1924 |
- #' tbl+ #' row_vars = "SEX", |
||
| 612 | +1925 |
- #'+ #' col_vars = "ARM", avar = "AGE", afun = range |
||
| 613 | +1926 |
- #' @export+ #' )) |
||
| 614 | +1927 |
- split_rows_by_multivar <- function(lyt,+ #' |
||
| 615 | +1928 |
- vars,+ #' @export |
||
| 616 | +1929 |
- split_fun = NULL,+ qtable_layout <- function(data, |
||
| 617 | +1930 |
- split_label = "",+ row_vars = character(), |
||
| 618 | +1931 |
- varlabels = vars,+ col_vars = character(), |
||
| 619 | +1932 |
- format = NULL,+ avar = NULL, |
||
| 620 | +1933 |
- na_str = NA_character_,+ row_labels = NULL, |
||
| 621 | +1934 |
- nested = TRUE,+ afun = NULL, |
||
| 622 | +1935 |
- child_labels = c("default", "visible", "hidden"),
+ summarize_groups = FALSE, |
||
| 623 | +1936 |
- indent_mod = 0L,+ title = "", |
||
| 624 | +1937 |
- section_div = NA_character_,+ subtitles = character(), |
||
| 625 | +1938 |
- extra_args = list()) {
- |
- ||
| 626 | -2x | -
- child_labels <- match.arg(child_labels)- |
- ||
| 627 | -2x | -
- spl <- MultiVarSplit(+ main_footer = character(), |
||
| 628 | -2x | +|||
| 1939 | +
- vars = vars, split_label = split_label, varlabels,+ prov_footer = character(), |
|||
| 629 | -2x | +|||
| 1940 | +
- split_format = format,+ show_colcounts = TRUE, |
|||
| 630 | -2x | +|||
| 1941 | +
- split_na_str = na_str,+ drop_levels = TRUE, |
|||
| 631 | -2x | +|||
| 1942 | +
- child_labels = child_labels,+ ..., |
|||
| 632 | -2x | +|||
| 1943 | +
- indent_mod = indent_mod,+ .default_rlabel = NULL) {
|
|||
| 633 | -2x | +1944 | +16x |
- split_fun = split_fun,+ subafun <- substitute(afun) |
| 634 | -2x | +1945 | +16x |
- section_div = section_div,+ if (!is.null(.default_rlabel)) {
|
| 635 | -2x | +1946 | +16x |
- extra_args = extra_args+ dflt_row_lbl <- .default_rlabel |
| 636 | +1947 |
- )- |
- ||
| 637 | -2x | -
- pos <- next_rpos(lyt, nested)+ } else if ( |
||
| 638 | -2x | +|||
| 1948 | +! |
- split_rows(lyt, spl, pos)+ is.name(subafun) && |
||
| 639 | -+ | |||
| 1949 | +! |
- }+ is.function(afun) && |
||
| 640 | +1950 |
-
+ ## this is gross. basically testing |
||
| 641 | +1951 |
- #' Split on static or dynamic cuts of the data+ ## if the symbol we have corresponds |
||
| 642 | +1952 |
- #'+ ## in some meaningful way to the function |
||
| 643 | +1953 |
- #' Create columns (or row splits) based on values (such as quartiles) of `var`.+ ## we will be calling. |
||
| 644 | -+ | |||
| 1954 | +! |
- #'+ identical( |
||
| 645 | -+ | |||
| 1955 | +! |
- #' @inheritParams lyt_args+ mget( |
||
| 646 | -+ | |||
| 1956 | +! |
- #'+ as.character(subafun), |
||
| 647 | -+ | |||
| 1957 | +! |
- #' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*,+ mode = "function", |
||
| 648 | -+ | |||
| 1958 | +! |
- #' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect+ envir = parent.frame(1), |
||
| 649 | -+ | |||
| 1959 | +! |
- #' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under.+ ifnotfound = list(NULL), |
||
| 650 | -+ | |||
| 1960 | +! |
- #'+ inherits = TRUE |
||
| 651 | -+ | |||
| 1961 | +! |
- #' @inherit split_cols_by return+ )[[1]], |
||
| 652 | -+ | |||
| 1962 | +! |
- #'+ afun |
||
| 653 | +1963 |
- #' @examples+ ) |
||
| 654 | +1964 |
- #' library(dplyr)+ ) {
|
||
| 655 | -+ | |||
| 1965 | +! |
- #'+ dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ") |
||
| 656 | +1966 |
- #' # split_cols_by_cuts+ } else {
|
||
| 657 | -+ | |||
| 1967 | +! |
- #' lyt <- basic_table() %>%+ dflt_row_lbl <- if (is.null(avar)) "count" else avar |
||
| 658 | +1968 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 659 | +1969 |
- #' split_cols_by_cuts("AGE",
+
|
||
| 660 | -+ | |||
| 1970 | +16x |
- #' split_label = "Age",+ if (is.null(afun)) {
|
||
| 661 | -+ | |||
| 1971 | +5x |
- #' cuts = c(0, 25, 35, 1000),+ afun <- count |
||
| 662 | +1972 |
- #' cutlabels = c("young", "medium", "old")
+ } |
||
| 663 | +1973 |
- #' ) %>%+ |
||
| 664 | -+ | |||
| 1974 | +16x |
- #' analyze(c("BMRKR2", "STRATA2")) %>%
+ if (is.null(avar)) {
|
||
| 665 | -+ | |||
| 1975 | +5x |
- #' append_topleft("counts")
+ avar <- names(data)[1] |
||
| 666 | +1976 |
- #'+ } |
||
| 667 | -+ | |||
| 1977 | +16x |
- #' tbl <- build_table(lyt, ex_adsl)+ fakeres <- afun(data[[avar]], ...) |
||
| 668 | -+ | |||
| 1978 | +16x |
- #' tbl+ multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups |
||
| 669 | +1979 |
- #'+ ## this is before we plug in the default so if not specified by the user |
||
| 670 | +1980 |
- #' # split_rows_by_cuts+ ## explicitly, row_labels is NULL at this point. |
||
| 671 | -+ | |||
| 1981 | +16x |
- #' lyt2 <- basic_table() %>%+ if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
|
||
| 672 | -+ | |||
| 1982 | +2x |
- #' split_cols_by("ARM") %>%
+ stop( |
||
| 673 | -+ | |||
| 1983 | +2x |
- #' split_rows_by_cuts("AGE",
+ "Length of row_labels (",
|
||
| 674 | -+ | |||
| 1984 | +2x |
- #' split_label = "Age",+ length(row_labels), |
||
| 675 | -+ | |||
| 1985 | +2x |
- #' cuts = c(0, 25, 35, 1000),+ ") does not agree with number of rows generated by analysis function (",
|
||
| 676 | -+ | |||
| 1986 | +2x |
- #' cutlabels = c("young", "medium", "old")
+ n_cells_res(fakeres), |
||
| 677 | +1987 |
- #' ) %>%+ ")." |
||
| 678 | +1988 |
- #' analyze(c("BMRKR2", "STRATA2")) %>%
+ ) |
||
| 679 | +1989 |
- #' append_topleft("counts")
+ } |
||
| 680 | +1990 |
- #'+ |
||
| 681 | -+ | |||
| 1991 | +14x |
- #'+ if (is.null(row_labels)) {
|
||
| 682 | -+ | |||
| 1992 | +10x |
- #' tbl2 <- build_table(lyt2, ex_adsl)+ row_labels <- dflt_row_lbl |
||
| 683 | +1993 |
- #' tbl2+ } |
||
| 684 | +1994 |
- #'+ |
||
| 685 | -+ | |||
| 1995 | +14x |
- #' # split_cols_by_quartiles+ lyt <- basic_table( |
||
| 686 | -+ | |||
| 1996 | +14x |
- #'+ title = title, |
||
| 687 | -+ | |||
| 1997 | +14x |
- #' lyt3 <- basic_table() %>%+ subtitles = subtitles, |
||
| 688 | -+ | |||
| 1998 | +14x |
- #' split_cols_by("ARM") %>%
+ main_footer = main_footer, |
||
| 689 | -+ | |||
| 1999 | +14x |
- #' split_cols_by_quartiles("AGE", split_label = "Age") %>%
+ prov_footer = prov_footer, |
||
| 690 | -+ | |||
| 2000 | +14x |
- #' analyze(c("BMRKR2", "STRATA2")) %>%
+ show_colcounts = show_colcounts |
||
| 691 | +2001 |
- #' append_topleft("counts")
+ ) |
||
| 692 | +2002 |
- #'+ |
||
| 693 | -+ | |||
| 2003 | +14x |
- #' tbl3 <- build_table(lyt3, ex_adsl)+ for (var in col_vars) lyt <- split_cols_by(lyt, var) |
||
| 694 | +2004 |
- #' tbl3+ |
||
| 695 | -+ | |||
| 2005 | +14x |
- #'+ for (var in head(row_vars, -1)) {
|
||
| 696 | -+ | |||
| 2006 | +4x |
- #' # split_rows_by_quartiles+ lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL) |
||
| 697 | -+ | |||
| 2007 | +4x |
- #' lyt4 <- basic_table(show_colcounts = TRUE) %>%+ if (summarize_groups) {
|
||
| 698 | -+ | |||
| 2008 | +2x |
- #' split_cols_by("ARM") %>%
+ lyt <- summarize_row_groups(lyt) |
||
| 699 | +2009 |
- #' split_rows_by_quartiles("AGE", split_label = "Age") %>%
+ } |
||
| 700 | +2010 |
- #' analyze("BMRKR2") %>%
+ } |
||
| 701 | +2011 |
- #' append_topleft(c("Age Quartiles", " Counts BMRKR2"))
+
|
||
| 702 | -+ | |||
| 2012 | +14x |
- #'+ tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character() |
||
| 703 | -+ | |||
| 2013 | +14x |
- #' tbl4 <- build_table(lyt4, ex_adsl)+ if (length(row_vars) > 0) {
|
||
| 704 | -+ | |||
| 2014 | +10x |
- #' tbl4+ if (!multirow) {
|
||
| 705 | +2015 |
- #'+ ## in the single row in splitting case, we use the row label as the topleft |
||
| 706 | +2016 |
- #' # split_cols_by_cutfun+ ## and the split values as the row labels for a more compact apeparance |
||
| 707 | -+ | |||
| 2017 | +6x |
- #' cutfun <- function(x) {
+ tleft <- row_labels |
||
| 708 | -+ | |||
| 2018 | +6x |
- #' cutpoints <- c(+ row_labels <- NA_character_ |
||
| 709 | -+ | |||
| 2019 | +6x |
- #' min(x),+ lyt <- split_rows_by( |
||
| 710 | -+ | |||
| 2020 | +6x |
- #' mean(x),+ lyt, tail(row_vars, 1), |
||
| 711 | -+ | |||
| 2021 | +6x |
- #' max(x)+ split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden" |
||
| 712 | +2022 |
- #' )+ ) |
||
| 713 | +2023 |
- #'+ } else {
|
||
| 714 | -+ | |||
| 2024 | +4x |
- #' names(cutpoints) <- c("", "Younger", "Older")
+ lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL) |
||
| 715 | +2025 |
- #' cutpoints+ } |
||
| 716 | -+ | |||
| 2026 | +10x |
- #' }+ if (summarize_groups) {
|
||
| 717 | -+ | |||
| 2027 | +2x |
- #'+ lyt <- summarize_row_groups(lyt) |
||
| 718 | +2028 |
- #' lyt5 <- basic_table() %>%+ } |
||
| 719 | +2029 |
- #' split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
+ } |
||
| 720 | -+ | |||
| 2030 | +14x |
- #' analyze("SEX")
+ inner_afun <- .quick_afun(afun, row_labels) |
||
| 721 | -+ | |||
| 2031 | +14x |
- #'+ lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...)) |
||
| 722 | -+ | |||
| 2032 | +14x |
- #' tbl5 <- build_table(lyt5, ex_adsl)+ lyt <- append_topleft(lyt, tleft) |
||
| 723 | +2033 |
- #' tbl5+ } |
||
| 724 | +2034 |
- #'+ |
||
| 725 | +2035 |
- #' # split_rows_by_cutfun+ #' @rdname qtable_layout |
||
| 726 | +2036 |
- #' lyt6 <- basic_table() %>%+ #' @export |
||
| 727 | +2037 |
- #' split_cols_by("SEX") %>%
+ qtable <- function(data, |
||
| 728 | +2038 |
- #' split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
+ row_vars = character(), |
||
| 729 | +2039 |
- #' analyze("BMRKR2")
+ col_vars = character(), |
||
| 730 | +2040 |
- #'+ avar = NULL, |
||
| 731 | +2041 |
- #' tbl6 <- build_table(lyt6, ex_adsl)+ row_labels = NULL, |
||
| 732 | +2042 |
- #' tbl6+ afun = NULL, |
||
| 733 | +2043 |
- #'+ summarize_groups = FALSE, |
||
| 734 | +2044 |
- #' @author Gabriel Becker+ title = "", |
||
| 735 | +2045 |
- #' @export+ subtitles = character(), |
||
| 736 | +2046 |
- #' @rdname varcuts+ main_footer = character(), |
||
| 737 | +2047 |
- split_cols_by_cuts <- function(lyt, var, cuts,+ prov_footer = character(), |
||
| 738 | +2048 |
- cutlabels = NULL,+ show_colcounts = TRUE, |
||
| 739 | +2049 |
- split_label = var,+ drop_levels = TRUE, |
||
| 740 | +2050 |
- nested = TRUE,+ ...) {
|
||
| 741 | +2051 |
- cumulative = FALSE) {
- |
- ||
| 742 | -3x | -
- spl <- make_static_cut_split(- |
- ||
| 743 | -3x | -
- var = var,+ ## this involves substitution so it needs to appear in both functions. Gross but true. |
||
| 744 | -3x | +2052 | +16x |
- split_label = split_label,+ subafun <- substitute(afun) |
| 745 | -3x | +|||
| 2053 | +
- cuts = cuts,+ if ( |
|||
| 746 | -3x | +2054 | +16x |
- cutlabels = cutlabels,+ is.name(subafun) && is.function(afun) && |
| 747 | -3x | +|||
| 2055 | +
- cumulative = cumulative+ ## this is gross. basically testing |
|||
| 748 | +2056 |
- )+ ## if the symbol we have corresponds |
||
| 749 | +2057 |
- ## if(cumulative)+ ## in some meaningful way to the function |
||
| 750 | +2058 |
- ## spl = as(spl, "CumulativeCutSplit")+ ## we will be calling. |
||
| 751 | -3x | +2059 | +16x |
- pos <- next_cpos(lyt, nested)+ identical( |
| 752 | -3x | +2060 | +16x |
- split_cols(lyt, spl, pos)+ mget( |
| 753 | -+ | |||
| 2061 | +16x |
- }+ as.character(subafun), |
||
| 754 | -+ | |||
| 2062 | +16x |
-
+ mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE |
||
| 755 | -+ | |||
| 2063 | +16x |
- #' @export+ )[[1]], |
||
| 756 | -+ | |||
| 2064 | +16x |
- #' @rdname varcuts+ afun |
||
| 757 | +2065 |
- split_rows_by_cuts <- function(lyt, var, cuts,+ ) |
||
| 758 | +2066 |
- cutlabels = NULL,+ ) {
|
||
| 759 | -+ | |||
| 2067 | +11x |
- split_label = var,+ dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ") |
||
| 760 | +2068 |
- format = NULL,+ } else {
|
||
| 761 | -+ | |||
| 2069 | +5x |
- na_str = NA_character_,+ dflt_row_lbl <- if (is.null(avar)) "count" else avar |
||
| 762 | +2070 |
- nested = TRUE,+ } |
||
| 763 | +2071 |
- cumulative = FALSE,+ |
||
| 764 | -+ | |||
| 2072 | +16x |
- label_pos = "hidden",+ lyt <- qtable_layout( |
||
| 765 | -+ | |||
| 2073 | +16x |
- section_div = NA_character_) {
+ data = data, |
||
| 766 | -2x | +2074 | +16x |
- label_pos <- match.arg(label_pos, label_pos_values)+ row_vars = row_vars, |
| 767 | -+ | |||
| 2075 | +16x |
- ## VarStaticCutSplit(+ col_vars = col_vars, |
||
| 768 | -2x | +2076 | +16x |
- spl <- make_static_cut_split(var, split_label,+ avar = avar, |
| 769 | -2x | +2077 | +16x |
- cuts = cuts,+ row_labels = row_labels, |
| 770 | -2x | +2078 | +16x |
- cutlabels = cutlabels,+ afun = afun, |
| 771 | -2x | +2079 | +16x |
- split_format = format,+ summarize_groups = summarize_groups, |
| 772 | -2x | +2080 | +16x |
- split_na_str = na_str,+ title = title, |
| 773 | -2x | +2081 | +16x |
- label_pos = label_pos,+ subtitles = subtitles, |
| 774 | -2x | +2082 | +16x |
- cumulative = cumulative,+ main_footer = main_footer, |
| 775 | -2x | +2083 | +16x |
- section_div = section_div+ prov_footer = prov_footer, |
| 776 | -+ | |||
| 2084 | +16x |
- )+ show_colcounts = show_colcounts, |
||
| 777 | -+ | |||
| 2085 | +16x |
- ## if(cumulative)+ drop_levels = drop_levels, |
||
| 778 | +2086 |
- ## spl = as(spl, "CumulativeCutSplit")- |
- ||
| 779 | -2x | -
- pos <- next_rpos(lyt, nested)+ ..., |
||
| 780 | -2x | +2087 | +16x |
- split_rows(lyt, spl, pos)+ .default_rlabel = dflt_row_lbl |
| 781 | +2088 |
- }+ ) |
||
| 782 | -+ | |||
| 2089 | +14x |
-
+ build_table(lyt, data) |
||
| 783 | +2090 |
- #' @export+ } |
| 784 | +1 |
- #' @rdname varcuts+ #' Variable associated with a split |
||
| 785 | +2 |
- split_cols_by_cutfun <- function(lyt, var,+ #' |
||
| 786 | +3 |
- cutfun = qtile_cuts,+ #' This function is intended for use when writing custom splitting logic. In cases where the split is associated with |
||
| 787 | +4 |
- cutlabelfun = function(x) NULL,+ #' a single variable, the name of that variable will be returned. At time of writing this includes splits generated |
||
| 788 | +5 |
- split_label = var,+ #' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()], |
||
| 789 | +6 |
- nested = TRUE,+ #' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives. |
||
| 790 | +7 |
- extra_args = list(),+ #' |
||
| 791 | +8 |
- cumulative = FALSE) {
+ #' @param spl (`VarLevelSplit`)\cr the split object. |
||
| 792 | -3x | +|||
| 9 | +
- spl <- VarDynCutSplit(var, split_label,+ #' |
|||
| 793 | -3x | +|||
| 10 | +
- cutfun = cutfun,+ #' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised. |
|||
| 794 | -3x | +|||
| 11 | +
- cutlabelfun = cutlabelfun,+ #' |
|||
| 795 | -3x | +|||
| 12 | +
- extra_args = extra_args,+ #' @export |
|||
| 796 | -3x | +|||
| 13 | +
- cumulative = cumulative,+ #' @seealso \code{\link{make_split_fun}}
|
|||
| 797 | -3x | +14 | +2x |
- label_pos = "hidden"+ setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
|
| 798 | +15 |
- )+ |
||
| 799 | -3x | +|||
| 16 | +
- pos <- next_cpos(lyt, nested)+ #' @rdname spl_variable+ |
+ |||
| 17 | ++ |
+ #' @export |
||
| 800 | -3x | +18 | +1x |
- split_cols(lyt, spl, pos)+ setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
|
| 801 | +19 |
- }+ |
||
| 802 | +20 | ++ |
+ #' @rdname spl_variable+ |
+ |
| 21 | ++ |
+ #' @export+ |
+ ||
| 22 | +! | +
+ setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
+ |
+ ||
| 23 | ||||
| 803 | +24 | ++ |
+ #' @rdname spl_variable+ |
+ |
| 25 |
#' @export |
|||
| 26 | +! | +
+ setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
+ |
+ ||
| 804 | +27 |
- #' @rdname varcuts+ |
||
| 805 | +28 |
- split_cols_by_quartiles <- function(lyt, var, split_label = var,+ #' @rdname spl_variable |
||
| 806 | +29 |
- nested = TRUE,+ #' @export |
||
| 807 | +30 |
- extra_args = list(),+ setMethod( |
||
| 808 | +31 |
- cumulative = FALSE) {
+ "spl_variable", "Split", |
||
| 809 | -2x | +32 | +1x |
- split_cols_by_cutfun(+ function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
|
| 810 | -2x | +|||
| 33 | +
- lyt = lyt,+ ) |
|||
| 811 | -2x | +|||
| 34 | +
- var = var,+ |
|||
| 812 | -2x | +|||
| 35 | +
- split_label = split_label,+ in_col_split <- function(spl_ctx) {
|
|||
| 813 | -2x | +|||
| 36 | +! |
- cutfun = qtile_cuts,+ 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) {
|
||
| 814 | -2x | +43 | +45x |
- cutlabelfun = function(x) {
+ msg_2_append <- "" |
| 815 | -2x | +44 | +45x |
- c(+ if (!is.null(component)) {
|
| 816 | -2x | +45 | +33x |
- "[min, Q1]",+ msg_2_append <- paste0( |
| 817 | -2x | +46 | +33x |
- "(Q1, Q2]",+ "Invalid split function constructed by upstream call to ", |
| 818 | -2x | +47 | +33x |
- "(Q2, Q3]",+ "make_split_fun. Problem source: ", |
| 819 | -2x | +48 | +33x |
- "(Q3, max]"+ component, " argument." |
| 820 | +49 |
- )+ ) |
||
| 821 | +50 |
- },+ } |
||
| 822 | -2x | +51 | +45x |
- nested = nested,+ if (!(nm %in% names(pinfo))) {
|
| 823 | -2x | +|||
| 52 | +! |
- extra_args = extra_args,+ stop( |
||
| 824 | -2x | +|||
| 53 | +! |
- cumulative = cumulative+ "Split result does not have required element: ", nm, ".", |
||
| 825 | -+ | |||
| 54 | +! |
- )+ msg_2_append |
||
| 826 | +55 |
- ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,+ ) |
||
| 827 | +56 |
- ## cutlabelfun = function(x) c("[min, Q1]",
+ } |
||
| 828 | -+ | |||
| 57 | +45x |
- ## "(Q1, Q2]",+ if (!is.null(len) && length(pinfo[[nm]]) != len) {
|
||
| 829 | -+ | |||
| 58 | +! |
- ## "(Q2, Q3]",+ stop( |
||
| 830 | -+ | |||
| 59 | +! |
- ## "(Q3, max]"),+ "Split result element ", nm, " does not have required length ", len, ".", |
||
| 831 | -+ | |||
| 60 | +! |
- ## split_format = format,+ msg_2_append |
||
| 832 | +61 |
- ## extra_args = extra_args,+ ) |
||
| 833 | +62 |
- ## cumulative = cumulative,+ }+ |
+ ||
| 63 | +45x | +
+ TRUE |
||
| 834 | +64 |
- ## label_pos = "hidden")+ } |
||
| 835 | +65 |
- ## pos = next_cpos(lyt, nested)+ |
||
| 836 | +66 |
- ## split_cols(lyt, spl, pos)+ 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 |
||
| 837 | +72 |
} |
||
| 838 | +73 | |||
| 839 | +74 |
- #' @export+ #' Construct split result object |
||
| 840 | +75 |
- #' @rdname varcuts+ #' |
||
| 841 | +76 |
- split_rows_by_quartiles <- function(lyt, var, split_label = var,+ #' These functions can be used to create or add to a split result in functions which implement core splitting or |
||
| 842 | +77 |
- format = NULL,+ #' post-processing within a custom split function. |
||
| 843 | +78 |
- na_str = NA_character_,+ #' |
||
| 844 | +79 |
- nested = TRUE,+ #' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet. |
||
| 845 | +80 |
- child_labels = c("default", "visible", "hidden"),
+ #' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split. |
||
| 846 | +81 |
- extra_args = list(),+ #' @param labels (`character`)\cr the labels associated with each facet. |
||
| 847 | +82 |
- cumulative = FALSE,+ #' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to |
||
| 848 | +83 |
- indent_mod = 0L,+ #' analysis functions applied within the facet. |
||
| 849 | +84 |
- label_pos = "hidden",+ #' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g., |
||
| 850 | +85 |
- section_div = NA_character_) {
+ #' created with `quote()`) to be used during column subsetting. |
||
| 851 | -2x | +|||
| 86 | +
- split_rows_by_cutfun(+ #' |
|||
| 852 | -2x | +|||
| 87 | +
- lyt = lyt,+ #' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and |
|||
| 853 | -2x | +|||
| 88 | +
- var = var,+ #' `labels`, which are the same length and correspond to each other element-wise. |
|||
| 854 | -2x | +|||
| 89 | +
- split_label = split_label,+ #' |
|||
| 855 | -2x | +|||
| 90 | +
- format = format,+ #' @details |
|||
| 856 | -2x | +|||
| 91 | +
- na_str = na_str,+ #' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables |
|||
| 857 | -2x | +|||
| 92 | +
- cutfun = qtile_cuts,+ #' internals expect it, most of which are not relevant to end users. |
|||
| 858 | -2x | +|||
| 93 | +
- cutlabelfun = function(x) {
+ #' |
|||
| 859 | -2x | +|||
| 94 | +
- c(+ #' @examples |
|||
| 860 | -2x | +|||
| 95 | +
- "[min, Q1]",+ #' splres <- make_split_result( |
|||
| 861 | -2x | +|||
| 96 | +
- "(Q1, Q2]",+ #' values = c("hi", "lo"),
|
|||
| 862 | -2x | +|||
| 97 | +
- "(Q2, Q3]",+ #' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]), |
|||
| 863 | -2x | +|||
| 98 | +
- "(Q3, max]"+ #' labels = c("more data", "less data"),
|
|||
| 864 | +99 |
- )+ #' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10)) |
||
| 865 | +100 |
- },+ #' ) |
||
| 866 | -2x | +|||
| 101 | +
- nested = nested,+ #' |
|||
| 867 | -2x | +|||
| 102 | +
- child_labels = child_labels,+ #' splres2 <- add_to_split_result(splres, |
|||
| 868 | -2x | +|||
| 103 | +
- extra_args = extra_args,+ #' values = "med", |
|||
| 869 | -2x | +|||
| 104 | +
- cumulative = cumulative,+ #' datasplit = list(med = mtcars[1:20, ]), |
|||
| 870 | -2x | +|||
| 105 | +
- indent_mod = indent_mod,+ #' labels = "kinda some data", |
|||
| 871 | -2x | +|||
| 106 | +
- label_pos = label_pos,+ #' subset_exprs = quote(seq_along(wt) <= 20) |
|||
| 872 | -2x | +|||
| 107 | +
- section_div = section_div+ #' ) |
|||
| 873 | +108 |
- )+ #' |
||
| 874 | +109 |
-
+ #' @family make_custom_split |
||
| 875 | +110 |
- ## label_pos <- match.arg(label_pos, label_pos_values)+ #' @rdname make_split_result |
||
| 876 | +111 |
- ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,+ #' @export |
||
| 877 | +112 |
- ## cutlabelfun = ,+ #' @family make_custom_split |
||
| 878 | +113 |
- ## split_format = format,+ make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
|
||
| 879 | -+ | |||
| 114 | +9x |
- ## child_labels = child_labels,+ if (length(values) == 1 && is(datasplit, "data.frame")) {
|
||
| 880 | -+ | |||
| 115 | +! |
- ## extra_args = extra_args,+ datasplit <- list(datasplit) |
||
| 881 | +116 |
- ## cumulative = cumulative,+ } |
||
| 882 | -+ | |||
| 117 | +9x |
- ## indent_mod = indent_mod,+ ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs) |
||
| 883 | -+ | |||
| 118 | +9x |
- ## label_pos = label_pos)+ if (!is.null(extras)) {
|
||
| 884 | -+ | |||
| 119 | +! |
- ## pos = next_rpos(lyt, nested)+ ret$extras <- extras |
||
| 885 | +120 |
- ## split_rows(lyt, spl, pos)+ }+ |
+ ||
| 121 | +9x | +
+ .fixupvals(ret) |
||
| 886 | +122 |
} |
||
| 887 | +123 | |||
| 888 | +124 |
- qtile_cuts <- function(x) {
+ #' @param splres (`list`)\cr a list representing the result of splitting. |
||
| 889 | -6x | +|||
| 125 | +
- ret <- quantile(x)+ #' |
|||
| 890 | -6x | +|||
| 126 | +
- names(ret) <- c(+ #' @rdname make_split_result |
|||
| 891 | +127 |
- "",+ #' @export+ |
+ ||
| 128 | ++ |
+ add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
|
||
| 892 | -6x | +129 | +4x |
- "1st qrtile",+ validate_split_result(splres) |
| 893 | -6x | +130 | +4x |
- "2nd qrtile",+ newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs)) |
| 894 | -6x | +131 | +4x |
- "3rd qrtile",+ ret <- lapply( |
| 895 | -6x | +132 | +4x |
- "4th qrtile"+ names(splres),+ |
+
| 133 | +4x | +
+ function(nm) c(splres[[nm]], newstuff[[nm]]) |
||
| 896 | +134 |
) |
||
| 897 | -6x | +135 | +4x |
- ret+ names(ret) <- names(splres)+ |
+
| 136 | +4x | +
+ .fixupvals(ret) |
||
| 898 | +137 |
} |
||
| 899 | +138 | |||
| 900 | +139 |
- #' @export+ + |
+ ||
| 140 | +13x | +
+ .can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
|
||
| 901 | +141 |
- #' @rdname varcuts+ |
||
| 902 | +142 |
- split_rows_by_cutfun <- function(lyt, var,+ #' Create a custom splitting function |
||
| 903 | +143 |
- cutfun = qtile_cuts,+ #' |
||
| 904 | +144 |
- cutlabelfun = function(x) NULL,+ #' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that |
||
| 905 | +145 |
- split_label = var,+ #' should split via `core_split`. They will be called on the data in the order they appear in the list. |
||
| 906 | +146 |
- format = NULL,+ #' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that |
||
| 907 | +147 |
- na_str = NA_character_,+ #' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior |
||
| 908 | +148 |
- nested = TRUE,+ #' cannot be used in column splits. |
||
| 909 | +149 |
- child_labels = c("default", "visible", "hidden"),
+ #' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting. |
||
| 910 | +150 |
- extra_args = list(),+ #' |
||
| 911 | +151 |
- cumulative = FALSE,+ #' @details |
||
| 912 | +152 |
- indent_mod = 0L,+ #' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process: |
||
| 913 | +153 |
- label_pos = "hidden",+ #' |
||
| 914 | +154 |
- section_div = NA_character_) {
+ #' 1. Pre-processing of the incoming data to be split. |
||
| 915 | -2x | +|||
| 155 | +
- label_pos <- match.arg(label_pos, label_pos_values)+ #' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets. |
|||
| 916 | -2x | +|||
| 156 | +
- child_labels <- match.arg(child_labels)+ #' 3. Post-processing operations on the set of facets (groups) generated by the split. |
|||
| 917 | -2x | +|||
| 157 | +
- spl <- VarDynCutSplit(var, split_label,+ #' |
|||
| 918 | -2x | +|||
| 158 | +
- cutfun = cutfun,+ #' This function provides an interface to create custom split functions by implementing and specifying sets of |
|||
| 919 | -2x | +|||
| 159 | +
- cutlabelfun = cutlabelfun,+ #' operations in each of those classes of customization independently. |
|||
| 920 | -2x | +|||
| 160 | +
- split_format = format,+ #' |
|||
| 921 | -2x | +|||
| 161 | +
- split_na_str = na_str,+ #' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept |
|||
| 922 | -2x | +|||
| 162 | +
- child_labels = child_labels,+ #' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame. |
|||
| 923 | -2x | +|||
| 163 | +
- extra_args = extra_args,+ #' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if |
|||
| 924 | -2x | +|||
| 164 | +
- cumulative = cumulative,+ #' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables, |
|||
| 925 | -2x | +|||
| 165 | +
- indent_mod = indent_mod,+ #' because they will not be present when validity checking is done). |
|||
| 926 | -2x | +|||
| 166 | +
- label_pos = label_pos,+ #' |
|||
| 927 | -2x | +|||
| 167 | +
- section_div = section_div+ #' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones |
|||
| 928 | +168 |
- )+ #' or to reorder levels based on observed counts, etc. |
||
| 929 | -2x | +|||
| 169 | +
- pos <- next_rpos(lyt, nested)+ #' |
|||
| 930 | -2x | +|||
| 170 | +
- split_rows(lyt, spl, pos)+ #' Core splitting functions override the fundamental |
|||
| 931 | +171 |
- }+ #' splitting procedure, and are only necessary in rare cases. These |
||
| 932 | +172 |
-
+ #' must accept `spl`, `df`, `vals`, `labels`, and can optionally |
||
| 933 | +173 |
- #' .spl_context within analysis and split functions+ #' accept `.spl_context`. They should return a split result object |
||
| 934 | +174 |
- #'+ #' constructed via `make_split_result()`. |
||
| 935 | +175 |
- #' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function+ #' |
||
| 936 | +176 |
- #' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for+ #' 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 | ++ |
+ #' 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 | +32850x | +
+ if (!is.null(align)) {
+ |
+ |
| 29 | +56x | +
+ check_aligns(align)+ |
+ |
| 30 | ++ |
+ }+ |
+ |
| 31 | +32850x | +
+ if (is(x, "CellValue")) {
+ |
+ |
| 32 | +19813x | +
+ if (!is.null(label)) {
+ |
+ |
| 33 | +1x | +
+ obj_label(x) <- label+ |
+ |
| 34 | ++ |
+ }+ |
+ |
| 35 | +19813x | +
+ if (colspan != 1L) {
+ |
+ |
| 36 | +1x | +
+ cell_cspan(x) <- colspan+ |
+ |
| 37 | ++ |
+ }+ |
+ |
| 38 | +19813x | +
+ if (!is.null(indent_mod)) {
+ |
+ |
| 39 | +1x | +
+ indent_mod(x) <- indent_mod+ |
+ |
| 40 | ++ |
+ }+ |
+ |
| 41 | +19813x | +
+ if (!is.null(format)) {
+ |
+ |
| 42 | +1x | +
+ obj_format(x) <- format+ |
+ |
| 43 | ++ |
+ }+ |
+ |
| 44 | +19813x | +
+ if (!is.null(footnotes)) {
+ |
+ |
| 45 | +357x | +
+ cell_footnotes(x) <- lapply(footnotes, RefFootnote)+ |
+ |
| 46 | ++ |
+ }+ |
+ |
| 47 | +19813x | +
+ if (!is.null(format_na_str)) {
+ |
+ |
| 48 | +! | +
+ obj_na_str(x) <- format_na_str+ |
+ |
| 49 | ++ |
+ }+ |
+ |
| 50 | +19813x | +
+ ret <- x+ |
+ |
| 51 | ++ |
+ } else {
+ |
+ |
| 52 | +13037x | +
+ if (is.null(label)) {
+ |
+ |
| 53 | +10110x | +
+ label <- obj_label(x)+ |
+ |
| 54 | ++ |
+ }+ |
+ |
| 55 | +13037x | +
+ if (is.null(format)) {
+ |
+ |
| 56 | +7074x | +
+ format <- obj_format(x)+ |
+ |
| 57 | ++ |
+ }+ |
+ |
| 58 | +13037x | +
+ if (is.null(indent_mod)) {
+ |
+ |
| 59 | +13037x | +
+ indent_mod <- indent_mod(x)+ |
+ |
| 60 | ++ |
+ }+ |
+ |
| 61 | +13037x | +
+ footnotes <- lapply(footnotes, RefFootnote)+ |
+ |
| 62 | +13037x | +
+ ret <- CellValue(+ |
+ |
| 63 | +13037x | +
+ val = x,+ |
+ |
| 64 | +13037x | +
+ format = format,+ |
+ |
| 65 | +13037x | +
+ colspan = colspan,+ |
+ |
| 66 | +13037x | +
+ label = label,+ |
+ |
| 67 | +13037x | +
+ indent_mod = indent_mod,+ |
+ |
| 68 | +13037x | +
+ footnotes = footnotes,+ |
+ |
| 69 | +13037x | +
+ format_na_str = format_na_str+ |
+ |
| 70 | +13037x | +
+ ) # RefFootnote(footnote))+ |
+ |
| 71 | ++ |
+ }+ |
+ |
| 72 | +32850x | +
+ if (!is.null(align)) {
+ |
+ |
| 73 | +56x | +
+ cell_align(ret) <- align+ |
+ |
| 74 | ++ |
+ }+ |
+ |
| 75 | +32850x | +
+ 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 | +5922x | +
+ if (is.function(.formats)) {
+ |
+ |
| 155 | +! | +
+ .formats <- list(.formats)+ |
+ |
| 156 | ++ |
+ }+ |
+ |
| 157 | ++ | + + | +|
| 158 | +5922x | +
+ l <- c(list(...), .list)+ |
+ |
| 159 | ++ | + + | +|
| 160 | +5922x | +
+ if (missing(.names) && missing(.labels)) {
+ |
+ |
| 161 | +1849x | +
+ if (length(l) > 0 && is.null(names(l))) {
+ |
+ |
| 162 | +! | +
+ stop("need a named list")
+ |
+ |
| 163 | ++ |
+ } else {
+ |
+ |
| 164 | +1849x | +
+ .names <- names(l)+ |
+ |
| 165 | ++ |
+ }+ |
+ |
| 166 | +1849x | +
+ stopifnot(!anyNA(.names))+ |
+ |
| 167 | ++ |
+ }+ |
+ |
| 168 | ++ | + + | +|
| 169 | +5922x | +
+ 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 | +5922x | +
+ if (is.null(.formats)) {
+ |
+ |
| 187 | +5462x | +
+ .formats <- list(NULL)+ |
+ |
| 188 | ++ |
+ }+ |
+ |
| 189 | +5922x | +
+ stopifnot(is.list(.cell_footnotes))+ |
+ |
| 190 | +5922x | +
+ if (length(.cell_footnotes) != length(l)) {
+ |
+ |
| 191 | +1234x | +
+ .cell_footnotes <- c(+ |
+ |
| 192 | +1234x | +
+ .cell_footnotes,+ |
+ |
| 193 | +1234x | +
+ setNames(+ |
+ |
| 194 | +1234x | +
+ rep(list(character()),+ |
+ |
| 195 | +1234x | +
+ length.out = length(setdiff(+ |
+ |
| 196 | +1234x | +
+ names(l),+ |
+ |
| 197 | +1234x | +
+ names(.cell_footnotes)+ |
+ |
| 198 | ++ |
+ ))+ |
+ |
| 199 | ++ |
+ ),+ |
+ |
| 200 | +1234x | +
+ setdiff(+ |
+ |
| 201 | +1234x | +
+ names(l),+ |
+ |
| 202 | +1234x | +
+ names(.cell_footnotes)+ |
+ |
| 203 | ++ |
+ )+ |
+ |
| 204 | ++ |
+ )+ |
+ |
| 205 | ++ |
+ )+ |
+ |
| 206 | +1234x | +
+ .cell_footnotes <- .cell_footnotes[names(l)]+ |
+ |
| 207 | ++ |
+ }+ |
+ |
| 208 | +5922x | +
+ if (is.null(.aligns)) {
+ |
+ |
| 209 | +5919x | +
+ .aligns <- list(NULL)+ |
+ |
| 210 | ++ |
+ }+ |
+ |
| 211 | +5922x | +
+ l2 <- mapply(rcell,+ |
+ |
| 212 | +5922x | +
+ x = l, format = .formats,+ |
+ |
| 213 | +5922x | +
+ footnotes = .cell_footnotes %||% list(NULL),+ |
+ |
| 214 | +5922x | +
+ align = .aligns,+ |
+ |
| 215 | +5922x | +
+ format_na_str = .format_na_strs %||% list(NULL),+ |
+ |
| 216 | +5922x | +
+ SIMPLIFY = FALSE+ |
+ |
| 217 | ++ |
+ )+ |
+ |
| 218 | ++ |
+ }+ |
+ |
| 219 | +5922x | +
+ if (is.null(.labels)) {
+ |
+ |
| 220 | +2722x | +
+ objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "")+ |
+ |
| 221 | +2722x | +
+ if (any(nzchar(objlabs))) {
+ |
+ |
| 222 | +69x | +
+ .labels <- objlabs+ |
+ |
| 223 | ++ |
+ }+ |
+ |
| 224 | ++ |
+ }+ |
+ |
| 225 | ++ | + + | +|
| 226 | +5922x | +
+ if (is.null(.names) && !is.null(names(l))) {
+ |
+ |
| 227 | +97x | +
+ .names <- names(l)+ |
+ |
| 228 | ++ |
+ }+ |
+ |
| 229 | +5922x | +
+ stopifnot(is.list(.row_footnotes))+ |
+ |
| 230 | +5922x | +
+ if (length(.row_footnotes) != length(l2)) {
+ |
+ |
| 231 | +1234x | +
+ tmp <- .row_footnotes+ |
+ |
| 232 | +1234x | +
+ .row_footnotes <- vector("list", length(l2))
+ |
+ |
| 233 | +1234x | +
+ pos <- match(names(tmp), .names)+ |
+ |
| 234 | +1234x | +
+ nonna <- which(!is.na(pos))+ |
+ |
| 235 | +1234x | +
+ .row_footnotes[pos] <- tmp[nonna]+ |
+ |
| 236 | ++ |
+ # length(.row_footnotes) <- length(l2)+ |
+ |
| 237 | ++ |
+ }+ |
+ |
| 238 | +5922x | +
+ ret <- RowsVerticalSection(l2,+ |
+ |
| 239 | +5922x | +
+ names = .names,+ |
+ |
| 240 | +5922x | +
+ labels = .labels,+ |
+ |
| 241 | +5922x | +
+ indent_mods = .indent_mods,+ |
+ |
| 242 | +5922x | +
+ formats = .formats,+ |
+ |
| 243 | +5922x | +
+ footnotes = .row_footnotes,+ |
+ |
| 244 | +5922x | +
+ 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 |
|
| 937 | -+ | ||
| 574 | +! |
- #' [split_rows_by()]).+ ) # , indent_mod = im) |
|
| 938 | +575 |
- #'+ } else {
|
|
| 939 | -+ | ||
| 576 | +132x |
- #' @details+ rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im) |
|
| 940 | +577 |
- #' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within+ } |
|
| 941 | +578 |
- #' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set+ }, |
|
| 942 | -+ | ||
| 579 | +66x |
- #' of) rows the analysis function is creating, although the information is in a slightly different form. Each split+ f = final_formats, x = final_vals, |
|
| 943 | -+ | ||
| 580 | +66x |
- #' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented+ l = final_labels, |
|
| 944 | -+ | ||
| 581 | +66x |
- #' via the following columns:+ na_str = final_format_na_strs, |
|
| 945 | +582 |
- #'+ # im = final_imods, |
|
| 946 | -+ | ||
| 583 | +66x |
- #' \describe{
+ SIMPLIFY = FALSE |
|
| 947 | +584 |
- #' \item{split}{The name of the split (often the variable being split).}
+ ) |
|
| 948 | -+ | ||
| 585 | +66x |
- #' \item{value}{The string representation of the value at that split (`split`).}
+ in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels) |
|
| 949 | +586 |
- #' \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
+ } |
|
| 950 | -+ | ||
| 587 | +23x |
- #' defined by the combination of `split` and `value` of this row *and all rows above this row*.}+ formals(ret) <- formals(fun) |
|
| 951 | -+ | ||
| 588 | +23x |
- #' \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
+ ret |
|
| 952 | +589 |
- #' \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
+ } |
|
| 953 | +590 |
- #' (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's+ |
|
| 954 | +591 |
- #' `full_parent_df` corresponding to the column.}+ insert_replace <- function(x, nm, newvals = x[[nm]]) {
|
|
| 955 | -+ | ||
| 592 | +15x |
- #' \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
+ i <- match(nm, names(x)) |
|
| 956 | -+ | ||
| 593 | +15x |
- #' column path together.}+ if (is.na(i)) {
|
|
| 957 | -+ | ||
| 594 | +! |
- #' \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
+ stop("name not found")
|
|
| 958 | +595 |
- #' for the column currently being created by the analysis function.}+ } |
|
| 959 | -+ | ||
| 596 | +15x |
- #' \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
+ bef <- if (i > 1) 1:(i - 1) else numeric() |
|
| 960 | -+ | ||
| 597 | +15x |
- #' data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.}+ aft <- if (i < length(x)) (i + 1):length(x) else numeric() |
|
| 961 | -+ | ||
| 598 | +15x |
- #' \item{cur_col_n}{Integer column containing the observation counts for that split.}
+ ret <- c(x[bef], newvals, x[aft]) |
|
| 962 | -+ | ||
| 599 | +15x |
- #' \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
+ names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft]) |
|
| 963 | -+ | ||
| 600 | +15x |
- #' \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
+ ret |
|
| 964 | +601 |
- #' }+ } |
|
| 965 | +602 |
- #'+ |
|
| 966 | +603 |
- #' @note+ parser_helper <- function(text, envir = parent.frame(2)) {
|
|
| 967 | -+ | ||
| 604 | +495x |
- #' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame+ parse(text = text, keep.source = FALSE) |
|
| 968 | +605 |
- #' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the+ } |
|
| 969 | +606 |
- #' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the+ |
|
| 970 | +607 |
- #' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()].+ length_w_name <- function(x, .parent_splval) {
|
|
| 971 | -+ | ||
| 608 | +! |
- #'+ in_rows(length(x), |
|
| 972 | -+ | ||
| 609 | +! |
- #' @name spl_context+ .names = value_labels(.parent_splval) |
|
| 973 | +610 |
- NULL+ ) |
|
| 974 | +611 |
-
+ } |
| 975 | +1 |
- #' Additional parameters within analysis and content functions (`afun`/`cfun`)+ #' @import formatters |
||
| 976 | +2 |
- #'+ #' @importMethodsFrom formatters toString matrix_form nlines |
||
| 977 | +3 |
- #' @description+ NULL |
||
| 978 | +4 |
- #' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()],+ |
||
| 979 | +5 |
- #' respectively. These parameters grant access to relevant information like the row split structure (see+ # toString ---- |
||
| 980 | +6 |
- #' [spl_context]) and the predefined baseline (`.ref_group`).+ |
||
| 981 | +7 |
- #'+ ## #' @export |
||
| 982 | +8 |
- #' @details+ ## setGeneric("toString", function(x,...) standardGeneric("toString"))
|
||
| 983 | +9 |
- #' We list and describe all the parameters that can be added to a custom analysis function below:+ |
||
| 984 | +10 |
- #'+ ## ## preserve S3 behavior |
||
| 985 | +11 |
- #' \describe{
+ ## setMethod("toString", "ANY", base::toString)
|
||
| 986 | +12 |
- #' \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
+
|
||
| 987 | +13 |
- #' \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
+ ## #' @export |
||
| 988 | +14 |
- #' \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
+ ## setMethod("print", "ANY", base::print)
|
||
| 989 | +15 |
- #' column-based subsetting).}+ |
||
| 990 | +16 |
- #' \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
+ #' Convert an `rtable` object to a string |
||
| 991 | +17 |
- #' subsetting).}+ #' |
||
| 992 | +18 |
- #' \item{.var}{Variable being analyzed.}
+ #' @inheritParams formatters::toString |
||
| 993 | +19 |
- #' \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
+ #' @inheritParams gen_args |
||
| 994 | +20 |
- #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}+ #' @inherit formatters::toString |
||
| 995 | +21 |
- #' \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
+ #' |
||
| 996 | +22 |
- #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}+ #' @return A string representation of `x` as it appears when printed. |
||
| 997 | +23 |
- #' \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
+ #' |
||
| 998 | +24 |
- #' \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
+ #' @examples |
||
| 999 | +25 |
- #' See [spl_context].}+ #' library(dplyr) |
||
| 1000 | +26 |
- #' \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with
+ #' |
||
| 1001 | +27 |
- #' `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`.+ #' iris2 <- iris %>% |
||
| 1002 | +28 |
- #' It can be an empty table if all the entries are filtered out.}+ #' group_by(Species) %>% |
||
| 1003 | +29 |
- #' \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 1004 | +30 |
- #' faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs`+ #' ungroup() |
||
| 1005 | +31 |
- #' in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.}+ #' |
||
| 1006 | +32 |
- #' \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
+ #' lyt <- basic_table() %>% |
||
| 1007 | +33 |
- #' \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
+ #' split_cols_by("Species") %>%
|
||
| 1008 | +34 |
- #' if `alt_counts_df` is used (see [build_table()]).}+ #' split_cols_by("group") %>%
|
||
| 1009 | +35 |
- #' }+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
|
||
| 1010 | +36 |
#' |
||
| 1011 | +37 |
- #' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be+ #' tbl <- build_table(lyt, iris2) |
||
| 1012 | +38 |
- #' treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during+ #' |
||
| 1013 | +39 |
- #' data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is+ #' cat(toString(tbl, col_gap = 3)) |
||
| 1014 | +40 |
- #' provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present.+ #' |
||
| 1015 | +41 |
- #'+ #' @rdname tostring |
||
| 1016 | +42 |
- #' @name additional_fun_params+ #' @aliases tostring toString,VTableTree-method |
||
| 1017 | +43 |
- NULL+ #' @exportMethod toString |
||
| 1018 | +44 |
-
+ setMethod("toString", "VTableTree", function(x,
|
||
| 1019 | +45 |
- #' Generate rows analyzing variables across columns+ widths = NULL, |
||
| 1020 | +46 |
- #'+ col_gap = 3, |
||
| 1021 | +47 |
- #' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by+ hsep = horizontal_sep(x), |
||
| 1022 | +48 |
- #' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting,+ indent_size = 2, |
||
| 1023 | +49 |
- #' the tabulation will occur at the current/next level of nesting by default.+ tf_wrap = FALSE, |
||
| 1024 | +50 |
- #'+ max_width = NULL, |
||
| 1025 | +51 |
- #' @inheritParams lyt_args+ fontspec = font_spec(), |
||
| 1026 | +52 |
- #'+ ttype_ok = FALSE) {
|
||
| 1027 | -+ | |||
| 53 | +40x |
- #' @inherit split_cols_by return+ toString( |
||
| 1028 | -+ | |||
| 54 | +40x |
- #'+ matrix_form(x, |
||
| 1029 | -+ | |||
| 55 | +40x |
- #' @details+ indent_rownames = TRUE, |
||
| 1030 | -+ | |||
| 56 | +40x |
- #' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a+ indent_size = indent_size, |
||
| 1031 | -+ | |||
| 57 | +40x |
- #' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the+ fontspec = fontspec, |
||
| 1032 | -+ | |||
| 58 | +40x |
- #' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`.+ col_gap = col_gap |
||
| 1033 | +59 |
- #'+ ), |
||
| 1034 | -+ | |||
| 60 | +40x |
- #' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the+ widths = widths, col_gap = col_gap, |
||
| 1035 | -+ | |||
| 61 | +40x |
- #' function accepts will change the behavior when tabulation is performed as follows:+ hsep = hsep, |
||
| 1036 | -+ | |||
| 62 | +40x |
- #'+ tf_wrap = tf_wrap, |
||
| 1037 | -+ | |||
| 63 | +40x |
- #' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant+ max_width = max_width, |
||
| 1038 | -+ | |||
| 64 | +40x |
- #' column (from `var` here) of the raw data being used to build the table.+ fontspec = fontspec, |
||
| 1039 | -+ | |||
| 65 | +40x |
- #' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of+ ttype_ok = ttype_ok |
||
| 1040 | +66 |
- #' the raw data being tabulated.+ ) |
||
| 1041 | +67 |
- #'+ }) |
||
| 1042 | +68 |
- #' In addition to differentiation on the first argument, the analysis function can optionally accept a number of+ |
||
| 1043 | +69 |
- #' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation+ #' Table shells |
||
| 1044 | +70 |
- #' machinery. These are listed and described in [additional_fun_params].+ #' |
||
| 1045 | +71 |
- #'+ #' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather |
||
| 1046 | +72 |
- #' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling+ #' displaying the formatting instructions for each cell. |
||
| 1047 | +73 |
- #' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()].+ #' |
||
| 1048 | +74 |
- #' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and+ #' @inheritParams formatters::toString |
||
| 1049 | +75 |
- #' the unmodified values provided by the tabulation framework.+ #' @inheritParams gen_args |
||
| 1050 | +76 |
#' |
||
| 1051 | +77 |
- #' @examples+ #' @return |
||
| 1052 | +78 |
- #' lyt <- basic_table() %>%+ #' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console. |
||
| 1053 | +79 |
- #' split_cols_by("ARM") %>%
+ #' * `table_shell_str` returns the string representing the table shell. |
||
| 1054 | +80 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
+ #' |
||
| 1055 | +81 |
- #' lyt+ #' @seealso [value_formats()] for a matrix of formats for each cell in a table. |
||
| 1056 | +82 |
#' |
||
| 1057 | +83 |
- #' tbl <- build_table(lyt, DM)+ #' @examples |
||
| 1058 | +84 |
- #' tbl+ #' library(dplyr) |
||
| 1059 | +85 |
#' |
||
| 1060 | +86 |
- #' lyt2 <- basic_table() %>%+ #' iris2 <- iris %>% |
||
| 1061 | +87 |
- #' split_cols_by("Species") %>%
+ #' group_by(Species) %>% |
||
| 1062 | +88 |
- #' analyze(head(names(iris), -1), afun = function(x) {
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 1063 | +89 |
- #' list(+ #' ungroup() |
||
| 1064 | +90 |
- #' "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ #' |
||
| 1065 | +91 |
- #' "range" = rcell(diff(range(x)), format = "xx.xx")+ #' lyt <- basic_table() %>% |
||
| 1066 | +92 |
- #' )+ #' split_cols_by("Species") %>%
|
||
| 1067 | +93 |
- #' })+ #' split_cols_by("group") %>%
|
||
| 1068 | +94 |
- #' lyt2+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
|
||
| 1069 | +95 |
#' |
||
| 1070 | +96 |
- #' tbl2 <- build_table(lyt2, iris)+ #' tbl <- build_table(lyt, iris2) |
||
| 1071 | +97 |
- #' tbl2+ #' table_shell(tbl) |
||
| 1072 | +98 |
#' |
||
| 1073 | -- |
- #' @author Gabriel Becker- |
- ||
| 1074 | +99 |
#' @export |
||
| 1075 | +100 |
- analyze <- function(lyt,+ table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), |
||
| 1076 | +101 |
- vars,+ tf_wrap = FALSE, max_width = NULL) {
|
||
| 1077 | -+ | |||
| 102 | +2x |
- afun = simple_analysis,+ cat(table_shell_str( |
||
| 1078 | -+ | |||
| 103 | +2x |
- var_labels = vars,+ tt = tt, widths = widths, col_gap = col_gap, hsep = hsep, |
||
| 1079 | -+ | |||
| 104 | +2x |
- table_names = vars,+ tf_wrap = tf_wrap, max_width = max_width |
||
| 1080 | +105 |
- format = NULL,+ )) |
||
| 1081 | +106 |
- na_str = NA_character_,+ } |
||
| 1082 | +107 |
- nested = TRUE,+ |
||
| 1083 | +108 |
- ## can't name this na_rm symbol conflict with possible afuns!!+ ## XXX consider moving to formatters, its really just a function |
||
| 1084 | +109 |
- inclNAs = FALSE,+ ## of the MatrixPrintForm |
||
| 1085 | +110 |
- extra_args = list(),+ #' @rdname table_shell |
||
| 1086 | +111 |
- show_labels = c("default", "visible", "hidden"),
+ #' @export |
||
| 1087 | +112 |
- indent_mod = 0L,+ table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), |
||
| 1088 | +113 |
- section_div = NA_character_) {
+ tf_wrap = FALSE, max_width = NULL) {
|
||
| 1089 | -300x | +114 | +2x |
- show_labels <- match.arg(show_labels)+ matform <- matrix_form(tt, indent_rownames = TRUE) |
| 1090 | -300x | -
- subafun <- substitute(afun)- |
- ||
| 1091 | -+ | 115 | +2x |
- if (+ format_strs <- vapply( |
| 1092 | -300x | +116 | +2x |
- is.name(subafun) &&+ as.vector(matform$formats), |
| 1093 | -300x | -
- is.function(afun) &&- |
- ||
| 1094 | -- |
- ## this is gross. basically testing- |
- ||
| 1095 | -- |
- ## if the symbol we have corresponds- |
- ||
| 1096 | -+ | 117 | +2x |
- ## in some meaningful way to the function+ function(x) {
|
| 1097 | -+ | |||
| 118 | +18x |
- ## we will be calling.+ if (inherits(x, "function")) {
|
||
| 1098 | -300x | +119 | +1x |
- identical(+ "<fnc>" |
| 1099 | -300x | +120 | +17x |
- mget(+ } else if (inherits(x, "character")) {
|
| 1100 | -300x | +121 | +17x |
- as.character(subafun),+ x |
| 1101 | -300x | +|||
| 122 | +
- mode = "function",+ } else {
|
|||
| 1102 | -300x | +|||
| 123 | +! |
- ifnotfound = list(NULL),+ stop("Don't know how to make a shell with formats of class: ", class(x))
|
||
| 1103 | -300x | +|||
| 124 | +
- inherits = TRUE+ } |
|||
| 1104 | -300x | +|||
| 125 | +
- )[[1]], afun+ }, "" |
|||
| 1105 | +126 |
- )+ ) |
||
| 1106 | +127 |
- ) {
+
|
||
| 1107 | -166x | +128 | +2x |
- defrowlab <- as.character(subafun)+ format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings)) |
| 1108 | -+ | |||
| 129 | +2x |
- } else {
+ format_strs_mat[, 1] <- matform$strings[, 1] |
||
| 1109 | -134x | +130 | +2x |
- defrowlab <- var_labels+ nlh <- mf_nlheader(matform) |
| 1110 | -+ | |||
| 131 | +2x |
- }+ format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ] |
||
| 1111 | +132 | |||
| 1112 | -300x | +133 | +2x |
- spl <- AnalyzeMultiVars(vars, var_labels,+ matform$strings <- format_strs_mat |
| 1113 | -300x | +134 | +2x |
- afun = afun,+ if (is.null(widths)) {
|
| 1114 | -300x | +135 | +2x |
- split_format = format,+ widths <- propose_column_widths(matform) |
| 1115 | -300x | +|||
| 136 | +
- split_na_str = na_str,+ } |
|||
| 1116 | -300x | +137 | +2x |
- defrowlab = defrowlab,+ toString(matform, |
| 1117 | -300x | +138 | +2x |
- inclNAs = inclNAs,+ widths = widths, col_gap = col_gap, hsep = hsep, |
| 1118 | -300x | +139 | +2x |
- extra_args = extra_args,+ tf_wrap = tf_wrap, max_width = max_width |
| 1119 | -300x | +|||
| 140 | +
- indent_mod = indent_mod,+ ) |
|||
| 1120 | -300x | +|||
| 141 | +
- child_names = table_names,+ } |
|||
| 1121 | -300x | +|||
| 142 | +
- child_labels = show_labels,+ |
|||
| 1122 | -300x | +|||
| 143 | +
- section_div = section_div+ #' Transform an `rtable` to a list of matrices which can be used for outputting |
|||
| 1123 | +144 |
- )+ #' |
||
| 1124 | +145 |
-
+ #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML |
||
| 1125 | -300x | +|||
| 146 | +
- if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
+ #' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form. |
|||
| 1126 | -27x | +|||
| 147 | +
- cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars)+ #' |
|||
| 1127 | +148 |
- } else {
+ #' @inheritParams gen_args |
||
| 1128 | +149 |
- ## analysis compounding now done in split_rows+ #' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output |
||
| 1129 | -271x | +|||
| 150 | +
- pos <- next_rpos(lyt, nested)+ #' has indented row names (strings pre-fixed). |
|||
| 1130 | -271x | +|||
| 151 | +
- split_rows(lyt, spl, pos)+ #' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain |
|||
| 1131 | +152 |
- }+ #' newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`. |
||
| 1132 | +153 |
- }+ #' @param fontspec (`font_spec`)\cr The font that should be used by default when |
||
| 1133 | +154 |
-
+ #' rendering this `MatrixPrintForm` object, or NULL (the default). |
||
| 1134 | +155 |
- get_acolvar_name <- function(lyt) {
+ #' @param col_gap (`numeric(1)`)]\cr The number of spaces (in the font specified |
||
| 1135 | +156 |
- ## clyt <- clayout(lyt)+ #' by `fontspec`) that should be placed between columns when the table |
||
| 1136 | +157 |
- ## stopifnot(length(clyt) == 1L)+ #' is rendered directly to text (e.g., by `toString` or `export_as_txt`). Defaults |
||
| 1137 | +158 |
- ## vec = clyt[[1]]+ #' to `3`. |
||
| 1138 | +159 |
- ## vcls = vapply(vec, class, "")+ #' |
||
| 1139 | +160 |
- ## pos = max(which(vcls == "MultiVarSplit"))+ #' @details |
||
| 1140 | -22x | +|||
| 161 | +
- paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
+ #' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell |
|||
| 1141 | +162 |
- }+ #' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal |
||
| 1142 | +163 |
-
+ #' function. |
||
| 1143 | +164 |
- get_acolvar_vars <- function(lyt) {
+ #' |
||
| 1144 | -35x | +|||
| 165 | +
- clyt <- clayout(lyt)+ #' @return A list with the following elements: |
|||
| 1145 | -35x | +|||
| 166 | +
- stopifnot(length(clyt) == 1L)+ #' \describe{
|
|||
| 1146 | -35x | +|||
| 167 | +
- vec <- clyt[[1]]+ #' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
|
|||
| 1147 | -35x | +|||
| 168 | +
- vcls <- vapply(vec, class, "")+ #' and cell values of `tt`.} |
|||
| 1148 | -35x | +|||
| 169 | +
- pos <- which(vcls == "MultiVarSplit")+ #' \item{`spans`}{The column-span information for each print-string in the `strings` matrix.}
|
|||
| 1149 | -35x | +|||
| 170 | +
- if (length(pos) > 0) {
+ #' \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.}
|
|||
| 1150 | -35x | +|||
| 171 | +
- spl_payload(vec[[pos]])+ #' \item{`display`}{Whether each print-string in the strings matrix should be printed.}
|
|||
| 1151 | +172 |
- } else {
+ #' \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
|
||
| 1152 | -! | +|||
| 173 | +
- "non_multivar"+ #' } |
|||
| 1153 | +174 |
- }+ #' |
||
| 1154 | +175 |
- }+ #' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines. |
||
| 1155 | +176 |
-
+ #' |
||
| 1156 | +177 |
- #' Generate rows analyzing different variables across columns+ #' @examples |
||
| 1157 | +178 |
- #'+ #' library(dplyr) |
||
| 1158 | +179 |
- #' @inheritParams lyt_args+ #' |
||
| 1159 | +180 |
- #' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list+ #' iris2 <- iris %>% |
||
| 1160 | +181 |
- #' will be repped out as needed and matched by position with the columns during tabulation. This functions+ #' group_by(Species) %>% |
||
| 1161 | +182 |
- #' accepts the same parameters as [analyze()] like `afun` and `format`. For further information see+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 1162 | +183 |
- #' [additional_fun_params].+ #' ungroup() |
||
| 1163 | +184 |
#' |
||
| 1164 | +185 |
- #' @inherit split_cols_by return+ #' lyt <- basic_table() %>% |
||
| 1165 | +186 |
- #'+ #' split_cols_by("Species") %>%
|
||
| 1166 | +187 |
- #' @seealso [split_cols_by_multivar()]+ #' split_cols_by("group") %>%
|
||
| 1167 | +188 |
- #'+ #' analyze(c("Sepal.Length", "Petal.Width"),
|
||
| 1168 | +189 |
- #' @examples+ #' afun = list_wrap_x(summary), format = "xx.xx" |
||
| 1169 | +190 |
- #' library(dplyr)+ #' ) |
||
| 1170 | +191 |
#' |
||
| 1171 | +192 |
- #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))+ #' lyt |
||
| 1172 | +193 |
#' |
||
| 1173 | +194 |
- #' ## toy example where we take the mean of the first variable and the+ #' tbl <- build_table(lyt, iris2) |
||
| 1174 | +195 |
- #' ## count of >.5 for the second.+ #' |
||
| 1175 | +196 |
- #' colfuns <- list(+ #' matrix_form(tbl) |
||
| 1176 | +197 |
- #' function(x) rcell(mean(x), format = "xx.x"),+ #' |
||
| 1177 | +198 |
- #' function(x) rcell(sum(x > .5), format = "xx")+ #' @export |
||
| 1178 | +199 |
- #' )+ setMethod( |
||
| 1179 | +200 |
- #'+ "matrix_form", "VTableTree", |
||
| 1180 | +201 |
- #' lyt <- basic_table() %>%+ function(obj, |
||
| 1181 | +202 |
- #' split_cols_by("ARM") %>%
+ indent_rownames = FALSE, |
||
| 1182 | +203 |
- #' split_cols_by_multivar(c("value", "pctdiff")) %>%
+ expand_newlines = TRUE, |
||
| 1183 | +204 |
- #' split_rows_by("RACE",
+ indent_size = 2, |
||
| 1184 | +205 |
- #' split_label = "ethnicity",+ fontspec = NULL, |
||
| 1185 | +206 |
- #' split_fun = drop_split_levels+ col_gap = 3L) {
|
||
| 1186 | -+ | |||
| 207 | +324x |
- #' ) %>%+ stopifnot(is(obj, "VTableTree")) |
||
| 1187 | -+ | |||
| 208 | +324x |
- #' summarize_row_groups() %>%+ check_ccount_vis_ok(obj) |
||
| 1188 | -+ | |||
| 209 | +323x |
- #' analyze_colvars(afun = colfuns)+ header_content <- .tbl_header_mat(obj) # first col are for row.names |
||
| 1189 | +210 |
- #' lyt+ |
||
| 1190 | -+ | |||
| 211 | +321x |
- #'+ sr <- make_row_df(obj, fontspec = fontspec) |
||
| 1191 | +212 |
- #' tbl <- build_table(lyt, ANL)+ + |
+ ||
| 213 | +321x | +
+ body_content_strings <- if (NROW(sr) == 0) {
+ |
+ ||
| 214 | +5x | +
+ character() |
||
| 1192 | +215 |
- #' tbl+ } else {
+ |
+ ||
| 216 | +316x | +
+ cbind(as.character(sr$label), get_formatted_cells(obj)) |
||
| 1193 | +217 |
- #'+ } |
||
| 1194 | +218 |
- #' lyt2 <- basic_table() %>%+ + |
+ ||
| 219 | +321x | +
+ formats_strings <- if (NROW(sr) == 0) {
+ |
+ ||
| 220 | +5x | +
+ character() |
||
| 1195 | +221 |
- #' split_cols_by("ARM") %>%
+ } else {
+ |
+ ||
| 222 | +316x | +
+ cbind("", get_formatted_cells(obj, shell = TRUE))
|
||
| 1196 | +223 |
- #' split_cols_by_multivar(c("value", "pctdiff"),
+ } |
||
| 1197 | +224 |
- #' varlabels = c("Measurement", "Pct Diff")
+
+ |
+ ||
| 225 | +321x | +
+ tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
+ |
+ ||
| 226 | +7091x | +
+ sp <- row_cspans(rr)+ |
+ ||
| 227 | +7091x | +
+ rep(sp, times = sp) |
||
| 1198 | +228 |
- #' ) %>%+ }) |
||
| 1199 | +229 |
- #' split_rows_by("RACE",
+
|
||
| 1200 | +230 |
- #' split_label = "ethnicity",+ ## the 1 is for row labels+ |
+ ||
| 231 | +321x | +
+ body_spans <- if (nrow(obj) > 0) {
+ |
+ ||
| 232 | +316x | +
+ cbind(1L, do.call(rbind, tsptmp)) |
||
| 1201 | +233 |
- #' split_fun = drop_split_levels+ } else {
+ |
+ ||
| 234 | +5x | +
+ matrix(1, nrow = 0, ncol = ncol(obj) + 1) |
||
| 1202 | +235 |
- #' ) %>%+ } |
||
| 1203 | +236 |
- #' summarize_row_groups() %>%+ + |
+ ||
| 237 | +321x | +
+ body_aligns <- if (NROW(sr) == 0) {
+ |
+ ||
| 238 | +5x | +
+ character() |
||
| 1204 | +239 |
- #' analyze_colvars(afun = mean, format = "xx.xx")+ } else {
+ |
+ ||
| 240 | +316x | +
+ cbind("left", get_cell_aligns(obj))
|
||
| 1205 | +241 |
- #'+ } |
||
| 1206 | +242 |
- #' tbl2 <- build_table(lyt2, ANL)+ + |
+ ||
| 243 | +321x | +
+ body <- rbind(header_content$body, body_content_strings) |
||
| 1207 | +244 |
- #' tbl2+ + |
+ ||
| 245 | +321x | +
+ hdr_fmt_blank <- matrix("",
+ |
+ ||
| 246 | +321x | +
+ nrow = nrow(header_content$body),+ |
+ ||
| 247 | +321x | +
+ ncol = ncol(header_content$body) |
||
| 1208 | +248 |
- #'+ )+ |
+ ||
| 249 | +321x | +
+ if (disp_ccounts(obj)) {
+ |
+ ||
| 250 | +50x | +
+ hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
|
||
| 1209 | +251 |
- #' @author Gabriel Becker+ } |
||
| 1210 | +252 |
- #' @export+ + |
+ ||
| 253 | +321x | +
+ formats <- rbind(hdr_fmt_blank, formats_strings) |
||
| 1211 | +254 |
- analyze_colvars <- function(lyt,+ + |
+ ||
| 255 | +321x | +
+ spans <- rbind(header_content$span, body_spans)+ |
+ ||
| 256 | +321x | +
+ row.names(spans) <- NULL |
||
| 1212 | +257 |
- afun,+ + |
+ ||
| 258 | +321x | +
+ aligns <- rbind(+ |
+ ||
| 259 | +321x | +
+ matrix(rep("center", length(header_content$body)),
+ |
+ ||
| 260 | +321x | +
+ nrow = nrow(header_content$body) |
||
| 1213 | +261 |
- format = NULL,+ ),+ |
+ ||
| 262 | +321x | +
+ body_aligns |
||
| 1214 | +263 |
- na_str = NA_character_,+ ) |
||
| 1215 | +264 |
- nested = TRUE,+ + |
+ ||
| 265 | +321x | +
+ aligns[, 1] <- "left" # row names and topleft (still needed for topleft) |
||
| 1216 | +266 |
- extra_args = list(),+ + |
+ ||
| 267 | +321x | +
+ nr_header <- nrow(header_content$body)+ |
+ ||
| 268 | +321x | +
+ if (indent_rownames) {
+ |
+ ||
| 269 | +246x | +
+ body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent),+ |
+ ||
| 270 | +246x | +
+ incr = indent_size |
||
| 1217 | +271 |
- indent_mod = 0L,+ ) |
||
| 1218 | +272 |
- inclNAs = FALSE) {
+ # why also formats? |
||
| 1219 | -22x | +273 | +246x |
- if (is.function(afun)) {
+ formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent), |
| 1220 | -13x | +274 | +246x |
- subafun <- substitute(afun)+ incr = indent_size |
| 1221 | +275 |
- if (+ ) |
||
| 1222 | -13x | +276 | +75x |
- is.name(subafun) &&+ } else if (NROW(sr) > 0) {
|
| 1223 | -13x | +277 | +71x |
- is.function(afun) &&+ sr$indent <- rep(0, NROW(sr)) |
| 1224 | +278 |
- ## this is gross. basically testing+ } |
||
| 1225 | +279 |
- ## if the symbol we have corresponds+ + |
+ ||
| 280 | +321x | +
+ col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
+ |
+ ||
| 281 | +3093x | +
+ if (length(x) == 0) {
|
||
| 1226 | +282 |
- ## in some meaningful way to the function+ "" |
||
| 1227 | +283 |
- ## we will be calling.+ } else {
|
||
| 1228 | -13x | +284 | +5x |
- identical(+ paste(vapply(x, format_fnote_ref, ""), collapse = " ")+ |
+
| 285 | ++ |
+ } |
||
| 1229 | -13x | +286 | +321x |
- mget(+ }, ""), ncol = ncol(body)) |
| 1230 | -13x | +287 | +321x |
- as.character(subafun),+ body_ref_strs <- get_ref_matrix(obj)+ |
+
| 288 | ++ | + | ||
| 1231 | -13x | +289 | +321x |
- mode = "function",+ body <- matrix( |
| 1232 | -13x | +290 | +321x |
- ifnotfound = list(NULL),+ paste0( |
| 1233 | -13x | +291 | +321x |
- inherits = TRUE+ body, |
| 1234 | -13x | +292 | +321x |
- )[[1]],+ rbind( |
| 1235 | -13x | +293 | +321x |
- afun+ col_ref_strs,+ |
+
| 294 | +321x | +
+ body_ref_strs |
||
| 1236 | +295 |
) |
||
| 1237 | +296 |
- ) {
+ ), |
||
| 1238 | -13x | +297 | +321x |
- defrowlab <- as.character(subafun)+ nrow = nrow(body),+ |
+
| 298 | +321x | +
+ ncol = ncol(body) |
||
| 1239 | +299 |
- } else {
+ ) |
||
| 1240 | -! | +|||
| 300 | +
- defrowlab <- ""+ + |
+ |||
| 301 | +321x | +
+ ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here+ |
+ ||
| 302 | +321x | +
+ pag_titles <- page_titles(obj) |
||
| 1241 | +303 |
- }+ |
||
| 1242 | -13x | +304 | +321x |
- afun <- lapply(+ MatrixPrintForm( |
| 1243 | -13x | +305 | +321x |
- get_acolvar_vars(lyt),+ strings = body, |
| 1244 | -13x | +306 | +321x |
- function(x) afun+ spans = spans, |
| 1245 | -+ | |||
| 307 | +321x |
- )+ aligns = aligns,+ |
+ ||
| 308 | +321x | +
+ formats = formats, |
||
| 1246 | +309 |
- } else {
+ ## display = display, purely a function of spans, handled in constructor now |
||
| 1247 | -9x | +310 | +321x |
- defrowlab <- ""+ row_info = sr,+ |
+
| 311 | +321x | +
+ colpaths = make_col_df(obj)[["path"]], |
||
| 1248 | +312 |
- }+ ## line_grouping handled internally now line_grouping = 1:nrow(body), |
||
| 1249 | -22x | +313 | +321x |
- spl <- AnalyzeColVarSplit(+ ref_fnotes = ref_fnotes, |
| 1250 | -22x | +314 | +321x |
- afun = afun,+ nlines_header = nr_header, ## this is fixed internally |
| 1251 | -22x | +315 | +321x |
- defrowlab = defrowlab,+ nrow_header = nr_header, |
| 1252 | -22x | +316 | +321x |
- split_format = format,+ expand_newlines = expand_newlines, |
| 1253 | -22x | +317 | +321x |
- split_na_str = na_str,+ has_rowlabs = TRUE, |
| 1254 | -22x | +318 | +321x |
- split_name = get_acolvar_name(lyt),+ has_topleft = TRUE, |
| 1255 | -22x | +319 | +321x |
- indent_mod = indent_mod,+ main_title = main_title(obj), |
| 1256 | -22x | +320 | +321x |
- extra_args = extra_args,+ subtitles = subtitles(obj), |
| 1257 | -22x | +321 | +321x |
- inclNAs = inclNAs+ page_titles = pag_titles, |
| 1258 | -+ | |||
| 322 | +321x |
- )+ main_footer = main_footer(obj), |
||
| 1259 | -22x | +323 | +321x |
- pos <- next_rpos(lyt, nested, for_analyze = TRUE)+ prov_footer = prov_footer(obj), |
| 1260 | -22x | +324 | +321x |
- split_rows(lyt, spl, pos)+ table_inset = table_inset(obj), |
| 1261 | -+ | |||
| 325 | +321x |
- }+ header_section_div = header_section_div(obj), |
||
| 1262 | -+ | |||
| 326 | +321x |
-
+ horizontal_sep = horizontal_sep(obj), |
||
| 1263 | -+ | |||
| 327 | +321x |
- ## Add a total column at the next **top level** spot in+ indent_size = indent_size, |
||
| 1264 | -+ | |||
| 328 | +321x |
- ## the column layout.+ fontspec = fontspec, |
||
| 1265 | -+ | |||
| 329 | +321x |
-
+ col_gap = col_gap |
||
| 1266 | +330 |
- #' Add overall column+ ) |
||
| 1267 | +331 |
- #'+ } |
||
| 1268 | +332 |
- #' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits.+ ) |
||
| 1269 | +333 |
- #' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits.+ |
||
| 1270 | +334 |
- #'+ |
||
| 1271 | +335 |
- #' @inheritParams lyt_args+ check_ccount_vis_ok <- function(tt) {
|
||
| 1272 | -+ | |||
| 336 | +324x |
- #'+ ctree <- coltree(tt) |
||
| 1273 | -+ | |||
| 337 | +324x |
- #' @inherit split_cols_by return+ tlkids <- tree_children(ctree) |
||
| 1274 | -+ | |||
| 338 | +324x |
- #'+ lapply(tlkids, ccvis_check_subtree) |
||
| 1275 | -+ | |||
| 339 | +323x |
- #' @seealso [add_overall_level()]+ invisible(NULL) |
||
| 1276 | +340 |
- #'+ } |
||
| 1277 | +341 |
- #' @examples+ |
||
| 1278 | +342 |
- #' lyt <- basic_table() %>%+ ccvis_check_subtree <- function(ctree) {
+ |
+ ||
| 343 | +1673x | +
+ kids <- tree_children(ctree) |
||
| 1279 | -+ | |||
| 344 | +1673x |
- #' split_cols_by("ARM") %>%
+ if (is.null(kids)) {
|
||
| 1280 | -+ | |||
| 345 | +! |
- #' add_overall_col("All Patients") %>%
+ return(invisible(NULL)) |
||
| 1281 | +346 |
- #' analyze("AGE")
+ } |
||
| 1282 | -+ | |||
| 347 | +1673x |
- #' lyt+ vals <- vapply(kids, disp_ccounts, TRUE) |
||
| 1283 | -+ | |||
| 348 | +1673x |
- #'+ if (length(unique(vals)) > 1) {
|
||
| 1284 | -+ | |||
| 349 | +1x |
- #' tbl <- build_table(lyt, DM)+ unmatch <- which(!duplicated(vals))[1:2] |
||
| 1285 | -+ | |||
| 350 | +1x |
- #' tbl+ stop( |
||
| 1286 | -+ | |||
| 351 | +1x |
- #'+ "Detected different colcount visibility among sibling facets (those ", |
||
| 1287 | -+ | |||
| 352 | +1x |
- #' @export+ "arising from the same split_cols_by* layout instruction). This is ", |
||
| 1288 | -+ | |||
| 353 | +1x |
- add_overall_col <- function(lyt, label) {
+ "not supported.\n", |
||
| 1289 | -99x | +354 | +1x |
- spl <- AllSplit(label)+ "Set count values to NA if you want a blank space to appear as the ", |
| 1290 | -99x | +355 | +1x |
- split_cols(+ "displayed count for particular facets.\n", |
| 1291 | -99x | +356 | +1x |
- lyt,+ "First disagreement occured at paths:\n", |
| 1292 | -99x | +357 | +1x |
- spl,+ .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[1]]]))), "\n", |
| 1293 | -99x | +358 | +1x |
- next_cpos(lyt, FALSE)+ .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[2]]]))) |
| 1294 | +359 |
- )+ ) |
||
| 1295 | +360 |
- }+ } |
||
| 1296 | -+ | |||
| 361 | +1672x |
-
+ lapply(kids, ccvis_check_subtree) |
||
| 1297 | -+ | |||
| 362 | +1672x |
- ## add_row_summary ====+ invisible(NULL) |
||
| 1298 | +363 |
-
+ } |
||
| 1299 | +364 |
- #' @inheritParams lyt_args+ .quick_handle_nl <- function(str_v) {
|
||
| 1300 | -+ | |||
| 365 | +! |
- #'+ if (any(grepl("\n", str_v))) {
|
||
| 1301 | -+ | |||
| 366 | +! |
- #' @export+ return(unlist(strsplit(str_v, "\n", fixed = TRUE))) |
||
| 1302 | +367 |
- #'+ } else {
|
||
| 1303 | -+ | |||
| 368 | +! |
- #' @rdname int_methods+ return(str_v) |
||
| 1304 | +369 |
- setGeneric(+ } |
||
| 1305 | +370 |
- ".add_row_summary",+ } |
||
| 1306 | +371 |
- function(lyt,+ |
||
| 1307 | +372 |
- label,+ .resolve_fn_symbol <- function(fn) {
|
||
| 1308 | -+ | |||
| 373 | +3242x |
- cfun,+ if (!is(fn, "RefFootnote")) {
|
||
| 1309 | -+ | |||
| 374 | +! |
- child_labels = c("default", "visible", "hidden"),
+ return(NULL) |
||
| 1310 | +375 |
- cformat = NULL,+ } |
||
| 1311 | -+ | |||
| 376 | +3242x |
- cna_str = "-",+ ret <- ref_symbol(fn) |
||
| 1312 | -+ | |||
| 377 | +3242x |
- indent_mod = 0L,+ if (is.na(ret)) {
|
||
| 1313 | -+ | |||
| 378 | +3242x |
- cvar = "",+ ret <- as.character(ref_index(fn)) |
||
| 1314 | +379 |
- extra_args = list()) {
+ } |
||
| 1315 | -411x | +380 | +3242x |
- standardGeneric(".add_row_summary")
+ ret |
| 1316 | +381 |
- }+ } |
||
| 1317 | +382 |
- )+ |
||
| 1318 | +383 |
-
+ format_fnote_ref <- function(fn) {
|
||
| 1319 | -+ | |||
| 384 | +43194x |
- #' @rdname int_methods+ if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
|
||
| 1320 | -+ | |||
| 385 | +42653x |
- setMethod(+ return("")
|
||
| 1321 | -+ | |||
| 386 | +541x |
- ".add_row_summary", "PreDataTableLayouts",+ } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
|
||
| 1322 | -+ | |||
| 387 | +! |
- function(lyt,+ return(vapply(fn, format_fnote_ref, "")) |
||
| 1323 | +388 |
- label,+ } |
||
| 1324 | -+ | |||
| 389 | +541x |
- cfun,+ if (is.list(fn)) {
+ |
+ ||
| 390 | +536x | +
+ inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol)) |
||
| 1325 | +391 |
- child_labels = c("default", "visible", "hidden"),
+ } else {
+ |
+ ||
| 392 | +5x | +
+ inds <- .resolve_fn_symbol(fn) |
||
| 1326 | +393 |
- cformat = NULL,+ }+ |
+ ||
| 394 | +541x | +
+ if (length(inds) > 0) {
+ |
+ ||
| 395 | +541x | +
+ paste0(" {", paste(unique(inds), collapse = ", "), "}")
|
||
| 1327 | +396 |
- cna_str = "-",+ } else {
|
||
| 1328 | +397 |
- indent_mod = 0L,+ "" |
||
| 1329 | +398 |
- cvar = "",+ } |
||
| 1330 | +399 |
- extra_args = list()) {
+ } |
||
| 1331 | -105x | +|||
| 400 | +
- child_labels <- match.arg(child_labels)+ |
|||
| 1332 | -105x | +|||
| 401 | +
- tmp <- .add_row_summary(rlayout(lyt), label, cfun,+ format_fnote_note <- function(fn) {
|
|||
| 1333 | -105x | +402 | +2691x |
- child_labels = child_labels,+ if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
|
| 1334 | -105x | +|||
| 403 | +! |
- cformat = cformat,+ return(character()) |
||
| 1335 | -105x | +|||
| 404 | +
- cna_str = cna_str,+ } |
|||
| 1336 | -105x | +405 | +2691x |
- indent_mod = indent_mod,+ if (is.list(fn)) {
|
| 1337 | -105x | +|||
| 406 | +! |
- cvar = cvar,+ return(unlist(lapply(unlist(fn), format_fnote_note))) |
||
| 1338 | -105x | +|||
| 407 | +
- extra_args = extra_args+ } |
|||
| 1339 | +408 |
- )+ |
||
| 1340 | -105x | +409 | +2691x |
- rlayout(lyt) <- tmp+ if (is(fn, "RefFootnote")) {
|
| 1341 | -105x | +410 | +2691x |
- lyt+ paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
|
| 1342 | +411 |
- }+ } else {
|
||
| 1343 | -+ | |||
| 412 | +! |
- )+ NULL |
||
| 1344 | +413 |
-
+ } |
||
| 1345 | +414 |
- #' @rdname int_methods+ } |
||
| 1346 | +415 |
- setMethod(+ |
||
| 1347 | +416 |
- ".add_row_summary", "PreDataRowLayout",+ .fn_ind_extractor <- function(strs) {
|
||
| 1348 | -+ | |||
| 417 | +! |
- function(lyt,+ res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
|
||
| 1349 | -+ | |||
| 418 | +! |
- label,+ res[res == "NA"] <- NA_character_ |
||
| 1350 | +419 |
- cfun,+ ## these mixing is allowed now with symbols |
||
| 1351 | +420 |
- child_labels = c("default", "visible", "hidden"),
+ ## if(!(sum(is.na(res)) %in% c(0L, length(res)))) |
||
| 1352 | +421 |
- cformat = NULL,+ ## stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
|
||
| 1353 | -+ | |||
| 422 | +! |
- cna_str = "-",+ res |
||
| 1354 | +423 |
- indent_mod = 0L,+ } |
||
| 1355 | +424 |
- cvar = "",+ |
||
| 1356 | +425 |
- extra_args = list()) {
+ get_ref_matrix <- function(tt) {
|
||
| 1357 | -105x | +426 | +321x |
- child_labels <- match.arg(child_labels)+ if (ncol(tt) == 0 || nrow(tt) == 0) {
|
| 1358 | -105x | +427 | +5x |
- if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
+ return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
|
| 1359 | +428 |
- ## XXX ignoring indent mod here+ } |
||
| 1360 | -9x | +429 | +316x |
- rt <- root_spl(lyt)+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE) |
| 1361 | -9x | +430 | +316x |
- rt <- .add_row_summary(rt,+ lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE) |
| 1362 | -9x | +431 | +316x |
- label,+ cstrs <- unlist(lapply(lst, format_fnote_ref)) |
| 1363 | -9x | +432 | +316x |
- cfun,+ bodymat <- matrix(cstrs, |
| 1364 | -9x | +433 | +316x |
- child_labels = child_labels,+ byrow = TRUE, |
| 1365 | -9x | +434 | +316x |
- cformat = cformat,+ nrow = nrow(tt), |
| 1366 | -9x | +435 | +316x |
- cna_str = cna_str,+ ncol = ncol(tt) |
| 1367 | -9x | +|||
| 436 | +
- cvar = cvar,+ ) |
|||
| 1368 | -9x | +437 | +316x |
- extra_args = extra_args+ cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat) |
| 1369 | +438 |
- )- |
- ||
| 1370 | -9x | -
- root_spl(lyt) <- rt+ } |
||
| 1371 | +439 |
- } else {
+
|
||
| 1372 | -96x | +|||
| 440 | +
- ind <- length(lyt)+ get_formatted_fnotes <- function(tt) {
|
|||
| 1373 | -96x | +441 | +321x |
- tmp <- .add_row_summary(lyt[[ind]], label, cfun,+ colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes) |
| 1374 | -96x | +442 | +321x |
- child_labels = child_labels,+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE) |
| 1375 | -96x | +443 | +321x |
- cformat = cformat,+ lst <- c( |
| 1376 | -96x | +444 | +321x |
- cna_str = cna_str,+ colresfs, |
| 1377 | -96x | +445 | +321x |
- indent_mod = indent_mod,+ unlist( |
| 1378 | -96x | +446 | +321x |
- cvar = cvar,+ lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)), |
| 1379 | -96x | +447 | +321x |
- extra_args = extra_args+ recursive = FALSE |
| 1380 | +448 |
- )+ ) |
||
| 1381 | -96x | +|||
| 449 | +
- lyt[[ind]] <- tmp+ ) |
|||
| 1382 | +450 |
- }+ |
||
| 1383 | -105x | +451 | +321x |
- lyt+ inds <- vapply(lst, ref_index, 1L) |
| 1384 | -+ | |||
| 452 | +321x |
- }+ ord <- order(inds) |
||
| 1385 | -+ | |||
| 453 | +321x |
- )+ lst <- lst[ord] |
||
| 1386 | -+ | |||
| 454 | +321x |
-
+ syms <- vapply(lst, ref_symbol, "") |
||
| 1387 | -+ | |||
| 455 | +321x |
- #' @rdname int_methods+ keep <- is.na(syms) | !duplicated(syms) |
||
| 1388 | -+ | |||
| 456 | +321x |
- setMethod(+ lst <- lst[keep] |
||
| 1389 | -+ | |||
| 457 | +321x |
- ".add_row_summary", "SplitVector",+ unique(vapply(lst, format_fnote_note, "")) |
||
| 1390 | +458 |
- function(lyt,+ |
||
| 1391 | +459 |
- label,+ ## , recursive = FALSE) |
||
| 1392 | +460 |
- cfun,+ ## rlst <- unlist(lapply(rows, row_footnotes)) |
||
| 1393 | +461 |
- child_labels = c("default", "visible", "hidden"),
+ ## lst <- |
||
| 1394 | +462 |
- cformat = NULL,+ ## syms <- vapply(lst, ref_symbol, "") |
||
| 1395 | +463 |
- cna_str = "-",+ ## keep <- is.na(syms) | !duplicated(syms) |
||
| 1396 | +464 |
- indent_mod = 0L,+ ## lst <- lst[keep] |
||
| 1397 | +465 |
- cvar = "",+ ## inds <- vapply(lst, ref_index, 1L) |
||
| 1398 | +466 |
- extra_args = list()) {
- |
- ||
| 1399 | -96x | -
- child_labels <- match.arg(child_labels)- |
- ||
| 1400 | -96x | -
- ind <- length(lyt)- |
- ||
| 1401 | -! | -
- if (ind == 0) stop("no split to add content rows at")
- |
- ||
| 1402 | -96x | -
- spl <- lyt[[ind]]+ ## cellstrs <- unlist(lapply(lst, format_fnote_note)) |
||
| 1403 | +467 |
- # if(is(spl, "AnalyzeVarSplit"))+ ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw)))) |
||
| 1404 | +468 |
- # stop("can't add content rows to analyze variable split")
- |
- ||
| 1405 | -96x | -
- tmp <- .add_row_summary(spl,+ ## allstrs <- c(colstrs, rstrs, cellstrs) |
||
| 1406 | -96x | +|||
| 469 | +
- label,+ ## inds <- .fn_ind_extractor(allstrs) |
|||
| 1407 | -96x | +|||
| 470 | +
- cfun,+ ## allstrs[order(inds)] |
|||
| 1408 | -96x | +|||
| 471 | +
- child_labels = child_labels,+ } |
|||
| 1409 | -96x | +|||
| 472 | +
- cformat = cformat,+ |
|||
| 1410 | -96x | +|||
| 473 | +
- cna_str = cna_str,+ .do_tbl_h_piece2 <- function(tt) {
|
|||
| 1411 | -96x | +474 | +329x |
- indent_mod = indent_mod,+ coldf <- make_col_df(tt, visible_only = FALSE) |
| 1412 | -96x | +475 | +329x |
- cvar = cvar,+ remain <- seq_len(nrow(coldf)) |
| 1413 | -96x | -
- extra_args = extra_args- |
- ||
| 1414 | -+ | 476 | +329x |
- )+ chunks <- list() |
| 1415 | -96x | +477 | +329x |
- lyt[[ind]] <- tmp+ cur <- 1 |
| 1416 | -96x | +478 | +329x |
- lyt+ na_str <- colcount_na_str(tt) |
| 1417 | +479 |
- }+ |
||
| 1418 | +480 |
- )+ ## XXX this would be better as the facet-associated |
||
| 1419 | +481 |
-
+ ## format but I don't know that we need to |
||
| 1420 | +482 |
- #' @rdname int_methods+ ## support that level of differentiation anyway... |
||
| 1421 | -+ | |||
| 483 | +329x |
- setMethod(+ cc_format <- colcount_format(tt) |
||
| 1422 | +484 |
- ".add_row_summary", "Split",+ ## each iteration of this loop identifies |
||
| 1423 | +485 |
- function(lyt,+ ## all rows corresponding to one top-level column |
||
| 1424 | +486 |
- label,+ ## label and its children, then processes those |
||
| 1425 | +487 |
- cfun,+ ## with .do_header_chunk |
||
| 1426 | -+ | |||
| 488 | +329x |
- child_labels = c("default", "visible", "hidden"),
+ while (length(remain) > 0) {
|
||
| 1427 | -+ | |||
| 489 | +886x |
- cformat = NULL,+ rw <- remain[1] |
||
| 1428 | -+ | |||
| 490 | +886x |
- cna_str = "-",+ inds <- coldf$leaf_indices[[rw]] |
||
| 1429 | -+ | |||
| 491 | +886x |
- indent_mod = 0L,+ endblock <- which(coldf$abs_pos == max(inds)) |
||
| 1430 | +492 |
- cvar = "",+ |
||
| 1431 | -+ | |||
| 493 | +886x |
- extra_args = list()) {
+ stopifnot(endblock >= rw) |
||
| 1432 | -105x | +494 | +886x |
- child_labels <- match.arg(child_labels)+ chunk_res <- .do_header_chunk(coldf[rw:endblock, ], cc_format, na_str = na_str) |
| 1433 | -+ | |||
| 495 | +884x |
- # lbl_kids = .labelkids_helper(child_labels)+ chunk_res <- unlist(chunk_res, recursive = FALSE) |
||
| 1434 | -105x | +496 | +884x |
- content_fun(lyt) <- cfun+ chunks[[cur]] <- chunk_res |
| 1435 | -105x | +497 | +884x |
- content_indent_mod(lyt) <- indent_mod+ remain <- remain[remain > endblock] |
| 1436 | -105x | +498 | +884x |
- content_var(lyt) <- cvar+ cur <- cur + 1 |
| 1437 | +499 |
- ## obj_format(lyt) = cformat+ } |
||
| 1438 | -105x | +500 | +327x |
- content_format(lyt) <- cformat+ chunks <- .pad_tops(chunks) |
| 1439 | -105x | -
- if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
- |
- ||
| 1440 | -! | +501 | +327x |
- label_kids(lyt) <- child_labels+ lapply( |
| 1441 | -+ | |||
| 502 | +327x |
- }+ seq_len(length(chunks[[1]])), |
||
| 1442 | -105x | +503 | +327x |
- content_na_str <- cna_str+ function(i) {
|
| 1443 | -105x | +504 | +522x |
- content_extra_args(lyt) <- extra_args+ DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE)) |
| 1444 | -105x | +|||
| 505 | +
- lyt+ } |
|||
| 1445 | +506 |
- }+ ) |
||
| 1446 | +507 |
- )+ } |
||
| 1447 | +508 | |||
| 1448 | +509 |
- .count_raw_constr <- function(var, format, label_fstr) {
+ .pad_end <- function(lst, padto, ncols) {
|
||
| 1449 | -2x | +510 | +1407x |
- function(df, labelstr = "") {
+ curcov <- sum(vapply(lst, cell_cspan, 0L)) |
| 1450 | -24x | +511 | +1407x |
- if (grepl("%s", label_fstr, fixed = TRUE)) {
+ if (curcov == padto) {
|
| 1451 | -21x | +512 | +1407x | +
+ return(lst)+ |
+
| 513 | ++ |
+ }+ |
+ ||
| 514 | ++ | + + | +||
| 515 | +! |
- label <- sprintf(label_fstr, labelstr)+ c(lst, list(rcell("", colspan = padto - curcov)))
|
||
| 1452 | +516 |
- } else {
+ } |
||
| 1453 | -3x | +|||
| 517 | +
- label <- label_fstr+ |
|||
| 1454 | +518 |
- }+ .pad_tops <- function(chunks) {
|
||
| 1455 | -24x | +519 | +327x |
- if (is(df, "data.frame")) {
+ lens <- vapply(chunks, length, 1L) |
| 1456 | -24x | +520 | +327x |
- if (!is.null(var) && nzchar(var)) {
+ padto <- max(lens) |
| 1457 | -3x | +521 | +327x |
- cnt <- sum(!is.na(df[[var]]))+ needpad <- lens != padto |
| 1458 | -+ | |||
| 522 | +327x |
- } else {
+ if (all(!needpad)) {
|
||
| 1459 | -21x | +523 | +321x |
- cnt <- nrow(df)+ return(chunks) |
| 1460 | +524 |
- }+ } |
||
| 1461 | -2x | +|||
| 525 | +
- } else { # df is the data column vector
+
|
|||
| 1462 | -! | +|||
| 526 | +6x |
- cnt <- sum(!is.na(df))+ for (i in seq_along(lens)) {
|
||
| 1463 | -+ | |||
| 527 | +25x |
- }+ if (lens[i] < padto) {
|
||
| 1464 | -24x | +528 | +10x |
- ret <- rcell(cnt,+ chk <- chunks[[i]] |
| 1465 | -24x | +529 | +10x |
- format = format,+ span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L)) |
| 1466 | -24x | +530 | +10x |
- label = label+ chunks[[i]] <- c( |
| 1467 | -+ | |||
| 531 | +10x |
- )+ replicate(list(list(rcell("", colspan = span))),
|
||
| 1468 | -24x | +532 | +10x |
- ret+ n = padto - lens[i] |
| 1469 | +533 |
- }+ ), |
||
| 1470 | -+ | |||
| 534 | +10x |
- }+ chk |
||
| 1471 | +535 |
-
+ ) |
||
| 1472 | +536 |
- .count_wpcts_constr <- function(var, format, label_fstr) {
+ } |
||
| 1473 | -90x | +|||
| 537 | +
- function(df, labelstr = "", .N_col) {
+ } |
|||
| 1474 | -1523x | +538 | +6x |
- if (grepl("%s", label_fstr, fixed = TRUE)) {
+ chunks |
| 1475 | -1499x | +|||
| 539 | +
- label <- sprintf(label_fstr, labelstr)+ } |
|||
| 1476 | +540 |
- } else {
+
|
||
| 1477 | -24x | +|||
| 541 | +
- label <- label_fstr+ .do_header_chunk <- function(coldf, cc_format, na_str) {
|
|||
| 1478 | +542 |
- }+ ## hard assumption that coldf is a section |
||
| 1479 | -1523x | +|||
| 543 | +
- if (is(df, "data.frame")) {
+ ## of a column dataframe summary that was |
|||
| 1480 | -1523x | +|||
| 544 | +
- if (!is.null(var) && nzchar(var)) {
+ ## created with visible_only=FALSE |
|||
| 1481 | -407x | +545 | +886x |
- cnt <- sum(!is.na(df[[var]]))+ nleafcols <- length(coldf$leaf_indices[[1]]) |
| 1482 | +546 |
- } else {
+
|
||
| 1483 | -1116x | +547 | +886x |
- cnt <- nrow(df)+ spldfs <- split(coldf, lengths(coldf$path)) |
| 1484 | -+ | |||
| 548 | +886x |
- }+ toret <- lapply( |
||
| 1485 | -90x | +549 | +886x |
- } else { # df is the data column vector
+ seq_along(spldfs), |
| 1486 | -! | +|||
| 550 | +886x |
- cnt <- sum(!is.na(df))+ function(i) {
|
||
| 1487 | -+ | |||
| 551 | +1236x |
- }+ rws <- spldfs[[i]] |
||
| 1488 | -+ | |||
| 552 | +1236x |
- ## the formatter does the *100 so we don't here.+ thisbit_vals <- lapply( |
||
| 1489 | -+ | |||
| 553 | +1236x |
- ## TODO name elements of this so that ARD generation has access to them+ seq_len(nrow(rws)), |
||
| 1490 | -+ | |||
| 554 | +1236x |
- ## ret <- rcell(c(n = cnt, pct = cnt / .N_col),+ function(ri) {
|
||
| 1491 | -1523x | +555 | +1685x |
- ret <- rcell(c(cnt, cnt / .N_col),+ cellii <- rcell(rws[ri, "label", drop = TRUE], |
| 1492 | -1523x | +556 | +1685x |
- format = format,+ colspan = rws$total_span[ri], |
| 1493 | -1523x | +557 | +1685x |
- label = label+ footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]] |
| 1494 | +558 |
- )+ ) |
||
| 1495 | -1523x | -
- ret- |
- ||
| 1496 | -+ | 559 | +1685x |
- }+ cellii |
| 1497 | +560 |
- }+ } |
||
| 1498 | +561 |
-
+ ) |
||
| 1499 | -+ | |||
| 562 | +1236x |
- .validate_cfuns <- function(fun) {
+ ret <- list(.pad_end(thisbit_vals, padto = nleafcols)) |
||
| 1500 | -111x | +563 | +1236x |
- if (is.list(fun)) {
+ anycounts <- any(rws$ccount_visible) |
| 1501 | -2x | +564 | +1236x |
- return(unlist(lapply(fun, .validate_cfuns)))+ if (anycounts) {
|
| 1502 | -+ | |||
| 565 | +173x |
- }+ thisbit_ns <- lapply( |
||
| 1503 | -+ | |||
| 566 | +173x |
-
+ seq_len(nrow(rws)), |
||
| 1504 | -109x | +567 | +173x |
- frmls <- formals(fun)+ function(ri) {
|
| 1505 | -109x | +568 | +337x |
- ls_pos <- match("labelstr", names(frmls))
+ vis_ri <- rws$ccount_visible[ri] |
| 1506 | -109x | +569 | +337x |
- if (is.na(ls_pos)) {
+ val <- if (vis_ri) rws$col_count[ri] else NULL |
| 1507 | -! | +|||
| 570 | +337x |
- stop("content functions must explicitly accept a 'labelstr' argument")
+ fmt <- rws$ccount_format[ri] |
||
| 1508 | -+ | |||
| 571 | +337x |
- }+ if (is.character(fmt)) {
|
||
| 1509 | -+ | |||
| 572 | +337x |
-
+ cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == fmt)))) |
||
| 1510 | -109x | +573 | +337x |
- list(fun)+ if (cfmt_dim == "2d") {
|
| 1511 | -+ | |||
| 574 | +7x |
- }+ if (grepl("%", fmt)) {
|
||
| 1512 | -+ | |||
| 575 | +6x |
-
+ val <- c(val, 1) ## XXX This is the old behavior but it doesn't take into account parent counts... |
||
| 1513 | +576 |
- #' Analysis function to count levels of a factor with percentage of the column total+ } else {
|
||
| 1514 | -+ | |||
| 577 | +1x |
- #'+ stop( |
||
| 1515 | -+ | |||
| 578 | +1x |
- #' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery.+ "This 2d format is not supported for column counts. ", |
||
| 1516 | -+ | |||
| 579 | +1x |
- #' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery.+ "Please choose a 1d format or a 2d format that includes a % value." |
||
| 1517 | +580 |
- #'+ ) |
||
| 1518 | +581 |
- #' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor.+ } |
||
| 1519 | -+ | |||
| 582 | +330x |
- #'+ } else if (cfmt_dim == "3d") {
|
||
| 1520 | -+ | |||
| 583 | +1x |
- #' @examples+ stop("3d formats are not supported for column counts.")
|
||
| 1521 | +584 |
- #' counts_wpcts(DM$SEX, 400)+ } |
||
| 1522 | +585 |
- #'+ } |
||
| 1523 | -+ | |||
| 586 | +335x |
- #' @export+ cellii <- rcell( |
||
| 1524 | -+ | |||
| 587 | +335x |
- counts_wpcts <- function(x, .N_col) {
+ val, |
||
| 1525 | -2x | +588 | +335x |
- if (!is.factor(x)) {
+ colspan = rws$total_span[ri], |
| 1526 | -1x | +589 | +335x |
- stop(+ format = fmt, # cc_format, |
| 1527 | -1x | +590 | +335x |
- "using the 'counts_wpcts' analysis function requires factor data ",+ format_na_str = na_str |
| 1528 | -1x | +|||
| 591 | +
- "to guarantee equal numbers of rows across all collumns, got class ",+ ) |
|||
| 1529 | -1x | +592 | +335x |
- class(x), "."+ cellii |
| 1530 | +593 |
- )+ } |
||
| 1531 | +594 |
- }- |
- ||
| 1532 | -1x | -
- ret <- table(x)+ ) |
||
| 1533 | -1x | +595 | +171x |
- in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)")))+ ret <- c(ret, list(.pad_end(thisbit_ns, padto = nleafcols))) |
| 1534 | +596 |
- }+ } |
||
| 1535 | -+ | |||
| 597 | +1234x |
-
+ ret |
||
| 1536 | +598 |
- #' Add a content row of summary counts+ } |
||
| 1537 | +599 |
- #'+ ) |
||
| 1538 | -+ | |||
| 600 | +884x |
- #' @inheritParams lyt_args+ toret |
||
| 1539 | +601 |
- #'+ } |
||
| 1540 | +602 |
- #' @inherit split_cols_by return+ |
||
| 1541 | +603 |
- #'+ .tbl_header_mat <- function(tt) {
|
||
| 1542 | -+ | |||
| 604 | +323x |
- #' @details+ rows <- .do_tbl_h_piece2(tt) ## (clyt) |
||
| 1543 | -+ | |||
| 605 | +321x |
- #' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values+ cinfo <- col_info(tt) |
||
| 1544 | +606 |
- #' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of+ |
||
| 1545 | -+ | |||
| 607 | +321x |
- #' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only+ nc <- ncol(tt) |
||
| 1546 | -+ | |||
| 608 | +321x |
- #' raw counts are used.+ body <- matrix(rapply(rows, function(x) {
|
||
| 1547 | -+ | |||
| 609 | +512x |
- #'+ cs <- row_cspans(x) |
||
| 1548 | -+ | |||
| 610 | +512x |
- #' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset+ strs <- get_formatted_cells(x) |
||
| 1549 | -+ | |||
| 611 | +512x |
- #' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept+ strs |
||
| 1550 | -+ | |||
| 612 | +321x |
- #' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently+ }), ncol = nc, byrow = TRUE) |
||
| 1551 | +613 |
- #' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]).+ |
||
| 1552 | -+ | |||
| 614 | +321x |
- #'+ span <- matrix(rapply(rows, function(x) {
|
||
| 1553 | -+ | |||
| 615 | +512x |
- #' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params]+ cs <- row_cspans(x) |
||
| 1554 | -+ | |||
| 616 | +! |
- #' that can be used in `cfun`.+ if (is.null(cs)) cs <- rep(1, ncol(x)) |
||
| 1555 | -+ | |||
| 617 | +512x |
- #'+ rep(cs, cs) |
||
| 1556 | -+ | |||
| 618 | +321x |
- #' @examples+ }), ncol = nc, byrow = TRUE) |
||
| 1557 | +619 |
- #' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
+
|
||
| 1558 | -+ | |||
| 620 | +321x |
- #'+ fnote <- do.call( |
||
| 1559 | -+ | |||
| 621 | +321x |
- #' lyt <- basic_table() %>%+ rbind, |
||
| 1560 | -+ | |||
| 622 | +321x |
- #' split_cols_by("ARM") %>%
+ lapply(rows, function(x) {
|
||
| 1561 | -+ | |||
| 623 | +512x |
- #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
+ cell_footnotes(x) |
||
| 1562 | +624 |
- #' summarize_row_groups(label_fstr = "%s (n)") %>%+ }) |
||
| 1563 | +625 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
+ ) |
||
| 1564 | +626 |
- #' lyt+ |
||
| 1565 | -+ | |||
| 627 | +321x |
- #'+ tl <- top_left(cinfo) |
||
| 1566 | -+ | |||
| 628 | +321x |
- #' tbl <- build_table(lyt, DM2)+ lentl <- length(tl) |
||
| 1567 | -+ | |||
| 629 | +321x |
- #' tbl+ nli <- nrow(body) |
||
| 1568 | -+ | |||
| 630 | +321x |
- #'+ if (lentl == 0) {
|
||
| 1569 | -+ | |||
| 631 | +272x |
- #' row_paths_summary(tbl) # summary count is a content table+ tl <- rep("", nli)
|
||
| 1570 | -+ | |||
| 632 | +49x |
- #'+ } else if (lentl > nli) {
|
||
| 1571 | -+ | |||
| 633 | +19x |
- #' ## use a cfun and extra_args to customize summarization+ tl_tmp <- paste0(tl, collapse = "\n") |
||
| 1572 | -+ | |||
| 634 | +19x |
- #' ## behavior+ tl <- rep("", nli)
|
||
| 1573 | -+ | |||
| 635 | +19x |
- #' sfun <- function(x, labelstr, trim) {
+ tl[length(tl)] <- tl_tmp |
||
| 1574 | -+ | |||
| 636 | +30x |
- #' in_rows(+ } else if (lentl < nli) {
|
||
| 1575 | +637 |
- #' c(mean(x, trim = trim), trim),+ # We want topleft alignment that goes to the bottom! |
||
| 1576 | -+ | |||
| 638 | +19x |
- #' .formats = "xx.x (xx.x%)",+ tl <- c(rep("", nli - lentl), tl)
|
||
| 1577 | +639 |
- #' .labels = sprintf(+ } |
||
| 1578 | -+ | |||
| 640 | +321x |
- #' "%s (Trimmed mean and trim %%)",+ list( |
||
| 1579 | -+ | |||
| 641 | +321x |
- #' labelstr+ body = cbind(tl, body, deparse.level = 0), span = cbind(1, span), |
||
| 1580 | -+ | |||
| 642 | +321x |
- #' )+ footnotes = cbind(list(list()), fnote) |
||
| 1581 | +643 |
- #' )+ ) |
||
| 1582 | +644 |
- #' }+ } |
||
| 1583 | +645 |
- #'+ |
||
| 1584 | +646 |
- #' lyt2 <- basic_table(show_colcounts = TRUE) %>%+ # get formatted cells ---- |
||
| 1585 | +647 |
- #' split_cols_by("ARM") %>%
+
|
||
| 1586 | +648 |
- #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
+ #' Get formatted cells |
||
| 1587 | +649 |
- #' summarize_row_groups("AGE",
+ #' |
||
| 1588 | +650 |
- #' cfun = sfun,+ #' @inheritParams gen_args |
||
| 1589 | +651 |
- #' extra_args = list(trim = .2)+ #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats |
||
| 1590 | +652 |
- #' ) %>%+ #' applied. Defaults to `FALSE`. |
||
| 1591 | +653 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ #' |
||
| 1592 | +654 |
- #' append_topleft(c("Country", " Age"))
+ #' @return The formatted print-strings for all (body) cells in `obj`. |
||
| 1593 | +655 |
#' |
||
| 1594 | +656 |
- #' tbl2 <- build_table(lyt2, DM2)+ #' @examples |
||
| 1595 | +657 |
- #' tbl2+ #' library(dplyr) |
||
| 1596 | +658 |
#' |
||
| 1597 | +659 |
- #' @author Gabriel Becker+ #' iris2 <- iris %>% |
||
| 1598 | +660 |
- #' @export+ #' group_by(Species) %>% |
||
| 1599 | +661 |
- summarize_row_groups <- function(lyt,+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 1600 | +662 |
- var = "",+ #' ungroup() |
||
| 1601 | +663 |
- label_fstr = "%s",+ #' |
||
| 1602 | +664 |
- format = "xx (xx.x%)",+ #' tbl <- basic_table() %>% |
||
| 1603 | +665 |
- na_str = "-",+ #' split_cols_by("Species") %>%
|
||
| 1604 | +666 |
- cfun = NULL,+ #' split_cols_by("group") %>%
|
||
| 1605 | +667 |
- indent_mod = 0L,+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
|
||
| 1606 | +668 |
- extra_args = list()) {
- |
- ||
| 1607 | -105x | -
- if (is.null(cfun)) {
- |
- ||
| 1608 | -92x | -
- if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
- |
- ||
| 1609 | -2x | -
- cfun <- .count_raw_constr(var, format, label_fstr)+ #' build_table(iris2) |
||
| 1610 | +669 |
- } else {
+ #' |
||
| 1611 | -90x | +|||
| 670 | +
- cfun <- .count_wpcts_constr(var, format, label_fstr)+ #' get_formatted_cells(tbl) |
|||
| 1612 | +671 |
- }+ #' |
||
| 1613 | +672 |
- }+ #' @export |
||
| 1614 | -105x | +|||
| 673 | +
- cfun <- .validate_cfuns(cfun)+ #' @rdname gfc |
|||
| 1615 | -105x | +674 | +41728x |
- .add_row_summary(lyt,+ setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells"))
|
| 1616 | -105x | +|||
| 675 | +
- cfun = cfun,+ |
|||
| 1617 | -105x | +|||
| 676 | +
- cformat = format,+ #' @rdname gfc |
|||
| 1618 | -105x | +|||
| 677 | +
- cna_str = na_str,+ setMethod( |
|||
| 1619 | -105x | +|||
| 678 | +
- indent_mod = indent_mod,+ "get_formatted_cells", "TableTree", |
|||
| 1620 | -105x | +|||
| 679 | +
- cvar = var,+ function(obj, shell = FALSE) {
|
|||
| 1621 | -105x | +680 | +3266x |
- extra_args = extra_args+ lr <- get_formatted_cells(tt_labelrow(obj), shell = shell) |
| 1622 | +681 |
- )+ |
||
| 1623 | -+ | |||
| 682 | +3266x |
- }+ ct <- get_formatted_cells(content_table(obj), shell = shell) |
||
| 1624 | +683 | |||
| 1625 | -- |
- #' Add the column population counts to the header- |
- ||
| 1626 | -+ | |||
| 684 | +3266x |
- #'+ els <- lapply(tree_children(obj), get_formatted_cells, shell = shell) |
||
| 1627 | +685 |
- #' Add the data derived column counts.+ |
||
| 1628 | +686 |
- #'+ ## TODO fix ncol problem for rrow() |
||
| 1629 | -+ | |||
| 687 | +3266x |
- #' @details It is often the case that the the column counts derived from the+ if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
|
||
| 1630 | -+ | |||
| 688 | +909x |
- #' input data to [build_table()] is not representative of the population counts.+ ct <- lr[NULL, ] |
||
| 1631 | +689 |
- #' For example, if events are counted in the table and the header should+ } |
||
| 1632 | +690 |
- #' display the number of subjects and not the total number of events.+ |
||
| 1633 | -+ | |||
| 691 | +3266x |
- #'+ do.call(rbind, c(list(lr), list(ct), els)) |
||
| 1634 | +692 |
- #' @inheritParams lyt_args+ } |
||
| 1635 | +693 |
- #'+ ) |
||
| 1636 | +694 |
- #' @inherit split_cols_by return+ |
||
| 1637 | +695 |
- #'+ #' @rdname gfc |
||
| 1638 | +696 |
- #' @examples+ setMethod( |
||
| 1639 | +697 |
- #' lyt <- basic_table() %>%+ "get_formatted_cells", "ElementaryTable", |
||
| 1640 | +698 |
- #' split_cols_by("ARM") %>%
+ function(obj, shell = FALSE) {
|
||
| 1641 | -+ | |||
| 699 | +6295x |
- #' add_colcounts() %>%+ lr <- get_formatted_cells(tt_labelrow(obj), shell = shell) |
||
| 1642 | -+ | |||
| 700 | +6295x |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ els <- lapply(tree_children(obj), get_formatted_cells, shell = shell) |
||
| 1643 | -+ | |||
| 701 | +6295x |
- #' analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
+ do.call(rbind, c(list(lr), els)) |
||
| 1644 | +702 |
- #' lyt+ } |
||
| 1645 | +703 |
- #'+ ) |
||
| 1646 | +704 |
- #' tbl <- build_table(lyt, DM)+ |
||
| 1647 | +705 |
- #' tbl+ #' @rdname gfc |
||
| 1648 | +706 |
- #'+ setMethod( |
||
| 1649 | +707 |
- #' @author Gabriel Becker+ "get_formatted_cells", "TableRow", |
||
| 1650 | +708 |
- #' @export+ function(obj, shell = FALSE) {
|
||
| 1651 | +709 |
- add_colcounts <- function(lyt, format = "(N=xx)") {
+ # Parent row format and na_str |
||
| 1652 | -76x | +710 | +22578x |
- if (is.null(lyt)) {
+ pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj) |
| 1653 | -! | +|||
| 711 | +22578x |
- lyt <- PreDataTableLayouts()+ pr_row_na_str <- obj_na_str(obj) %||% "NA" |
||
| 1654 | +712 |
- }+ |
||
| 1655 | -76x | +713 | +22578x |
- disp_ccounts(lyt) <- TRUE+ matrix( |
| 1656 | -76x | +714 | +22578x |
- colcount_format(lyt) <- format+ unlist(Map(function(val, spn, shelli) {
|
| 1657 | -76x | +715 | +108217x |
- lyt+ stopifnot(is(spn, "integer")) |
| 1658 | +716 |
- }+ |
||
| 1659 | -+ | |||
| 717 | +108217x |
-
+ out <- format_rcell(val, |
||
| 1660 | -+ | |||
| 718 | +108217x |
- ## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting.+ pr_row_format = pr_row_format, |
||
| 1661 | -+ | |||
| 719 | +108217x |
- #' Add an already calculated table to the layout+ pr_row_na_str = pr_row_na_str, |
||
| 1662 | -+ | |||
| 720 | +108217x |
- #'+ shell = shelli |
||
| 1663 | +721 |
- #' @inheritParams lyt_args+ ) |
||
| 1664 | -+ | |||
| 722 | +108217x |
- #' @inheritParams gen_args+ if (!is.function(out) && is.character(out)) {
|
||
| 1665 | -+ | |||
| 723 | +108209x |
- #'+ out <- paste(out, collapse = ", ") |
||
| 1666 | +724 |
- #' @inherit split_cols_by return+ } |
||
| 1667 | +725 |
- #'+ |
||
| 1668 | -+ | |||
| 726 | +108217x |
- #' @examples+ rep(list(out), spn) |
||
| 1669 | -+ | |||
| 727 | +22578x |
- #' lyt1 <- basic_table() %>%+ }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)), |
||
| 1670 | -+ | |||
| 728 | +22578x |
- #' split_cols_by("ARM") %>%
+ ncol = ncol(obj) |
||
| 1671 | +729 |
- #' analyze("AGE", afun = mean, format = "xx.xx")
+ ) |
||
| 1672 | +730 |
- #'+ } |
||
| 1673 | +731 |
- #' tbl1 <- build_table(lyt1, DM)+ ) |
||
| 1674 | +732 |
- #' tbl1+ |
||
| 1675 | +733 |
- #'+ #' @rdname gfc |
||
| 1676 | +734 |
- #' lyt2 <- basic_table() %>%+ setMethod( |
||
| 1677 | +735 |
- #' split_cols_by("ARM") %>%
+ "get_formatted_cells", "LabelRow", |
||
| 1678 | +736 |
- #' analyze("AGE", afun = sd, format = "xx.xx") %>%
+ function(obj, shell = FALSE) {
|
||
| 1679 | -+ | |||
| 737 | +9589x |
- #' add_existing_table(tbl1)+ nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
|
||
| 1680 | -+ | |||
| 738 | +9589x |
- #'+ vstr <- if (shell) "-" else "" |
||
| 1681 | -+ | |||
| 739 | +9589x |
- #' tbl2 <- build_table(lyt2, DM)+ if (labelrow_visible(obj)) {
|
||
| 1682 | -+ | |||
| 740 | +3310x |
- #' tbl2+ matrix(rep(vstr, nc), ncol = nc) |
||
| 1683 | +741 |
- #'+ } else {
|
||
| 1684 | -+ | |||
| 742 | +6279x |
- #' table_structure(tbl2)+ matrix(character(0), ncol = nc) |
||
| 1685 | +743 |
- #' row_paths_summary(tbl2)+ } |
||
| 1686 | +744 |
- #'+ } |
||
| 1687 | +745 |
- #' @author Gabriel Becker+ ) |
||
| 1688 | +746 |
- #' @export+ |
||
| 1689 | +747 |
- add_existing_table <- function(lyt, tt, indent_mod = 0) {
+ #' @rdname gfc |
||
| 1690 | -1x | +748 | +14998x |
- indent_mod(tt) <- indent_mod+ setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))
|
| 1691 | -1x | +|||
| 749 | +
- lyt <- split_rows(+ |
|||
| 1692 | -1x | +|||
| 750 | +
- lyt,+ #' @rdname gfc |
|||
| 1693 | -1x | +|||
| 751 | +
- tt,+ setMethod( |
|||
| 1694 | -1x | +|||
| 752 | +
- next_rpos(lyt, nested = FALSE)+ "get_cell_aligns", "TableTree", |
|||
| 1695 | +753 |
- )+ function(obj) {
|
||
| 1696 | -1x | +754 | +1631x |
- lyt+ lr <- get_cell_aligns(tt_labelrow(obj)) |
| 1697 | +755 |
- }+ + |
+ ||
| 756 | +1631x | +
+ ct <- get_cell_aligns(content_table(obj)) |
||
| 1698 | +757 | |||
| 1699 | -+ | |||
| 758 | +1631x |
- ## takes_coln = function(f) {
+ els <- lapply(tree_children(obj), get_cell_aligns) |
||
| 1700 | +759 |
- ## stopifnot(is(f, "function"))+ |
||
| 1701 | +760 |
- ## forms = names(formals(f))+ ## TODO fix ncol problem for rrow() |
||
| 1702 | -+ | |||
| 761 | +1631x |
- ## res = ".N_col" %in% forms+ if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
|
||
| 1703 | -+ | |||
| 762 | +454x |
- ## res+ ct <- lr[NULL, ] |
||
| 1704 | +763 |
- ## }+ } |
||
| 1705 | +764 | |||
| 1706 | -+ | |||
| 765 | +1631x |
- ## takes_totn = function(f) {
+ do.call(rbind, c(list(lr), list(ct), els)) |
||
| 1707 | +766 |
- ## stopifnot(is(f, "function"))+ } |
||
| 1708 | +767 |
- ## forms = names(formals(f))+ ) |
||
| 1709 | +768 |
- ## res = ".N_total" %in% forms+ |
||
| 1710 | +769 |
- ## res+ #' @rdname gfc |
||
| 1711 | +770 |
- ## }+ setMethod( |
||
| 1712 | +771 |
-
+ "get_cell_aligns", "ElementaryTable", |
||
| 1713 | +772 |
- ## use data to transform dynamic cuts to static cuts+ function(obj) {
|
||
| 1714 | -+ | |||
| 773 | +3143x |
- #' @rdname int_methods+ lr <- get_cell_aligns(tt_labelrow(obj)) |
||
| 1715 | -2612x | +774 | +3143x |
- setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))
+ els <- lapply(tree_children(obj), get_cell_aligns) |
| 1716 | -+ | |||
| 775 | +3143x |
-
+ do.call(rbind, c(list(lr), els)) |
||
| 1717 | +776 |
- #' @rdname int_methods+ } |
||
| 1718 | -975x | +|||
| 777 | +
- setMethod("fix_dyncuts", "Split", function(spl, df) spl)
+ ) |
|||
| 1719 | +778 | |||
| 1720 | +779 |
- #' @rdname int_methods+ #' @rdname gfc |
||
| 1721 | +780 |
setMethod( |
||
| 1722 | +781 |
- "fix_dyncuts", "VarDynCutSplit",+ "get_cell_aligns", "TableRow", |
||
| 1723 | +782 |
- function(spl, df) {
+ function(obj) {
|
||
| 1724 | -5x | +783 | +5436x |
- var <- spl_payload(spl)+ als <- vapply(row_cells(obj), cell_align, "") |
| 1725 | -5x | +784 | +5436x |
- varvec <- df[[var]]+ spns <- row_cspans(obj) |
| 1726 | +785 | |||
| 1727 | -5x | +786 | +5436x |
- cfun <- spl_cutfun(spl)+ matrix(rep(als, times = spns), |
| 1728 | -5x | +787 | +5436x |
- cuts <- cfun(varvec)+ ncol = ncol(obj) |
| 1729 | -5x | +|||
| 788 | +
- cutlabels <- spl_cutlabelfun(spl)(cuts)+ ) |
|||
| 1730 | -5x | +|||
| 789 | +
- if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
+ } |
|||
| 1731 | -1x | +|||
| 790 | +
- cutlabels <- names(cuts)[-1]+ ) |
|||
| 1732 | +791 |
- }+ |
||
| 1733 | +792 |
-
+ #' @rdname gfc |
||
| 1734 | -5x | +|||
| 793 | +
- ret <- make_static_cut_split(+ setMethod(+ |
+ |||
| 794 | ++ |
+ "get_cell_aligns", "LabelRow",+ |
+ ||
| 795 | ++ |
+ function(obj) {
|
||
| 1735 | -5x | +796 | +4788x |
- var = var, split_label = obj_label(spl),+ nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
|
| 1736 | -5x | +797 | +4788x |
- cuts = cuts, cutlabels = cutlabels,+ if (labelrow_visible(obj)) {
|
| 1737 | -5x | +798 | +1655x |
- cumulative = spl_is_cmlcuts(spl)+ matrix(rep("center", nc), ncol = nc)
|
| 1738 | +799 |
- )+ } else {
|
||
| 1739 | -+ | |||
| 800 | +3133x |
- ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl),+ matrix(character(0), ncol = nc) |
||
| 1740 | +801 |
- ## cuts = cuts, cutlabels = cutlabels)+ } |
||
| 1741 | +802 |
- ## ## classes are tthe same structurally CumulativeCutSplit+ } |
||
| 1742 | +803 |
- ## ## is just a sentinal so it can hit different make_subset_expr+ ) |
||
| 1743 | +804 |
- ## ## method+ |
||
| 1744 | +805 |
- ## if(spl_is_cmlcuts(spl))+ # utility functions ---- |
||
| 1745 | +806 |
- ## ret = as(ret, "CumulativeCutSplit")+ |
||
| 1746 | -5x | +|||
| 807 | +
- ret+ #' From a sorted sequence of numbers, remove numbers where diff == 1 |
|||
| 1747 | +808 |
- }+ #' |
||
| 1748 | +809 |
- )+ #' @examples |
||
| 1749 | +810 |
-
+ #' remove_consecutive_numbers(x = c(2, 4, 9)) |
||
| 1750 | +811 |
- #' @rdname int_methods+ #' remove_consecutive_numbers(x = c(2, 4, 5, 9)) |
||
| 1751 | +812 |
- setMethod(+ #' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9)) |
||
| 1752 | +813 |
- "fix_dyncuts", "VTableTree",+ #' remove_consecutive_numbers(x = 4:9) |
||
| 1753 | -1x | +|||
| 814 | +
- function(spl, df) spl+ #' |
|||
| 1754 | +815 |
- )+ #' @noRd |
||
| 1755 | +816 |
-
+ remove_consecutive_numbers <- function(x) {
|
||
| 1756 | +817 |
- .fd_helper <- function(spl, df) {
+ # actually should be integer |
||
| 1757 | -1311x | +|||
| 818 | +! |
- lst <- lapply(spl, fix_dyncuts, df = df)+ stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x)) |
||
| 1758 | -1311x | +|||
| 819 | +
- spl@.Data <- lst+ |
|||
| 1759 | -1311x | +|||
| 820 | +! |
- spl+ if (length(x) == 0) {
|
||
| 1760 | -+ | |||
| 821 | +! |
- }+ return(integer(0)) |
||
| 1761 | +822 |
-
+ } |
||
| 1762 | -+ | |||
| 823 | +! |
- #' @rdname int_methods+ if (!is.integer(x)) x <- as.integer(x) |
||
| 1763 | +824 |
- setMethod(+ |
||
| 1764 | -+ | |||
| 825 | +! |
- "fix_dyncuts", "PreDataRowLayout",+ x[c(TRUE, diff(x) != 1)] |
||
| 1765 | +826 |
- function(spl, df) {
+ } |
||
| 1766 | +827 |
- # rt = root_spl(spl)+ |
||
| 1767 | -320x | +|||
| 828 | +
- ret <- .fd_helper(spl, df)+ #' Insert an empty string |
|||
| 1768 | +829 |
- # root_spl(ret) = rt+ #' |
||
| 1769 | -320x | +|||
| 830 | +
- ret+ #' @examples |
|||
| 1770 | +831 |
- }+ #' empty_string_after(letters[1:5], 2) |
||
| 1771 | +832 |
- )+ #' empty_string_after(letters[1:5], c(2, 4)) |
||
| 1772 | +833 |
-
+ #' |
||
| 1773 | +834 |
- #' @rdname int_methods+ #' @noRd |
||
| 1774 | +835 |
- setMethod(+ empty_string_after <- function(x, indices) {
|
||
| 1775 | -+ | |||
| 836 | +! |
- "fix_dyncuts", "PreDataColLayout",+ if (length(indices) > 0) {
|
||
| 1776 | -+ | |||
| 837 | +! |
- function(spl, df) {
+ offset <- 0 |
||
| 1777 | -+ | |||
| 838 | +! |
- # rt = root_spl(spl)+ for (i in sort(indices)) {
|
||
| 1778 | -320x | +|||
| 839 | +! |
- ret <- .fd_helper(spl, df)+ x <- append(x, "", i + offset) |
||
| 1779 | -+ | |||
| 840 | +! |
- # root_spl(ret) = rt+ offset <- offset + 1 |
||
| 1780 | +841 |
- # disp_ccounts(ret) = disp_ccounts(spl)+ } |
||
| 1781 | +842 |
- # colcount_format(ret) = colcount_format(spl)+ } |
||
| 1782 | -320x | +|||
| 843 | +! |
- ret+ x |
||
| 1783 | +844 |
- }+ } |
||
| 1784 | +845 |
- )+ |
||
| 1785 | +846 |
-
+ #' Indent strings |
||
| 1786 | +847 |
- #' @rdname int_methods+ #' |
||
| 1787 | +848 |
- setMethod(+ #' Used in rtables to indent row names for the ASCII output. |
||
| 1788 | +849 |
- "fix_dyncuts", "SplitVector",+ #' |
||
| 1789 | +850 |
- function(spl, df) {
+ #' @param x (`character`)\cr a character vector. |
||
| 1790 | -671x | +|||
| 851 | +
- .fd_helper(spl, df)+ #' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`. |
|||
| 1791 | +852 |
- }+ #' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level. |
||
| 1792 | +853 |
- )+ #' @param including_newline (`flag`)\cr whether newlines should also be indented. |
||
| 1793 | +854 |
-
+ #' |
||
| 1794 | +855 |
- #' @rdname int_methods+ #' @return `x`, indented with left-padding with `indent * incr` white-spaces. |
||
| 1795 | +856 |
- setMethod(+ #' |
||
| 1796 | +857 |
- "fix_dyncuts", "PreDataTableLayouts",+ #' @examples |
||
| 1797 | +858 |
- function(spl, df) {
+ #' indent_string("a", 0)
|
||
| 1798 | -320x | +|||
| 859 | +
- rlayout(spl) <- fix_dyncuts(rlayout(spl), df)+ #' indent_string("a", 1)
|
|||
| 1799 | -320x | +|||
| 860 | +
- clayout(spl) <- fix_dyncuts(clayout(spl), df)+ #' indent_string(letters[1:3], 0:2) |
|||
| 1800 | -320x | +|||
| 861 | +
- spl+ #' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2) |
|||
| 1801 | +862 |
- }+ #' |
||
| 1802 | +863 |
- )+ #' @export |
||
| 1803 | +864 |
-
+ indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
|
||
| 1804 | -+ | |||
| 865 | +646x |
- ## Manual column construction in a simple (seeming to the user) way.+ if (length(x) > 0) {
|
||
| 1805 | -+ | |||
| 866 | +646x |
- #' Manual column declaration+ indent <- rep_len(indent, length.out = length(x)) |
||
| 1806 | -+ | |||
| 867 | +646x |
- #'+ incr <- rep_len(incr, length.out = length(x)) |
||
| 1807 | +868 |
- #' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given,+ } |
||
| 1808 | +869 |
- #' the values of the second are nested within each value of the first, and so on.+ |
||
| 1809 | -+ | |||
| 870 | +646x |
- #' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`.+ indent_str <- strrep(" ", (indent > 0) * indent * incr)
|
||
| 1810 | +871 |
- #'+ |
||
| 1811 | -+ | |||
| 872 | +646x |
- #' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed+ if (including_newline) {
|
||
| 1812 | -+ | |||
| 873 | +646x |
- #' table.+ x <- unlist(mapply(function(xi, stri) {
|
||
| 1813 | -+ | |||
| 874 | +13924x |
- #'+ gsub("\n", stri, xi, fixed = TRUE)
|
||
| 1814 | -+ | |||
| 875 | +646x |
- #' @examples+ }, x, paste0("\n", indent_str)))
|
||
| 1815 | +876 |
- #' # simple one level column space+ } |
||
| 1816 | +877 |
- #' rows <- lapply(1:5, function(i) {
+
|
||
| 1817 | -+ | |||
| 878 | +646x |
- #' DataRow(rep(i, times = 3))+ paste0(indent_str, x) |
||
| 1818 | +879 |
- #' })+ } |
||
| 1819 | +880 |
- #' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
+
|
||
| 1820 | +881 |
- #' tbl+ ## .paste_no_na <- function(x, ...) {
|
||
| 1821 | +882 |
- #'+ ## paste(na.omit(x), ...) |
||
| 1822 | +883 |
- #' # manually declared nesting+ ## } |
||
| 1823 | +884 |
- #' tbl2 <- TableTree(+ |
||
| 1824 | +885 |
- #' kids = list(DataRow(as.list(1:4))),+ ## #' Pad a string and align within string |
||
| 1825 | +886 |
- #' cinfo = manual_cols(+ ## #' |
||
| 1826 | +887 |
- #' Arm = c("Arm A", "Arm B"),
+ ## #' @param x string |
||
| 1827 | +888 |
- #' Gender = c("M", "F")
+ ## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown |
||
| 1828 | +889 |
- #' )+ ## #' |
||
| 1829 | +890 |
- #' )+ ## #' @noRd |
||
| 1830 | +891 |
- #' tbl2+ ## #' |
||
| 1831 | +892 |
- #'+ ## #' @examples |
||
| 1832 | +893 |
- #' @author Gabriel Becker+ ## #' |
||
| 1833 | +894 |
- #' @export+ ## #' padstr("abc", 3)
|
||
| 1834 | +895 |
- manual_cols <- function(..., .lst = list(...)) {
+ ## #' padstr("abc", 4)
|
||
| 1835 | -40x | +|||
| 896 | +
- if (is.null(names(.lst))) {
+ ## #' padstr("abc", 5)
|
|||
| 1836 | -40x | +|||
| 897 | +
- names(.lst) <- paste("colsplit", seq_along(.lst))
+ ## #' padstr("abc", 5, "left")
|
|||
| 1837 | +898 |
- }+ ## #' padstr("abc", 5, "right")
|
||
| 1838 | +899 |
-
+ ## #' |
||
| 1839 | -40x | +|||
| 900 | +
- splvec <- SplitVector(lst = mapply(ManualSplit,+ ## #' if(interactive()){
|
|||
| 1840 | -40x | +|||
| 901 | +
- levels = .lst,+ ## #' padstr("abc", 1)
|
|||
| 1841 | -40x | +|||
| 902 | +
- label = names(.lst)+ ## #' } |
|||
| 1842 | +903 |
- ))+ ## #' |
||
| 1843 | -40x | +|||
| 904 | +
- ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos())+ ## padstr <- function(x, n, just = c("center", "left", "right")) {
|
|||
| 1844 | -40x | +|||
| 905 | +
- InstantiatedColumnInfo(treelyt = ctree)+ |
|||
| 1845 | +906 |
- }+ ## just <- match.arg(just) |
||
| 1846 | +907 | |||
| 1847 | +908 |
- #' Returns a function that coerces the return values of a function to a list+ ## if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
|
||
| 1848 | +909 |
- #'+ ## if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
|
||
| 1849 | +910 |
- #' @param f (`function`)\cr the function to wrap.+ |
||
| 1850 | +911 |
- #'+ ## if (is.na(x)) x <- "<NA>" |
||
| 1851 | +912 |
- #' @details+ |
||
| 1852 | +913 |
- #' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an+ ## nc <- nchar(x) |
||
| 1853 | +914 |
- #' otherwise identical wrapper function whose first argument is named `df`.+ |
||
| 1854 | +915 |
- #'+ ## if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
|
||
| 1855 | +916 |
- #' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as+ |
||
| 1856 | +917 |
- #' their first argument are passed the full subset data frame, while those which accept anything else notably+ ## switch( |
||
| 1857 | +918 |
- #' including `x` are passed only the relevant subset of the variable being analyzed.+ ## just, |
||
| 1858 | +919 |
- #'+ ## center = {
|
||
| 1859 | +920 |
- #' @return A function that returns a list of `CellValue` objects.+ ## pad <- (n - nc)/2 |
||
| 1860 | +921 |
- #'+ ## paste0(spaces(floor(pad)), x, spaces(ceiling(pad))) |
||
| 1861 | +922 |
- #' @examples+ ## }, |
||
| 1862 | +923 |
- #' summary(iris$Sepal.Length)+ ## left = paste0(x, spaces(n - nc)), |
||
| 1863 | +924 |
- #'+ ## right = paste0(spaces(n - nc), x) |
||
| 1864 | +925 |
- #' f <- list_wrap_x(summary)+ ## ) |
||
| 1865 | +926 |
- #' f(x = iris$Sepal.Length)+ ## } |
||
| 1866 | +927 |
- #'+ |
||
| 1867 | +928 |
- #' f2 <- list_wrap_df(summary)+ ## spaces <- function(n) {
|
||
| 1868 | +929 |
- #' f2(df = iris$Sepal.Length)+ ## strrep(" ", n)
|
||
| 1869 | +930 |
- #'+ ## } |
||
| 1870 | +931 |
- #' @author Gabriel Becker+ |
||
| 1871 | +932 |
- #' @rdname list_wrap+ #' Convert matrix of strings into a string with aligned columns |
||
| 1872 | +933 |
- #' @export+ #' |
||
| 1873 | +934 |
- list_wrap_x <- function(f) {
- |
- ||
| 1874 | -17x | -
- function(x, ...) {
+ #' Note that this function is intended to print simple rectangular matrices and not `rtable`s. |
||
| 1875 | -74x | +|||
| 935 | +
- vs <- as.list(f(x, ...))+ #' |
|||
| 1876 | -74x | +|||
| 936 | +
- ret <- mapply(+ #' @param mat (`matrix`)\cr a matrix of strings. |
|||
| 1877 | -74x | +|||
| 937 | +
- function(v, nm) {
+ #' @param nheader (`integer(1)`)\cr number of header rows. |
|||
| 1878 | -258x | +|||
| 938 | +
- rcell(v, label = nm)+ #' @param colsep (`string`)\cr a string that separates the columns. |
|||
| 1879 | +939 |
- },+ #' @param hsep (`character(1)`)\cr character to build line separator. |
||
| 1880 | -74x | +|||
| 940 | +
- v = vs,+ #' |
|||
| 1881 | -74x | +|||
| 941 | +
- nm = names(vs)+ #' @return A string. |
|||
| 1882 | +942 |
- )+ #' |
||
| 1883 | -74x | +|||
| 943 | +
- ret+ #' @examples |
|||
| 1884 | +944 |
- }+ #' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
|
||
| 1885 | +945 |
- }+ #' cat(mat_as_string(mat)) |
||
| 1886 | +946 |
-
+ #' cat("\n")
|
||
| 1887 | +947 |
- #' @rdname list_wrap+ #' |
||
| 1888 | +948 |
- #' @export+ #' @noRd |
||
| 1889 | +949 |
- list_wrap_df <- function(f) {
+ mat_as_string <- function(mat, nheader = 1, colsep = " ", hsep = default_hsep()) {
|
||
| 1890 | -1x | +950 | +2x |
- function(df, ...) {
+ colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max) |
| 1891 | -1x | +|||
| 951 | +
- vs <- as.list(f(df, ...))+ |
|||
| 1892 | -1x | +952 | +2x |
- ret <- mapply(+ rows_formatted <- apply(mat, 1, function(row) {
|
| 1893 | -1x | +953 | +36x |
- function(v, nm) {
+ paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep) |
| 1894 | -6x | +|||
| 954 | +
- rcell(v, label = nm)+ }) |
|||
| 1895 | +955 |
- },+ |
||
| 1896 | -1x | +956 | +2x |
- v = vs,+ header_rows <- seq_len(nheader) |
| 1897 | -1x | +957 | +2x |
- nm = names(vs)+ nchwidth <- nchar(rows_formatted[1]) |
| 1898 | -+ | |||
| 958 | +2x |
- )+ paste(c( |
||
| 1899 | -1x | +959 | +2x |
- ret+ rows_formatted[header_rows], |
| 1900 | -+ | |||
| 960 | +2x |
- }+ substr(strrep(hsep, nchwidth), 1, nchwidth), |
||
| 1901 | -+ | |||
| 961 | +2x |
- }+ rows_formatted[-header_rows] |
||
| 1902 | -+ | |||
| 962 | +2x |
-
+ ), collapse = "\n") |
||
| 1903 | +963 |
- #' Layout with 1 column and zero rows+ } |
| 1904 | +1 |
- #'+ ## Rules for pagination |
||
| 1905 | +2 |
- #' Every layout must start with a basic table.+ ## |
||
| 1906 | +3 |
- #'+ ## 1. user defined number of lines per page |
||
| 1907 | +4 |
- #' @inheritParams constr_args+ ## 2. all lines have the same height |
||
| 1908 | +5 |
- #' @param show_colcounts (`flag`)\cr whether column counts should be displayed in the resulting table when this+ ## 3. header always reprinted on all pages |
||
| 1909 | +6 |
- #' layout is applied to data.+ ## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE) |
||
| 1910 | +7 |
- #' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d+ ## 5. Never (?) break on a "label"/content row |
||
| 1911 | +8 |
- #' where one component is a percent. See Details below.+ ## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table. |
||
| 1912 | +9 |
- #' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split+ ## |
||
| 1913 | +10 |
- #' or division of the table will be highlighted by a line made of that character. See [section_div] for more+ ## Current behavior: paginate_ttree takes a TableTree object and |
||
| 1914 | +11 |
- #' information.+ ## returns a list of rtable (S3) objects for printing. |
||
| 1915 | +12 |
- #'+ |
||
| 1916 | +13 |
- #' @details+ #' @inheritParams formatters::nlines |
||
| 1917 | +14 |
- #' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`,+ #' |
||
| 1918 | +15 |
- #' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always+ #' @rdname formatters_methods |
||
| 1919 | +16 |
- #' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be,+ #' @aliases nlines,TableRow-method |
||
| 1920 | +17 |
- #' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of+ #' @exportMethod nlines |
||
| 1921 | +18 |
- #' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list+ setMethod( |
||
| 1922 | +19 |
- #' of valid format labels to select from.+ "nlines", "TableRow", |
||
| 1923 | +20 |
- #'+ function(x, colwidths, max_width, fontspec, col_gap = 3) {
|
||
| 1924 | -+ | |||
| 21 | +11167x |
- #' @inherit split_cols_by return+ fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) + |
||
| 1925 | -+ | |||
| 22 | +11167x |
- #'+ sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) |
||
| 1926 | -+ | |||
| 23 | +11167x |
- #' @note+ fcells <- as.vector(get_formatted_cells(x)) |
||
| 1927 | -+ | |||
| 24 | +11167x |
- #' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably+ spans <- row_cspans(x) |
||
| 1928 | -+ | |||
| 25 | +11167x |
- #' strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as+ have_cw <- !is.null(colwidths) |
||
| 1929 | +26 |
- #' their percentage, even though the individual arm columns represent strict subsets of the "all patients" column.+ ## handle spanning so that the projected word-wrapping from nlines is correct |
||
| 1930 | -+ | |||
| 27 | +11167x |
- #'+ if (any(spans > 1)) {
|
||
| 1931 | -+ | |||
| 28 | +10x |
- #' - Note that subtitles ([subtitles()]) and footers ([main_footer()] and [prov_footer()]) that span more than one+ new_fcells <- character(length(spans)) |
||
| 1932 | -+ | |||
| 29 | +10x |
- #' line can be supplied as a character vector to maintain indentation on multiple lines.+ new_colwidths <- numeric(length(spans)) |
||
| 1933 | -+ | |||
| 30 | +10x |
- #'+ cur_fcells <- fcells |
||
| 1934 | -+ | |||
| 31 | +10x |
- #' @examples+ cur_colwidths <- colwidths[-1] ## not the row labels they can't span |
||
| 1935 | -+ | |||
| 32 | +10x |
- #' lyt <- basic_table() %>%+ for (i in seq_along(spans)) {
|
||
| 1936 | -+ | |||
| 33 | +24x |
- #' analyze("AGE", afun = mean)
+ spi <- spans[i] |
||
| 1937 | -+ | |||
| 34 | +24x |
- #'+ new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop |
||
| 1938 | -+ | |||
| 35 | +24x |
- #' tbl <- build_table(lyt, DM)+ new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1) |
||
| 1939 | -+ | |||
| 36 | +24x |
- #' tbl+ cur_fcells <- tail(cur_fcells, -1 * spi) |
||
| 1940 | -+ | |||
| 37 | +24x |
- #'+ cur_colwidths <- tail(cur_colwidths, -1 * spi) |
||
| 1941 | +38 |
- #' lyt2 <- basic_table(+ } |
||
| 1942 | -+ | |||
| 39 | +10x |
- #' title = "Title of table",+ if (have_cw) {
|
||
| 1943 | -+ | |||
| 40 | +4x |
- #' subtitles = c("a number", "of subtitles"),
+ colwidths <- c(colwidths[1], new_colwidths) |
||
| 1944 | +41 |
- #' main_footer = "test footer",+ } |
||
| 1945 | -+ | |||
| 42 | +10x |
- #' prov_footer = paste(+ fcells <- new_fcells |
||
| 1946 | +43 |
- #' "test.R program, executed at",+ } |
||
| 1947 | +44 |
- #' Sys.time()+ |
||
| 1948 | +45 |
- #' )+ ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE), |
||
| 1949 | +46 |
- #' ) %>%+ ## length, |
||
| 1950 | +47 |
- #' split_cols_by("ARM") %>%
+ ## 1L)) |
||
| 1951 | -+ | |||
| 48 | +11167x |
- #' analyze("AGE", mean)
+ rowext <- max( |
||
| 1952 | -+ | |||
| 49 | +11167x |
- #'+ unlist( |
||
| 1953 | -+ | |||
| 50 | +11167x |
- #' tbl2 <- build_table(lyt2, DM)+ mapply( |
||
| 1954 | -+ | |||
| 51 | +11167x |
- #' tbl2+ function(s, w) {
|
||
| 1955 | -+ | |||
| 52 | +60678x |
- #'+ nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec) |
||
| 1956 | +53 |
- #' lyt3 <- basic_table(+ }, |
||
| 1957 | -+ | |||
| 54 | +11167x |
- #' show_colcounts = TRUE,+ s = c(obj_label(x), fcells), |
||
| 1958 | -+ | |||
| 55 | +11167x |
- #' colcount_format = "xx. (xx.%)"+ w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
|
||
| 1959 | -+ | |||
| 56 | +11167x |
- #' ) %>%+ SIMPLIFY = FALSE |
||
| 1960 | +57 |
- #' split_cols_by("ARM")
+ ) |
||
| 1961 | +58 |
- #'+ ) |
||
| 1962 | +59 |
- #' @export+ ) |
||
| 1963 | +60 |
- basic_table <- function(title = "",+ + |
+ ||
| 61 | +11167x | +
+ rowext + fns |
||
| 1964 | +62 |
- subtitles = character(),+ } |
||
| 1965 | +63 |
- main_footer = character(),+ ) |
||
| 1966 | +64 |
- prov_footer = character(),+ |
||
| 1967 | +65 |
- show_colcounts = FALSE,+ #' @export |
||
| 1968 | +66 |
- colcount_format = "(N=xx)",+ #' @rdname formatters_methods |
||
| 1969 | +67 |
- header_section_div = NA_character_,+ setMethod( |
||
| 1970 | +68 |
- top_level_section_div = NA_character_,+ "nlines", "LabelRow", |
||
| 1971 | +69 |
- inset = 0L) {
+ function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
|
||
| 1972 | -302x | +70 | +3624x |
- inset <- as.integer(inset)+ if (labelrow_visible(x)) {
|
| 1973 | -302x | +71 | +3624x |
- if (is.na(inset) || inset < 0L) {
+ nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) + |
| 1974 | -2x | +72 | +3624x |
- stop("Got invalid table_inset value, must be an integer > 0")
+ sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) |
| 1975 | +73 |
- }- |
- ||
| 1976 | -300x | -
- .check_header_section_div(header_section_div)+ } else {
|
||
| 1977 | -300x | +|||
| 74 | +! |
- checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1)+ 0L |
||
| 1978 | +75 | - - | -||
| 1979 | -300x | -
- ret <- PreDataTableLayouts(- |
- ||
| 1980 | -300x | -
- title = title,- |
- ||
| 1981 | -300x | -
- subtitles = subtitles,- |
- ||
| 1982 | -300x | -
- main_footer = main_footer,- |
- ||
| 1983 | -300x | -
- prov_footer = prov_footer,- |
- ||
| 1984 | -300x | -
- header_section_div = header_section_div,- |
- ||
| 1985 | -300x | -
- top_level_section_div = top_level_section_div,+ } |
||
| 1986 | -300x | +|||
| 76 | +
- table_inset = as.integer(inset)+ } |
|||
| 1987 | +77 |
- )+ ) |
||
| 1988 | -300x | +|||
| 78 | +
- if (show_colcounts) {
+
|
|||
| 1989 | -71x | +|||
| 79 | +
- ret <- add_colcounts(ret, format = colcount_format)+ #' @export |
|||
| 1990 | +80 |
- }+ #' @rdname formatters_methods |
||
| 1991 | -300x | +|||
| 81 | +
- ret+ setMethod( |
|||
| 1992 | +82 |
- }+ "nlines", "RefFootnote", |
||
| 1993 | +83 |
-
+ function(x, colwidths, max_width, fontspec, col_gap = NULL) {
|
||
| 1994 | -+ | |||
| 84 | +2140x |
- #' Append a description to the 'top-left' materials for the layout+ nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec) |
||
| 1995 | +85 |
- #'+ } |
||
| 1996 | +86 |
- #' This function *adds* `newlines` to the current set of "top-left materials".+ ) |
||
| 1997 | +87 |
- #'+ |
||
| 1998 | +88 |
- #' @details+ #' @export |
||
| 1999 | +89 |
- #' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content+ #' @rdname formatters_methods |
||
| 2000 | +90 |
- #' displayed to the left of the column labels when the resulting tables are printed).+ setMethod( |
||
| 2001 | +91 |
- #'+ "nlines", "InstantiatedColumnInfo", |
||
| 2002 | +92 |
- #' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to+ function(x, colwidths, max_width, fontspec, col_gap = 3) {
|
||
| 2003 | -+ | |||
| 93 | +6x |
- #' them either when they are added or when they are displayed.+ h_rows <- .do_tbl_h_piece2(x) |
||
| 2004 | -+ | |||
| 94 | +6x |
- #'+ tl <- top_left(x) %||% rep("", length(h_rows))
|
||
| 2005 | -+ | |||
| 95 | +6x |
- #' @inheritParams lyt_args+ main_nls <- vapply( |
||
| 2006 | -+ | |||
| 96 | +6x |
- #' @param newlines (`character`)\cr the new line(s) to be added to the materials.+ seq_along(h_rows), |
||
| 2007 | -+ | |||
| 97 | +6x |
- #'+ function(i) {
|
||
| 2008 | -+ | |||
| 98 | +10x |
- #' @note+ max( |
||
| 2009 | -+ | |||
| 99 | +10x |
- #' Currently, where in the construction of the layout this is called makes no difference, as it is independent of+ nlines(h_rows[[i]], |
||
| 2010 | -+ | |||
| 100 | +10x |
- #' the actual splitting keywords. This may change in the future.+ colwidths = colwidths, |
||
| 2011 | -+ | |||
| 101 | +10x |
- #'+ fontspec = fontspec, |
||
| 2012 | -+ | |||
| 102 | +10x |
- #' This function is experimental, its name and the details of its behavior are subject to change in future versions.+ col_gap = col_gap |
||
| 2013 | +103 |
- #'+ ), |
||
| 2014 | -+ | |||
| 104 | +10x |
- #' @inherit split_cols_by return+ nlines(tl[i], |
||
| 2015 | -+ | |||
| 105 | +10x |
- #'+ colwidths = colwidths[1], |
||
| 2016 | -+ | |||
| 106 | +10x |
- #' @seealso [top_left()]+ fontspec = fontspec |
||
| 2017 | +107 |
- #'+ ) |
||
| 2018 | +108 |
- #' @examples+ ) |
||
| 2019 | +109 |
- #' library(dplyr)+ }, |
||
| 2020 | -+ | |||
| 110 | +6x |
- #'+ 1L |
||
| 2021 | +111 |
- #' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX))+ ) |
||
| 2022 | +112 |
- #'+ |
||
| 2023 | +113 |
- #' lyt <- basic_table() %>%+ ## lfs <- collect_leaves(coltree(x)) |
||
| 2024 | +114 |
- #' split_cols_by("ARM") %>%
+ ## depths <- sapply(lfs, function(l) length(pos_splits(l))) |
||
| 2025 | +115 |
- #' split_cols_by("SEX") %>%
+
|
||
| 2026 | -+ | |||
| 116 | +6x |
- #' split_rows_by("RACE") %>%
+ coldf <- make_col_df(x, colwidths = colwidths) |
||
| 2027 | -+ | |||
| 117 | +6x |
- #' append_topleft("Ethnicity") %>%
+ have_fnotes <- length(unlist(coldf$col_fnotes)) > 0 |
||
| 2028 | +118 |
- #' analyze("AGE") %>%
+ ## ret <- max(depths, length(top_left(x))) + |
||
| 2029 | +119 |
- #' append_topleft(" Age")
+ ## divider_height(x) |
||
| 2030 | -+ | |||
| 120 | +6x |
- #'+ ret <- sum(main_nls, divider_height(x)) |
||
| 2031 | -+ | |||
| 121 | +6x |
- #' tbl <- build_table(lyt, DM2)+ if (have_fnotes) {
|
||
| 2032 | -+ | |||
| 122 | +! |
- #' tbl+ ret <- sum( |
||
| 2033 | -+ | |||
| 123 | +! |
- #'+ ret, |
||
| 2034 | -+ | |||
| 124 | +! |
- #' @export+ vapply(unlist(coldf$col_fnotes), |
||
| 2035 | -+ | |||
| 125 | +! |
- append_topleft <- function(lyt, newlines) {
+ nlines, |
||
| 2036 | -53x | +|||
| 126 | +! |
- stopifnot(+ 1, |
||
| 2037 | -53x | +|||
| 127 | +! |
- is(lyt, "PreDataTableLayouts"),+ max_width = max_width, |
||
| 2038 | -53x | +|||
| 128 | +! |
- is(newlines, "character")+ fontspec = fontspec |
||
| 2039 | +129 |
- )- |
- ||
| 2040 | -53x | -
- lyt@top_left <- c(lyt@top_left, newlines)+ ), |
||
| 2041 | -53x | +|||
| 130 | +! |
- lyt+ 2 * divider_height(x) |
||
| 2042 | +131 |
- }+ ) |
| 1 | +132 |
- #' Compare two rtables+ } |
||
| 2 | -+ | |||
| 133 | +6x |
- #'+ ret |
||
| 3 | +134 |
- #' Prints a matrix where `.` means cell matches, `X` means cell does+ } |
||
| 4 | +135 |
- #' not match, `+` cell (row) is missing, and `-` cell (row)+ ) |
||
| 5 | +136 |
- #' should not be there. If `structure` is set to `TRUE`, `C` indicates+ |
||
| 6 | +137 |
- #' column-structure mismatch, `R` indicates row-structure mismatch, and+ col_dfrow <- function(col, |
||
| 7 | +138 |
- #' `S` indicates mismatch in both row and column structure.+ nm = obj_name(col), |
||
| 8 | +139 |
- #'+ lab = obj_label(col), |
||
| 9 | +140 |
- #' @param object (`VTableTree`)\cr `rtable` to test.+ cnum, |
||
| 10 | +141 |
- #' @param expected (`VTableTree`)\cr expected `rtable`.+ pth = NULL, |
||
| 11 | +142 |
- #' @param tol (`numeric(1)`)\cr tolerance.+ sibpos = NA_integer_, |
||
| 12 | +143 |
- #' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are+ nsibs = NA_integer_, |
||
| 13 | +144 |
- #' silently ignored.+ leaf_indices = cnum, |
||
| 14 | +145 |
- #' @param structure (`flag`)\cr whether structures (in the form of column and row+ span = length(leaf_indices), |
||
| 15 | +146 |
- #' paths to cells) should be compared. Currently defaults to `FALSE`, but this is+ col_fnotes = list(), |
||
| 16 | +147 |
- #' subject to change in future versions.+ col_count = facet_colcount(col, NULL), |
||
| 17 | +148 |
- #'+ ccount_visible = disp_ccounts(col), |
||
| 18 | +149 |
- #' @note In its current form, `compare_rtables` does not take structure into+ ccount_format = colcount_format(col), |
||
| 19 | +150 |
- #' account, only row and cell position.+ ccount_na_str, |
||
| 20 | +151 |
- #'+ global_cc_format) {
|
||
| 21 | -+ | |||
| 152 | +13302x |
- #' @return A matrix of class `rtables_diff` representing the differences+ if (is.null(pth)) {
|
||
| 22 | -+ | |||
| 153 | +12556x |
- #' between `object` and `expected` as described above.+ pth <- pos_to_path(tree_pos(col)) |
||
| 23 | +154 |
- #'+ } |
||
| 24 | -+ | |||
| 155 | +13302x |
- #' @examples+ data.frame( |
||
| 25 | -+ | |||
| 156 | +13302x |
- #' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
+ stringsAsFactors = FALSE, |
||
| 26 | -+ | |||
| 157 | +13302x |
- #' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
+ name = nm, |
||
| 27 | -+ | |||
| 158 | +13302x |
- #'+ label = lab, |
||
| 28 | -+ | |||
| 159 | +13302x |
- #' compare_rtables(object = t1, expected = t2)+ abs_pos = cnum, |
||
| 29 | -+ | |||
| 160 | +13302x |
- #'+ path = I(list(pth)), |
||
| 30 | -+ | |||
| 161 | +13302x |
- #' if (interactive()) {
+ pos_in_siblings = sibpos, |
||
| 31 | -+ | |||
| 162 | +13302x |
- #' Viewer(t1, t2)+ n_siblings = nsibs, |
||
| 32 | -+ | |||
| 163 | +13302x |
- #' }+ leaf_indices = I(list(leaf_indices)), |
||
| 33 | -+ | |||
| 164 | +13302x |
- #'+ total_span = span, |
||
| 34 | -+ | |||
| 165 | +13302x |
- #' expected <- rtable(+ col_fnotes = I(list(col_fnotes)), |
||
| 35 | -+ | |||
| 166 | +13302x |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ n_col_fnotes = length(col_fnotes), |
||
| 36 | -+ | |||
| 167 | +13302x |
- #' format = "xx",+ col_count = col_count, |
||
| 37 | -+ | |||
| 168 | +13302x |
- #' rrow("row 1", 10, 15),
+ ccount_visible = ccount_visible, |
||
| 38 | -+ | |||
| 169 | +13302x |
- #' rrow(),+ ccount_format = ccount_format %||% global_cc_format, |
||
| 39 | -+ | |||
| 170 | +13302x |
- #' rrow("section title"),
+ ccount_na_str = ccount_na_str |
||
| 40 | +171 |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ ) |
||
| 41 | +172 |
- #' )+ } |
||
| 42 | +173 |
- #'+ |
||
| 43 | +174 |
- #' expected+ pos_to_path <- function(pos) {
|
||
| 44 | -+ | |||
| 175 | +47222x |
- #'+ spls <- pos_splits(pos) |
||
| 45 | -+ | |||
| 176 | +47222x |
- #' object <- rtable(+ vals <- pos_splvals(pos) |
||
| 46 | +177 |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+
|
||
| 47 | -+ | |||
| 178 | +47222x |
- #' format = "xx",+ path <- character() |
||
| 48 | -+ | |||
| 179 | +47222x |
- #' rrow("row 1", 10, 15),
+ for (i in seq_along(spls)) {
|
||
| 49 | -+ | |||
| 180 | +59864x |
- #' rrow("section title"),
+ nm <- obj_name(spls[[i]]) |
||
| 50 | -+ | |||
| 181 | +59864x |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ val_i <- value_names(vals[[i]]) |
||
| 51 | -+ | |||
| 182 | +59864x |
- #' )+ path <- c( |
||
| 52 | -+ | |||
| 183 | +59864x |
- #'+ path, |
||
| 53 | -+ | |||
| 184 | +59864x |
- #' compare_rtables(object, expected, comp.attr = FALSE)+ obj_name(spls[[i]]), |
||
| 54 | +185 |
- #'+ ## rawvalues(vals[[i]])) |
||
| 55 | -+ | |||
| 186 | +59864x |
- #' object <- rtable(+ if (!is.na(val_i)) val_i |
||
| 56 | +187 |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ ) |
||
| 57 | +188 |
- #' format = "xx",+ } |
||
| 58 | -+ | |||
| 189 | +47222x |
- #' rrow("row 1", 10, 15),
+ path |
||
| 59 | +190 |
- #' rrow(),+ } |
||
| 60 | +191 |
- #' rrow("section title")
+
|
||
| 61 | +192 |
- #' )+ # make_row_df --------------------------------------------------------------- |
||
| 62 | +193 |
- #'+ |
||
| 63 | +194 |
- #' compare_rtables(object, expected)+ #' @inherit formatters::make_row_df |
||
| 64 | +195 |
#' |
||
| 65 | +196 |
- #' object <- rtable(+ # #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and |
||
| 66 | +197 |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ # #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination. |
||
| 67 | +198 |
- #' format = "xx",+ # #' |
||
| 68 | +199 |
- #' rrow("row 1", 14, 15.03),
+ # #' @return a data.frame of row/column-structure information used by the pagination machinery. |
||
| 69 | +200 |
- #' rrow(),+ # #' |
||
| 70 | +201 |
- #' rrow("section title"),
+ # #' @export |
||
| 71 | +202 |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ # #' @name make_row_df |
||
| 72 | +203 |
- #' )+ # #' @rdname make_row_df |
||
| 73 | +204 |
- #'+ # #' @aliases make_row_df,VTableTree-method |
||
| 74 | +205 |
- #' compare_rtables(object, expected)+ #' @rdname formatters_methods |
||
| 75 | +206 |
- #'+ #' @exportMethod make_row_df |
||
| 76 | +207 |
- #' object <- rtable(+ setMethod( |
||
| 77 | +208 |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ "make_row_df", "VTableTree", |
||
| 78 | +209 |
- #' format = "xx",+ function(tt, |
||
| 79 | +210 |
- #' rrow("row 1", 10, 15),
+ colwidths = NULL, |
||
| 80 | +211 |
- #' rrow(),+ visible_only = TRUE, |
||
| 81 | +212 |
- #' rrow("section title"),
+ rownum = 0, |
||
| 82 | +213 |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
+ indent = 0L, |
||
| 83 | +214 |
- #' )+ path = character(), |
||
| 84 | +215 |
- #'+ incontent = FALSE, |
||
| 85 | +216 |
- #' compare_rtables(object, expected)+ repr_ext = 0L, |
||
| 86 | +217 |
- #'+ repr_inds = integer(), |
||
| 87 | +218 |
- #' @export+ sibpos = NA_integer_, |
||
| 88 | +219 |
- compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,+ nsibs = NA_integer_, |
||
| 89 | +220 |
- structure = FALSE) {
+ max_width = NULL, |
||
| 90 | +221 |
- # if (identical(object, expected)) return(invisible(TRUE))+ fontspec = NULL, |
||
| 91 | +222 |
-
+ col_gap = 3) {
|
||
| 92 | -12x | +223 | +10410x |
- if (!is(object, "VTableTree")) {
+ indent <- indent + indent_mod(tt) |
| 93 | -! | +|||
| 224 | +
- stop(+ ## retained for debugging info |
|||
| 94 | -! | +|||
| 225 | +10410x |
- "argument object is expected to be of class TableTree or ",+ orig_rownum <- rownum # nolint |
||
| 95 | -! | +|||
| 226 | +10410x |
- "ElementaryTable"+ if (incontent) {
|
||
| 96 | -+ | |||
| 227 | +1438x |
- )+ path <- c(path, "@content")+ |
+ ||
| 228 | +8972x | +
+ } else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
|
||
| 97 | +229 |
- }+ ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint |
||
| 98 | -12x | +230 | +8924x |
- if (!is(expected, "VTableTree")) {
+ path <- c(path, obj_name(tt)) |
| 99 | -! | +|||
| 231 | +
- stop(+ } |
|||
| 100 | -! | +|||
| 232 | +10410x |
- "argument expected is expected to be of class TableTree or ",+ ret <- list() |
||
| 101 | -! | +|||
| 233 | +
- "ElementaryTable"+ |
|||
| 102 | +234 |
- )+ ## note this is the **table** not the label row |
||
| 103 | -+ | |||
| 235 | +10410x |
- }+ if (!visible_only) {
|
||
| 104 | -12x | +236 | +21x |
- dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)+ ret <- c( |
| 105 | -+ | |||
| 237 | +21x |
-
+ ret, |
||
| 106 | -12x | +238 | +21x |
- X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
+ list(pagdfrow( |
| 107 | -12x | +239 | +21x |
- row.names(X) <- as.character(1:dim_out[1])+ rnum = NA, |
| 108 | -12x | +240 | +21x |
- colnames(X) <- as.character(1:dim_out[2])+ nm = obj_name(tt), |
| 109 | -+ | |||
| 241 | +21x |
-
+ lab = "", |
||
| 110 | -12x | +242 | +21x |
- if (!identical(names(object), names(expected))) {
+ pth = path, |
| 111 | -7x | +243 | +21x |
- attr(X, "info") <- "column names are not the same"+ colwidths = colwidths, |
| 112 | -+ | |||
| 244 | +21x |
- }+ repext = repr_ext, |
||
| 113 | -+ | |||
| 245 | +21x |
-
+ repind = list(repr_inds), |
||
| 114 | -12x | +246 | +21x |
- if (!comp.attr) {
+ extent = 0, |
| 115 | -! | +|||
| 247 | +21x |
- attr(X, "info") <- c(+ indent = indent, |
||
| 116 | -! | +|||
| 248 | +21x |
- attr(X, "info"),+ rclass = class(tt), sibpos = sibpos, |
||
| 117 | -! | +|||
| 249 | +21x |
- "cell attributes have not been compared"+ nsibs = nsibs, |
||
| 118 | -+ | |||
| 250 | +21x |
- )+ nrowrefs = 0L, |
||
| 119 | -+ | |||
| 251 | +21x |
- }+ ncellrefs = 0L, |
||
| 120 | -12x | +252 | +21x |
- if (!identical(row.names(object), row.names(expected))) {
+ nreflines = 0L, |
| 121 | -2x | +253 | +21x |
- attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")+ fontspec = fontspec |
| 122 | +254 |
- }+ )) |
||
| 123 | +255 |
-
+ ) |
||
| 124 | -12x | +|||
| 256 | +
- nro <- nrow(object)+ } |
|||
| 125 | -12x | +257 | +10410x |
- nre <- nrow(expected)+ if (labelrow_visible(tt)) {
|
| 126 | -12x | +258 | +3604x |
- nco <- ncol(object)+ lr <- tt_labelrow(tt) |
| 127 | -12x | -
- nce <- ncol(expected)- |
- ||
| 128 | -+ | 259 | +3604x |
-
+ newdf <- make_row_df(lr, |
| 129 | -12x | +260 | +3604x |
- if (nco < nce) {
+ colwidths = colwidths, |
| 130 | -2x | +261 | +3604x |
- X[, seq(nco + 1, nce)] <- "-"+ visible_only = visible_only, |
| 131 | -10x | +262 | +3604x |
- } else if (nce < nco) {
+ rownum = rownum, |
| 132 | -3x | +263 | +3604x |
- X[, seq(nce + 1, nco)] <- "+"+ indent = indent, |
| 133 | -+ | |||
| 264 | +3604x |
- }+ path = path, |
||
| 134 | -12x | +265 | +3604x |
- if (nro < nre) {
+ incontent = TRUE, |
| 135 | -1x | +266 | +3604x |
- X[seq(nro + 1, nre), ] <- "-"+ repr_ext = repr_ext, |
| 136 | -11x | +267 | +3604x |
- } else if (nre < nro) {
+ repr_inds = repr_inds, |
| 137 | -! | +|||
| 268 | +3604x |
- X[seq(nre + 1, nro), ] <- "+"+ max_width = max_width, |
||
| 138 | -+ | |||
| 269 | +3604x |
- }+ fontspec = fontspec |
||
| 139 | +270 |
-
+ ) |
||
| 140 | -12x | +271 | +3604x |
- orig_object <- object # nolint+ rownum <- max(newdf$abs_rownumber, na.rm = TRUE) |
| 141 | -12x | +|||
| 272 | +
- orig_expected <- expected # nolint+ |
|||
| 142 | -12x | +273 | +3604x |
- if (nro != nre || nco != nce) {
+ ret <- c( |
| 143 | -5x | +274 | +3604x |
- object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]+ ret, |
| 144 | -5x | +275 | +3604x |
- expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]+ list(newdf) |
| 145 | -5x | +|||
| 276 | +
- inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)+ ) |
|||
| 146 | -5x | +277 | +3604x |
- X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner+ repr_ext <- repr_ext + 1L |
| 147 | -5x | +278 | +3604x |
- class(X) <- c("rtables_diff", class(X))
+ repr_inds <- c(repr_inds, rownum) |
| 148 | -5x | +279 | +3604x |
- return(X)+ indent <- indent + 1L |
| 149 | +280 |
- }+ } |
||
| 150 | +281 | |||
| 151 | -+ | |||
| 282 | +10410x |
- ## from here dimensions match!+ if (NROW(content_table(tt)) > 0) {
|
||
| 152 | -+ | |||
| 283 | +1438x |
-
+ ct_tt <- content_table(tt) |
||
| 153 | -7x | +284 | +1438x |
- orows <- cell_values(object, omit_labrows = FALSE)+ cind <- indent + indent_mod(ct_tt) |
| 154 | -7x | +285 | +1438x |
- erows <- cell_values(expected, omit_labrows = FALSE)+ trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt)) |
| 155 | -7x | +286 | +1438x |
- if (nrow(object) == 1) {
+ contdf <- make_row_df(ct_tt, |
| 156 | -! | +|||
| 287 | +1438x |
- orows <- list(orows)+ colwidths = colwidths, |
||
| 157 | -! | +|||
| 288 | +1438x |
- erows <- list(erows)+ visible_only = visible_only, |
||
| 158 | -+ | |||
| 289 | +1438x |
- }+ rownum = rownum, |
||
| 159 | -7x | +290 | +1438x |
- res <- mapply(compare_rrows,+ indent = cind, |
| 160 | -7x | +291 | +1438x |
- row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),+ path = path, |
| 161 | -7x | +292 | +1438x |
- USE.NAMES = FALSE, SIMPLIFY = FALSE+ incontent = TRUE, |
| 162 | -+ | |||
| 293 | +1438x |
- )+ repr_ext = repr_ext, |
||
| 163 | -7x | +294 | +1438x |
- X <- do.call(rbind, res)+ repr_inds = repr_inds, |
| 164 | -7x | +295 | +1438x |
- rpo <- row_paths(object)+ max_width = max_width, |
| 165 | -7x | +296 | +1438x |
- rpe <- row_paths(expected)+ fontspec = fontspec |
| 166 | +297 |
-
+ ) |
||
| 167 | -7x | +298 | +1438x |
- if (comp.attr) {
+ crnums <- contdf$abs_rownumber |
| 168 | -7x | +299 | +1438x |
- ofmts <- value_formats(object)+ crnums <- crnums[!is.na(crnums)] |
| 169 | -7x | +|||
| 300 | +
- efmts <- value_formats(expected)+ |
|||
| 170 | -+ | |||
| 301 | +1438x |
- ## dim(ofmts) <- NULL+ newrownum <- max(crnums, na.rm = TRUE) |
||
| 171 | -+ | |||
| 302 | +1438x |
- ## dim(efmts) <- NULL+ if (is.finite(newrownum)) {
|
||
| 172 | -+ | |||
| 303 | +1438x |
-
+ rownum <- newrownum |
||
| 173 | -7x | +304 | +1438x |
- fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim+ repr_ext <- repr_ext + length(crnums) |
| 174 | -+ | |||
| 305 | +1438x |
-
+ repr_inds <- c(repr_inds, crnums) |
||
| 175 | +306 |
-
+ } |
||
| 176 | -+ | |||
| 307 | +1438x |
- ## note the single index here!!!, no comma!!!!+ ret <- c(ret, list(contdf)) |
||
| 177 | -7x | +308 | +1438x |
- X[fmt_mismatch] <- "X"+ indent <- cind + 1 |
| 178 | +309 |
- }+ } |
||
| 179 | +310 | |||
| 180 | -+ | |||
| 311 | +10410x |
-
+ allkids <- tree_children(tt) |
||
| 181 | -7x | +312 | +10410x |
- if (structure) {
+ newnsibs <- length(allkids) |
| 182 | -1x | +313 | +10410x |
- rp_mismatches <- !mapply(identical, x = rpo, y = rpe)+ for (i in seq_along(allkids)) {
|
| 183 | -1x | +314 | +19277x |
- cpo <- col_paths(object)+ kid <- allkids[[i]] |
| 184 | -1x | +315 | +19277x |
- cpe <- col_paths(expected)+ kiddfs <- make_row_df(kid, |
| 185 | -1x | +316 | +19277x |
- cp_mismatches <- !mapply(identical, x = cpo, y = cpe)+ colwidths = colwidths, |
| 186 | -+ | |||
| 317 | +19277x |
-
+ visible_only = visible_only, |
||
| 187 | -1x | +318 | +19277x |
- if (any(rp_mismatches)) { # P for (row or column) path do not match
+ rownum = force(rownum), |
| 188 | -! | +|||
| 319 | +19277x |
- X[rp_mismatches, ] <- "R"+ indent = indent, ## + 1, |
||
| 189 | -+ | |||
| 320 | +19277x |
- }+ path = path, |
||
| 190 | -1x | +321 | +19277x |
- if (any(cp_mismatches)) {
+ incontent = incontent, |
| 191 | -1x | +322 | +19277x |
- crep <- rep("C", nrow(X))
+ repr_ext = repr_ext, |
| 192 | -1x | +323 | +19277x |
- if (any(rp_mismatches)) {
+ repr_inds = repr_inds, |
| 193 | -! | +|||
| 324 | +19277x |
- crep[rp_mismatches] <- "P"+ nsibs = newnsibs, |
||
| 194 | -+ | |||
| 325 | +19277x |
- }+ sibpos = i, |
||
| 195 | -1x | +326 | +19277x |
- X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))+ max_width = max_width,+ |
+
| 327 | +19277x | +
+ fontspec = fontspec |
||
| 196 | +328 |
- }+ ) |
||
| 197 | +329 |
- }+ |
||
| 198 | -7x | +|||
| 330 | +
- class(X) <- c("rtables_diff", class(X))
+ # print(kiddfs$abs_rownumber) |
|||
| 199 | -7x | +331 | +19277x |
- X+ rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE) |
| 200 | -+ | |||
| 332 | +19277x |
- }+ ret <- c(ret, list(kiddfs)) |
||
| 201 | +333 |
-
+ } |
||
| 202 | +334 |
- ## for (i in 1:dim(X)[1]) {
+
|
||
| 203 | -+ | |||
| 335 | +10410x |
- ## for (j in 1:dim(X)[2]) {
+ ret <- do.call(rbind, ret) |
||
| 204 | +336 | |||
| 205 | +337 |
- ## is_equivalent <- TRUE+ # Case where it has Elementary table or VTableTree section_div it is overridden |
||
| 206 | -+ | |||
| 338 | +10410x |
- ## if (i <= nro && i <= nre && j <= nco && j <= nce) {
+ if (!is.na(trailing_section_div(tt))) {
|
||
| 207 | -+ | |||
| 339 | +110x |
- ## x <- object[i,j, drop = TRUE]+ ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt) |
||
| 208 | +340 |
- ## y <- expected[i,j, drop = TRUE]+ } |
||
| 209 | -+ | |||
| 341 | +10410x |
-
+ ret |
||
| 210 | +342 |
- ## attr_x <- attributes(x)+ } |
||
| 211 | +343 |
- ## attr_y <- attributes(y)+ ) |
||
| 212 | +344 | |||
| 213 | +345 |
- ## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]+ # #' @exportMethod make_row_df |
||
| 214 | +346 |
- ## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]+ #' @inherit formatters::make_row_df |
||
| 215 | +347 |
-
+ #' |
||
| 216 | +348 |
- ## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
+ #' @export |
||
| 217 | +349 |
- ## is_equivalent <- FALSE+ #' @rdname formatters_methods |
||
| 218 | +350 |
- ## } else if (is.numeric(x) && is.numeric(y)) {
+ setMethod( |
||
| 219 | +351 |
- ## if (any(abs(na.omit(x - y)) > tol)) {
+ "make_row_df", "TableRow", |
||
| 220 | +352 |
- ## is_equivalent <- FALSE+ function(tt, colwidths = NULL, visible_only = TRUE, |
||
| 221 | +353 |
- ## }+ rownum = 0, |
||
| 222 | +354 |
- ## } else {
+ indent = 0L, |
||
| 223 | +355 |
- ## if (!identical(x, y)) {
+ path = "root", |
||
| 224 | +356 |
- ## is_equivalent <- FALSE+ incontent = FALSE, |
||
| 225 | +357 |
- ## }+ repr_ext = 0L, |
||
| 226 | +358 |
- ## }+ repr_inds = integer(), |
||
| 227 | +359 |
-
+ sibpos = NA_integer_, |
||
| 228 | +360 |
- ## if (!is_equivalent) {
+ nsibs = NA_integer_, |
||
| 229 | +361 |
- ## X[i,j] <- "X"+ max_width = NULL, |
||
| 230 | +362 |
- ## }+ fontspec, |
||
| 231 | +363 |
- ## } else if (i > nro || j > nco) {
+ col_gap = 3) {
|
||
| 232 | -+ | |||
| 364 | +11157x |
- ## ## missing in object+ indent <- indent + indent_mod(tt) |
||
| 233 | -+ | |||
| 365 | +11157x |
- ## X[i, j] <- "+"+ rownum <- rownum + 1 |
||
| 234 | -+ | |||
| 366 | +11157x |
- ## } else {
+ rrefs <- row_footnotes(tt) |
||
| 235 | -+ | |||
| 367 | +11157x |
- ## ## too many elements+ crefs <- cell_footnotes(tt) |
||
| 236 | -+ | |||
| 368 | +11157x |
- ## X[i, j] <- "-"+ reflines <- sum( |
||
| 237 | -+ | |||
| 369 | +11157x |
- ## }+ sapply( |
||
| 238 | -+ | |||
| 370 | +11157x |
- ## }+ c(rrefs, crefs), |
||
| 239 | -+ | |||
| 371 | +11157x |
- ## }+ nlines, |
||
| 240 | -+ | |||
| 372 | +11157x |
- ## class(X) <- c("rtable_diff", class(X))
+ colwidths = colwidths, |
||
| 241 | -+ | |||
| 373 | +11157x |
- ## X+ max_width = max_width, |
||
| 242 | -+ | |||
| 374 | +11157x |
- ## }+ fontspec = fontspec, |
||
| 243 | -+ | |||
| 375 | +11157x |
-
+ col_gap = col_gap |
||
| 244 | +376 |
- compare_value <- function(x, y, tol) {
+ ) |
||
| 245 | -359x | +377 | +11157x |
- if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
+ ) ## col_gap not strictly necessary as these aren't rows, but why not |
| 246 | -+ | |||
| 378 | +11157x |
- "."+ ret <- pagdfrow( |
||
| 247 | -+ | |||
| 379 | +11157x |
- } else {
+ row = tt, |
||
| 248 | -72x | +380 | +11157x |
- "X"+ rnum = rownum, |
| 249 | -+ | |||
| 381 | +11157x |
- }+ colwidths = colwidths, |
||
| 250 | -+ | |||
| 382 | +11157x |
- }+ sibpos = sibpos, |
||
| 251 | -+ | |||
| 383 | +11157x |
-
+ nsibs = nsibs, |
||
| 252 | -+ | |||
| 384 | +11157x |
- compare_rrows <- function(row1, row2, tol, ncol) {
+ pth = c(path, unname(obj_name(tt))), |
||
| 253 | -173x | +385 | +11157x |
- if (length(row1) == ncol && length(row2) == ncol) {
+ repext = repr_ext, |
| 254 | -115x | +386 | +11157x |
- mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)+ repind = repr_inds, |
| 255 | -58x | +387 | +11157x |
- } else if (length(row1) == 0 && length(row2) == 0) {
+ indent = indent, |
| 256 | -44x | +388 | +11157x |
- rep(".", ncol)
+ extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap), |
| 257 | +389 |
- } else {
+ ## these two are unlist calls cause they come in lists even with no footnotes |
||
| 258 | -14x | +390 | +11157x |
- rep("X", ncol)
+ nrowrefs = length(rrefs), |
| 259 | -+ | |||
| 391 | +11157x |
- }+ ncellrefs = length(unlist(crefs)), |
||
| 260 | -+ | |||
| 392 | +11157x |
- }+ nreflines = reflines, |
||
| 261 | -+ | |||
| 393 | +11157x |
-
+ trailing_sep = trailing_section_div(tt),+ |
+ ||
| 394 | +11157x | +
+ fontspec = fontspec |
||
| 262 | +395 |
- ## #' @export+ )+ |
+ ||
| 396 | +11157x | +
+ ret |
||
| 263 | +397 |
- ## print.rtable_diff <- function(x, ...) {
+ } |
||
| 264 | +398 |
- ## print.default(unclass(x), quote = FALSE, ...)+ ) |
||
| 265 | +399 |
- ## }+ |
| 1 | +400 |
- insert_brs <- function(vec) {
+ # #' @exportMethod make_row_df |
||
| 2 | -919x | +|||
| 401 | +
- if (length(vec) == 1) {
+ #' @export |
|||
| 3 | -919x | +|||
| 402 | +
- ret <- list(vec)+ #' @rdname formatters_methods |
|||
| 4 | +403 |
- } else {
+ setMethod( |
||
| 5 | -! | +|||
| 404 | +
- nout <- length(vec) * 2 - 1+ "make_row_df", "LabelRow", |
|||
| 6 | -! | +|||
| 405 | +
- ret <- vector("list", nout)
+ function(tt, colwidths = NULL, visible_only = TRUE, |
|||
| 7 | -! | +|||
| 406 | +
- for (i in seq_along(vec)) {
+ rownum = 0, |
|||
| 8 | -! | +|||
| 407 | +
- ret[[2 * i - 1]] <- vec[i]+ indent = 0L, |
|||
| 9 | -! | +|||
| 408 | +
- if (2 * i < nout) {
+ path = "root", |
|||
| 10 | -! | +|||
| 409 | +
- ret[[2 * i]] <- tags$br()+ incontent = FALSE, |
|||
| 11 | +410 |
- }+ repr_ext = 0L, |
||
| 12 | +411 |
- }+ repr_inds = integer(), |
||
| 13 | +412 |
- }+ sibpos = NA_integer_, |
||
| 14 | -919x | +|||
| 413 | +
- ret+ nsibs = NA_integer_, |
|||
| 15 | +414 |
- }+ max_width = NULL, |
||
| 16 | +415 |
-
+ fontspec, |
||
| 17 | +416 |
- div_helper <- function(lst, class) {
+ col_gap = 3) {
|
||
| 18 | -56x | +417 | +3624x |
- do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))+ rownum <- rownum + 1 |
| 19 | -+ | |||
| 418 | +3624x |
- }+ indent <- indent + indent_mod(tt) |
||
| 20 | -+ | |||
| 419 | +3624x |
-
+ ret <- pagdfrow(tt, |
||
| 21 | -+ | |||
| 420 | +3624x |
- #' Convert an `rtable` object to a `shiny.tag` HTML object+ extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap), |
||
| 22 | -+ | |||
| 421 | +3624x |
- #'+ rnum = rownum, |
||
| 23 | -+ | |||
| 422 | +3624x |
- #' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.+ colwidths = colwidths, |
||
| 24 | -+ | |||
| 423 | +3624x |
- #'+ sibpos = sibpos, |
||
| 25 | -+ | |||
| 424 | +3624x |
- #' @param x (`VTableTree`)\cr a `TableTree` object.+ nsibs = nsibs, |
||
| 26 | -+ | |||
| 425 | +3624x |
- #' @param class_table (`character`)\cr class for `table` tag.+ pth = path, |
||
| 27 | -+ | |||
| 426 | +3624x |
- #' @param class_tr (`character`)\cr class for `tr` tag.+ repext = repr_ext, |
||
| 28 | -+ | |||
| 427 | +3624x |
- #' @param class_th (`character`)\cr class for `th` tag.+ repind = repr_inds, |
||
| 29 | -+ | |||
| 428 | +3624x |
- #' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a+ indent = indent, |
||
| 30 | -+ | |||
| 429 | +3624x |
- #' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.+ nrowrefs = length(row_footnotes(tt)), |
||
| 31 | -+ | |||
| 430 | +3624x |
- #' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.+ ncellrefs = 0L, |
||
| 32 | -+ | |||
| 431 | +3624x |
- #' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,+ nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_, |
||
| 33 | -+ | |||
| 432 | +3624x |
- #' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label+ colwidths = colwidths, |
||
| 34 | -+ | |||
| 433 | +3624x |
- #' rows). Defaults to `"header"`.+ max_width = max_width, |
||
| 35 | -+ | |||
| 434 | +3624x |
- #' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults+ fontspec = fontspec, |
||
| 36 | -+ | |||
| 435 | +3624x |
- #' to `TRUE`.+ col_gap = col_gap |
||
| 37 | +436 |
- #' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults+ )), |
||
| 38 | -+ | |||
| 437 | +3624x |
- #' to `FALSE`.+ trailing_sep = trailing_section_div(tt), |
||
| 39 | -+ | |||
| 438 | +3624x |
- #'+ fontspec = fontspec |
||
| 40 | +439 |
- #' @importFrom htmltools tags+ ) |
||
| 41 | -+ | |||
| 440 | +3624x |
- #'+ if (!labelrow_visible(tt)) {
|
||
| 42 | -+ | |||
| 441 | +! |
- #' @return A `shiny.tag` object representing `x` in HTML.+ ret <- ret[0, , drop = FALSE] |
||
| 43 | +442 |
- #'+ }+ |
+ ||
| 443 | +3624x | +
+ ret |
||
| 44 | +444 |
- #' @examples+ } |
||
| 45 | +445 |
- #' tbl <- rtable(+ ) |
||
| 46 | +446 |
- #' header = LETTERS[1:3],+ |
||
| 47 | +447 |
- #' format = "xx",+ setGeneric("inner_col_df", function(ct,
|
||
| 48 | +448 |
- #' rrow("r1", 1, 2, 3),
+ colwidths = NULL, |
||
| 49 | +449 |
- #' rrow("r2", 4, 3, 2, indent = 1),
+ visible_only = TRUE, |
||
| 50 | +450 |
- #' rrow("r3", indent = 2)
+ colnum = 0L, |
||
| 51 | +451 |
- #' )+ sibpos = NA_integer_, |
||
| 52 | +452 |
- #'+ nsibs = NA_integer_, |
||
| 53 | +453 |
- #' as_html(tbl)+ ncolref = 0L, |
||
| 54 | +454 |
- #'+ na_str, |
||
| 55 | +455 |
- #' as_html(tbl, class_table = "table", class_tr = "row")+ global_cc_format) {
+ |
+ ||
| 456 | +19606x | +
+ standardGeneric("inner_col_df")
|
||
| 56 | +457 |
- #'+ }) |
||
| 57 | +458 |
- #' as_html(tbl, bold = c("header", "row_names"))
+
|
||
| 58 | +459 |
- #'+ #' Column layout summary |
||
| 59 | +460 |
- #' \dontrun{
+ #' |
||
| 60 | +461 |
- #' Viewer(tbl)+ #' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a |
||
| 61 | +462 |
- #' }+ #' `data.frame`. |
||
| 62 | +463 |
#' |
||
| 63 | +464 |
- #' @export+ #' @inheritParams formatters::make_row_df |
||
| 64 | +465 |
- as_html <- function(x,+ #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for |
||
| 65 | +466 |
- width = NULL,+ #' column counts if one is not specified for an individual column count. |
||
| 66 | +467 |
- class_table = "table table-condensed table-hover",+ #' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this. |
||
| 67 | +468 |
- class_tr = NULL,+ #' @export |
||
| 68 | +469 |
- class_th = NULL,+ make_col_df <- function(tt, |
||
| 69 | +470 |
- link_label = NULL,+ colwidths = NULL, |
||
| 70 | +471 |
- bold = c("header"),
+ visible_only = TRUE, |
||
| 71 | +472 |
- header_sep_line = TRUE,+ na_str = "", |
||
| 72 | +473 |
- no_spaces_between_cells = FALSE) {
+ ccount_format = colcount_format(tt) %||% "(N=xx)") {
|
||
| 73 | -7x | +474 | +3492x |
- if (is.null(x)) {
+ ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object |
| 74 | -! | +|||
| 475 | +3492x |
- return(tags$p("Empty Table"))
+ rows <- inner_col_df(ctree, |
||
| 75 | +476 |
- }+ ## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)), |
||
| 76 | -+ | |||
| 477 | +3492x |
-
+ colwidths = colwidths, |
||
| 77 | -7x | +478 | +3492x |
- stopifnot(is(x, "VTableTree"))+ visible_only = visible_only, |
| 78 | -+ | |||
| 479 | +3492x |
-
+ colnum = 1L, |
||
| 79 | -7x | +480 | +3492x |
- mat <- matrix_form(x, indent_rownames = TRUE)+ sibpos = 1L, |
| 80 | -+ | |||
| 481 | +3492x |
-
+ nsibs = 1L, |
||
| 81 | -7x | +482 | +3492x |
- nlh <- mf_nlheader(mat)+ na_str = na_str, |
| 82 | -7x | +483 | +3492x |
- nc <- ncol(x) + 1+ global_cc_format = ccount_format |
| 83 | -7x | +484 | +3492x |
- nr <- length(mf_lgrouping(mat))+ ) ## nsiblings includes current so 1 means "only child" |
| 84 | +485 | |||
| 486 | +3492x | +
+ do.call(rbind, rows)+ |
+ ||
| 85 | +487 |
- # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions+ } |
||
| 86 | -7x | +|||
| 488 | +
- cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)+ |
|||
| 87 | +489 |
-
+ setMethod( |
||
| 88 | -7x | +|||
| 490 | +
- for (i in seq_len(nr)) {
+ "inner_col_df", "LayoutColLeaf", |
|||
| 89 | -148x | +|||
| 491 | +
- for (j in seq_len(nc)) {
+ function(ct, colwidths, visible_only, |
|||
| 90 | -919x | +|||
| 492 | +
- curstrs <- mf_strings(mat)[i, j]+ colnum, |
|||
| 91 | -919x | +|||
| 493 | +
- curspn <- mf_spans(mat)[i, j]+ sibpos, |
|||
| 92 | -919x | +|||
| 494 | +
- algn <- mf_aligns(mat)[i, j]+ nsibs, |
|||
| 93 | +495 |
-
+ na_str,+ |
+ ||
| 496 | ++ |
+ global_cc_format) {
|
||
| 94 | -919x | +497 | +12556x |
- inhdr <- i <= nlh+ list(col_dfrow( |
| 95 | -919x | +498 | +12556x |
- tagfun <- if (inhdr) tags$th else tags$td+ col = ct, |
| 96 | -919x | +499 | +12556x |
- cells[i, j][[1]] <- tagfun(+ cnum = colnum, |
| 97 | -919x | +500 | +12556x |
- class = if (inhdr) class_th else class_tr,+ sibpos = sibpos, |
| 98 | -919x | +501 | +12556x |
- style = paste0("text-align: ", algn, ";"),
+ nsibs = nsibs, |
| 99 | -919x | +502 | +12556x |
- style = if (inhdr && !"header" %in% bold) "font-weight: normal;",+ leaf_indices = colnum, |
| 100 | -919x | +503 | +12556x |
- style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",+ col_fnotes = col_footnotes(ct), |
| 101 | -919x | +504 | +12556x |
- colspan = if (curspn != 1) curspn,+ ccount_na_str = na_str, |
| 102 | -919x | +505 | +12556x |
- insert_brs(curstrs)+ global_cc_format = global_cc_format |
| 103 | +506 |
- )+ )) |
||
| 104 | +507 |
- }+ } |
||
| 105 | +508 |
- }+ ) |
||
| 106 | +509 | |||
| 107 | -7x | +|||
| 510 | +
- if (header_sep_line) {
+ setMethod( |
|||
| 108 | -7x | +|||
| 511 | +
- cells[nlh][[1]] <- htmltools::tagAppendAttributes(+ "inner_col_df", "LayoutColTree", |
|||
| 109 | -7x | +|||
| 512 | +
- cells[nlh, 1][[1]],+ function(ct, colwidths, visible_only, |
|||
| 110 | -7x | +|||
| 513 | +
- style = "border-bottom: 1px solid black;"+ colnum, |
|||
| 111 | +514 |
- )+ sibpos, |
||
| 112 | +515 |
- }+ nsibs, |
||
| 113 | +516 |
-
+ na_str, |
||
| 114 | +517 |
- # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh+ global_cc_format) {
|
||
| 115 | -7x | +518 | +7050x |
- map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)+ kids <- tree_children(ct) |
| 116 | -7x | +519 | +7050x |
- row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)+ ret <- vector("list", length(kids))
|
| 117 | -7x | -
- map <- merge(map, row_info_df, by = "abs_rownumber")- |
- ||
| 118 | -+ | 520 | +7050x |
-
+ for (i in seq_along(kids)) {
|
| 119 | -+ | |||
| 521 | +16114x |
- # add indent values for headerlines+ k <- kids[[i]] |
||
| 120 | -7x | +522 | +16114x |
- map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)+ newrows <- do.call( |
| 121 | -+ | |||
| 523 | +16114x |
-
+ rbind, |
||
| 122 | -+ | |||
| 524 | +16114x |
-
+ inner_col_df(k, |
||
| 123 | -+ | |||
| 525 | +16114x |
- # Row labels style+ colnum = colnum, |
||
| 124 | -7x | +526 | +16114x |
- for (i in seq_len(nr)) {
+ sibpos = i, |
| 125 | -148x | +527 | +16114x |
- indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)+ nsibs = length(kids), |
| 126 | -+ | |||
| 528 | +16114x |
-
+ visible_only = visible_only, |
||
| 127 | -+ | |||
| 529 | +16114x |
- # Apply indentation+ na_str = na_str, |
||
| 128 | -148x | +530 | +16114x |
- if (indent > 0) {
+ global_cc_format = global_cc_format |
| 129 | -114x | +|||
| 531 | +
- cells[i, 1][[1]] <- htmltools::tagAppendAttributes(+ ) |
|||
| 130 | -114x | +|||
| 532 | +
- cells[i, 1][[1]],+ ) |
|||
| 131 | -114x | +533 | +16114x |
- style = paste0("padding-left: ", indent * 3, "ch;")
+ colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1 |
| 132 | -+ | |||
| 534 | +16114x |
- )+ ret[[i]] <- newrows |
||
| 133 | +535 |
} |
||
| 134 | +536 | |||
| 135 | -+ | |||
| 537 | +7050x |
- # Apply bold font weight if "row_names" is in 'bold'+ if (!visible_only) {
|
||
| 136 | -148x | +538 | +1448x |
- if ("row_names" %in% bold) {
+ allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)])) |
| 137 | -4x | +539 | +1448x |
- cells[i, 1][[1]] <- htmltools::tagAppendAttributes(+ thispth <- pos_to_path(tree_pos(ct)) |
| 138 | -4x | +540 | +1448x |
- cells[i, 1][[1]],+ if (any(nzchar(thispth))) {
|
| 139 | -4x | +541 | +746x |
- style = "font-weight: bold;"+ thisone <- list(col_dfrow( |
| 140 | -+ | |||
| 542 | +746x |
- )+ col = ct, |
||
| 141 | -+ | |||
| 543 | +746x |
- }+ cnum = NA_integer_, |
||
| 142 | -+ | |||
| 544 | +746x |
- }+ leaf_indices = allindices, |
||
| 143 | -+ | |||
| 545 | +746x |
-
+ sibpos = sibpos, |
||
| 144 | -+ | |||
| 546 | +746x |
- # label rows style+ nsibs = nsibs, |
||
| 145 | -7x | +547 | +746x |
- if ("label_rows" %in% bold) {
+ pth = thispth, |
| 146 | -! | +|||
| 548 | +746x |
- which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")+ col_fnotes = col_footnotes(ct), |
||
| 147 | -! | +|||
| 549 | +746x |
- cells[which_lbl_rows + nlh, ] <- lapply(+ ccount_na_str = na_str, |
||
| 148 | -! | +|||
| 550 | +746x |
- cells[which_lbl_rows + nlh, ],+ global_cc_format = global_cc_format |
||
| 149 | -! | +|||
| 551 | +
- htmltools::tagAppendAttributes,+ )) |
|||
| 150 | -! | +|||
| 552 | +746x |
- style = "font-weight: bold;"+ ret <- c(thisone, ret) |
||
| 151 | +553 |
- )+ } |
||
| 152 | +554 |
- }+ } |
||
| 153 | +555 | |||
| 154 | -- |
- # content rows style- |
- ||
| 155 | -7x | -
- if ("content_rows" %in% bold) {
- |
- ||
| 156 | -! | +556 | +7050x |
- which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
+ ret |
| 157 | -! | +|||
| 557 | +
- cells[which_cntnt_rows + nlh, ] <- lapply(+ } |
|||
| 158 | -! | +|||
| 558 | +
- cells[which_cntnt_rows + nlh, ],+ ) |
|||
| 159 | -! | +|||
| 559 | +
- htmltools::tagAppendAttributes,+ |
|||
| 160 | -! | +|||
| 560 | +
- style = "font-weight: bold;"+ ## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND |
|||
| 161 | +561 |
- )+ ## title/subtitle!!!!! |
||
| 162 | +562 |
- }+ .header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
|
||
| 163 | -+ | |||
| 563 | +3x |
-
+ cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec) |
||
| 164 | -7x | +564 | +3x |
- if (any(!mat$display)) {
+ if (any(nzchar(all_titles(tt)))) {
|
| 165 | +565 |
- # Check that expansion kept the same display info+ ## +1 is for blank line between subtitles and divider |
||
| 166 | +566 | 2x |
- check_expansion <- c()+ tlines <- sum(nlines(all_titles(tt), |
|
| 167 | +567 | 2x |
- for (ii in unique(mat$line_grouping)) {
- |
- |
| 168 | -121x | -
- rows <- which(mat$line_grouping == ii)+ colwidths = colwidths, |
||
| 169 | -121x | +568 | +2x |
- check_expansion <- c(+ max_width = max_width, |
| 170 | -121x | +569 | +2x |
- check_expansion,+ fontspec = fontspec |
| 171 | -121x | +570 | +2x |
- apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x))+ )) + divider_height(tt) + 1L |
| 172 | +571 |
- )+ } else {
|
||
| 173 | -+ | |||
| 572 | +1x |
- }+ tlines <- 0 |
||
| 174 | +573 |
-
+ } |
||
| 175 | -2x | -
- if (!all(check_expansion)) {
- |
- ||
| 176 | -! | +574 | +3x |
- stop(+ ret <- cinfo_lines + tlines |
| 177 | -! | +|||
| 575 | +3x |
- "Found that a group of rows have different display options even if ",+ if (verbose) {
|
||
| 178 | +576 | ! |
- "they belong to the same line group. This should not happen. Please ",+ message( |
|
| 179 | +577 | ! |
- "file an issue or report to the maintainers."+ "Lines required for header content: ", |
|
| 180 | +578 | ! |
- ) # nocov+ ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")" |
|
| 181 | +579 |
- }+ ) |
||
| 182 | +580 | - - | -||
| 183 | -2x | -
- for (ii in unique(mat$line_grouping)) {
+ } |
||
| 184 | -121x | +581 | +3x |
- rows <- which(mat$line_grouping == ii)+ ret |
| 185 | -121x | +|||
| 582 | +
- should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)+ } |
|||
| 186 | -121x | +|||
| 583 | +
- cells[ii, !should_display_col] <- NA_integer_+ |
|||
| 187 | +584 |
- }+ ## this is ***only*** lines that are expected to be repeated on multiple pages: |
||
| 188 | +585 |
- }+ ## main footer, prov footer, and referential footnotes on **columns** |
||
| 189 | +586 | |||
| 190 | -7x | +|||
| 587 | +
- rows <- apply(cells, 1, function(row) {
+ .footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
|
|||
| 191 | -148x | +588 | +3x |
- tags$tr(+ flines <- nlines(main_footer(tt), |
| 192 | -148x | +589 | +3x |
- class = class_tr,+ colwidths = colwidths, |
| 193 | -148x | +590 | +3x |
- style = "white-space: pre;",+ max_width = max_width - table_inset(tt), |
| 194 | -148x | +591 | +3x |
- Filter(function(x) !identical(x, NA_integer_), row)+ fontspec = fontspec |
| 195 | +592 |
- )+ ) + |
||
| 196 | -+ | |||
| 593 | +3x |
- })+ nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec) |
||
| 197 | -+ | |||
| 594 | +3x |
-
+ if (flines > 0) {
|
||
| 198 | -7x | +595 | +2x |
- hsep_line <- tags$hr(class = "solid")+ dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)+ |
+
| 596 | +2x | +
+ flines <- flines + dl_contrib + 1L |
||
| 199 | +597 |
-
+ } |
||
| 200 | -7x | +|||
| 598 | +
- hdrtag <- div_helper(+ |
|||
| 201 | -7x | +599 | +3x |
- class = "rtables-titles-block",+ if (verbose) {
|
| 202 | -7x | +|||
| 600 | +! |
- list(+ message( |
||
| 203 | -7x | +|||
| 601 | +! |
- div_helper(+ "Determining lines required for footer content", |
||
| 204 | -7x | +|||
| 602 | +! |
- class = "rtables-main-titles-block",+ if (have_cfnotes) " [column fnotes present]", |
||
| 205 | -7x | +|||
| 603 | +! |
- lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
+ ": ", flines, " lines" |
||
| 206 | -7x | +|||
| 604 | +
- class = "rtables-main-title"+ ) |
|||
| 207 | +605 |
- )+ } |
||
| 208 | +606 |
- ),+ |
||
| 209 | -7x | +607 | +3x |
- div_helper(+ flines |
| 210 | -7x | +|||
| 608 | +
- class = "rtables-subtitles-block",+ } |
|||
| 211 | -7x | +|||
| 609 | +
- lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
+
|
|||
| 212 | -7x | +|||
| 610 | +
- class = "rtables-subtitle"+ # Pagination --------------------------------------------------------------- |
|||
| 213 | +611 |
- )+ |
||
| 214 | +612 |
- )+ #' Pagination of a `TableTree` |
||
| 215 | +613 |
- )+ #' |
||
| 216 | +614 |
- )+ #' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size. |
||
| 217 | +615 |
-
+ #' |
||
| 218 | -7x | +|||
| 616 | +
- tabletag <- do.call(+ #' @inheritParams gen_args |
|||
| 219 | -7x | +|||
| 617 | +
- tags$table,+ #' @inheritParams paginate_table |
|||
| 220 | -7x | +|||
| 618 | +
- c(+ #' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows. |
|||
| 221 | -7x | +|||
| 619 | +
- rows,+ #' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a |
|||
| 222 | -7x | +|||
| 620 | +
- list(+ #' mid-subtable split to be valid. Defaults to 2. |
|||
| 223 | -7x | +|||
| 621 | +
- class = class_table,+ #' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other |
|||
| 224 | -7x | +|||
| 622 | +
- style = paste(+ #' considerations. Defaults to none. |
|||
| 225 | -7x | +|||
| 623 | +
- if (no_spaces_between_cells) "border-collapse: collapse;",+ #' |
|||
| 226 | -7x | +|||
| 624 | +
- if (!is.null(width)) paste("width:", width)
+ #' @return |
|||
| 227 | +625 |
- ),+ #' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`. |
||
| 228 | -7x | +|||
| 626 | +
- tags$caption(sprintf("(\\#tag:%s)", link_label),
+ #' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`. |
|||
| 229 | -7x | +|||
| 627 | +
- style = "caption-side: top;",+ #' |
|||
| 230 | -7x | +|||
| 628 | +
- .noWS = "after-begin"+ #' @details |
|||
| 231 | +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 |
||
| 232 | +631 |
- )+ #' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of |
||
| 233 | +632 |
- )+ #' text than rendering the table without pagination would. |
||
| 234 | +633 |
- )+ #' |
||
| 235 | +634 |
-
+ #' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content. |
||
| 236 | -7x | +|||
| 635 | +
- rfnotes <- div_helper(+ #' |
|||
| 237 | -7x | +|||
| 636 | +
- class = "rtables-ref-footnotes-block",+ #' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`). |
|||
| 238 | -7x | +|||
| 637 | +
- lapply(mat$ref_footnotes, tags$p,+ #' |
|||
| 239 | -7x | +|||
| 638 | +
- class = "rtables-referential-footnote"+ #' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same |
|||
| 240 | +639 |
- )+ #' algorithm used for vertical pagination to it. |
||
| 241 | +640 |
- )+ #' |
||
| 242 | +641 |
-
+ #' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and |
||
| 243 | -7x | +|||
| 642 | +
- mftr <- div_helper(+ #' characters-per-page (`cpp`) values. |
|||
| 244 | -7x | +|||
| 643 | +
- class = "rtables-main-footers-block",+ #' |
|||
| 245 | -7x | +|||
| 644 | +
- lapply(main_footer(x), tags$p,+ #' The full multi-direction pagination algorithm then is as follows: |
|||
| 246 | -7x | +|||
| 645 | +
- class = "rtables-main-footer"+ #' |
|||
| 247 | +646 |
- )+ #' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns): |
||
| 248 | +647 |
- )+ #' - titles/footers/column labels, and horizontal dividers in the vertical pagination case |
||
| 249 | +648 |
-
+ #' - row-labels, table_inset, and top-left materials in the horizontal case |
||
| 250 | -7x | +|||
| 649 | +
- pftr <- div_helper(+ #' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables. |
|||
| 251 | -7x | +|||
| 650 | +
- class = "rtables-prov-footers-block",+ #' 2. Perform vertical pagination separately on each table generated in (1). |
|||
| 252 | -7x | +|||
| 651 | +
- lapply(prov_footer(x), tags$p,+ #' 3. Perform horizontal pagination **on the entire table** and apply the results to each table |
|||
| 253 | -7x | +|||
| 652 | +
- class = "rtables-prov-footer"+ #' page generated in (1)-(2). |
|||
| 254 | +653 |
- )+ #' 4. Return a list of subtables representing full bi-directional pagination. |
||
| 255 | +654 |
- )+ #' |
||
| 256 | +655 |
-
+ #' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package: |
||
| 257 | +656 |
- ## XXX this omits the divs entirely if they are empty. Do we want that or do+ #' |
||
| 258 | +657 |
- ## we want them to be there but empty??+ #' @inheritSection formatters::pagination_algo Pagination Algorithm |
||
| 259 | -7x | +|||
| 658 | +
- ftrlst <- list(+ #' |
|||
| 260 | -7x | +|||
| 659 | +
- if (length(mat$ref_footnotes) > 0) rfnotes,+ #' @examples |
|||
| 261 | -7x | +|||
| 660 | +
- if (length(mat$ref_footnotes) > 0) hsep_line,+ #' s_summary <- function(x) {
|
|||
| 262 | -7x | +|||
| 661 | +
- if (length(main_footer(x)) > 0) mftr,+ #' if (is.numeric(x)) {
|
|||
| 263 | -7x | +|||
| 662 | +
- if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break+ #' in_rows( |
|||
| 264 | -7x | +|||
| 663 | +
- if (length(prov_footer(x)) > 0) pftr+ #' "n" = rcell(sum(!is.na(x)), format = "xx"), |
|||
| 265 | +664 |
- )+ #' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)), |
||
| 266 | +665 |
-
+ #' format = "xx.xx (xx.xx)" |
||
| 267 | -! | +|||
| 666 | +
- if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)+ #' ), |
|||
| 268 | -7x | +|||
| 667 | +
- ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]+ #' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"), |
|||
| 269 | +668 |
-
+ #' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx") |
||
| 270 | -7x | +|||
| 669 | +
- ftrtag <- div_helper(+ #' ) |
|||
| 271 | -7x | +|||
| 670 | +
- class = "rtables-footers-block",+ #' } else if (is.factor(x)) {
|
|||
| 272 | -7x | +|||
| 671 | +
- ftrlst+ #' vs <- as.list(table(x)) |
|||
| 273 | +672 |
- )+ #' do.call(in_rows, lapply(vs, rcell, format = "xx")) |
||
| 274 | +673 |
-
+ #' } else {
|
||
| 275 | -7x | +|||
| 674 | +
- div_helper(+ #' ( |
|||
| 276 | -7x | +|||
| 675 | +
- class = "rtables-all-parts-block",+ #' stop("type not supported")
|
|||
| 277 | -7x | +|||
| 676 | +
- list(+ #' ) |
|||
| 278 | -7x | +|||
| 677 | +
- hdrtag,+ #' } |
|||
| 279 | -7x | +|||
| 678 | +
- tabletag,+ #' } |
|||
| 280 | -7x | +|||
| 679 | +
- ftrtag+ #' |
|||
| 281 | +680 |
- )+ #' lyt <- basic_table() %>% |
||
| 282 | +681 |
- )+ #' split_cols_by(var = "ARM") %>% |
||
| 283 | +682 |
- }+ #' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
|
| 1 | +683 |
- #' Trimming and pruning criteria+ #' |
||
| 2 | +684 |
- #'+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 3 | +685 |
- #' Criteria functions (and constructors thereof) for trimming and pruning tables.+ #' tbl |
||
| 4 | +686 |
#' |
||
| 5 | +687 |
- #' @inheritParams gen_args+ #' nrow(tbl) |
||
| 6 | +688 |
#' |
||
| 7 | +689 |
- #' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.+ #' row_paths_summary(tbl) |
||
| 8 | +690 |
#' |
||
| 9 | +691 |
- #' @seealso [prune_table()], [trim_rows()]+ #' tbls <- paginate_table(tbl, lpp = 15) |
||
| 10 | +692 |
- #'+ #' mf <- matrix_form(tbl, indent_rownames = TRUE) |
||
| 11 | +693 |
- #' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`*+ #' w_tbls <- propose_column_widths(mf) # so that we have the same column widths |
||
| 12 | +694 |
- #' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.+ #' |
||
| 13 | +695 |
#' |
||
| 14 | +696 |
- #' @examples+ #' tmp <- lapply(tbls, function(tbli) {
|
||
| 15 | +697 |
- #' adsl <- ex_adsl+ #' cat(toString(tbli, widths = w_tbls)) |
||
| 16 | +698 |
- #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ #' cat("\n\n")
|
||
| 17 | +699 |
- #' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0+ #' cat("~~~~ PAGE BREAK ~~~~")
|
||
| 18 | +700 |
- #' adsl$BMRKR1 <- 0+ #' cat("\n\n")
|
||
| 19 | +701 |
- #'+ #' }) |
||
| 20 | +702 |
- #' tbl_to_prune <- basic_table() %>%+ #' |
||
| 21 | +703 |
- #' analyze("BMRKR1") %>%
+ #' @rdname paginate |
||
| 22 | +704 |
- #' split_cols_by("ARM") %>%
+ #' @export |
||
| 23 | +705 |
- #' split_rows_by("SEX") %>%
+ pag_tt_indices <- function(tt, |
||
| 24 | +706 |
- #' summarize_row_groups() %>%+ lpp = 15, |
||
| 25 | +707 |
- #' split_rows_by("STRATA1") %>%
+ min_siblings = 2, |
||
| 26 | +708 |
- #' summarize_row_groups() %>%+ nosplitin = character(), |
||
| 27 | +709 |
- #' analyze("AGE") %>%
+ colwidths = NULL, |
||
| 28 | +710 |
- #' build_table(adsl)+ max_width = NULL, |
||
| 29 | +711 |
- #'+ fontspec = NULL, |
||
| 30 | +712 |
- #' tbl_to_prune %>% prune_table(all_zero_or_na)+ col_gap = 3, |
||
| 31 | +713 |
- #'+ verbose = FALSE) {
|
||
| 32 | -+ | |||
| 714 | +3x |
- #' @rdname trim_prune_funs+ dheight <- divider_height(tt) |
||
| 33 | +715 |
- #' @export+ |
||
| 34 | +716 |
- all_zero_or_na <- function(tr) {
+ # cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width) |
||
| 35 | -347x | +717 | +3x |
- if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ coldf <- make_col_df(tt, colwidths) |
| 36 | -93x | +718 | +3x |
- return(FALSE)+ have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0 |
| 37 | +719 |
- }+ |
||
| 38 | -254x | +720 | +3x |
- rvs <- unlist(unname(row_values(tr)))+ hlines <- .header_rep_nlines(tt, |
| 39 | -254x | +721 | +3x |
- all(is.na(rvs) | rvs == 0 | !is.finite(rvs))+ colwidths = colwidths, max_width = max_width,+ |
+
| 722 | +3x | +
+ verbose = verbose,+ |
+ ||
| 723 | +3x | +
+ fontspec = fontspec |
||
| 40 | +724 |
- }+ ) |
||
| 41 | +725 |
-
+ ## if(any(nzchar(all_titles(tt)))) {
|
||
| 42 | +726 |
- #' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.+ ## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) + |
||
| 43 | +727 |
- #'+ ## length(wrap_txt(all_titles(tt), max_width = max_width)) + |
||
| 44 | +728 |
- #' @examples+ ## dheight + 1L |
||
| 45 | +729 |
- #' tbl_to_prune %>% prune_table(all_zero)+ ## } else {
|
||
| 46 | +730 |
- #'+ ## tlines <- 0 |
||
| 47 | +731 |
- #' @rdname trim_prune_funs+ ## } |
||
| 48 | +732 |
- #' @export+ ## flines <- nlines(main_footer(tt), colwidths = colwidths, |
||
| 49 | +733 |
- all_zero <- function(tr) {
+ ## max_width = max_width - table_inset(tt)) + |
||
| 50 | -8x | +|||
| 734 | +
- if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ ## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width) |
|||
| 51 | -! | +|||
| 735 | +
- return(FALSE)+ ## if(flines > 0) {
|
|||
| 52 | +736 |
- }+ ## dl_contrib <- if(have_cfnotes) 0 else dheight+ |
+ ||
| 737 | ++ |
+ ## flines <- flines + dl_contrib + 1L+ |
+ ||
| 738 | ++ |
+ ## } |
||
| 53 | -8x | +739 | +3x |
- rvs <- unlist(unname(row_values(tr)))+ flines <- .footer_rep_nlines(tt, |
| 54 | -8x | +740 | +3x |
- isTRUE(all(rvs == 0))+ colwidths = colwidths, |
| 55 | -+ | |||
| 741 | +3x |
- }+ max_width = max_width, |
||
| 56 | -+ | |||
| 742 | +3x |
-
+ have_cfnotes = have_cfnotes, |
||
| 57 | -+ | |||
| 743 | +3x |
- #' Trim rows from a populated table without regard for table structure+ fontspec = fontspec, |
||
| 58 | -+ | |||
| 744 | +3x |
- #'+ verbose = verbose |
||
| 59 | +745 |
- #' @inheritParams gen_args+ ) |
||
| 60 | +746 |
- #' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row+ ## row lines per page |
||
| 61 | -+ | |||
| 747 | +3x |
- #' should be removed. Defaults to [all_zero_or_na()].+ rlpp <- lpp - hlines - flines |
||
| 62 | -+ | |||
| 748 | +3x |
- #'+ if (verbose) {
|
||
| 63 | -+ | |||
| 749 | +! |
- #' @return The table with rows that have only `NA` or 0 cell values removed.+ message( |
||
| 64 | -+ | |||
| 750 | +! |
- #'+ "Adjusted Lines Per Page: ", |
||
| 65 | -+ | |||
| 751 | +! |
- #' @note+ rlpp, " (original lpp: ", lpp, ")" |
||
| 66 | +752 |
- #' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or+ ) |
||
| 67 | +753 |
- #' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on+ } |
||
| 68 | -+ | |||
| 754 | +3x |
- #' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.+ pagdf <- make_row_df(tt, colwidths, max_width = max_width) |
||
| 69 | +755 |
- #'+ |
||
| 70 | -+ | |||
| 756 | +3x |
- #' @details+ pag_indices_inner(pagdf, |
||
| 71 | -+ | |||
| 757 | +3x |
- #' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]+ rlpp = rlpp, min_siblings = min_siblings, |
||
| 72 | -+ | |||
| 758 | +3x |
- #' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure+ nosplitin = nosplitin, |
||
| 73 | -+ | |||
| 759 | +3x |
- #' into account.+ verbose = verbose, |
||
| 74 | -+ | |||
| 760 | +3x |
- #'+ have_col_fnotes = have_cfnotes, |
||
| 75 | -+ | |||
| 761 | +3x |
- #' @seealso [prune_table()]+ div_height = dheight, |
||
| 76 | -+ | |||
| 762 | +3x |
- #'+ col_gap = col_gap, |
||
| 77 | -+ | |||
| 763 | +3x |
- #' @examples+ has_rowlabels = TRUE |
||
| 78 | +764 |
- #' adsl <- ex_adsl+ ) |
||
| 79 | +765 |
- #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ } |
||
| 80 | +766 |
- #'+ |
||
| 81 | +767 |
- #' tbl_to_trim <- basic_table() %>%+ copy_title_footer <- function(to, from, newptitle) {
|
||
| 82 | -+ | |||
| 768 | +18x |
- #' analyze("BMRKR1") %>%
+ main_title(to) <- main_title(from) |
||
| 83 | -+ | |||
| 769 | +18x |
- #' split_cols_by("ARM") %>%
+ 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 |
||
| 84 | +774 |
- #' split_rows_by("SEX") %>%
+ } |
||
| 85 | +775 |
- #' summarize_row_groups() %>%+ |
||
| 86 | +776 |
- #' split_rows_by("STRATA1") %>%
+ 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 = ": ") |
||
| 87 | +784 |
- #' summarize_row_groups() %>%+ )+ |
+ ||
| 785 | +18x | +
+ labelrow_visible(tbl) <- FALSE+ |
+ ||
| 786 | +18x | +
+ tbl |
||
| 88 | +787 |
- #' analyze("AGE") %>%
+ } |
||
| 89 | +788 |
- #' build_table(adsl)+ ) |
||
| 90 | +789 |
- #'+ } |
||
| 91 | +790 |
- #' tbl_to_trim %>% trim_rows()+ |
||
| 92 | +791 |
- #'+ force_paginate <- function(tt, |
||
| 93 | +792 |
- #' tbl_to_trim %>% trim_rows(all_zero)+ force_pag = vapply(tree_children(tt), has_force_pag, NA), |
||
| 94 | +793 |
- #'+ verbose = FALSE) {
|
||
| 95 | +794 |
- #' @export+ ## forced pagination is happening at this+ |
+ ||
| 795 | +114x | +
+ if (has_force_pag(tt)) {
+ |
+ ||
| 796 | +8x | +
+ ret <- pag_btw_kids(tt)+ |
+ ||
| 797 | +8x | +
+ return(unlist(lapply(ret, force_paginate))) |
||
| 96 | +798 |
- trim_rows <- function(tt, criteria = all_zero_or_na) {
+ } |
||
| 97 | -3x | +799 | +106x |
- rows <- collect_leaves(tt, TRUE, TRUE)+ chunks <- list() |
| 98 | -3x | +800 | +106x |
- torm <- vapply(rows, criteria,+ kinds <- seq_along(force_pag) |
| 99 | -3x | +801 | +106x |
- NA,+ while (length(kinds) > 0) {
+ |
+
| 802 | +106x | +
+ 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)) |
||
| 100 | -3x | +|||
| 810 | +! |
- USE.NAMES = FALSE+ kinds <- kinds[-1] |
||
| 101 | +811 |
- )+ } else {
|
||
| 102 | -3x | +812 | +106x |
- tt[!torm, ,+ tmptbl <- tt |
| 103 | -3x | +813 | +106x |
- keep_topleft = TRUE,+ runend <- min(which(force_pag[kinds]), length(kinds)) |
| 104 | -3x | +814 | +106x |
- keep_titles = TRUE,+ useinds <- 1:runend |
| 105 | -3x | +815 | +106x |
- keep_footers = TRUE,+ tree_children(tmptbl) <- tree_children(tt)[useinds] |
| 106 | -3x | +816 | +106x |
- reindex_refs = TRUE+ chunks <- c(chunks, tmptbl) |
| 107 | -+ | |||
| 817 | +106x |
- ]+ kinds <- kinds[-useinds] |
||
| 108 | +818 |
- }+ } |
||
| 109 | +819 |
-
+ } |
||
| 110 | -+ | |||
| 820 | +106x |
- #' @inheritParams trim_rows+ unlist(chunks, recursive = TRUE) |
||
| 111 | +821 |
- #'+ } |
||
| 112 | +822 |
- #' @details+ |
||
| 113 | +823 |
- #' `content_all_zeros_nas` prunes a subtable if both of the following are true:+ #' @importFrom formatters do_forced_paginate |
||
| 114 | +824 |
- #'+ setMethod( |
||
| 115 | +825 |
- #' * It has a content table with exactly one row in it.+ "do_forced_paginate", "VTableTree", |
||
| 116 | -+ | |||
| 826 | +96x |
- #' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content+ function(obj) force_paginate(obj) |
||
| 117 | +827 |
- #' function is used, this represents pruning any subtable which corresponds to an empty set of the input data+ ) |
||
| 118 | +828 |
- #' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).+ + |
+ ||
| 829 | +190x | +
+ non_null_na <- function(x) !is.null(x) && is.na(x) |
||
| 119 | +830 |
- #'+ |
||
| 120 | +831 |
- #' @examples+ #' @inheritParams formatters::vert_pag_indices |
||
| 121 | +832 |
- #' tbl_to_prune %>% prune_table(content_all_zeros_nas)+ #' @inheritParams formatters::page_lcpp |
||
| 122 | +833 |
- #'+ #' @inheritParams formatters::toString |
||
| 123 | +834 |
- #' @rdname trim_prune_funs+ #' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination. |
||
| 124 | +835 |
- #' @export+ #' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal |
||
| 125 | +836 |
- content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
+ #' pagination should be done regardless of page size. |
||
| 126 | +837 |
- ## this will be NULL if+ #' |
||
| 127 | +838 |
- ## tt is something that doesn't have a content table+ #' @rdname paginate |
||
| 128 | -254x | +|||
| 839 | +
- ct <- content_table(tt)+ #' @aliases paginate_table |
|||
| 129 | +840 |
- ## NROW returns 0 for NULL.+ #' @export |
||
| 130 | -254x | +|||
| 841 | +
- if (NROW(ct) == 0 || nrow(ct) > 1) {
+ paginate_table <- function(tt, |
|||
| 131 | -242x | +|||
| 842 | +
- return(FALSE)+ page_type = "letter", |
|||
| 132 | +843 |
- }+ font_family = "Courier", |
||
| 133 | +844 |
-
+ font_size = 8, |
||
| 134 | -12x | +|||
| 845 | +
- cr <- tree_children(ct)[[1]]+ lineheight = 1, |
|||
| 135 | -12x | +|||
| 846 | +
- criteria(cr)+ landscape = FALSE, |
|||
| 136 | +847 |
- }+ pg_width = NULL, |
||
| 137 | +848 |
-
+ pg_height = NULL, |
||
| 138 | +849 |
- #' @details+ margins = c(top = .5, bottom = .5, left = .75, right = .75), |
||
| 139 | +850 |
- #' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on+ lpp = NA_integer_, |
||
| 140 | +851 |
- #' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no+ cpp = NA_integer_, |
||
| 141 | +852 |
- #' children.+ min_siblings = 2, |
||
| 142 | +853 |
- #'+ nosplitin = character(), |
||
| 143 | +854 |
- #' @examples+ colwidths = NULL, |
||
| 144 | +855 |
- #' tbl_to_prune %>% prune_table(prune_empty_level)+ tf_wrap = FALSE, |
||
| 145 | +856 |
- #'+ max_width = NULL, |
||
| 146 | +857 |
- #' @rdname trim_prune_funs+ fontspec = font_spec(font_family, font_size, lineheight), |
||
| 147 | +858 |
- #' @export+ col_gap = 3, |
||
| 148 | +859 |
- prune_empty_level <- function(tt) {
+ verbose = FALSE) {
|
||
| 149 | -389x | +860 | +52x |
- if (is(tt, "TableRow")) {
+ new_dev <- open_font_dev(fontspec) |
| 150 | -151x | +861 | +52x |
- return(all_zero_or_na(tt))+ if (new_dev) {
+ |
+
| 862 | +39x | +
+ on.exit(close_font_dev()) |
||
| 151 | +863 |
} |
||
| 152 | +864 | |||
| 153 | -238x | +865 | +52x |
- if (content_all_zeros_nas(tt)) {
+ if ((non_null_na(lpp) || non_null_na(cpp)) && |
| 154 | -2x | +866 | +52x |
- return(TRUE)+ (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
|
| 155 | -+ | |||
| 867 | +12x |
- }+ pg_lcpp <- page_lcpp( |
||
| 156 | -236x | +868 | +12x |
- kids <- tree_children(tt)+ page_type = page_type, |
| 157 | -236x | +869 | +12x |
- length(kids) == 0+ font_family = font_family, |
| 158 | -+ | |||
| 870 | +12x |
- }+ font_size = font_size, |
||
| 159 | -+ | |||
| 871 | +12x |
-
+ lineheight = lineheight, |
||
| 160 | -+ | |||
| 872 | +12x |
- #' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes+ pg_width = pg_width, |
||
| 161 | -+ | |||
| 873 | +12x |
- #' only in the case of all non-missing zero values.+ pg_height = pg_height, |
||
| 162 | -+ | |||
| 874 | +12x |
- #'+ margins = margins, |
||
| 163 | -+ | |||
| 875 | +12x |
- #' @examples+ landscape = landscape, |
||
| 164 | -+ | |||
| 876 | +12x |
- #' tbl_to_prune %>% prune_table(prune_zeros_only)+ fontspec = fontspec |
||
| 165 | +877 |
- #'+ ) |
||
| 166 | +878 |
- #' @rdname trim_prune_funs+ |
||
| 167 | -+ | |||
| 879 | +12x |
- #' @export+ if (non_null_na(lpp)) {
+ |
+ ||
| 880 | +6x | +
+ lpp <- pg_lcpp$lpp |
||
| 168 | +881 |
- prune_zeros_only <- function(tt) {
+ } |
||
| 169 | -16x | +882 | +12x |
- if (is(tt, "TableRow")) {
+ if (is.na(cpp)) {
|
| 170 | +883 | 8x |
- return(all_zero(tt))+ cpp <- pg_lcpp$cpp |
|
| 171 | +884 |
- }+ } |
||
| 172 | +885 |
-
+ } else {
|
||
| 173 | -8x | +886 | +40x |
- if (content_all_zeros_nas(tt, criteria = all_zero)) {
+ if (non_null_na(cpp)) {
|
| 174 | +887 | ! |
- return(TRUE)+ cpp <- NULL |
|
| 175 | +888 |
- }- |
- ||
| 176 | -8x | -
- kids <- tree_children(tt)+ } |
||
| 177 | -8x | -
- length(kids) == 0- |
- ||
| 178 | -- |
- }- |
- ||
| 179 | -+ | 889 | +40x |
-
+ if (non_null_na(lpp)) {
|
| 180 | -+ | |||
| 890 | +! |
- #' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.+ lpp <- 70 |
||
| 181 | +891 |
- #' Subtables whose combined/average count are below this threshold will be pruned.+ } |
||
| 182 | +892 |
- #' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.+ } |
||
| 183 | +893 |
- #'+ |
||
| 184 | -+ | |||
| 894 | +52x |
- #' @details+ if (is.null(colwidths)) {
|
||
| 185 | -+ | |||
| 895 | +35x |
- #' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which+ colwidths <- propose_column_widths( |
||
| 186 | -+ | |||
| 896 | +35x |
- #' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell+ matrix_form( |
||
| 187 | -+ | |||
| 897 | +35x |
- #' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.+ tt, |
||
| 188 | -+ | |||
| 898 | +35x |
- #'+ indent_rownames = TRUE, |
||
| 189 | -+ | |||
| 899 | +35x |
- #' @examples+ fontspec = fontspec, |
||
| 190 | -+ | |||
| 900 | +35x |
- #' min_prune <- low_obs_pruner(70, "sum")+ col_gap = col_gap |
||
| 191 | +901 |
- #' tbl_to_prune %>% prune_table(min_prune)+ ), |
||
| 192 | -+ | |||
| 902 | +35x |
- #'+ fontspec = fontspec |
||
| 193 | +903 |
- #' @rdname trim_prune_funs+ ) |
||
| 194 | +904 |
- #' @export+ } |
||
| 195 | +905 |
- low_obs_pruner <- function(min, type = c("sum", "mean")) {
- |
- ||
| 196 | -3x | -
- type <- match.arg(type)+ |
||
| 197 | -3x | +906 | +52x |
- function(tt) {
+ if (!tf_wrap) {
|
| 198 | -21x | +907 | +42x |
- if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
+ if (!is.null(max_width)) {
|
| 199 | -9x | +|||
| 908 | +! |
- return(FALSE) ## only trimming on count content rows+ warning("tf_wrap is FALSE - ignoring non-null max_width value.")
|
||
| 200 | +909 |
} |
||
| 201 | -12x | -
- ctr <- tree_children(ctab)[[1]]- |
- ||
| 202 | -12x | +910 | +42x |
- vals <- sapply(row_values(ctr), function(v) v[[1]])+ max_width <- NULL |
| 203 | -12x | +911 | +10x |
- sumvals <- sum(vals)+ } else if (is.null(max_width)) {
|
| 204 | -12x | +912 | +5x |
- if (type == "mean") {
+ max_width <- cpp |
| 205 | -8x | +913 | +5x |
- sumvals <- sumvals / length(vals)+ } else if (identical(max_width, "auto")) {
|
| 206 | +914 |
- }+ ## XXX this 3 is column sep width!!!!!!! |
||
| 207 | -12x | +|||
| 915 | +! |
- sumvals < min+ max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1) |
||
| 208 | +916 |
} |
||
| 209 | -- |
- }- |
- ||
| 210 | -- | - - | -||
| 211 | -- |
- #' Recursively prune a `TableTree`- |
- ||
| 212 | -+ | |||
| 917 | +52x |
- #'+ if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
|
||
| 213 | -+ | |||
| 918 | +! |
- #' @inheritParams gen_args+ warning("max_width specified is wider than characters per page width (cpp).")
|
||
| 214 | +919 |
- #' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the+ } |
||
| 215 | +920 |
- #' entire subtree should be removed.+ |
||
| 216 | +921 |
- #' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.+ ## taken care of in vert_pag_indices now |
||
| 217 | +922 |
- #' Defaults to `NA` which indicates pruning should happen at all levels.+ ## if(!is.null(cpp)) |
||
| 218 | +923 |
- #' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.+ ## cpp <- cpp - table_inset(tt) |
||
| 219 | +924 |
- #'+ |
||
| 220 | -+ | |||
| 925 | +52x |
- #' @return A `TableTree` pruned via recursive application of `prune_func`.+ force_pag <- vapply(tree_children(tt), has_force_pag, TRUE) |
||
| 221 | -+ | |||
| 926 | +52x |
- #'+ if (has_force_pag(tt) || any(force_pag)) {
|
||
| 222 | -+ | |||
| 927 | +5x |
- #' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included+ spltabs <- do_forced_paginate(tt) |
||
| 223 | -+ | |||
| 928 | +5x |
- #' in the `rtables` package.+ spltabs <- unlist(spltabs, recursive = TRUE) |
||
| 224 | -+ | |||
| 929 | +5x |
- #'+ ret <- lapply(spltabs, paginate_table, |
||
| 225 | -+ | |||
| 930 | +5x |
- #' @examples+ lpp = lpp, |
||
| 226 | -+ | |||
| 931 | +5x |
- #' adsl <- ex_adsl+ cpp = cpp, |
||
| 227 | -+ | |||
| 932 | +5x |
- #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ min_siblings = min_siblings, |
||
| 228 | -+ | |||
| 933 | +5x |
- #'+ nosplitin = nosplitin, |
||
| 229 | -+ | |||
| 934 | +5x |
- #' tbl_to_prune <- basic_table() %>%+ colwidths = colwidths, |
||
| 230 | -+ | |||
| 935 | +5x |
- #' split_cols_by("ARM") %>%
+ tf_wrap = tf_wrap, |
||
| 231 | -+ | |||
| 936 | +5x |
- #' split_rows_by("SEX") %>%
+ max_width = max_width, |
||
| 232 | -+ | |||
| 937 | +5x |
- #' summarize_row_groups() %>%+ fontspec = fontspec, |
||
| 233 | -+ | |||
| 938 | +5x |
- #' split_rows_by("STRATA1") %>%
+ verbose = verbose, |
||
| 234 | -+ | |||
| 939 | +5x |
- #' summarize_row_groups() %>%+ col_gap = col_gap |
||
| 235 | +940 |
- #' analyze("AGE") %>%
+ ) |
||
| 236 | -+ | |||
| 941 | +5x |
- #' build_table(adsl)+ return(unlist(ret, recursive = TRUE)) |
||
| 237 | +942 |
- #'+ } |
||
| 238 | +943 |
- #' tbl_to_prune %>% prune_table()+ |
||
| 239 | -+ | |||
| 944 | +47x |
- #'+ inds <- paginate_indices(tt, |
||
| 240 | -+ | |||
| 945 | +47x |
- #' @export+ page_type = page_type, |
||
| 241 | -+ | |||
| 946 | +47x |
- prune_table <- function(tt,+ fontspec = fontspec, |
||
| 242 | +947 |
- prune_func = prune_empty_level,+ ## font_family = font_family, |
||
| 243 | +948 |
- stop_depth = NA_real_,+ ## font_size = font_size, |
||
| 244 | +949 |
- depth = 0) {
+ ## lineheight = lineheight, |
||
| 245 | -323x | -
- if (!is.na(stop_depth) && depth > stop_depth) {
- |
- ||
| 246 | -! | +950 | +47x |
- return(tt)+ landscape = landscape, |
| 247 | -+ | |||
| 951 | +47x |
- }+ pg_width = pg_width, |
||
| 248 | -323x | +952 | +47x |
- if (is(tt, "TableRow")) {
+ pg_height = pg_height, |
| 249 | -54x | +953 | +47x |
- if (prune_func(tt)) {
+ margins = margins, |
| 250 | -! | +|||
| 954 | +47x |
- tt <- NULL+ lpp = lpp, |
||
| 251 | -+ | |||
| 955 | +47x |
- }+ cpp = cpp, |
||
| 252 | -54x | +956 | +47x |
- return(tt)+ min_siblings = min_siblings, |
| 253 | -+ | |||
| 957 | +47x |
- }+ nosplitin = nosplitin, |
||
| 254 | -+ | |||
| 958 | +47x |
-
+ colwidths = colwidths, |
||
| 255 | -269x | +959 | +47x |
- kids <- tree_children(tt)+ tf_wrap = tf_wrap, |
| 256 | -+ | |||
| 960 | +47x |
-
+ max_width = max_width, |
||
| 257 | -269x | +961 | +47x |
- torm <- vapply(kids, function(tb) {
+ col_gap = col_gap, |
| 258 | -386x | +962 | +47x |
- !is.null(tb) && prune_func(tb)+ verbose = verbose |
| 259 | -269x | +963 | +47x |
- }, NA)+ ) ## paginate_table apparently doesn't accept indent_size |
| 260 | +964 | |||
| 261 | -269x | +965 | +42x |
- keepkids <- kids[!torm]+ res <- lapply( |
| 262 | -269x | +966 | +42x |
- keepkids <- lapply(keepkids, prune_table,+ inds$pag_row_indices, |
| 263 | -269x | +967 | +42x |
- prune_func = prune_func,+ function(ii) {
|
| 264 | -269x | +968 | +117x |
- stop_depth = stop_depth,+ subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE] |
| 265 | -269x | -
- depth = depth + 1- |
- ||
| 266 | -+ | 969 | +117x |
- )+ lapply( |
| 267 | -+ | |||
| 970 | +117x |
-
+ inds$pag_col_indices, |
||
| 268 | -269x | +971 | +117x |
- keepkids <- keepkids[!vapply(keepkids, is.null, NA)]+ function(jj) {
|
| 269 | -269x | +972 | +216x |
- if (length(keepkids) > 0) {
+ subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE] |
-
| 270 | -135x | +|||
| 973 | +
- tree_children(tt) <- keepkids+ } |
|||
| 271 | +974 |
- } else {
+ ) |
||
| 272 | -134x | +|||
| 975 | +
- tt <- NULL+ } |
|||
| 273 | +976 |
- }+ ) |
||
| 274 | -269x | +977 | +42x |
- tt+ res <- unlist(res, recursive = FALSE)+ |
+
| 978 | +42x | +
+ res |
||
| 275 | +979 |
}@@ -135999,14 +142873,14 @@ rtables coverage - 90.60% |
| 1 |
- #' Create an `ElementaryTable` from a `data.frame`+ #' Format `rcell` objects |
||
| 3 |
- #' @param df (`data.frame`)\cr a data frame.+ #' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects |
||
| 5 |
- #' @details+ #' @inheritParams lyt_args |
||
| 6 |
- #' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column+ #' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value. |
||
| 7 |
- #' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior+ #' @param format (`string` or `function`)\cr the format label or formatter function to |
||
| 8 |
- #' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.+ #' apply to `x`. |
||
| 9 |
- #'+ #' @param output (`string`)\cr output type. |
||
| 10 |
- #' @seealso [as_result_df()] for the inverse operation.+ #' @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 |
- #' @examples+ #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the |
||
| 13 |
- #' df_to_tt(mtcars)+ #' values with formats applied. Defaults to `FALSE`. |
||
| 15 |
- #' @export+ #' @return Formatted text. |
||
| 16 |
- df_to_tt <- function(df) {
+ #' |
||
| 17 | -4x | +
- colnms <- colnames(df)+ #' @examples |
|
| 18 | -4x | +
- cinfo <- manual_cols(colnms)+ #' cll <- CellValue(pi, format = "xx.xxx") |
|
| 19 | -4x | +
- rnames <- rownames(df)+ #' format_rcell(cll) |
|
| 20 | -4x | +
- havern <- !is.null(rnames)+ #' |
|
| 21 |
-
+ #' # Cell values precedes the row values |
||
| 22 | -4x | +
- if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
+ #' cll <- CellValue(pi, format = "xx.xxx") |
|
| 23 | -1x | +
- rnames <- df$label_name+ #' format_rcell(cll, pr_row_format = "xx.x") |
|
| 24 | -1x | +
- df <- df[, -match("label_name", colnms)]
+ #' |
|
| 25 | -1x | +
- colnms <- colnames(df)+ #' # Similarly for NA values |
|
| 26 | -1x | +
- cinfo <- manual_cols(colnms)+ #' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA") |
|
| 27 | -1x | +
- havern <- TRUE+ #' format_rcell(cll, pr_row_na_str = "This is NA") |
|
| 28 |
- }+ #' |
||
| 29 |
-
+ #' @export |
||
| 30 | -4x | +
- kids <- lapply(seq_len(nrow(df)), function(i) {
+ format_rcell <- function(x, format, |
|
| 31 | -124x | +
- rni <- if (havern) rnames[i] else ""+ output = c("ascii", "html"),
|
|
| 32 | -124x | +
- do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))+ na_str = obj_na_str(x) %||% "NA", |
|
| 33 |
- })+ pr_row_format = NULL, |
||
| 34 |
-
+ pr_row_na_str = NULL, |
||
| 35 | -4x | +
- ElementaryTable(kids = kids, cinfo = cinfo)+ shell = FALSE) {
|
|
| 36 | + |
+ # Check for format and parent row format+ |
+ |
| 37 | +108234x | +
+ format <- if (missing(format)) obj_format(x) else format+ |
+ |
| 38 | +108234x | +
+ if (is.null(format) && !is.null(pr_row_format)) {
+ |
+ |
| 39 | +75649x | +
+ format <- pr_row_format+ |
+ |
| 40 | ++ |
+ }+ |
+ |
| 41 | ++ |
+ # Check for na_str from parent+ |
+ |
| 42 | +108234x | +
+ if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
+ |
+ |
| 43 | +90260x | +
+ na_str <- pr_row_na_str+ |
+ |
| 44 | ++ |
+ }+ |
+ |
| 45 | ++ | + + | +|
| 46 | ++ |
+ # Main call to external function or shell+ |
+ |
| 47 | +108234x | +
+ if (shell) {
+ |
+ |
| 48 | +28342x | +
+ return(format)+ |
+ |
| 49 | ++ |
+ }+ |
+ |
| 50 | +79892x | +
+ format_value(rawvalues(x),+ |
+ |
| 51 | +79892x | +
+ format = format,+ |
+ |
| 52 | +79892x | +
+ output = output,+ |
+ |
| 53 | +79892x | +
+ na_str = na_str+ |
+ |
| 54 | ++ |
+ )+ |
+ |
| 55 | +
} |
@@ -136257,14 +143264,14 @@
| 1 |
- #' Find degenerate (sub)structures within a table+ #' Score functions for sorting `TableTrees` |
|||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @inheritParams gen_args |
|||
| 5 |
- #' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if+ #' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting. |
|||
| 6 |
- #' they have associated content rows).+ #' |
|||
| 7 |
- #'+ #' @export |
|||
| 8 |
- #' @param tt (`TableTree`)\cr a `TableTree` object.+ #' @rdname score_funs |
|||
| 9 |
- #'+ cont_n_allcols <- function(tt) {
|
|||
| 10 | -+ | 6x |
- #' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.+ ctab <- content_table(tt) |
|
| 11 | -+ | 6x |
- #'+ if (NROW(ctab) == 0) {
|
|
| 12 | -+ | 2x |
- #' @examples+ stop( |
|
| 13 | -+ | 2x |
- #' find_degen_struct(rtable("hi"))
+ "cont_n_allcols score function used at subtable [", |
|
| 14 | -+ | 2x |
- #'+ obj_name(tt), "] that has no content table." |
|
| 15 |
- #' @family table structure validation functions+ ) |
|||
| 16 |
- #' @export+ } |
|||
| 17 | -+ | 4x |
- find_degen_struct <- function(tt) {
+ sum(sapply( |
|
| 18 | -7x | +4x |
- degen <- list()+ row_values(tree_children(ctab)[[1]]), |
|
| 19 | -+ | 4x |
-
+ function(cv) cv[1] |
|
| 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) {
+ #' @param j (`numeric(1)`)\cr index of column used for scoring. |
||
| 24 | -69x | +
- degen <<- c(degen, list(path))+ #' |
||
| 25 |
- } else {
+ #' @seealso For examples and details, please read the documentation for [sort_at_path()] and the |
|||
| 26 | -34x | +
- for (i in seq_along(kids)) {
+ #' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html) |
||
| 27 | -96x | +
- recurse_check(kids[[i]], path = c(path, names(kids)[i]))+ #' vignette. |
||
| 28 |
- }+ #' |
|||
| 29 |
- }+ #' @export |
|||
| 30 |
- }+ #' @rdname score_funs |
|||
| 31 |
- }+ cont_n_onecol <- function(j) {
|
|||
| 32 | -7x | +2x |
- recurse_check(tt, obj_name(tt) %||% "root")+ function(tt) {
|
|
| 33 | -7x | +6x |
- degen+ ctab <- content_table(tt) |
|
| 34 | -+ | 6x |
- }+ if (NROW(ctab) == 0) {
|
|
| 35 | -+ | 2x |
-
+ stop( |
|
| 36 | -+ | 2x |
- #' Validate and assert valid table structure+ "cont_n_allcols score function used at subtable [", |
|
| 37 | -+ | 2x |
- #'+ obj_name(tt), "] that has no content table." |
|
| 38 |
- #' @description `r lifecycle::badge("experimental")`
+ ) |
|||
| 39 |
- #'+ } |
|||
| 40 | -+ | 4x |
- #' A `TableTree` (`rtables`-built table) is considered degenerate if:+ row_values(tree_children(ctab)[[1]])[[j]][1] |
|
| 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 |
- #' }+ #' Sorting a table at a specific path |
|||
| 46 |
- #' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.+ #' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree. |
|||
| 48 |
- #' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or+ #' @inheritParams gen_args |
|||
| 49 |
- #' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more+ #' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position |
|||
| 50 |
- #' invalid substructures.+ #' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value |
|||
| 51 |
- #'+ #' to be sorted. |
|||
| 52 |
- #' @param tt (`TableTree`)\cr a `TableTree` object.+ #' @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 |
- #' @return+ #' characters. |
|||
| 55 |
- #' * `validate_table_struct` returns a logical value indicating valid structure.+ #' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to |
|||
| 56 |
- #' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.+ #' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores |
|||
| 57 |
- #'+ #' should be placed in the order. |
|||
| 58 |
- #' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.+ #' @param .prev_path (`character`)\cr internal detail, do not set manually. |
|||
| 60 |
- #' @examples+ #' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done |
|||
| 61 |
- #' validate_table_struct(rtable("hahaha"))
+ #' at `path`. |
|||
| 62 |
- #' \dontrun{
+ #' |
|||
| 63 |
- #' assert_valid_table(rtable("oops"))
+ #' @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 |
- #' @family table structure validation functions+ #' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting |
|||
| 67 |
- #' @export+ #' operations. |
|||
| 68 |
- validate_table_struct <- function(tt) {
+ #' |
|||
| 69 | -1x | +
- degen_pths <- find_degen_struct(tt)+ #' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus |
||
| 70 | -1x | +
- length(degen_pths) == 0+ #' 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 |
- ## XXX this doesn't handle content paths correctly+ #' |
|||
| 74 |
- .path_to_disp <- function(pth) {
+ #' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means |
|||
| 75 | -2x | +
- if (length(pth) == 1) {
+ #' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This |
||
| 76 | -1x | +
- return(pth)+ #' can occur multiple times in a path. |
||
| 77 |
- }+ #' |
|||
| 78 | -1x | +
- has_cont <- any(pth == "@content")+ #' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by [make_row_df()] |
||
| 79 | -1x | +
- if (has_cont) {
+ #' with the `visible_only` argument set to `FALSE`. It can also be inferred from the summary given by |
||
| 80 | -! | +
- contpos <- which(pth == "@content")+ #' [table_structure()]. |
||
| 81 | -! | +
- cont_disp <- paste(tail(pth, length(pth) - contpos + 1),+ #' |
||
| 82 | -! | +
- collapse = "->"+ #' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related |
||
| 83 |
- )+ #' vignette |
|||
| 84 | -! | +
- pth <- head(pth, contpos)+ #' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)) |
||
| 85 |
- } else {
+ #' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also |
|||
| 86 | -1x | +
- cont_disp <- character()+ #' 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 | -1x | +
- topaste <- character(0)+ #' |
||
| 90 | -1x | +
- fullpth <- pth+ #' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows |
||
| 91 | -1x | +
- while (length(pth) > 0) {
+ #' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some |
||
| 92 | -2x | +
- if (length(pth) <= 1) {
+ #' useful descriptor and accessor functions (coming from related vignette): |
||
| 93 | -! | +
- topaste <- c(topaste, pth)+ #' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values. |
||
| 94 | -! | +
- pth <- character()+ #' - [obj_name()] - Retrieves the name of an object. Note this can differ from the label that is displayed (if any is) |
||
| 95 |
- } else {
+ #' when printing. |
|||
| 96 | -2x | +
- topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
+ #' - [obj_label()] - Retrieves the display label of an object. Note this can differ from the name that appears in the |
||
| 97 | -2x | +
- pth <- tail(pth, -2)+ #' 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 | -1x | +
- topaste <- c(topaste, cont_disp)+ #' thereof, though that should not happen in practice). |
||
| 101 | -1x | +
- paste(topaste, collapse = "->")+ #' |
||
| 102 |
- }+ #' @seealso |
|||
| 103 |
-
+ #' * Score functions [cont_n_allcols()] and [cont_n_onecol()]. |
|||
| 104 |
- no_analyze_guess <- paste0(+ #' * [make_row_df()] and [table_structure()] for pathing information. |
|||
| 105 |
- "Was this table created using ",+ #' * [tt_at_path()] to select a table's (sub)structure at a given path. |
|||
| 106 |
- "summarize_row_groups but no calls ",+ #' |
|||
| 107 |
- "to analyze?\n"+ #' @examples |
|||
| 108 |
- )+ #' # Creating a table to sort |
|||
| 109 |
-
+ #' |
|||
| 110 |
- use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
+ #' # Function that gives two statistics per table-tree "leaf" |
|||
| 111 |
-
+ #' more_analysis_fnc <- function(x) {
|
|||
| 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"+ #' in_rows( |
||
| 127 | +113 |
- )+ #' "median" = median(x), |
||
| 128 | +114 |
- }- |
- ||
| 129 | -2x | -
- msg <- paste(msg, use_sanitize_msg, sep = "\n")- |
- ||
| 130 | -2x | -
- msg+ #' "mean" = mean(x), |
||
| 131 | +115 |
- }+ #' .formats = "xx.x" |
||
| 132 | +116 |
-
+ #' ) |
||
| 133 | +117 |
- #' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.+ #' } |
||
| 134 | +118 |
#' |
||
| 135 | -- |
- #' @rdname validate_table_struct- |
- ||
| 136 | -- |
- #' @export- |
- ||
| 137 | +119 |
- 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)+ #' # Main layout of the table |
||
| 141 | +120 |
- }+ #' raw_lyt <- basic_table() %>% |
||
| 142 | +121 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 143 | +122 |
- ## we failed, now we build an informative error/warning message- |
- ||
| 144 | -2x | -
- msg <- make_degen_message(degen_pths, tt)+ #' split_rows_by( |
||
| 145 | +123 | - - | -||
| 146 | -2x | -
- if (!warn_only) {
- |
- ||
| 147 | -2x | -
- stop(msg)+ #' "RACE", |
||
| 148 | +124 |
- }- |
- ||
| 149 | -! | -
- warning(msg)- |
- ||
| 150 | -! | -
- return(FALSE)+ #' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
|
||
| 151 | +125 |
- }+ #' ) %>% |
||
| 152 | +126 |
-
+ #' summarize_row_groups() %>% |
||
| 153 | +127 |
- #' Sanitize degenerate table structures+ #' split_rows_by("STRATA1") %>%
|
||
| 154 | +128 |
- #'+ #' summarize_row_groups() %>% |
||
| 155 | +129 |
- #' @description `r lifecycle::badge("experimental")`
+ #' analyze("AGE", afun = more_analysis_fnc)
|
||
| 156 | +130 |
#' |
||
| 157 | -- |
- #' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.- |
- ||
| 158 | +131 |
- #'+ #' # Creating the table and pruning empty and NAs |
||
| 159 | +132 |
- #' @param tt (`TableTree`)\cr a `TableTree` object.+ #' tbl <- build_table(raw_lyt, DM) %>% |
||
| 160 | +133 |
- #' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.+ #' prune_table() |
||
| 161 | +134 |
#' |
||
| 162 | -- |
- #' @details- |
- ||
| 163 | -- |
- #' This function locates degenerate portions of the table (including the table overall in the case of a table with no- |
- ||
| 164 | +135 |
- #' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table+ #' # Peek at the table structure to understand how it is built |
||
| 165 | +136 |
- #' guaranteed to be non-degenerate.+ #' table_structure(tbl) |
||
| 166 | +137 |
#' |
||
| 167 | -- |
- #' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate- |
- ||
| 168 | +138 |
- #' version of the table is returned.+ #' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for |
||
| 169 | +139 |
- #'+ #' # the ASIAN group/row-split. This uses content_table() accessor function as it |
||
| 170 | +140 |
- #' @examples+ #' # is a "ContentRow". In this case, we also base our sorting only on the second column. |
||
| 171 | +141 |
- #' sanitize_table_struct(rtable("cool beans"))
+ #' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
|
||
| 172 | +142 |
#' |
||
| 173 | -- |
- #' lyt <- basic_table() %>%- |
- ||
| 174 | -- |
- #' split_cols_by("ARM") %>%
- |
- ||
| 175 | +143 |
- #' split_rows_by("SEX") %>%
+ #' # Custom scoring function that is working on "DataRow"s |
||
| 176 | +144 |
- #' summarize_row_groups()+ #' scorefun <- function(tt) {
|
||
| 177 | +145 |
- #'+ #' # Here we could use browser() |
||
| 178 | +146 |
- #' ## Degenerate because it doesn't have any analyze calls -> no data rows+ #' sum(unlist(row_values(tt))) # Different accessor function |
||
| 179 | +147 |
- #' badtab <- build_table(lyt, DM)+ #' } |
||
| 180 | +148 |
- #' sanitize_table_struct(badtab)+ #' # Sorting mean and median for all the AGE leaves! |
||
| 181 | +149 |
- #'+ #' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
|
||
| 182 | +150 |
- #' @family table structure validation functions+ #' |
||
| 183 | +151 |
#' @export |
||
| 184 | +152 |
- sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
+ sort_at_path <- function(tt, |
||
| 185 | -4x | +|||
| 153 | +
- rdf <- make_row_df(tt)+ path, |
|||
| 186 | +154 |
-
+ scorefun, |
||
| 187 | -4x | +|||
| 155 | +
- emptyrow <- DataRow(+ decreasing = NA, |
|||
| 188 | -4x | +|||
| 156 | +
- vals = list(empty_msg),+ na.pos = c("omit", "last", "first"),
|
|||
| 189 | -4x | +|||
| 157 | +
- name = "empty_section",+ .prev_path = character()) {
|
|||
| 190 | -4x | +158 | +35x |
- label = "",+ if (NROW(tt) == 0) {
|
| 191 | -4x | +159 | +1x |
- cspan = ncol(tt),+ return(tt) |
| 192 | -4x | +|||
| 160 | +
- cinfo = col_info(tt),+ } |
|||
| 193 | -4x | +|||
| 161 | +
- format = "xx",+ |
|||
| 194 | -4x | +|||
| 162 | +
- table_inset = table_inset(tt)+ ## XXX hacky fix this!!! |
|||
| 195 | +163 |
- )+ ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior |
||
| 196 | -4x | +164 | +34x |
- degen_pths <- find_degen_struct(tt)+ if (path[1] == "root") {
|
| 197 | +165 |
-
+ ## always remove first root element but only add it to |
||
| 198 | -4x | +|||
| 166 | +
- if (identical(degen_pths, list("root"))) {
+ ## .prev_path (used for error reporting) if it actually matched the name |
|||
| 199 | -2x | +167 | +1x |
- tree_children(tt) <- list(empty_row = emptyrow)+ if (obj_name(tt) == "root") {
|
| 200 | -2x | -
- return(tt)- |
- ||
| 201 | -+ | 168 | +1x |
- }+ .prev_path <- c(.prev_path, path[1]) |
| 202 | +169 |
-
+ } |
||
| 203 | -2x | +170 | +1x |
- for (pth in degen_pths) {
+ path <- path[-1] |
| 204 | +171 |
- ## FIXME this shouldn't be necessary. why is it?+ } |
||
| 205 | -33x | +172 | +34x |
- tti <- tt_at_path(tt, path = pth)+ if (identical(obj_name(tt), path[1])) {
|
| 206 | -33x | +173 | +1x |
- tree_children(tti) <- list(empty_section = emptyrow)+ .prev_path <- c(.prev_path, path[1]) |
| 207 | -33x | +174 | +1x |
- tt_at_path(tt, path = pth) <- tti+ path <- path[-1] |
| 208 | +175 |
} |
||
| 209 | -2x | -
- tt- |
- ||
| 210 | -- |
- }- |
-
| 1 | +176 |
- #' Change indentation of all `rrows` in an `rtable`+ |
||
| 2 | -+ | |||
| 177 | +34x |
- #'+ curpath <- path |
||
| 3 | -+ | |||
| 178 | +34x |
- #' Change indentation of all `rrows` in an `rtable`+ subtree <- tt |
||
| 4 | -+ | |||
| 179 | +34x |
- #'+ backpath <- c() |
||
| 5 | -+ | |||
| 180 | +34x |
- #' @param x (`VTableTree`)\cr an `rtable` object.+ count <- 0 |
||
| 6 | -+ | |||
| 181 | +34x |
- #' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is+ while (length(curpath) > 0) {
|
||
| 7 | -+ | |||
| 182 | +40x |
- #' less than 0, the indentation is set to 0.+ curname <- curpath[1] |
||
| 8 | -+ | |||
| 183 | +40x |
- #'+ oldkids <- tree_children(subtree) |
||
| 9 | +184 |
- #' @return `x` with its indent modifier incremented by `by`.+ ## we sort each child separately based on the score function |
||
| 10 | +185 |
- #'+ ## and the remaining path |
||
| 11 | -+ | |||
| 186 | +40x |
- #' @examples+ if (curname == "*") {
|
||
| 12 | -+ | |||
| 187 | +7x |
- #' is_setosa <- iris$Species == "setosa"+ oldnames <- vapply(oldkids, obj_name, "") |
||
| 13 | -+ | |||
| 188 | +7x |
- #' m_tbl <- rtable(+ newkids <- lapply( |
||
| 14 | -+ | |||
| 189 | +7x |
- #' header = rheader(+ seq_along(oldkids), |
||
| 15 | -+ | |||
| 190 | +7x |
- #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ function(i) {
|
||
| 16 | -+ | |||
| 191 | +27x |
- #' rrow(NULL, "mean", "median", "mean", "median")+ sort_at_path(oldkids[[i]], |
||
| 17 | -+ | |||
| 192 | +27x |
- #' ),+ path = curpath[-1], |
||
| 18 | -+ | |||
| 193 | +27x |
- #' rrow(+ scorefun = scorefun, |
||
| 19 | -+ | |||
| 194 | +27x |
- #' row.name = "All Species",+ decreasing = decreasing, |
||
| 20 | -+ | |||
| 195 | +27x |
- #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ na.pos = na.pos, |
||
| 21 | +196 |
- #' mean(iris$Petal.Length), median(iris$Petal.Length),+ ## its ok to modify the "path" here because its only ever used for |
||
| 22 | +197 |
- #' format = "xx.xx"+ ## informative error reporting. |
||
| 23 | -+ | |||
| 198 | +27x |
- #' ),+ .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
|
||
| 24 | +199 |
- #' rrow(+ ) |
||
| 25 | +200 |
- #' row.name = "Setosa",+ } |
||
| 26 | +201 |
- #' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),+ ) |
||
| 27 | -+ | |||
| 202 | +4x |
- #' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),+ names(newkids) <- oldnames |
||
| 28 | -+ | |||
| 203 | +4x |
- #' format = "xx.xx"+ newtab <- subtree |
||
| 29 | -+ | |||
| 204 | +4x |
- #' )+ tree_children(newtab) <- newkids |
||
| 30 | -+ | |||
| 205 | +4x |
- #' )+ if (length(backpath) > 0) {
|
||
| 31 | -+ | |||
| 206 | +3x |
- #' indent(m_tbl)+ ret <- recursive_replace(tt, backpath, value = newtab) |
||
| 32 | +207 |
- #' indent(m_tbl, 2)+ } else {
|
||
| 33 | -+ | |||
| 208 | +1x |
- #'+ ret <- newtab |
||
| 34 | +209 |
- #' @export+ } |
||
| 35 | -+ | |||
| 210 | +4x |
- indent <- function(x, by = 1) {
+ return(ret) |
||
| 36 | -9x | +211 | +33x |
- if (nrow(x) == 0 || by == 0) {
+ } else if (!(curname %in% names(oldkids))) {
|
| 37 | -9x | +212 | +1x |
- return(x)+ stop( |
| 38 | -+ | |||
| 213 | +1x |
- }+ "Unable to find child(ren) '", |
||
| 39 | -+ | |||
| 214 | +1x |
-
+ curname, "'\n\t occurred at path: ", |
||
| 40 | -! | +|||
| 215 | +1x |
- indent_mod(x) <- indent_mod(x) + by+ paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "), |
||
| 41 | -! | +|||
| 216 | +1x |
- x+ "\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n", |
||
| 42 | -+ | |||
| 217 | +1x |
- }+ "'table_structure(obj)' to explore valid paths." |
||
| 43 | +218 |
-
+ ) |
||
| 44 | +219 |
- #' Clear all indent modifiers from a table+ } |
||
| 45 | -+ | |||
| 220 | +32x |
- #'+ subtree <- tree_children(subtree)[[curname]] |
||
| 46 | -+ | |||
| 221 | +32x |
- #' @inheritParams gen_args+ backpath <- c(backpath, curpath[1]) |
||
| 47 | -+ | |||
| 222 | +32x |
- #'+ curpath <- curpath[-1] |
||
| 48 | -+ | |||
| 223 | +32x |
- #' @return The same class as `tt`, with all indent modifiers set to zero.+ count <- count + 1 |
||
| 49 | +224 |
- #'+ } |
||
| 50 | -+ | |||
| 225 | +26x |
- #' @examples+ real_backpath <- path[seq_len(count)] |
||
| 51 | +226 |
- #' lyt1 <- basic_table() %>%+ |
||
| 52 | -+ | |||
| 227 | +26x |
- #' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
+ na.pos <- match.arg(na.pos) |
||
| 53 | +228 |
- #' split_rows_by("AEBODSYS", child_labels = "visible") %>%
+ ## subtree <- tt_at_path(tt, path) |
||
| 54 | -+ | |||
| 229 | +26x |
- #' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
+ kids <- tree_children(subtree) |
||
| 55 | +230 |
- #' analyze("AGE", indent_mod = -1L)
+ ## relax this to allow character "scores" |
||
| 56 | +231 |
- #'+ ## scores <- vapply(kids, scorefun, NA_real_) |
||
| 57 | -+ | |||
| 232 | +26x |
- #' tbl1 <- build_table(lyt1, ex_adae)+ scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e)) |
||
| 58 | -+ | |||
| 233 | +26x |
- #' tbl1+ errs <- which(vapply(scores, is, class2 = "error", TRUE)) |
||
| 59 | -+ | |||
| 234 | +26x |
- #' clear_indent_mods(tbl1)+ if (length(errs) > 0) {
|
||
| 60 | -+ | |||
| 235 | +2x |
- #'+ stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
|
||
| 61 | -+ | |||
| 236 | +2x |
- #' @export+ "First error: ", scores[[errs[1]]]$message, |
||
| 62 | -+ | |||
| 237 | +2x |
- #' @rdname clear_imods+ "\n\toccurred at path: ", |
||
| 63 | -40x | +238 | +2x |
- setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
+ paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "), |
| 64 | -+ | |||
| 239 | +2x |
-
+ call. = FALSE |
||
| 65 | +240 |
- #' @export+ ) |
||
| 66 | +241 |
- #' @rdname clear_imods+ } else {
|
||
| 67 | -+ | |||
| 242 | +24x |
- setMethod(+ scores <- unlist(scores) |
||
| 68 | +243 |
- "clear_indent_mods", "VTableTree",+ } |
||
| 69 | -+ | |||
| 244 | +24x |
- function(tt) {
+ if (!is.null(dim(scores)) || length(scores) != length(kids)) {
|
||
| 70 | -25x | +|||
| 245 | +! |
- ct <- content_table(tt)+ stop( |
||
| 71 | -25x | +|||
| 246 | +! |
- if (!is.null(ct)) {
+ "Score function does not appear to have return exactly one ", |
||
| 72 | -9x | +|||
| 247 | +! |
- content_table(tt) <- clear_indent_mods(ct)+ "scalar value per child" |
||
| 73 | +248 |
- }+ ) |
||
| 74 | -25x | +|||
| 249 | +
- tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)+ } |
|||
| 75 | -25x | +250 | +24x |
- indent_mod(tt) <- 0L+ if (is.na(decreasing)) {
|
| 76 | -25x | +251 | +8x |
- tt+ decreasing <- if (is.character(scores)) FALSE else TRUE |
| 77 | +252 |
} |
||
| 78 | -+ | |||
| 253 | +24x |
- )+ ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing) |
||
| 79 | -+ | |||
| 254 | +24x |
-
+ newkids <- kids[ord] |
||
| 80 | -+ | |||
| 255 | +24x |
- #' @export+ if (anyNA(scores) && na.pos == "omit") { # we did na last here
|
||
| 81 | -+ | |||
| 256 | +! |
- #' @rdname clear_imods+ newkids <- head(newkids, -1 * sum(is.na(scores))) |
||
| 82 | +257 |
- setMethod(+ } |
||
| 83 | +258 |
- "clear_indent_mods", "TableRow",+ |
||
| 84 | -+ | |||
| 259 | +24x |
- function(tt) {
+ newtree <- subtree |
||
| 85 | -15x | +260 | +24x |
- indent_mod(tt) <- 0L+ tree_children(newtree) <- newkids |
| 86 | -15x | +261 | +24x |
- tt+ tt_at_path(tt, path) <- newtree |
| 87 | -+ | |||
| 262 | +24x |
- }+ tt |
||
| 88 | +263 |
- )+ } |
| 1 |
- #' Score functions for sorting `TableTrees`+ #' Find degenerate (sub)structures within a table |
||
| 3 |
- #' @inheritParams gen_args+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.+ #' 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 |
- #' @export+ #' |
||
| 8 |
- #' @rdname score_funs+ #' @param tt (`TableTree`)\cr a `TableTree` object. |
||
| 9 |
- cont_n_allcols <- function(tt) {
+ #' |
||
| 10 | -6x | +
- ctab <- content_table(tt)+ #' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table. |
|
| 11 | -6x | +
- if (NROW(ctab) == 0) {
+ #' |
|
| 12 | -2x | +
- stop(+ #' @examples |
|
| 13 | -2x | +
- "cont_n_allcols score function used at subtable [",+ #' find_degen_struct(rtable("hi"))
|
|
| 14 | -2x | +
- obj_name(tt), "] that has no content table."+ #' |
|
| 15 |
- )+ #' @family table structure validation functions |
||
| 16 |
- }+ #' @export |
||
| 17 | -4x | +
- sum(sapply(+ find_degen_struct <- function(tt) {
|
|
| 18 | -4x | +7x |
- row_values(tree_children(ctab)[[1]]),+ degen <- list() |
| 19 | -4x | +
- function(cv) cv[1]+ |
|
| 20 | -+ | 7x |
- ))+ recurse_check <- function(tti, path) {
|
| 21 | -+ | 103x |
- }+ if (is(tti, "VTableTree")) {
|
| 22 | -+ | 103x |
-
+ kids <- tree_children(tti) |
| 23 | -+ | 103x |
- #' @param j (`numeric(1)`)\cr index of column used for scoring.+ if (length(kids) == 0) {
|
| 24 | -+ | 69x |
- #'+ degen <<- c(degen, list(path)) |
| 25 |
- #' @seealso For examples and details, please read the documentation for [sort_at_path()] and the+ } else {
|
||
| 26 | -+ | 34x |
- #' [Sorting and Pruning](https://insightsengineering.github.io/rtables/main/articles/sorting_pruning.html) vignette.+ for (i in seq_along(kids)) {
|
| 27 | -+ | 96x |
- #'+ recurse_check(kids[[i]], path = c(path, names(kids)[i])) |
| 28 |
- #' @export+ } |
||
| 29 |
- #' @rdname score_funs+ } |
||
| 30 |
- cont_n_onecol <- function(j) {
+ } |
||
| 31 | -2x | +
- function(tt) {
+ } |
|
| 32 | -6x | +7x |
- ctab <- content_table(tt)+ recurse_check(tt, obj_name(tt) %||% "root") |
| 33 | -6x | +7x |
- if (NROW(ctab) == 0) {
+ degen |
| 34 | -2x | +
- stop(+ } |
|
| 35 | -2x | +
- "cont_n_allcols score function used at subtable [",+ |
|
| 36 | -2x | +
- obj_name(tt), "] that has no content table."+ #' Validate and assert valid table structure |
|
| 37 |
- )+ #' |
||
| 38 |
- }+ #' @description `r lifecycle::badge("experimental")`
|
||
| 39 | -4x | +
- row_values(tree_children(ctab)[[1]])[[j]][1]+ #' |
|
| 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 |
- #' Sorting a table at a specific path+ #' \item{It contains a subtable which is degenerate by the criterion above.}
|
||
| 44 |
- #'+ #' } |
||
| 45 |
- #' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.+ #' |
||
| 46 |
- #'+ #' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure. |
||
| 47 |
- #' @inheritParams gen_args+ #' |
||
| 48 |
- #' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position+ #' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or |
||
| 49 |
- #' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value+ #' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more |
||
| 50 |
- #' to be sorted.+ #' invalid substructures. |
||
| 51 |
- #' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If+ #' |
||
| 52 |
- #' unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are+ #' @param tt (`TableTree`)\cr a `TableTree` object. |
||
| 53 |
- #' characters.+ #' |
||
| 54 |
- #' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to+ #' @return |
||
| 55 |
- #' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores+ #' * `validate_table_struct` returns a logical value indicating valid structure. |
||
| 56 |
- #' should be placed in the order.+ #' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables. |
||
| 57 |
- #' @param .prev_path (`character`)\cr internal detail, do not set manually.+ #' |
||
| 58 |
- #'+ #' @note This function is experimental and the exact text of the warning/error is subject to change in future releases. |
||
| 59 |
- #' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done+ #' |
||
| 60 |
- #' at `path`.+ #' @examples |
||
| 61 |
- #'+ #' validate_table_struct(rtable("hahaha"))
|
||
| 62 |
- #' @details+ #' \dontrun{
|
||
| 63 |
- #' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"`+ #' assert_valid_table(rtable("oops"))
|
||
| 64 |
- #' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting+ #' } |
||
| 65 |
- #' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting+ #' |
||
| 66 |
- #' operations.+ #' @family table structure validation functions |
||
| 67 |
- #'+ #' @export |
||
| 68 |
- #' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus+ validate_table_struct <- function(tt) {
|
||
| 69 | -+ | 1x |
- #' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper+ degen_pths <- find_degen_struct(tt) |
| 70 | -+ | 1x |
- #' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare+ length(degen_pths) == 0 |
| 71 |
- #' it, which we encourage users to avoid.+ } |
||
| 72 |
- #'+ |
||
| 73 |
- #' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means+ ## XXX this doesn't handle content paths correctly |
||
| 74 |
- #' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This+ .path_to_disp <- function(pth) {
|
||
| 75 | -+ | 4x |
- #' can occur multiple times in a path.+ if (length(pth) == 1) {
|
| 76 | -+ | 1x |
- #'+ return(pth) |
| 77 |
- #' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by [make_row_df()]+ } |
||
| 78 | -+ | 3x |
- #' with the `visible_only` argument set to `FALSE`. It can also be inferred from the summary given by+ has_cont <- any(pth == "@content") |
| 79 | -+ | 3x |
- #' [table_structure()].+ if (has_cont) {
|
| 80 | -+ | ! |
- #'+ contpos <- which(pth == "@content") |
| 81 | -+ | ! |
- #' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related+ cont_disp <- paste(tail(pth, length(pth) - contpos + 1), |
| 82 | -+ | ! |
- #' vignette ([Sorting and Pruning](https://insightsengineering.github.io/rtables/main/articles/sorting_pruning.html))+ collapse = "->" |
| 83 |
- #' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also+ ) |
||
| 84 | -+ | ! |
- #' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and+ pth <- head(pth, contpos) |
| 85 |
- #' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is+ } else {
|
||
| 86 | -+ | 3x |
- #' commonly produced by calling one of the various [analyze()] instances.+ cont_disp <- character() |
| 87 |
- #'+ } |
||
| 88 |
- #' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows+ |
||
| 89 | -+ | 3x |
- #' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some+ topaste <- character(0) |
| 90 | -+ | 3x |
- #' useful descriptor and accessor functions (coming from related vignette):+ fullpth <- pth |
| 91 | -+ | 3x |
- #' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.+ while (length(pth) > 0) {
|
| 92 | -+ | 6x |
- #' - [obj_name()] - Retrieves the name of an object. Note this can differ from the label that is displayed (if any is)+ if (length(pth) <= 1) {
|
| 93 | -+ | ! |
- #' when printing.+ topaste <- c(topaste, pth) |
| 94 | -+ | ! |
- #' - [obj_label()] - Retrieves the display label of an object. Note this can differ from the name that appears in the+ pth <- character() |
| 95 |
- #' path.+ } else {
|
||
| 96 | -+ | 6x |
- #' - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).+ topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
|
| 97 | -+ | 6x |
- #' - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix+ pth <- tail(pth, -2) |
| 98 |
- #' thereof, though that should not happen in practice).+ } |
||
| 99 |
- #'+ } |
||
| 100 | -+ | 3x |
- #' @seealso+ topaste <- c(topaste, cont_disp) |
| 101 | -+ | 3x |
- #' * Score functions [cont_n_allcols()] and [cont_n_onecol()].+ paste(topaste, collapse = "->") |
| 102 |
- #' * [make_row_df()] and [table_structure()] for pathing information.+ } |
||
| 103 |
- #' * [tt_at_path()] to select a table's (sub)structure at a given path.+ |
||
| 104 |
- #'+ no_analyze_guess <- paste0( |
||
| 105 |
- #' @examples+ "Was this table created using ", |
||
| 106 |
- #' # Creating a table to sort+ "summarize_row_groups but no calls ", |
||
| 107 |
- #'+ "to analyze?\n" |
||
| 108 |
- #' # Function that gives two statistics per table-tree "leaf"+ ) |
||
| 109 |
- #' more_analysis_fnc <- function(x) {
+
|
||
| 110 |
- #' in_rows(+ use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
|
||
| 111 |
- #' "median" = median(x),+ |
||
| 112 |
- #' "mean" = mean(x),+ make_degen_message <- function(degen_pths, tt) {
|
||
| 113 | -+ | 2x |
- #' .formats = "xx.x"+ 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 |
- #' # Main layout of the table+ ), |
||
| 118 | -+ | 2x |
- #' raw_lyt <- basic_table() %>%+ length(degen_pths), .path_to_disp(degen_pths[[1]]) |
| 119 |
- #' split_cols_by("ARM") %>%
+ ) |
||
| 120 | -+ | 2x |
- #' split_rows_by(+ if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
|
| 121 | -+ | 1x |
- #' "RACE",+ msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values", |
| 122 | -+ | 1x |
- #' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
+ sep = "\n" |
| 123 |
- #' ) %>%+ ) |
||
| 124 | -+ | 1x |
- #' summarize_row_groups() %>%+ } else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
|
| 125 | -+ | 1x |
- #' split_rows_by("STRATA1") %>%
+ msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())", |
| 126 | -+ | 1x |
- #' summarize_row_groups() %>%+ sep = "\n" |
| 127 |
- #' analyze("AGE", afun = more_analysis_fnc)
+ ) |
||
| 128 |
- #'+ } |
||
| 129 | -+ | 2x |
- #' # Creating the table and pruning empty and NAs+ msg <- paste(msg, use_sanitize_msg, sep = "\n") |
| 130 | -+ | 2x |
- #' tbl <- build_table(raw_lyt, DM) %>%+ msg |
| 131 |
- #' prune_table()+ } |
||
| 132 |
- #'+ |
||
| 133 |
- #' # Peek at the table structure to understand how it is built+ #' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`. |
||
| 134 |
- #' table_structure(tbl)+ #' |
||
| 135 |
- #'+ #' @rdname validate_table_struct |
||
| 136 |
- #' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for+ #' @export |
||
| 137 |
- #' # the ASIAN group/row-split. This uses content_table() accessor function as it+ assert_valid_table <- function(tt, warn_only = FALSE) {
|
||
| 138 | -+ | 2x |
- #' # is a "ContentRow". In this case, we also base our sorting only on the second column.+ degen_pths <- find_degen_struct(tt) |
| 139 | -+ | 2x |
- #' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
+ if (length(degen_pths) == 0) {
|
| 140 | -+ | ! |
- #'+ return(TRUE) |
| 141 |
- #' # Custom scoring function that is working on "DataRow"s+ } |
||
| 142 |
- #' scorefun <- function(tt) {
+
|
||
| 143 |
- #' # Here we could use browser()+ ## we failed, now we build an informative error/warning message |
||
| 144 | -+ | 2x |
- #' sum(unlist(row_values(tt))) # Different accessor function+ msg <- make_degen_message(degen_pths, tt) |
| 145 |
- #' }+ |
||
| 146 | -+ | 2x |
- #' # Sorting mean and median for all the AGE leaves!+ if (!warn_only) {
|
| 147 | -+ | 2x |
- #' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
+ stop(msg) |
| 148 |
- #'+ } |
||
| 149 | -+ | ! |
- #' @export+ warning(msg) |
| 150 | -+ | ! |
- sort_at_path <- function(tt,+ return(FALSE) |
| 151 |
- path,+ } |
||
| 152 |
- scorefun,+ |
||
| 153 |
- decreasing = NA,+ #' Sanitize degenerate table structures |
||
| 154 |
- na.pos = c("omit", "last", "first"),
+ #' |
||
| 155 |
- .prev_path = character()) {
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 156 | -35x | +
- if (NROW(tt) == 0) {
+ #' |
|
| 157 | -1x | +
- return(tt)+ #' 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 |
- ## XXX hacky fix this!!!+ #' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows. |
||
| 161 |
- ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior+ #' |
||
| 162 | -34x | +
- if (path[1] == "root") {
+ #' @details |
|
| 163 |
- ## always remove first root element but only add it to+ #' This function locates degenerate portions of the table (including the table overall in the case of a table with no |
||
| 164 |
- ## .prev_path (used for error reporting) if it actually matched the name+ #' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table |
||
| 165 | -1x | +
- if (obj_name(tt) == "root") {
+ #' guaranteed to be non-degenerate. |
|
| 166 | -1x | +
- .prev_path <- c(.prev_path, path[1])+ #' |
|
| 167 |
- }+ #' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate |
||
| 168 | -1x | +
- path <- path[-1]+ #' version of the table is returned. |
|
| 169 |
- }+ #' |
||
| 170 | -34x | +
- if (identical(obj_name(tt), path[1])) {
+ #' @examples |
|
| 171 | -1x | +
- .prev_path <- c(.prev_path, path[1])+ #' sanitize_table_struct(rtable("cool beans"))
|
|
| 172 | -1x | +
- path <- path[-1]+ #' |
|
| 173 |
- }+ #' lyt <- basic_table() %>% |
||
| 174 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 175 | -34x | +
- curpath <- path+ #' split_rows_by("SEX") %>%
|
|
| 176 | -34x | +
- subtree <- tt+ #' summarize_row_groups() |
|
| 177 | -34x | +
- backpath <- c()+ #' |
|
| 178 | -34x | +
- count <- 0+ #' ## Degenerate because it doesn't have any analyze calls -> no data rows |
|
| 179 | -34x | +
- while (length(curpath) > 0) {
+ #' badtab <- build_table(lyt, DM) |
|
| 180 | -40x | +
- curname <- curpath[1]+ #' sanitize_table_struct(badtab) |
|
| 181 | -40x | +
- oldkids <- tree_children(subtree)+ #' |
|
| 182 |
- ## we sort each child separately based on the score function+ #' @family table structure validation functions |
||
| 183 |
- ## and the remaining path+ #' @export |
||
| 184 | -40x | +
- if (curname == "*") {
+ sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
|
|
| 185 | -7x | +4x |
- oldnames <- vapply(oldkids, obj_name, "")+ rdf <- make_row_df(tt) |
| 186 | -7x | +
- newkids <- lapply(+ |
|
| 187 | -7x | +4x |
- seq_along(oldkids),+ emptyrow <- DataRow( |
| 188 | -7x | +4x |
- function(i) {
+ vals = list(empty_msg), |
| 189 | -27x | +4x |
- sort_at_path(oldkids[[i]],+ name = "empty_section", |
| 190 | -27x | +4x |
- path = curpath[-1],+ label = "", |
| 191 | -27x | +4x |
- scorefun = scorefun,+ cspan = ncol(tt), |
| 192 | -27x | +4x |
- decreasing = decreasing,+ cinfo = col_info(tt), |
| 193 | -27x | +4x |
- na.pos = na.pos,+ format = "xx", |
| 194 | -+ | 4x |
- ## its ok to modify the "path" here because its only ever used for+ table_inset = table_inset(tt) |
| 195 |
- ## informative error reporting.+ ) |
||
| 196 | -27x | +4x |
- .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
+ 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 | -4x | +2x |
- names(newkids) <- oldnames+ return(tt) |
| 201 | -4x | +
- newtab <- subtree+ } |
|
| 202 | -4x | +
- tree_children(newtab) <- newkids+ |
|
| 203 | -4x | +2x |
- if (length(backpath) > 0) {
+ for (pth in degen_pths) {
|
| 204 | -3x | +
- ret <- recursive_replace(tt, backpath, value = newtab)+ ## FIXME this shouldn't be necessary. why is it? |
|
| 205 | -+ | 33x |
- } else {
+ tti <- tt_at_path(tt, path = pth) |
| 206 | -1x | +33x |
- ret <- newtab+ tree_children(tti) <- list(empty_section = emptyrow) |
| 207 | -+ | 33x |
- }+ tt_at_path(tt, path = pth) <- tti |
| 208 | -4x | +
- return(ret)+ } |
|
| 209 | -33x | +2x |
- } else if (!(curname %in% names(oldkids))) {
+ tt |
| 210 | -1x | +
- stop(+ } |
|
| 211 | -1x | +
| 1 | +
- "Unable to find child(ren) '",+ #' Trimming and pruning criteria |
|||
| 212 | -1x | +|||
| 2 | +
- curname, "'\n\t occurred at path: ",+ #' |
|||
| 213 | -1x | +|||
| 3 | +
- paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),+ #' Criteria functions (and constructors thereof) for trimming and pruning tables. |
|||
| 214 | -1x | +|||
| 4 | +
- "\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",+ #' |
|||
| 215 | -1x | +|||
| 5 | +
- "'table_structure(obj)' to explore valid paths."+ #' @inheritParams gen_args |
|||
| 216 | +6 |
- )+ #' |
||
| 217 | +7 |
- }+ #' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning. |
||
| 218 | -32x | +|||
| 8 | +
- subtree <- tree_children(subtree)[[curname]]+ #' |
|||
| 219 | -32x | +|||
| 9 | +
- backpath <- c(backpath, curpath[1])+ #' @seealso [prune_table()], [trim_rows()] |
|||
| 220 | -32x | +|||
| 10 | +
- curpath <- curpath[-1]+ #' |
|||
| 221 | -32x | +|||
| 11 | +
- count <- count + 1+ #' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`* |
|||
| 222 | +12 |
- }+ #' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values. |
||
| 223 | -26x | +|||
| 13 | +
- real_backpath <- path[seq_len(count)]+ #' |
|||
| 224 | +14 |
-
+ #' @examples |
||
| 225 | -26x | +|||
| 15 | +
- na.pos <- match.arg(na.pos)+ #' adsl <- ex_adsl |
|||
| 226 | +16 |
- ## subtree <- tt_at_path(tt, path)+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
||
| 227 | -26x | +|||
| 17 | +
- kids <- tree_children(subtree)+ #' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0 |
|||
| 228 | +18 |
- ## relax this to allow character "scores"+ #' adsl$BMRKR1 <- 0 |
||
| 229 | +19 |
- ## scores <- vapply(kids, scorefun, NA_real_)+ #' |
||
| 230 | -26x | +|||
| 20 | +
- scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e))+ #' tbl_to_prune <- basic_table() %>% |
|||
| 231 | -26x | +|||
| 21 | +
- errs <- which(vapply(scores, is, class2 = "error", TRUE))+ #' analyze("BMRKR1") %>%
|
|||
| 232 | -26x | +|||
| 22 | +
- if (length(errs) > 0) {
+ #' split_cols_by("ARM") %>%
|
|||
| 233 | -2x | +|||
| 23 | +
- stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
+ #' split_rows_by("SEX") %>%
|
|||
| 234 | -2x | +|||
| 24 | +
- "First error: ", scores[[errs[1]]]$message,+ #' summarize_row_groups() %>% |
|||
| 235 | -2x | +|||
| 25 | +
- "\n\toccurred at path: ",+ #' split_rows_by("STRATA1") %>%
|
|||
| 236 | -2x | +|||
| 26 | +
- paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),+ #' summarize_row_groups() %>% |
|||
| 237 | -2x | +|||
| 27 | +
- call. = FALSE+ #' analyze("AGE") %>%
|
|||
| 238 | +28 |
- )+ #' build_table(adsl) |
||
| 239 | +29 |
- } else {
+ #'+ |
+ ||
| 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) {
|
||
| 240 | -24x | +35 | +347x |
- scores <- unlist(scores)+ if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ |
+
| 36 | +93x | +
+ return(FALSE) |
||
| 241 | +37 |
} |
||
| 242 | -24x | +38 | +254x |
- if (!is.null(dim(scores)) || length(scores) != length(kids)) {
+ rvs <- unlist(unname(row_values(tr))) |
| 243 | -! | +|||
| 39 | +254x |
- stop(+ all(is.na(rvs) | rvs == 0 | !is.finite(rvs)) |
||
| 244 | -! | +|||
| 40 | +
- "Score function does not appear to have return exactly one ",+ } |
|||
| 245 | -! | +|||
| 41 | +
- "scalar value per child"+ |
|||
| 246 | +42 |
- )+ #' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values. |
||
| 247 | +43 |
- }+ #' |
||
| 248 | -24x | +|||
| 44 | +
- if (is.na(decreasing)) {
+ #' @examples |
|||
| 249 | -8x | +|||
| 45 | +
- decreasing <- if (is.character(scores)) FALSE else TRUE+ #' tbl_to_prune %>% prune_table(all_zero) |
|||
| 250 | +46 |
- }+ #' |
||
| 251 | -24x | +|||
| 47 | +
- ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)+ #' @rdname trim_prune_funs |
|||
| 252 | -24x | +|||
| 48 | +
- newkids <- kids[ord]+ #' @export+ |
+ |||
| 49 | ++ |
+ all_zero <- function(tr) {
|
||
| 253 | -24x | +50 | +8x |
- if (anyNA(scores) && na.pos == "omit") { # we did na last here
+ if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
|
| 254 | +51 | ! |
- newkids <- head(newkids, -1 * sum(is.na(scores)))+ return(FALSE) |
|
| 255 | +52 |
} |
||
| 53 | +8x | +
+ rvs <- unlist(unname(row_values(tr)))+ |
+ ||
| 54 | +8x | +
+ isTRUE(all(rvs == 0))+ |
+ ||
| 256 | +55 | ++ |
+ }+ |
+ |
| 56 | ||||
| 257 | -24x | +|||
| 57 | +
- newtree <- subtree+ #' Trim rows from a populated table without regard for table structure |
|||
| 258 | -24x | +|||
| 58 | +
- tree_children(newtree) <- newkids+ #' |
|||
| 259 | -24x | +|||
| 59 | +
- tt_at_path(tt, path) <- newtree+ #' @inheritParams gen_args |
|||
| 260 | -24x | +|||
| 60 | +
- tt+ #' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row |
|||
| 261 | +61 |
- }+ #' should be removed. Defaults to [all_zero_or_na()]. |
| 1 | +62 |
- # paths summary ----+ #' |
||
| 2 | +63 |
-
+ #' @return The table with rows that have only `NA` or 0 cell values removed. |
||
| 3 | +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 |
- #' Get a list of table row/column paths+ #' into account. |
|||
| 4 | +74 |
#' |
||
| 5 | +75 |
- #' @param x (`VTableTree`)\cr an `rtable` object.+ #' @seealso [prune_table()] |
||
| 6 | +76 |
#' |
||
| 7 | +77 |
- #' @return A list of paths to each row/column within `x`.+ #' @examples |
||
| 8 | +78 |
- #'+ #' adsl <- ex_adsl |
||
| 9 | +79 |
- #' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
||
| 10 | +80 |
#' |
||
| 11 | +81 |
- #' @examples+ #' tbl_to_trim <- basic_table() %>% |
||
| 12 | +82 |
- #' lyt <- basic_table() %>%+ #' analyze("BMRKR1") %>%
|
||
| 13 | +83 |
#' split_cols_by("ARM") %>%
|
||
| 14 | +84 |
- #' analyze(c("SEX", "AGE"))
+ #' split_rows_by("SEX") %>%
|
||
| 15 | +85 |
- #'+ #' summarize_row_groups() %>% |
||
| 16 | +86 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' split_rows_by("STRATA1") %>%
|
||
| 17 | +87 |
- #' tbl+ #' summarize_row_groups() %>% |
||
| 18 | +88 |
- #'+ #' analyze("AGE") %>%
|
||
| 19 | +89 |
- #' row_paths(tbl)+ #' build_table(adsl) |
||
| 20 | +90 |
- #' col_paths(tbl)+ #' |
||
| 21 | +91 |
- #'+ #' tbl_to_trim %>% trim_rows() |
||
| 22 | +92 |
- #' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
+ #' |
||
| 23 | +93 |
- #'+ #' tbl_to_trim %>% trim_rows(all_zero) |
||
| 24 | +94 |
- #' @rdname make_col_row_df+ #' |
||
| 25 | +95 |
#' @export |
||
| 26 | +96 |
- row_paths <- function(x) {
+ trim_rows <- function(tt, criteria = all_zero_or_na) {
|
||
| 27 | -45x | +97 | +3x |
- stopifnot(is_rtable(x))+ rows <- collect_leaves(tt, TRUE, TRUE) |
| 28 | -45x | +98 | +3x |
- make_row_df(x, visible_only = TRUE)$path+ torm <- vapply(rows, criteria, |
| 29 | -+ | |||
| 99 | +3x |
- }+ NA, |
||
| 30 | -+ | |||
| 100 | +3x |
-
+ USE.NAMES = FALSE |
||
| 31 | +101 |
- #' @rdname make_col_row_df+ ) |
||
| 32 | -+ | |||
| 102 | +3x |
- #' @export+ tt[!torm, , |
||
| 33 | -+ | |||
| 103 | +3x |
- col_paths <- function(x) {
+ keep_topleft = TRUE, |
||
| 34 | -1604x | +104 | +3x |
- if (!is(coltree(x), "LayoutColTree")) {
+ keep_titles = TRUE, |
| 35 | -! | +|||
| 105 | +3x |
- stop("I don't know how to extract the column paths from an object of class ", class(x))
+ keep_footers = TRUE, |
||
| 36 | -+ | |||
| 106 | +3x |
- }+ reindex_refs = TRUE |
||
| 37 | -1604x | +|||
| 107 | +
- make_col_df(x, visible_only = TRUE)$path+ ] |
|||
| 38 | +108 |
} |
||
| 39 | +109 | |||
| 40 | +110 |
- #' Print row/column paths summary+ #' @inheritParams trim_rows |
||
| 41 | +111 |
#' |
||
| 42 | +112 |
- #' @param x (`VTableTree`)\cr an `rtable` object.+ #' @details |
||
| 43 | +113 |
- #'+ #' `content_all_zeros_nas` prunes a subtable if both of the following are true: |
||
| 44 | +114 |
- #' @return A data frame summarizing the row- or column-structure of `x`.+ #' |
||
| 45 | +115 |
- #'+ #' * It has a content table with exactly one row in it. |
||
| 46 | +116 |
- #' @examples+ #' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content |
||
| 47 | +117 |
- #' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
+ #' function is used, this represents pruning any subtable which corresponds to an empty set of the input data |
||
| 48 | +118 |
- #'+ #' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data). |
||
| 49 | +119 |
- #' lyt <- basic_table() %>%+ #' |
||
| 50 | +120 |
- #' split_cols_by("ARM") %>%
+ #' @examples |
||
| 51 | +121 |
- #' split_cols_by("SEX", split_fun = drop_split_levels) %>%
+ #' tbl_to_prune %>% prune_table(content_all_zeros_nas) |
||
| 52 | +122 |
- #' analyze(c("AGE", "BMRKR2"))
+ #' |
||
| 53 | +123 |
- #'+ #' @rdname trim_prune_funs |
||
| 54 | +124 |
- #' tbl <- build_table(lyt, ex_adsl_MF)+ #' @export |
||
| 55 | +125 |
- #' tbl+ content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
|
||
| 56 | +126 |
- #'+ ## this will be NULL if |
||
| 57 | +127 |
- #' df <- row_paths_summary(tbl)+ ## tt is something that doesn't have a content table |
||
| 58 | -+ | |||
| 128 | +254x |
- #' df+ ct <- content_table(tt) |
||
| 59 | +129 |
- #'+ ## NROW returns 0 for NULL. |
||
| 60 | -+ | |||
| 130 | +254x |
- #' col_paths_summary(tbl)+ if (NROW(ct) == 0 || nrow(ct) > 1) {
|
||
| 61 | -+ | |||
| 131 | +242x |
- #'+ return(FALSE) |
||
| 62 | +132 |
- #' # manually constructed table+ } |
||
| 63 | +133 |
- #' tbl2 <- rtable(+ |
||
| 64 | -+ | |||
| 134 | +12x |
- #' rheader(+ cr <- tree_children(ct)[[1]] |
||
| 65 | -+ | |||
| 135 | +12x |
- #' rrow(+ criteria(cr) |
||
| 66 | +136 |
- #' "row 1", rcell("a", colspan = 2),
+ } |
||
| 67 | +137 |
- #' rcell("b", colspan = 2)
+
|
||
| 68 | +138 |
- #' ),+ #' @details |
||
| 69 | +139 |
- #' rrow("h2", "a", "b", "c", "d")
+ #' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on |
||
| 70 | +140 |
- #' ),+ #' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no |
||
| 71 | +141 |
- #' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
+ #' children. |
||
| 72 | +142 |
- #' )+ #' |
||
| 73 | +143 |
- #' col_paths_summary(tbl2)+ #' @examples |
||
| 74 | +144 |
- #'+ #' tbl_to_prune %>% prune_table(prune_empty_level) |
||
| 75 | +145 |
- #' @export+ #' |
||
| 76 | +146 |
- row_paths_summary <- function(x) {
+ #' @rdname trim_prune_funs |
||
| 77 | -1x | +|||
| 147 | +
- stopifnot(is_rtable(x))+ #' @export |
|||
| 78 | +148 |
-
+ prune_empty_level <- function(tt) {
|
||
| 79 | -1x | +149 | +389x |
- if (nrow(x) == 0) {
+ if (is(tt, "TableRow")) {
|
| 80 | -! | +|||
| 150 | +151x |
- return("rowname node_class path\n---------------------\n")
+ return(all_zero_or_na(tt)) |
||
| 81 | +151 |
} |
||
| 82 | +152 | |||
| 83 | -1x | +153 | +238x |
- pagdf <- make_row_df(x, visible_only = TRUE)+ if (content_all_zeros_nas(tt)) {
|
| 84 | -1x | +154 | +2x |
- row.names(pagdf) <- NULL+ return(TRUE) |
| 85 | +155 | - - | -||
| 86 | -1x | -
- 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 | +156 | +236x |
- xi$node_class,+ kids <- tree_children(tt) |
| 92 | -28x | +157 | +236x |
- paste(xi$path, collapse = ", ")+ length(kids) == 0 |
| 93 | +158 |
- )+ } |
||
| 94 | +159 |
- }))+ |
||
| 95 | +160 |
- )+ #' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes |
||
| 96 | +161 | - - | -||
| 97 | -1x | -
- txt <- mat_as_string(mat)- |
- ||
| 98 | -1x | -
- cat(txt)- |
- ||
| 99 | -1x | -
- cat("\n")
+ #' only in the case of all non-missing zero values. |
||
| 100 | +162 | - - | -||
| 101 | -1x | -
- invisible(pagdf[, c("label", "indent", "node_class", "path")])
+ #' |
||
| 102 | +163 |
- }+ #' @examples |
||
| 103 | +164 |
-
+ #' tbl_to_prune %>% prune_table(prune_zeros_only) |
||
| 104 | +165 |
- #' @rdname row_paths_summary+ #' |
||
| 105 | +166 |
- #' @export+ #' @rdname trim_prune_funs |
||
| 106 | +167 |
- col_paths_summary <- function(x) {
- |
- ||
| 107 | -1x | -
- stopifnot(is_rtable(x))+ #' @export |
||
| 108 | +168 |
-
+ prune_zeros_only <- function(tt) {
|
||
| 109 | -1x | +169 | +16x |
- pagdf <- make_col_df(x, visible_only = FALSE)+ if (is(tt, "TableRow")) {
|
| 110 | -1x | +170 | +8x |
- row.names(pagdf) <- NULL+ return(all_zero(tt)) |
| 111 | +171 |
-
+ } |
||
| 112 | -1x | +|||
| 172 | +
- mat <- rbind(+ |
|||
| 113 | -1x | +173 | +8x |
- c("label", "path"),
+ if (content_all_zeros_nas(tt, criteria = all_zero)) {
|
| 114 | -1x | +|||
| 174 | +! |
- t(apply(pagdf, 1, function(xi) {
+ return(TRUE) |
||
| 115 | -6x | +|||
| 175 | +
- c(+ } |
|||
| 116 | -6x | +176 | +8x |
- indent_string(xi$label, floor(length(xi$path) / 2 - 1)),+ kids <- tree_children(tt) |
| 117 | -6x | +177 | +8x |
- paste(xi$path, collapse = ", ")+ length(kids) == 0 |
| 118 | +178 |
- )+ } |
||
| 119 | +179 |
- }))+ |
||
| 120 | +180 |
- )+ #' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value. |
||
| 121 | +181 | - - | -||
| 122 | -1x | -
- txt <- mat_as_string(mat)+ #' Subtables whose combined/average count are below this threshold will be pruned. |
||
| 123 | -1x | +|||
| 182 | +
- cat(txt)+ #' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`. |
|||
| 124 | -1x | +|||
| 183 | +
- cat("\n")
+ #' |
|||
| 125 | +184 |
-
+ #' @details |
||
| 126 | -1x | +|||
| 185 | +
- invisible(pagdf[, c("label", "path")])
+ #' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which |
|||
| 127 | +186 |
- }+ #' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell |
||
| 128 | +187 |
-
+ #' values (defined as the first value per cell regardless of how many values per cell there are) against `min`. |
||
| 129 | +188 |
- # Rows ----+ #' |
||
| 130 | +189 |
- # . Summarize Rows ----+ #' @examples |
||
| 131 | +190 |
-
+ #' min_prune <- low_obs_pruner(70, "sum") |
||
| 132 | +191 |
- # summarize_row_df <-+ #' tbl_to_prune %>% prune_table(min_prune) |
||
| 133 | +192 |
- # function(name,+ #' |
||
| 134 | +193 |
- # label,+ #' @rdname trim_prune_funs |
||
| 135 | +194 |
- # indent,+ #' @export |
||
| 136 | +195 |
- # depth,+ low_obs_pruner <- function(min, type = c("sum", "mean")) {
|
||
| 137 | -+ | |||
| 196 | +3x |
- # rowtype,+ type <- match.arg(type) |
||
| 138 | -+ | |||
| 197 | +3x |
- # indent_mod,+ function(tt) {
|
||
| 139 | -+ | |||
| 198 | +21x |
- # level) {
+ if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
|
||
| 140 | -+ | |||
| 199 | +9x |
- # data.frame(+ return(FALSE) ## only trimming on count content rows |
||
| 141 | +200 |
- # name = name,+ } |
||
| 142 | -+ | |||
| 201 | +12x |
- # label = label,+ ctr <- tree_children(ctab)[[1]] |
||
| 143 | -+ | |||
| 202 | +12x |
- # indent = indent,+ vals <- sapply(row_values(ctr), function(v) v[[1]]) |
||
| 144 | -+ | |||
| 203 | +12x |
- # depth = level,+ sumvals <- sum(vals) |
||
| 145 | -+ | |||
| 204 | +12x |
- # rowtype = rowtype,+ if (type == "mean") {
|
||
| 146 | -+ | |||
| 205 | +8x |
- # indent_mod = indent_mod,+ sumvals <- sumvals / length(vals) |
||
| 147 | +206 |
- # level = level,+ } |
||
| 148 | -+ | |||
| 207 | +12x |
- # stringsAsFactors = FALSE+ sumvals < min |
||
| 149 | +208 |
- # )+ } |
||
| 150 | +209 |
- # }+ } |
||
| 151 | +210 | |||
| 152 | +211 |
- #' Summarize rows+ #' Recursively prune a `TableTree` |
||
| 153 | +212 |
#' |
||
| 154 | +213 |
#' @inheritParams gen_args |
||
| 155 | +214 |
- #' @param depth (`numeric(1)`)\cr depth.+ #' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the |
||
| 156 | +215 |
- #' @param indent (`numeric(1)`)\cr indent.+ #' entire subtree should be removed. |
||
| 157 | +216 |
- #'+ #' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning. |
||
| 158 | +217 |
- #' @examples+ #' Defaults to `NA` which indicates pruning should happen at all levels. |
||
| 159 | +218 |
- #' library(dplyr)+ #' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user. |
||
| 160 | +219 |
#' |
||
| 161 | +220 |
- #' iris2 <- iris %>%+ #' @return A `TableTree` pruned via recursive application of `prune_func`. |
||
| 162 | +221 |
- #' group_by(Species) %>%+ #' |
||
| 163 | +222 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ #' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included |
||
| 164 | +223 |
- #' ungroup()+ #' in the `rtables` package. |
||
| 165 | +224 |
#' |
||
| 166 | +225 |
- #' lyt <- basic_table() %>%+ #' @examples |
||
| 167 | +226 |
- #' split_cols_by("Species") %>%
+ #' adsl <- ex_adsl |
||
| 168 | +227 |
- #' split_cols_by("group") %>%
+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
||
| 169 | +228 |
- #' analyze(c("Sepal.Length", "Petal.Width"),
+ #' |
||
| 170 | +229 |
- #' afun = list_wrap_x(summary),+ #' tbl_to_prune <- basic_table() %>% |
||
| 171 | +230 |
- #' format = "xx.xx"+ #' split_cols_by("ARM") %>%
|
||
| 172 | +231 |
- #' )+ #' split_rows_by("SEX") %>%
|
||
| 173 | +232 |
- #'+ #' summarize_row_groups() %>% |
||
| 174 | +233 |
- #' tbl <- build_table(lyt, iris2)+ #' split_rows_by("STRATA1") %>%
|
||
| 175 | +234 |
- #'+ #' summarize_row_groups() %>% |
||
| 176 | +235 |
- #' @rdname int_methods+ #' analyze("AGE") %>%
|
||
| 177 | +236 |
- setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
+ #' build_table(adsl) |
||
| 178 | -! | +|||
| 237 | +
- standardGeneric("summarize_rows_inner")
+ #' |
|||
| 179 | +238 |
- })+ #' tbl_to_prune %>% prune_table() |
||
| 180 | +239 |
-
+ #' |
||
| 181 | +240 |
- #' @rdname int_methods+ #' @export |
||
| 182 | +241 |
- setMethod(+ prune_table <- function(tt, |
||
| 183 | +242 |
- "summarize_rows_inner", "TableTree",+ prune_func = prune_empty_level, |
||
| 184 | +243 |
- function(obj, depth = 0, indent = 0) {
+ stop_depth = NA_real_,+ |
+ ||
| 244 | ++ |
+ depth = 0) {
+ |
+ ||
| 245 | +323x | +
+ if (!is.na(stop_depth) && depth > stop_depth) {
|
||
| 185 | +246 | ! |
- indent <- max(0L, indent + indent_mod(obj))+ return(tt) |
|
| 186 | +247 |
-
+ } |
||
| 187 | -! | +|||
| 248 | +323x |
- lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)+ if (is(tt, "TableRow")) {
|
||
| 188 | -! | +|||
| 249 | +54x |
- if (!is.null(lr)) {
+ if (prune_func(tt)) {
|
||
| 189 | +250 | ! |
- ret <- list(lr)+ tt <- NULL |
|
| 190 | +251 |
- } else {
+ } |
||
| 191 | -! | +|||
| 252 | +54x |
- ret <- list()+ return(tt) |
||
| 192 | +253 |
- }+ } |
||
| 193 | +254 | |||
| 194 | -! | +|||
| 255 | +269x |
- indent <- indent + (!is.null(lr))+ kids <- tree_children(tt) |
||
| 195 | +256 | |||
| 196 | -! | +|||
| 257 | +269x |
- ctab <- content_table(obj)+ torm <- vapply(kids, function(tb) {
|
||
| 197 | -! | +|||
| 258 | +386x |
- if (NROW(ctab)) {
+ !is.null(tb) && prune_func(tb) |
||
| 198 | -! | +|||
| 259 | +269x |
- ct <- summarize_rows_inner(ctab,+ }, NA) |
||
| 199 | -! | +|||
| 260 | +
- depth = depth,+ |
|||
| 200 | -! | +|||
| 261 | +269x |
- indent = indent + indent_mod(ctab)+ keepkids <- kids[!torm] |
||
| 201 | -+ | |||
| 262 | +269x |
- )+ keepkids <- lapply(keepkids, prune_table, |
||
| 202 | -! | +|||
| 263 | +269x |
- ret <- c(ret, ct)+ prune_func = prune_func, |
||
| 203 | -! | +|||
| 264 | +269x |
- indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))+ stop_depth = stop_depth,+ |
+ ||
| 265 | +269x | +
+ depth = depth + 1 |
||
| 204 | +266 |
- }+ ) |
||
| 205 | +267 | |||
| 206 | -! | +|||
| 268 | +269x |
- kids <- tree_children(obj)+ keepkids <- keepkids[!vapply(keepkids, is.null, NA)] |
||
| 207 | -! | +|||
| 269 | +269x |
- els <- lapply(tree_children(obj), summarize_rows_inner,+ if (length(keepkids) > 0) {
|
||
| 208 | -! | +|||
| 270 | +135x |
- depth = depth + 1, indent = indent+ tree_children(tt) <- keepkids |
||
| 209 | +271 |
- )+ } else {
|
||
| 210 | -! | +|||
| 272 | +134x |
- if (!are(kids, "TableRow")) {
+ tt <- NULL |
||
| 211 | -! | +|||
| 273 | +
- if (!are(kids, "VTableTree")) {
+ }+ |
+ |||
| 274 | +269x | +
+ tt |
||
| 212 | +275 |
- ## hatchet job of a hack, wrap em just so we can unlist em all at+ } |
| 213 | +1 |
- ## the same level+ insert_brs <- function(vec) {
|
||
| 214 | -! | +|||
| 2 | +919x |
- rowinds <- vapply(kids, is, NA, class2 = "TableRow")+ if (length(vec) == 1) {
|
||
| 215 | -! | +|||
| 3 | +919x |
- els[rowinds] <- lapply(els[rowinds], function(x) list(x))+ ret <- list(vec) |
||
| 216 | +4 |
- }+ } else {
|
||
| 217 | +5 | ! |
- els <- unlist(els, recursive = FALSE)+ nout <- length(vec) * 2 - 1 |
|
| 218 | -+ | |||
| 6 | +! |
- }+ ret <- vector("list", nout)
|
||
| 219 | +7 | ! |
- ret <- c(ret, els)+ for (i in seq_along(vec)) {
|
|
| 220 | +8 | ! |
- ret+ ret[[2 * i - 1]] <- vec[i] |
|
| 221 | -+ | |||
| 9 | +! |
- ## df <- do.call(rbind, c(list(lr), list(ct), els))+ if (2 * i < nout) {
|
||
| 222 | -+ | |||
| 10 | +! |
-
+ ret[[2 * i]] <- tags$br() |
||
| 223 | +11 |
- ## row.names(df) <- NULL+ } |
||
| 224 | +12 |
- ## df+ } |
||
| 225 | +13 |
} |
||
| 226 | -+ | |||
| 14 | +919x |
- )+ ret |
||
| 227 | +15 |
-
+ } |
||
| 228 | +16 |
- # Print Table Structure ----+ |
||
| 229 | +17 |
-
+ div_helper <- function(lst, class) {
|
||
| 230 | -+ | |||
| 18 | +56x |
- #' Summarize table+ do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst))) |
||
| 231 | +19 |
- #'+ } |
||
| 232 | +20 |
- #' @param x (`VTableTree`)\cr a table object.+ |
||
| 233 | +21 |
- #' @param detail (`string`)\cr either `row` or `subtable`.+ #' Convert an `rtable` object to a `shiny.tag` HTML object |
||
| 234 | +22 |
#' |
||
| 235 | +23 |
- #' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.+ #' The returned HTML object can be immediately used in `shiny` and `rmarkdown`. |
||
| 236 | +24 |
#' |
||
| 237 | +25 |
- #' @examples+ #' @param x (`VTableTree`)\cr a `TableTree` object. |
||
| 238 | +26 |
- #' library(dplyr)+ #' @param class_table (`character`)\cr class for `table` tag. |
||
| 239 | +27 |
- #'+ #' @param class_tr (`character`)\cr class for `tr` tag. |
||
| 240 | +28 |
- #' iris2 <- iris %>%+ #' @param class_th (`character`)\cr class for `th` tag. |
||
| 241 | +29 |
- #' group_by(Species) %>%+ #' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a |
||
| 242 | +30 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ #' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`. |
||
| 243 | +31 |
- #' ungroup()+ #' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table. |
||
| 244 | +32 |
- #'+ #' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`, |
||
| 245 | +33 |
- #' lyt <- basic_table() %>%+ #' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label |
||
| 246 | +34 |
- #' split_cols_by("Species") %>%
+ #' rows). Defaults to `"header"`. |
||
| 247 | +35 |
- #' split_cols_by("group") %>%
+ #' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults |
||
| 248 | +36 |
- #' analyze(c("Sepal.Length", "Petal.Width"),
+ #' to `TRUE`. |
||
| 249 | +37 |
- #' afun = list_wrap_x(summary),+ #' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults |
||
| 250 | +38 |
- #' format = "xx.xx"+ #' to `FALSE`. |
||
| 251 | +39 |
- #' )+ #' |
||
| 252 | +40 |
- #'+ #' @importFrom htmltools tags |
||
| 253 | +41 |
- #' tbl <- build_table(lyt, iris2)+ #' |
||
| 254 | +42 |
- #' tbl+ #' @return A `shiny.tag` object representing `x` in HTML. |
||
| 255 | +43 |
#' |
||
| 256 | +44 |
- #' row_paths(tbl)+ #' @examples |
||
| 257 | +45 |
- #'+ #' tbl <- rtable( |
||
| 258 | +46 |
- #' table_structure(tbl)+ #' header = LETTERS[1:3], |
||
| 259 | +47 |
- #'+ #' format = "xx", |
||
| 260 | +48 |
- #' table_structure(tbl, detail = "row")+ #' rrow("r1", 1, 2, 3),
|
||
| 261 | +49 |
- #'+ #' rrow("r2", 4, 3, 2, indent = 1),
|
||
| 262 | +50 |
- #' @export+ #' rrow("r3", indent = 2)
|
||
| 263 | +51 |
- table_structure <- function(x, detail = c("subtable", "row")) {
- |
- ||
| 264 | -2x | -
- detail <- match.arg(detail)+ #' ) |
||
| 265 | +52 | - - | -||
| 266 | -2x | -
- switch(detail,- |
- ||
| 267 | -1x | -
- subtable = treestruct(x),- |
- ||
| 268 | -1x | -
- row = table_structure_inner(x),- |
- ||
| 269 | -! | -
- stop("unsupported level of detail ", detail)
+ #' |
||
| 270 | +53 |
- )+ #' as_html(tbl) |
||
| 271 | +54 |
- }+ #' |
||
| 272 | +55 |
-
+ #' as_html(tbl, class_table = "table", class_tr = "row") |
||
| 273 | +56 |
- #' @param obj (`VTableTree`)\cr a table object.+ #' |
||
| 274 | +57 |
- #' @param depth (`numeric(1)`)\cr depth in tree.+ #' as_html(tbl, bold = c("header", "row_names"))
|
||
| 275 | +58 |
- #' @param indent (`numeric(1)`)\cr indent.+ #' |
||
| 276 | +59 |
- #' @param print_indent (`numeric(1)`)\cr indent for printing.+ #' \dontrun{
|
||
| 277 | +60 |
- #'+ #' Viewer(tbl) |
||
| 278 | +61 |
- #' @rdname int_methods+ #' } |
||
| 279 | +62 |
- setGeneric(+ #' |
||
| 280 | +63 |
- "table_structure_inner",+ #' @export |
||
| 281 | +64 |
- function(obj,+ as_html <- function(x, |
||
| 282 | +65 |
- depth = 0,+ width = NULL, |
||
| 283 | +66 |
- indent = 0,+ class_table = "table table-condensed table-hover", |
||
| 284 | +67 |
- print_indent = 0) {
- |
- ||
| 285 | -70x | -
- standardGeneric("table_structure_inner")
+ class_tr = NULL, |
||
| 286 | +68 |
- }+ class_th = NULL, |
||
| 287 | +69 |
- )+ link_label = NULL, |
||
| 288 | +70 |
-
+ bold = c("header"),
|
||
| 289 | +71 |
- scat <- function(..., indent = 0, newline = TRUE) {
- |
- ||
| 290 | -101x | -
- txt <- paste(..., collapse = "", sep = "")+ header_sep_line = TRUE, |
||
| 291 | +72 |
-
+ no_spaces_between_cells = FALSE) {
|
||
| 292 | -101x | -
- cat(indent_string(txt, indent))- |
- ||
| 293 | -+ | 73 | +7x |
-
+ if (is.null(x)) {
|
| 294 | -101x | +|||
| 74 | +! |
- if (newline) cat("\n")
+ return(tags$p("Empty Table"))
|
||
| 295 | +75 |
- }+ } |
||
| 296 | +76 | |||
| 297 | -+ | |||
| 77 | +7x |
- ## helper functions+ stopifnot(is(x, "VTableTree")) |
||
| 298 | +78 |
- obj_visible <- function(x) {
+
|
||
| 299 | -50x | -
- x@visible- |
- ||
| 300 | -+ | 79 | +7x |
- }+ mat <- matrix_form(x, indent_rownames = TRUE) |
| 301 | +80 | |||
| 302 | -+ | |||
| 81 | +7x |
- is_empty_labelrow <- function(x) {
+ nlh <- mf_nlheader(mat) |
||
| 303 | -4x | +82 | +7x |
- obj_label(x) == "" && !labelrow_visible(x)+ nc <- ncol(x) + 1 |
| 304 | -+ | |||
| 83 | +7x |
- }+ nr <- length(mf_lgrouping(mat)) |
||
| 305 | +84 | |||
| 306 | +85 |
- is_empty_ElementaryTable <- function(x) {
+ # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions |
||
| 307 | -10x | +86 | +7x |
- length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))+ cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc) |
| 308 | +87 |
- }+ |
||
| 309 | -+ | |||
| 88 | +7x |
-
+ for (i in seq_len(nr)) {
|
||
| 310 | -+ | |||
| 89 | +148x |
- #' @param object (`VTableTree`)\cr a table object.+ for (j in seq_len(nc)) {
|
||
| 311 | -+ | |||
| 90 | +919x |
- #'+ curstrs <- mf_strings(mat)[i, j] |
||
| 312 | -+ | |||
| 91 | +919x |
- #' @rdname int_methods+ curspn <- mf_spans(mat)[i, j] |
||
| 313 | -+ | |||
| 92 | +919x |
- #' @export+ algn <- mf_aligns(mat)[i, j] |
||
| 314 | +93 |
- setGeneric("str", function(object, ...) {
+
|
||
| 315 | -! | +|||
| 94 | +919x |
- standardGeneric("str")
+ inhdr <- i <= nlh |
||
| 316 | -+ | |||
| 95 | +919x |
- })+ tagfun <- if (inhdr) tags$th else tags$td |
||
| 317 | -+ | |||
| 96 | +919x |
-
+ cells[i, j][[1]] <- tagfun( |
||
| 318 | -+ | |||
| 97 | +919x |
- #' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike+ class = if (inhdr) class_th else class_tr, |
||
| 319 | -+ | |||
| 98 | +919x |
- #' the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects.+ style = paste0("text-align: ", algn, ";"),
|
||
| 320 | -+ | |||
| 99 | +919x |
- #'+ style = if (inhdr && !"header" %in% bold) "font-weight: normal;", |
||
| 321 | -+ | |||
| 100 | +919x |
- #' @rdname int_methods+ style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;", |
||
| 322 | -+ | |||
| 101 | +919x |
- #' @export+ colspan = if (curspn != 1) curspn, |
||
| 323 | -+ | |||
| 102 | +919x |
- setMethod(+ insert_brs(curstrs) |
||
| 324 | +103 |
- "str", "VTableTree",+ ) |
||
| 325 | +104 |
- 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 | +105 |
- )- |
- ||
| 331 | -! | -
- invisible(NULL)+ } |
||
| 332 | +106 |
- }+ |
||
| 333 | -+ | |||
| 107 | +7x |
- )+ if (header_sep_line) {
|
||
| 334 | -+ | |||
| 108 | +7x |
-
+ cells[nlh][[1]] <- htmltools::tagAppendAttributes( |
||
| 335 | -+ | |||
| 109 | +7x |
- #' @inheritParams table_structure_inner+ cells[nlh, 1][[1]], |
||
| 336 | -+ | |||
| 110 | +7x |
- #' @rdname int_methods+ style = "border-bottom: 1px solid black;" |
||
| 337 | +111 |
- setMethod(+ ) |
||
| 338 | +112 |
- "table_structure_inner", "TableTree",+ } |
||
| 339 | +113 |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
- |
- ||
| 340 | -10x | -
- indent <- indent + indent_mod(obj)+ |
||
| 341 | +114 |
-
+ # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh |
||
| 342 | -10x | +115 | +7x |
- scat("TableTree: ", "[", obj_name(obj), "] (",
+ map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping) |
| 343 | -10x | +116 | +7x |
- obj_label(obj), ")",+ row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh) |
| 344 | -10x | +117 | +7x |
- indent = print_indent+ map <- merge(map, row_info_df, by = "abs_rownumber") |
| 345 | +118 |
- )+ |
||
| 346 | +119 | - - | -||
| 347 | -10x | -
- table_structure_inner(+ # add indent values for headerlines |
||
| 348 | -10x | +120 | +7x |
- tt_labelrow(obj), depth, indent,+ map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map) |
| 349 | -10x | +|||
| 121 | +
- print_indent + 1+ |
|||
| 350 | +122 |
- )+ |
||
| 351 | +123 |
-
+ # Row labels style |
||
| 352 | -10x | +124 | +7x |
- ctab <- content_table(obj)+ for (i in seq_len(nr)) {
|
| 353 | -10x | +125 | +148x |
- visible_content <- if (is_empty_ElementaryTable(ctab)) {
+ indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1) |
| 354 | +126 |
- # scat("content: -", indent = print_indent + 1)
- |
- ||
| 355 | -4x | -
- FALSE+ |
||
| 356 | +127 |
- } else {
- |
- ||
| 357 | -6x | -
- scat("content:", indent = print_indent + 1)
+ # Apply indentation |
||
| 358 | -6x | +128 | +148x |
- table_structure_inner(ctab,+ if (indent > 0) {
|
| 359 | -6x | +129 | +114x |
- depth = depth,+ cells[i, 1][[1]] <- htmltools::tagAppendAttributes( |
| 360 | -6x | +130 | +114x |
- indent = indent + indent_mod(ctab),+ cells[i, 1][[1]], |
| 361 | -6x | +131 | +114x |
- print_indent = print_indent + 2+ style = paste0("padding-left: ", indent * 3, "ch;")
|
| 362 | +132 |
) |
||
| 363 | +133 |
} |
||
| 364 | +134 | |||
| 365 | -10x | -
- if (length(tree_children(obj)) == 0) {
- |
- ||
| 366 | -! | -
- scat("children: - ", indent = print_indent + 1)
- |
- ||
| 367 | +135 |
- } else {
- |
- ||
| 368 | -10x | -
- scat("children: ", indent = print_indent + 1)
+ # Apply bold font weight if "row_names" is in 'bold' |
||
| 369 | -10x | +136 | +148x |
- lapply(tree_children(obj), table_structure_inner,+ if ("row_names" %in% bold) {
|
| 370 | -10x | +137 | +4x |
- depth = depth + 1,+ cells[i, 1][[1]] <- htmltools::tagAppendAttributes( |
| 371 | -10x | +138 | +4x |
- indent = indent + visible_content * (1 + indent_mod(ctab)),+ cells[i, 1][[1]], |
| 372 | -10x | +139 | +4x |
- print_indent = print_indent + 2+ style = "font-weight: bold;" |
| 373 | +140 |
) |
||
| 374 | +141 |
} |
||
| 375 | +142 | - - | -||
| 376 | -10x | -
- invisible(NULL)+ } |
||
| 377 | +143 |
- }+ |
||
| 378 | +144 |
- )+ # label rows style |
||
| 379 | -+ | |||
| 145 | +7x |
-
+ if ("label_rows" %in% bold) {
|
||
| 380 | -+ | |||
| 146 | +! |
- #' @rdname int_methods+ which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") |
||
| 381 | -+ | |||
| 147 | +! |
- setMethod(+ cells[which_lbl_rows + nlh, ] <- lapply( |
||
| 382 | -+ | |||
| 148 | +! |
- "table_structure_inner", "ElementaryTable",+ cells[which_lbl_rows + nlh, ], |
||
| 383 | -+ | |||
| 149 | +! |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+ htmltools::tagAppendAttributes, |
||
| 384 | -15x | +|||
| 150 | +! |
- scat("ElementaryTable: ", "[", obj_name(obj),
+ style = "font-weight: bold;" |
||
| 385 | -15x | +|||
| 151 | +
- "] (", obj_label(obj), ")",
+ ) |
|||
| 386 | -15x | +|||
| 152 | +
- indent = print_indent+ } |
|||
| 387 | +153 |
- )+ |
||
| 388 | +154 |
-
+ # content rows style |
||
| 389 | -15x | +155 | +7x |
- indent <- indent + indent_mod(obj)+ if ("content_rows" %in% bold) {
|
| 390 | -+ | |||
| 156 | +! | +
+ which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
+ |
+ ||
| 157 | +! | +
+ cells[which_cntnt_rows + nlh, ] <- lapply(+ |
+ ||
| 158 | +! |
-
+ cells[which_cntnt_rows + nlh, ], |
||
| 391 | -15x | +|||
| 159 | +! |
- table_structure_inner(+ htmltools::tagAppendAttributes, |
||
| 392 | -15x | +|||
| 160 | +! |
- tt_labelrow(obj), depth,+ style = "font-weight: bold;" |
||
| 393 | -15x | +|||
| 161 | +
- indent, print_indent + 1+ ) |
|||
| 394 | +162 |
- )+ } |
||
| 395 | +163 | |||
| 396 | -15x | +164 | +7x |
- if (length(tree_children(obj)) == 0) {
+ if (any(!mat$display)) {
|
| 397 | -! | +|||
| 165 | +
- scat("children: - ", indent = print_indent + 1)
+ # Check that expansion kept the same display info |
|||
| 398 | -+ | |||
| 166 | +2x |
- } else {
+ check_expansion <- c() |
||
| 399 | -15x | +167 | +2x |
- scat("children: ", indent = print_indent + 1)
+ for (ii in unique(mat$line_grouping)) {
|
| 400 | -15x | +168 | +121x |
- lapply(tree_children(obj), table_structure_inner,+ rows <- which(mat$line_grouping == ii) |
| 401 | -15x | +169 | +121x |
- depth = depth + 1, indent = indent,+ check_expansion <- c( |
| 402 | -15x | +170 | +121x |
- print_indent = print_indent + 2+ check_expansion,+ |
+
| 171 | +121x | +
+ apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) |
||
| 403 | +172 |
) |
||
| 404 | +173 |
} |
||
| 405 | +174 | |||
| 406 | -15x | +175 | +2x |
- invisible(NULL)+ if (!all(check_expansion)) {
|
| 407 | -+ | |||
| 176 | +! |
- }+ stop( |
||
| 408 | -+ | |||
| 177 | +! |
- )+ "Found that a group of rows have different display options even if ", |
||
| 409 | -+ | |||
| 178 | +! |
-
+ "they belong to the same line group. This should not happen. Please ", |
||
| 410 | -+ | |||
| 179 | +! |
- #' @rdname int_methods+ "file an issue or report to the maintainers." |
||
| 411 | -+ | |||
| 180 | +! |
- setMethod(+ ) # nocov |
||
| 412 | +181 |
- "table_structure_inner", "TableRow",+ } |
||
| 413 | +182 |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+
|
||
| 414 | -20x | +183 | +2x |
- scat(class(obj), ": ", "[", obj_name(obj), "] (",
+ for (ii in unique(mat$line_grouping)) {
|
| 415 | -20x | +184 | +121x |
- obj_label(obj), ")",+ rows <- which(mat$line_grouping == ii) |
| 416 | -20x | +185 | +121x |
- indent = print_indent+ should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any) |
| 417 | -+ | |||
| 186 | +121x |
- )+ cells[ii, !should_display_col] <- NA_integer_ |
||
| 418 | +187 |
-
+ } |
||
| 419 | -20x | +|||
| 188 | +
- indent <- indent + indent_mod(obj)+ } |
|||
| 420 | +189 | |||
| 421 | -20x | +190 | +7x |
- invisible(NULL)+ rows <- apply(cells, 1, function(row) {
|
| 422 | -+ | |||
| 191 | +148x |
- }+ tags$tr( |
||
| 423 | -+ | |||
| 192 | +148x |
- )+ class = class_tr, |
||
| 424 | -+ | |||
| 193 | +148x |
-
+ style = "white-space: pre;", |
||
| 425 | -+ | |||
| 194 | +148x |
- #' @rdname int_methods+ Filter(function(x) !identical(x, NA_integer_), row) |
||
| 426 | +195 |
- setMethod(+ ) |
||
| 427 | +196 |
- "table_structure_inner", "LabelRow",+ }) |
||
| 428 | +197 |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+
|
||
| 429 | -25x | +198 | +7x |
- indent <- indent + indent_mod(obj)+ hsep_line <- tags$hr(class = "solid") |
| 430 | +199 | |||
| 431 | -25x | -
- txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""- |
- ||
| 432 | -+ | 200 | +7x |
-
+ hdrtag <- div_helper( |
| 433 | -25x | +201 | +7x |
- scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
+ class = "rtables-titles-block", |
| 434 | -25x | +202 | +7x |
- txtvis,+ list( |
| 435 | -25x | +203 | +7x |
- indent = print_indent+ div_helper( |
| 436 | -+ | |||
| 204 | +7x |
- )+ class = "rtables-main-titles-block", |
||
| 437 | -+ | |||
| 205 | +7x |
-
+ lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
|
||
| 438 | -25x | +206 | +7x |
- obj_visible(obj)+ class = "rtables-main-title" |
| 439 | +207 |
- }+ ) |
||
| 440 | +208 |
- )+ ), |
| 1 | -+ | |||
| 209 | +7x |
- .reindex_one_pos <- function(refs, cur_idx_fun) {
+ div_helper( |
||
| 2 | -2194x | +210 | +7x |
- if (length(refs) == 0) {
+ class = "rtables-subtitles-block", |
| 3 | -2080x | +211 | +7x |
- return(refs)+ lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
|
| 4 | -+ | |||
| 212 | +7x |
- }+ class = "rtables-subtitle" |
||
| 5 | +213 |
-
+ ) |
||
| 6 | -114x | +|||
| 214 | +
- lapply(refs, function(refi) {
+ ) |
|||
| 7 | +215 |
- ## these can be symbols, e.g. ^, †now, those are+ ) |
||
| 8 | +216 |
- ## special and don't get reindexed cause they're not numbered+ ) |
||
| 9 | +217 |
- ## to begin with+ |
||
| 10 | -119x | +218 | +7x |
- idx <- ref_index(refi)+ tabletag <- do.call( |
| 11 | -119x | +219 | +7x |
- if (is.na(idx) || !is.na(as.integer(idx))) {
+ tags$table, |
| 12 | -119x | -
- ref_index(refi) <- cur_idx_fun(refi)- |
- ||
| 13 | -+ | 220 | +7x |
- }+ c( |
| 14 | -119x | +221 | +7x |
- refi+ rows, |
| 15 | -+ | |||
| 222 | +7x |
- })+ list( |
||
| 16 | -+ | |||
| 223 | +7x |
- }+ class = class_table, |
||
| 17 | -+ | |||
| 224 | +7x |
-
+ style = paste( |
||
| 18 | -72x | +225 | +7x |
- setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))
+ if (no_spaces_between_cells) "border-collapse: collapse;", |
| 19 | -+ | |||
| 226 | +7x |
-
+ if (!is.null(width)) paste("width:", width)
|
||
| 20 | +227 |
- setMethod(+ ), |
||
| 21 | -+ | |||
| 228 | +7x |
- ".idx_helper", "TableRow",+ tags$caption(sprintf("(\\#tag:%s)", link_label),
|
||
| 22 | -+ | |||
| 229 | +7x |
- function(tr, cur_idx_fun) {
+ style = "caption-side: top;", |
||
| 23 | -70x | +230 | +7x |
- row_footnotes(tr) <- .reindex_one_pos(+ .noWS = "after-begin" |
| 24 | -70x | +|||
| 231 | +
- row_footnotes(tr),+ ) |
|||
| 25 | -70x | +|||
| 232 | +
- cur_idx_fun+ ) |
|||
| 26 | +233 |
) |
||
| 27 | +234 |
-
+ ) |
||
| 28 | -70x | +|||
| 235 | +
- cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs,+ |
|||
| 29 | -70x | +236 | +7x |
- .reindex_one_pos,+ rfnotes <- div_helper( |
| 30 | -70x | +237 | +7x |
- cur_idx_fun = cur_idx_fun+ class = "rtables-ref-footnotes-block", |
| 31 | -+ | |||
| 238 | +7x |
- )+ lapply(mat$ref_footnotes, tags$p, |
||
| 32 | -70x | +239 | +7x |
- tr+ class = "rtables-referential-footnote" |
| 33 | +240 |
- }+ ) |
||
| 34 | +241 |
- )+ ) |
||
| 35 | +242 | |||
| 36 | -+ | |||
| 243 | +7x |
- setMethod(+ mftr <- div_helper( |
||
| 37 | -+ | |||
| 244 | +7x |
- ".idx_helper", "VTableTree",+ class = "rtables-main-footers-block", |
||
| 38 | -+ | |||
| 245 | +7x |
- function(tr, cur_idx_fun) {
+ lapply(main_footer(x), tags$p, |
||
| 39 | -2x | +246 | +7x |
- if (!labelrow_visible(tr)) {
+ class = "rtables-main-footer" |
| 40 | +247 |
- stop("got a row footnote on a non-visible label row. this should never happen") # nocov
+ ) |
||
| 41 | +248 |
- }- |
- ||
| 42 | -2x | -
- lr <- tt_labelrow(tr)+ ) |
||
| 43 | +249 | |||
| 44 | -2x | +250 | +7x |
- row_footnotes(lr) <- .reindex_one_pos(+ pftr <- div_helper( |
| 45 | -2x | +251 | +7x |
- row_footnotes(lr),+ class = "rtables-prov-footers-block", |
| 46 | -2x | +252 | +7x |
- cur_idx_fun+ lapply(prov_footer(x), tags$p, |
| 47 | -+ | |||
| 253 | +7x |
- )+ class = "rtables-prov-footer" |
||
| 48 | +254 | - - | -||
| 49 | -2x | -
- tt_labelrow(tr) <- lr+ ) |
||
| 50 | +255 | - - | -||
| 51 | -2x | -
- tr+ ) |
||
| 52 | +256 |
- }+ |
||
| 53 | +257 |
- )+ ## XXX this omits the divs entirely if they are empty. Do we want that or do |
||
| 54 | +258 |
-
+ ## we want them to be there but empty?? |
||
| 55 | -+ | |||
| 259 | +7x |
- index_col_refs <- function(tt, cur_idx_fun) {
+ ftrlst <- list( |
||
| 56 | -409x | +260 | +7x |
- ctree <- coltree(tt)+ if (length(mat$ref_footnotes) > 0) rfnotes, |
| 57 | -409x | +261 | +7x |
- ctree <- .index_col_refs_inner(ctree, cur_idx_fun)+ if (length(mat$ref_footnotes) > 0) hsep_line, |
| 58 | -409x | +262 | +7x |
- coltree(tt) <- ctree+ if (length(main_footer(x)) > 0) mftr, |
| 59 | -409x | +263 | +7x |
- tt+ if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break |
| 60 | -+ | |||
| 264 | +7x |
- }+ if (length(prov_footer(x)) > 0) pftr |
||
| 61 | +265 |
-
+ ) |
||
| 62 | +266 |
- .index_col_refs_inner <- function(ctree, cur_idx_fun) {
- |
- ||
| 63 | -1865x | -
- col_footnotes(ctree) <- .reindex_one_pos(+ |
||
| 64 | -1865x | +|||
| 267 | +! |
- col_footnotes(ctree),+ if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst) |
||
| 65 | -1865x | -
- cur_idx_fun- |
- ||
| 66 | -+ | 268 | +7x |
- )+ ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)] |
| 67 | +269 | |||
| 68 | -1865x | -
- if (is(ctree, "LayoutColTree")) {
- |
- ||
| 69 | -694x | +270 | +7x |
- tree_children(ctree) <- lapply(tree_children(ctree),+ ftrtag <- div_helper( |
| 70 | -694x | +271 | +7x |
- .index_col_refs_inner,+ class = "rtables-footers-block", |
| 71 | -694x | +272 | +7x |
- cur_idx_fun = cur_idx_fun+ ftrlst |
| 72 | +273 |
- )+ ) |
||
| 73 | +274 |
- }+ |
||
| 74 | -1865x | +275 | +7x |
- ctree+ div_helper( |
| 75 | -+ | |||
| 276 | +7x |
- ## cfs <- col_footnotes(ctree)+ class = "rtables-all-parts-block", |
||
| 76 | -+ | |||
| 277 | +7x |
- ## if(length(unlist(cfs)) > 0) {
+ list( |
||
| 77 | -+ | |||
| 278 | +7x |
- ## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,+ hdrtag, |
||
| 78 | -+ | |||
| 279 | +7x |
- ## function(refs) lapply(refs, function(refi) {
+ tabletag, |
||
| 79 | -+ | |||
| 280 | +7x |
- }+ ftrtag |
||
| 80 | +281 |
-
+ ) |
||
| 81 | +282 |
- #' Update footnote indices on a built table+ ) |
||
| 82 | +283 |
- #'+ } |
| 83 | +1 |
- #' Re-indexes footnotes within a built table.+ #' Create an `ElementaryTable` from a `data.frame` |
||
| 84 | +2 |
#' |
||
| 85 | +3 |
- #' @inheritParams gen_args+ #' @param df (`data.frame`)\cr a data frame. |
||
| 86 | +4 |
#' |
||
| 87 | +5 |
#' @details |
||
| 88 | +6 |
- #' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes+ #' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column |
||
| 89 | +7 |
- #' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based+ #' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior |
||
| 90 | +8 |
- #' on the full table.+ #' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique. |
||
| 91 | +9 |
#' |
||
| 92 | +10 |
- #' @note In the future this should not generally need to be called manually.+ #' @seealso [as_result_df()] for the inverse operation. |
||
| 93 | +11 |
#' |
||
| 94 | +12 |
- #' @export+ #' @examples |
||
| 95 | +13 |
- update_ref_indexing <- function(tt) {
- |
- ||
| 96 | -409x | -
- col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))- |
- ||
| 97 | -409x | -
- row_fnotes <- row_footnotes(tt)- |
- ||
| 98 | -409x | -
- cell_fnotes <- cell_footnotes(tt)- |
- ||
| 99 | -409x | -
- all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))- |
- ||
| 100 | -409x | -
- all_fns <- unlist(t(all_fns))- |
- ||
| 101 | -409x | -
- unique_fnotes <- unique(sapply(all_fns, ref_msg))+ #' df_to_tt(mtcars) |
||
| 102 | +14 | - - | -||
| 103 | -409x | -
- cur_index <- function(ref_fn) {
- |
- ||
| 104 | -119x | -
- match(ref_msg(ref_fn), unique_fnotes)+ #' |
||
| 105 | +15 |
- }+ #' @export |
||
| 106 | +16 |
-
+ df_to_tt <- function(df) {
|
||
| 107 | -409x | +17 | +4x |
- if (ncol(tt) > 0) {
+ colnms <- colnames(df) |
| 108 | -409x | -
- 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 | -+ | 18 | +4x |
- ## still need to do those here before returning!!!+ cinfo <- manual_cols(colnms) |
| 112 | -409x | +19 | +4x |
- if (nrow(tt) == 0) {
+ rnames <- rownames(df) |
| 113 | -16x | +20 | +4x |
- return(tt)+ havern <- !is.null(rnames) |
| 114 | +21 |
- }+ |
||
| 115 | -+ | |||
| 22 | +4x |
-
+ if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
|
||
| 116 | -393x | +23 | +1x |
- rdf <- make_row_df(tt)+ rnames <- df$label_name |
| 117 | -+ | |||
| 24 | +1x |
-
+ df <- df[, -match("label_name", colnms)]
|
||
| 118 | -393x | +25 | +1x |
- rdf <- rdf[rdf$nreflines > 0, ]+ colnms <- colnames(df) |
| 119 | -393x | +26 | +1x |
- if (nrow(rdf) == 0) {
+ cinfo <- manual_cols(colnms) |
| 120 | -356x | +27 | +1x |
- return(tt)+ havern <- TRUE |
| 121 | +28 |
} |
||
| 122 | +29 | |||
| 123 | -37x | -
- for (i in seq_len(nrow(rdf))) {
- |
- ||
| 124 | -72x | -
- path <- unname(rdf$path[[i]])- |
- ||
| 125 | -72x | -
- tt_at_path(tt, path) <-- |
- ||
| 126 | -72x | +30 | +4x |
- .idx_helper(+ kids <- lapply(seq_len(nrow(df)), function(i) {
|
| 127 | -72x | +|||
| 31 | +124x |
- tt_at_path(tt, path),+ rni <- if (havern) rnames[i] else "" |
||
| 128 | -72x | +32 | +124x |
- cur_index+ do.call(rrow, c(list(row.name = rni), unclass(df[i, ]))) |
| 129 | +33 |
- )+ }) |
||
| 130 | +34 |
- }+ |
||
| 131 | -37x | +35 | +4x |
- tt+ ElementaryTable(kids = kids, cinfo = cinfo) |
| 132 | +36 |
}@@ -144204,140 +150763,140 @@ rtables coverage - 90.60% |
| 1 |
- #' Format `rcell` objects+ #' @importFrom utils browseURL |
||
| 2 |
- #'+ NULL |
||
| 3 |
- #' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects+ |
||
| 4 |
- #'+ #' Display an `rtable` object in the Viewer pane in RStudio or in a browser |
||
| 5 |
- #' @inheritParams lyt_args+ #' |
||
| 6 |
- #' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.+ #' The table will be displayed using bootstrap styling. |
||
| 7 |
- #' @param format (`string` or `function`)\cr the format label or formatter function to+ #' |
||
| 8 |
- #' apply to `x`.+ #' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package). |
||
| 9 |
- #' @param output (`string`)\cr output type.+ #' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`. |
||
| 10 |
- #' @param pr_row_format (`list`)\cr list of default formats coming from the general row.+ #' @param ... arguments passed to [as_html()]. |
||
| 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+ #' @return Not meaningful. Called for the side effect of opening a browser or viewer pane. |
||
| 13 |
- #' values with formats applied. Defaults to `FALSE`.+ #' |
||
| 14 |
- #'+ #' @examples |
||
| 15 |
- #' @return Formatted text.+ #' if (interactive()) {
|
||
| 16 |
- #'+ #' sl5 <- factor(iris$Sepal.Length > 5, |
||
| 17 |
- #' @examples+ #' levels = c(TRUE, FALSE), |
||
| 18 |
- #' cll <- CellValue(pi, format = "xx.xxx")+ #' labels = c("S.L > 5", "S.L <= 5")
|
||
| 19 |
- #' format_rcell(cll)+ #' ) |
||
| 21 |
- #' # Cell values precedes the row values+ #' df <- cbind(iris, sl5 = sl5) |
||
| 22 |
- #' cll <- CellValue(pi, format = "xx.xxx")+ #' |
||
| 23 |
- #' format_rcell(cll, pr_row_format = "xx.x")+ #' lyt <- basic_table() %>% |
||
| 24 |
- #'+ #' split_cols_by("sl5") %>%
|
||
| 25 |
- #' # Similarly for NA values+ #' analyze("Sepal.Length")
|
||
| 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")+ #' tbl <- build_table(lyt, df) |
||
| 29 |
- #' @export+ #' Viewer(tbl) |
||
| 30 |
- format_rcell <- function(x, format,+ #' Viewer(tbl, tbl) |
||
| 31 |
- output = c("ascii", "html"),
+ #' |
||
| 32 |
- na_str = obj_na_str(x) %||% "NA",+ #' |
||
| 33 |
- pr_row_format = NULL,+ #' tbl2 <- htmltools::tags$div( |
||
| 34 |
- pr_row_na_str = NULL,+ #' class = "table-responsive", |
||
| 35 |
- shell = FALSE) {
+ #' as_html(tbl, class_table = "table") |
||
| 36 |
- # Check for format and parent row format+ #' ) |
||
| 37 | -105785x | +
- format <- if (missing(format)) obj_format(x) else format+ #' |
|
| 38 | -105785x | +
- if (is.null(format) && !is.null(pr_row_format)) {
+ #' Viewer(tbl, tbl2) |
|
| 39 | -73924x | +
- format <- pr_row_format+ #' } |
|
| 40 |
- }+ #' @export |
||
| 41 |
- # Check for na_str from parent+ Viewer <- function(x, y = NULL, ...) {
|
||
| 42 | -105785x | +3x |
- if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
+ check_convert <- function(x, name, accept_NULL = FALSE) {
|
| 43 | -87979x | +6x |
- na_str <- pr_row_na_str+ if (accept_NULL && is.null(x)) {
|
| 44 | -+ | 3x |
- }+ NULL |
| 45 | -+ | 3x |
-
+ } else if (is(x, "shiny.tag")) {
|
| 46 | -+ | ! |
- # Main call to external function or shell+ x |
| 47 | -105785x | +3x |
- if (shell) {
+ } else if (is(x, "VTableTree")) {
|
| 48 | -28179x | +3x |
- return(format)+ as_html(x, ...) |
| 49 |
- }+ } else {
|
||
| 50 | -77606x | +! |
- format_value(rawvalues(x),+ stop("object of class rtable or shiny tag excepted for ", name)
|
| 51 | -77606x | +
- format = format,+ } |
|
| 52 | -77606x | +
- output = output,+ } |
|
| 53 | -77606x | +
- na_str = na_str+ |
|
| 54 | -+ | 3x |
- )+ x_tag <- check_convert(x, "x", FALSE) |
| 55 | -+ | 3x |
- }+ y_tag <- check_convert(y, "y", TRUE) |
| 1 | +56 |
- #' Check if an object is a valid `rtable`+ |
||
| 2 | -+ | |||
| 57 | +3x |
- #'+ html_output <- if (is.null(y)) {
+ |
+ ||
| 58 | +3x | +
+ x_tag |
||
| 3 | +59 |
- #' @param x (`ANY`)\cr an object.+ } 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) |
||
| 4 | +64 |
- #'+ )) |
||
| 5 | +65 |
- #' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.+ } |
||
| 6 | +66 |
- #'+ + |
+ ||
| 67 | +3x | +
+ sandbox_folder <- file.path(tempdir(), "rtable") |
||
| 7 | +68 |
- #' @examples+ + |
+ ||
| 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) |
||
| 8 | +73 |
- #' is_rtable(build_table(basic_table(), iris))+ # list.files(sandbox_folder) |
||
| 9 | +74 |
- #'+ } |
||
| 10 | +75 |
- #' @export+ |
||
| 11 | +76 |
- is_rtable <- function(x) {
+ # get html name |
||
| 12 | -47x | +77 | +3x |
- is(x, "VTableTree")+ n_try <- 10000 |
| 13 | -+ | |||
| 78 | +3x |
- }+ for (i in seq_len(n_try)) {
+ |
+ ||
| 79 | +6x | +
+ htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
|
||
| 14 | +80 | |||
| 15 | -+ | |||
| 81 | +6x |
- # nocov start+ if (!file.exists(htmlFile)) {
|
||
| 16 | -+ | |||
| 82 | +3x |
- ## is each object in a collection from a class+ break |
||
| 17 | -+ | |||
| 83 | +3x |
- are <- function(object_collection, class2) {
+ } else if (i == n_try) {
+ |
+ ||
| 84 | +! | +
+ stop("too many html rtables created, restart your session")
|
||
| 18 | +85 |
- all(vapply(object_collection, is, logical(1), class2))+ } |
||
| 19 | +86 |
- }+ } |
||
| 20 | +87 | |||
| 21 | -+ | |||
| 88 | +3x |
- num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
+ 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" |
||
| 22 | +96 |
- stopifnot(is.numeric(x))+ ),+ |
+ ||
| 97 | +3x | +
+ tags$title("rtable"),
+ |
+ ||
| 98 | +3x | +
+ tags$link(+ |
+ ||
| 99 | +3x | +
+ href = "css/bootstrap.min.css",+ |
+ ||
| 100 | +3x | +
+ rel = "stylesheet" |
||
| 23 | +101 |
-
+ ) |
||
| 24 | +102 |
- if (length(x) == 1) {
+ ),+ |
+ ||
| 103 | +3x | +
+ tags$body(+ |
+ ||
| 104 | +3x | +
+ html_output |
||
| 25 | +105 |
- return(TRUE)+ ) |
||
| 26 | +106 |
- }+ ) |
||
| 27 | +107 | |||
| 28 | -+ | |||
| 108 | +3x |
- y <- range(x) / mean(x)+ cat( |
||
| 29 | -+ | |||
| 109 | +3x |
- isTRUE(all.equal(y[1], y[2], tolerance = tol))+ paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
+ |
+ ||
| 110 | +3x | +
+ file = htmlFile, append = FALSE |
||
| 30 | +111 |
- }+ ) |
||
| 31 | +112 | |||
| 113 | +3x | +
+ viewer <- getOption("viewer")
+ |
+ ||
| 32 | +114 |
- # copied over from utils.nest which is not open-source+ + |
+ ||
| 115 | +3x | +
+ if (!is.null(viewer)) {
+ |
+ ||
| 116 | +3x | +
+ viewer(htmlFile) |
||
| 33 | +117 |
- all_true <- function(lst, fcn, ...) {
+ } else {
+ |
+ ||
| 118 | +! | +
+ browseURL(htmlFile) |
||
| 34 | +119 |
- all(vapply(lst, fcn, logical(1), ...))+ } |
||
| 35 | +120 |
} |
| 36 | +1 |
-
+ #' Change indentation of all `rrows` in an `rtable` |
||
| 37 | +2 |
- is_logical_single <- function(x) {
+ #' |
||
| 38 | +3 |
- !is.null(x) &&+ #' Change indentation of all `rrows` in an `rtable` |
||
| 39 | +4 |
- is.logical(x) &&+ #' |
||
| 40 | +5 |
- length(x) == 1 &&+ #' @param x (`VTableTree`)\cr an `rtable` object. |
||
| 41 | +6 |
- !is.na(x)+ #' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is |
||
| 42 | +7 |
- }+ #' less than 0, the indentation is set to 0. |
||
| 43 | +8 |
-
+ #' |
||
| 44 | +9 |
- is_logical_vector_modif <- function(x, min_length = 1) {
+ #' @return `x` with its indent modifier incremented by `by`. |
||
| 45 | +10 |
- !is.null(x) &&+ #' |
||
| 46 | +11 |
- is.logical(x) &&+ #' @examples |
||
| 47 | +12 |
- is.atomic(x) &&+ #' is_setosa <- iris$Species == "setosa" |
||
| 48 | +13 |
- !anyNA(x) &&+ #' m_tbl <- rtable( |
||
| 49 | +14 |
- ifelse(min_length > 0, length(x) >= min_length, TRUE)+ #' header = rheader( |
||
| 50 | +15 |
- }+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
|
||
| 51 | +16 |
- # nocov end+ #' rrow(NULL, "mean", "median", "mean", "median") |
||
| 52 | +17 |
-
+ #' ), |
||
| 53 | +18 |
- # Shorthand for functions that take df as first parameter+ #' rrow( |
||
| 54 | +19 |
- .takes_df <- function(f) {
+ #' row.name = "All Species", |
||
| 55 | -1595x | +|||
| 20 | +
- func_takes(f, "df", is_first = TRUE)+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
|||
| 56 | +21 |
- }+ #' mean(iris$Petal.Length), median(iris$Petal.Length), |
||
| 57 | +22 |
-
+ #' format = "xx.xx" |
||
| 58 | +23 |
- # Checking if function takes parameters+ #' ), |
||
| 59 | +24 |
- func_takes <- function(func, params, is_first = FALSE) {
+ #' rrow( |
||
| 60 | -10825x | +|||
| 25 | +
- if (is.list(func)) {
+ #' row.name = "Setosa", |
|||
| 61 | -2252x | +|||
| 26 | +
- return(lapply(func, func_takes, params = params, is_first = is_first))+ #' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]), |
|||
| 62 | +27 |
- }+ #' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]), |
||
| 63 | -8573x | +|||
| 28 | +
- if (is.null(func) || !is(func, "function")) {
+ #' format = "xx.xx" |
|||
| 64 | +29 |
- # safe-net: should this fail instead?+ #' ) |
||
| 65 | -1750x | +|||
| 30 | +
- return(setNames(rep(FALSE, length(params)), params))+ #' ) |
|||
| 66 | +31 |
- }+ #' indent(m_tbl) |
||
| 67 | -6823x | +|||
| 32 | +
- f_params <- formals(func)+ #' indent(m_tbl, 2) |
|||
| 68 | -6823x | +|||
| 33 | +
- if (!is_first) {
+ #' |
|||
| 69 | -2247x | +|||
| 34 | +
- return(setNames(params %in% names(f_params), params))+ #' @export |
|||
| 70 | +35 |
- } else {
+ indent <- function(x, by = 1) {
|
||
| 71 | -4576x | +36 | +9x |
- if (length(params) > 1L) {
+ if (nrow(x) == 0 || by == 0) {
|
| 72 | -1x | +37 | +9x |
- stop("is_first works only with one parameters.")
+ return(x) |
| 73 | +38 |
- }+ } |
||
| 74 | -4575x | +|||
| 39 | +
- return(!is.null(f_params) && names(f_params)[1] == params)+ |
|||
| 75 | -+ | |||
| 40 | +! |
- }+ indent_mod(x) <- indent_mod(x) + by+ |
+ ||
| 41 | +! | +
+ x |
||
| 76 | +42 |
} |
||
| 77 | +43 | |||
| 78 | +44 |
- #' Translate spl_context to a path to display in error messages+ #' Clear all indent modifiers from a table |
||
| 79 | +45 |
#' |
||
| 80 | +46 |
- #' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred.+ #' @inheritParams gen_args |
||
| 81 | +47 |
#' |
||
| 82 | +48 |
- #' @return A character string containing a description of the row path corresponding to `ctx`.+ #' @return The same class as `tt`, with all indent modifiers set to zero. |
||
| 83 | +49 |
#' |
||
| 84 | +50 |
- #' @export+ #' @examples |
||
| 85 | +51 |
- spl_context_to_disp_path <- function(ctx) {
+ #' lyt1 <- basic_table() %>% |
||
| 86 | +52 |
- ## this can happen in the first split in column space, but+ #' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
|
||
| 87 | +53 |
- ## should never happen in row space+ #' split_rows_by("AEBODSYS", child_labels = "visible") %>%
|
||
| 88 | -13x | +|||
| 54 | +
- if (length(ctx$split) == 0) {
+ #' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
|
|||
| 89 | -2x | +|||
| 55 | +
- return("root")
+ #' analyze("AGE", indent_mod = -1L)
|
|||
| 90 | +56 |
- }+ #' |
||
| 91 | -11x | +|||
| 57 | +
- if (ctx$split[1] == "root" && ctx$value[1] == "root") {
+ #' tbl1 <- build_table(lyt1, ex_adae) |
|||
| 92 | -10x | +|||
| 58 | +
- ctx <- ctx[-1, ]+ #' tbl1 |
|||
| 93 | +59 |
- }+ #' clear_indent_mods(tbl1) |
||
| 94 | -11x | +|||
| 60 | +
- ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
+ #' |
|||
| 95 | -11x | +|||
| 61 | +
- collapse = "->"+ #' @export |
|||
| 96 | +62 |
- )+ #' @rdname clear_imods |
||
| 97 | -11x | +63 | +40x |
- if (length(ret) == 0 || nchar(ret) == 0) {
+ setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
|
| 98 | -4x | +|||
| 64 | +
- ret <- "root"+ |
|||
| 99 | +65 |
- }+ #' @export |
||
| 100 | -11x | +|||
| 66 | +
- ret+ #' @rdname clear_imods |
|||
| 101 | +67 |
- }+ setMethod( |
||
| 102 | +68 |
-
+ "clear_indent_mods", "VTableTree", |
||
| 103 | +69 |
- # Utility function to paste vector of values in a nice way+ function(tt) {
|
||
| 104 | -+ | |||
| 70 | +25x |
- paste_vec <- function(vec) {
+ ct <- content_table(tt) |
||
| 105 | -7x | +71 | +25x |
- paste0('c("', paste(vec, collapse = '", "'), '")')
+ if (!is.null(ct)) {
|
| 106 | -+ | |||
| 72 | +9x |
- }+ content_table(tt) <- clear_indent_mods(ct) |
||
| 107 | +73 |
-
+ } |
||
| 108 | -+ | |||
| 74 | +25x |
- # Utility for checking if a package is installed+ tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)+ |
+ ||
| 75 | +25x | +
+ indent_mod(tt) <- 0L+ |
+ ||
| 76 | +25x | +
+ tt |
||
| 109 | +77 |
- check_required_packages <- function(pkgs) {
+ } |
||
| 110 | -28x | +|||
| 78 | +
- for (pkgi in pkgs) {
+ ) |
|||
| 111 | -32x | +|||
| 79 | +
- if (!requireNamespace(pkgi, quietly = TRUE)) {
+
|
|||
| 112 | -1x | +|||
| 80 | +
- stop(+ #' @export |
|||
| 113 | -1x | +|||
| 81 | +
- "This function requires the ", pkgi, " package. ",+ #' @rdname clear_imods |
|||
| 114 | -1x | +|||
| 82 | +
- "Please install it if you wish to use it"+ setMethod( |
|||
| 115 | +83 |
- )+ "clear_indent_mods", "TableRow", |
||
| 116 | +84 |
- }+ function(tt) {
+ |
+ ||
| 85 | +15x | +
+ indent_mod(tt) <- 0L+ |
+ ||
| 86 | +15x | +
+ tt |
||
| 117 | +87 |
} |
||
| 118 | +88 |
- }+ ) |
||
| 28 | -1257x | +1351x |
setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))
|
@@ -145663,7 +152467,7 @@ |
| 34 | -919x | +1013x |
function(x, ...) in_rows("Mean" = rcell(mean(x, ...), format = "xx.xx"))
|