Nothing
## Rules for pagination
##
## 1. user defined number of lines per page
## 2. all lines have the same height
## 3. header always reprinted on all pages
## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE)
## 5. Never (?) break on a "label"/content row
## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table.
##
## Current behavior: paginate_ttree takes a TableTree object and
## returns a list of rtable (S3) objects for printing.
#' @inheritParams formatters::nlines
#'
#' @rdname formatters_methods
#' @aliases nlines,TableRow-method
#' @exportMethod nlines
setMethod(
"nlines", "TableRow",
function(x, colwidths, max_width, fontspec, col_gap = 3) {
fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) +
sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))
fcells <- as.vector(get_formatted_cells(x))
spans <- row_cspans(x)
have_cw <- !is.null(colwidths)
## handle spanning so that the projected word-wrapping from nlines is correct
if (any(spans > 1)) {
new_fcells <- character(length(spans))
new_colwidths <- numeric(length(spans))
cur_fcells <- fcells
cur_colwidths <- colwidths[-1] ## not the row labels they can't span
for (i in seq_along(spans)) {
spi <- spans[i]
new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop
new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1)
cur_fcells <- tail(cur_fcells, -1 * spi)
cur_colwidths <- tail(cur_colwidths, -1 * spi)
}
if (have_cw) {
colwidths <- c(colwidths[1], new_colwidths)
}
fcells <- new_fcells
}
## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE),
## length,
## 1L))
rowext <- max(
unlist(
mapply(
function(s, w) {
nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec)
},
s = c(obj_label(x), fcells),
w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
SIMPLIFY = FALSE
)
)
)
rowext + fns
}
)
#' @export
#' @rdname formatters_methods
setMethod(
"nlines", "LabelRow",
function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
if (labelrow_visible(x)) {
nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) +
sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))
} else {
0L
}
}
)
#' @export
#' @rdname formatters_methods
setMethod(
"nlines", "RefFootnote",
function(x, colwidths, max_width, fontspec, col_gap = NULL) {
nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
}
)
#' @export
#' @rdname formatters_methods
setMethod(
"nlines", "InstantiatedColumnInfo",
function(x, colwidths, max_width, fontspec, col_gap = 3) {
h_rows <- .do_tbl_h_piece2(x)
tl <- top_left(x) %||% rep("", length(h_rows))
main_nls <- vapply(
seq_along(h_rows),
function(i) {
max(
nlines(h_rows[[i]],
colwidths = colwidths,
fontspec = fontspec,
col_gap = col_gap
),
nlines(tl[i],
colwidths = colwidths[1],
fontspec = fontspec
)
)
},
1L
)
## lfs <- collect_leaves(coltree(x))
## depths <- sapply(lfs, function(l) length(pos_splits(l)))
coldf <- make_col_df(x, colwidths = colwidths)
have_fnotes <- length(unlist(coldf$col_fnotes)) > 0
## ret <- max(depths, length(top_left(x))) +
## divider_height(x)
ret <- sum(main_nls, divider_height(x))
if (have_fnotes) {
ret <- sum(
ret,
vapply(unlist(coldf$col_fnotes),
nlines,
1,
max_width = max_width,
fontspec = fontspec
),
2 * divider_height(x)
)
}
ret
}
)
col_dfrow <- function(col,
nm = obj_name(col),
lab = obj_label(col),
cnum,
pth = NULL,
sibpos = NA_integer_,
nsibs = NA_integer_,
leaf_indices = cnum,
span = length(leaf_indices),
col_fnotes = list(),
col_count = facet_colcount(col, NULL),
ccount_visible = disp_ccounts(col),
ccount_format = colcount_format(col),
ccount_na_str,
global_cc_format) {
if (is.null(pth)) {
pth <- pos_to_path(tree_pos(col))
}
data.frame(
stringsAsFactors = FALSE,
name = nm,
label = lab,
abs_pos = cnum,
path = I(list(pth)),
pos_in_siblings = sibpos,
n_siblings = nsibs,
leaf_indices = I(list(leaf_indices)),
total_span = span,
col_fnotes = I(list(col_fnotes)),
n_col_fnotes = length(col_fnotes),
col_count = col_count,
ccount_visible = ccount_visible,
ccount_format = ccount_format %||% global_cc_format,
ccount_na_str = ccount_na_str
)
}
pos_to_path <- function(pos) {
spls <- pos_splits(pos)
vals <- pos_splvals(pos)
path <- character()
for (i in seq_along(spls)) {
nm <- obj_name(spls[[i]])
val_i <- value_names(vals[[i]])
path <- c(
path,
obj_name(spls[[i]]),
## rawvalues(vals[[i]]))
if (!is.na(val_i)) val_i
)
}
path
}
# make_row_df ---------------------------------------------------------------
#' @inherit formatters::make_row_df
#'
# #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and
# #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination.
# #'
# #' @return a data.frame of row/column-structure information used by the pagination machinery.
# #'
# #' @export
# #' @name make_row_df
# #' @rdname make_row_df
# #' @aliases make_row_df,VTableTree-method
#' @rdname formatters_methods
#' @exportMethod make_row_df
setMethod(
"make_row_df", "VTableTree",
function(tt,
colwidths = NULL,
visible_only = TRUE,
rownum = 0,
indent = 0L,
path = character(),
incontent = FALSE,
repr_ext = 0L,
repr_inds = integer(),
sibpos = NA_integer_,
nsibs = NA_integer_,
max_width = NULL,
fontspec = NULL,
col_gap = 3) {
indent <- indent + indent_mod(tt)
## retained for debugging info
orig_rownum <- rownum # nolint
if (incontent) {
path <- c(path, "@content")
} else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint
path <- c(path, obj_name(tt))
}
ret <- list()
## note this is the **table** not the label row
if (!visible_only) {
ret <- c(
ret,
list(pagdfrow(
rnum = NA,
nm = obj_name(tt),
lab = "",
pth = path,
colwidths = colwidths,
repext = repr_ext,
repind = list(repr_inds),
extent = 0,
indent = indent,
rclass = class(tt), sibpos = sibpos,
nsibs = nsibs,
nrowrefs = 0L,
ncellrefs = 0L,
nreflines = 0L,
fontspec = fontspec
))
)
}
if (labelrow_visible(tt)) {
lr <- tt_labelrow(tt)
newdf <- make_row_df(lr,
colwidths = colwidths,
visible_only = visible_only,
rownum = rownum,
indent = indent,
path = path,
incontent = TRUE,
repr_ext = repr_ext,
repr_inds = repr_inds,
max_width = max_width,
fontspec = fontspec
)
rownum <- max(newdf$abs_rownumber, na.rm = TRUE)
ret <- c(
ret,
list(newdf)
)
repr_ext <- repr_ext + 1L
repr_inds <- c(repr_inds, rownum)
indent <- indent + 1L
}
if (NROW(content_table(tt)) > 0) {
ct_tt <- content_table(tt)
cind <- indent + indent_mod(ct_tt)
trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt))
contdf <- make_row_df(ct_tt,
colwidths = colwidths,
visible_only = visible_only,
rownum = rownum,
indent = cind,
path = path,
incontent = TRUE,
repr_ext = repr_ext,
repr_inds = repr_inds,
max_width = max_width,
fontspec = fontspec
)
crnums <- contdf$abs_rownumber
crnums <- crnums[!is.na(crnums)]
newrownum <- max(crnums, na.rm = TRUE)
if (is.finite(newrownum)) {
rownum <- newrownum
repr_ext <- repr_ext + length(crnums)
repr_inds <- c(repr_inds, crnums)
}
ret <- c(ret, list(contdf))
indent <- cind + 1
}
allkids <- tree_children(tt)
newnsibs <- length(allkids)
for (i in seq_along(allkids)) {
kid <- allkids[[i]]
kiddfs <- make_row_df(kid,
colwidths = colwidths,
visible_only = visible_only,
rownum = force(rownum),
indent = indent, ## + 1,
path = path,
incontent = incontent,
repr_ext = repr_ext,
repr_inds = repr_inds,
nsibs = newnsibs,
sibpos = i,
max_width = max_width,
fontspec = fontspec
)
# print(kiddfs$abs_rownumber)
rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)
ret <- c(ret, list(kiddfs))
}
ret <- do.call(rbind, ret)
# Case where it has Elementary table or VTableTree section_div it is overridden
if (!is.na(trailing_section_div(tt))) {
ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt)
}
ret
}
)
# #' @exportMethod make_row_df
#' @inherit formatters::make_row_df
#'
#' @export
#' @rdname formatters_methods
setMethod(
"make_row_df", "TableRow",
function(tt, colwidths = NULL, visible_only = TRUE,
rownum = 0,
indent = 0L,
path = "root",
incontent = FALSE,
repr_ext = 0L,
repr_inds = integer(),
sibpos = NA_integer_,
nsibs = NA_integer_,
max_width = NULL,
fontspec,
col_gap = 3) {
indent <- indent + indent_mod(tt)
rownum <- rownum + 1
rrefs <- row_footnotes(tt)
crefs <- cell_footnotes(tt)
reflines <- sum(
sapply(
c(rrefs, crefs),
nlines,
colwidths = colwidths,
max_width = max_width,
fontspec = fontspec,
col_gap = col_gap
)
) ## col_gap not strictly necessary as these aren't rows, but why not
ret <- pagdfrow(
row = tt,
rnum = rownum,
colwidths = colwidths,
sibpos = sibpos,
nsibs = nsibs,
pth = c(path, unname(obj_name(tt))),
repext = repr_ext,
repind = repr_inds,
indent = indent,
extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),
## these two are unlist calls cause they come in lists even with no footnotes
nrowrefs = length(rrefs),
ncellrefs = length(unlist(crefs)),
nreflines = reflines,
trailing_sep = trailing_section_div(tt),
fontspec = fontspec
)
ret
}
)
# #' @exportMethod make_row_df
#' @export
#' @rdname formatters_methods
setMethod(
"make_row_df", "LabelRow",
function(tt, colwidths = NULL, visible_only = TRUE,
rownum = 0,
indent = 0L,
path = "root",
incontent = FALSE,
repr_ext = 0L,
repr_inds = integer(),
sibpos = NA_integer_,
nsibs = NA_integer_,
max_width = NULL,
fontspec,
col_gap = 3) {
rownum <- rownum + 1
indent <- indent + indent_mod(tt)
ret <- pagdfrow(tt,
extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),
rnum = rownum,
colwidths = colwidths,
sibpos = sibpos,
nsibs = nsibs,
pth = path,
repext = repr_ext,
repind = repr_inds,
indent = indent,
nrowrefs = length(row_footnotes(tt)),
ncellrefs = 0L,
nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_,
colwidths = colwidths,
max_width = max_width,
fontspec = fontspec,
col_gap = col_gap
)),
trailing_sep = trailing_section_div(tt),
fontspec = fontspec
)
if (!labelrow_visible(tt)) {
ret <- ret[0, , drop = FALSE]
}
ret
}
)
setGeneric("inner_col_df", function(ct,
colwidths = NULL,
visible_only = TRUE,
colnum = 0L,
sibpos = NA_integer_,
nsibs = NA_integer_,
ncolref = 0L,
na_str,
global_cc_format) {
standardGeneric("inner_col_df")
})
#' Column layout summary
#'
#' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a
#' `data.frame`.
#'
#' @inheritParams formatters::make_row_df
#' @param ccount_format (`FormatSpec`)\cr The format to be used by default for
#' column counts if one is not specified for an individual column count.
#' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this.
#' @export
make_col_df <- function(tt,
colwidths = NULL,
visible_only = TRUE,
na_str = "",
ccount_format = colcount_format(tt) %||% "(N=xx)") {
ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object
rows <- inner_col_df(ctree,
## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)),
colwidths = colwidths,
visible_only = visible_only,
colnum = 1L,
sibpos = 1L,
nsibs = 1L,
na_str = na_str,
global_cc_format = ccount_format
) ## nsiblings includes current so 1 means "only child"
do.call(rbind, rows)
}
setMethod(
"inner_col_df", "LayoutColLeaf",
function(ct, colwidths, visible_only,
colnum,
sibpos,
nsibs,
na_str,
global_cc_format) {
list(col_dfrow(
col = ct,
cnum = colnum,
sibpos = sibpos,
nsibs = nsibs,
leaf_indices = colnum,
col_fnotes = col_footnotes(ct),
ccount_na_str = na_str,
global_cc_format = global_cc_format
))
}
)
setMethod(
"inner_col_df", "LayoutColTree",
function(ct, colwidths, visible_only,
colnum,
sibpos,
nsibs,
na_str,
global_cc_format) {
kids <- tree_children(ct)
ret <- vector("list", length(kids))
for (i in seq_along(kids)) {
k <- kids[[i]]
newrows <- do.call(
rbind,
inner_col_df(k,
colnum = colnum,
sibpos = i,
nsibs = length(kids),
visible_only = visible_only,
na_str = na_str,
global_cc_format = global_cc_format
)
)
colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1
ret[[i]] <- newrows
}
if (!visible_only) {
allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)]))
thispth <- pos_to_path(tree_pos(ct))
if (any(nzchar(thispth))) {
thisone <- list(col_dfrow(
col = ct,
cnum = NA_integer_,
leaf_indices = allindices,
sibpos = sibpos,
nsibs = nsibs,
pth = thispth,
col_fnotes = col_footnotes(ct),
ccount_na_str = na_str,
global_cc_format = global_cc_format
))
ret <- c(thisone, ret)
}
}
ret
}
)
## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND
## title/subtitle!!!!!
.header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
if (any(nzchar(all_titles(tt)))) {
## +1 is for blank line between subtitles and divider
tlines <- sum(nlines(all_titles(tt),
colwidths = colwidths,
max_width = max_width,
fontspec = fontspec
)) + divider_height(tt) + 1L
} else {
tlines <- 0
}
ret <- cinfo_lines + tlines
if (verbose) {
message(
"Lines required for header content: ",
ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")"
)
}
ret
}
## this is ***only*** lines that are expected to be repeated on multiple pages:
## main footer, prov footer, and referential footnotes on **columns**
.footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
flines <- nlines(main_footer(tt),
colwidths = colwidths,
max_width = max_width - table_inset(tt),
fontspec = fontspec
) +
nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
if (flines > 0) {
dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)
flines <- flines + dl_contrib + 1L
}
if (verbose) {
message(
"Determining lines required for footer content",
if (have_cfnotes) " [column fnotes present]",
": ", flines, " lines"
)
}
flines
}
# Pagination ---------------------------------------------------------------
#' Pagination of a `TableTree`
#'
#' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size.
#'
#' @inheritParams gen_args
#' @inheritParams paginate_table
#' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows.
#' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a
#' mid-subtable split to be valid. Defaults to 2.
#' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other
#' considerations. Defaults to none.
#'
#' @return
#' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`.
#' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`.
#'
#' @details
#' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated
#' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the
#' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of
#' text than rendering the table without pagination would.
#'
#' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content.
#'
#' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`).
#'
#' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same
#' algorithm used for vertical pagination to it.
#'
#' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and
#' characters-per-page (`cpp`) values.
#'
#' The full multi-direction pagination algorithm then is as follows:
#'
#' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns):
#' - titles/footers/column labels, and horizontal dividers in the vertical pagination case
#' - row-labels, table_inset, and top-left materials in the horizontal case
#' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables.
#' 2. Perform vertical pagination separately on each table generated in (1).
#' 3. Perform horizontal pagination **on the entire table** and apply the results to each table
#' page generated in (1)-(2).
#' 4. Return a list of subtables representing full bi-directional pagination.
#'
#' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package:
#'
#' @inheritSection formatters::pagination_algo Pagination Algorithm
#'
#' @examples
#' s_summary <- function(x) {
#' if (is.numeric(x)) {
#' in_rows(
#' "n" = rcell(sum(!is.na(x)), format = "xx"),
#' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)),
#' format = "xx.xx (xx.xx)"
#' ),
#' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"),
#' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx")
#' )
#' } else if (is.factor(x)) {
#' vs <- as.list(table(x))
#' do.call(in_rows, lapply(vs, rcell, format = "xx"))
#' } else {
#' (
#' stop("type not supported")
#' )
#' }
#' }
#'
#' lyt <- basic_table() %>%
#' split_cols_by(var = "ARM") %>%
#' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' nrow(tbl)
#'
#' row_paths_summary(tbl)
#'
#' tbls <- paginate_table(tbl, lpp = 15)
#' mf <- matrix_form(tbl, indent_rownames = TRUE)
#' w_tbls <- propose_column_widths(mf) # so that we have the same column widths
#'
#'
#' tmp <- lapply(tbls, function(tbli) {
#' cat(toString(tbli, widths = w_tbls))
#' cat("\n\n")
#' cat("~~~~ PAGE BREAK ~~~~")
#' cat("\n\n")
#' })
#'
#' @rdname paginate
#' @export
pag_tt_indices <- function(tt,
lpp = 15,
min_siblings = 2,
nosplitin = character(),
colwidths = NULL,
max_width = NULL,
fontspec = NULL,
col_gap = 3,
verbose = FALSE) {
dheight <- divider_height(tt)
# cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width)
coldf <- make_col_df(tt, colwidths)
have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0
hlines <- .header_rep_nlines(tt,
colwidths = colwidths, max_width = max_width,
verbose = verbose,
fontspec = fontspec
)
## if(any(nzchar(all_titles(tt)))) {
## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) +
## length(wrap_txt(all_titles(tt), max_width = max_width)) +
## dheight + 1L
## } else {
## tlines <- 0
## }
## flines <- nlines(main_footer(tt), colwidths = colwidths,
## max_width = max_width - table_inset(tt)) +
## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width)
## if(flines > 0) {
## dl_contrib <- if(have_cfnotes) 0 else dheight
## flines <- flines + dl_contrib + 1L
## }
flines <- .footer_rep_nlines(tt,
colwidths = colwidths,
max_width = max_width,
have_cfnotes = have_cfnotes,
fontspec = fontspec,
verbose = verbose
)
## row lines per page
rlpp <- lpp - hlines - flines
if (verbose) {
message(
"Adjusted Lines Per Page: ",
rlpp, " (original lpp: ", lpp, ")"
)
}
pagdf <- make_row_df(tt, colwidths, max_width = max_width)
pag_indices_inner(pagdf,
rlpp = rlpp, min_siblings = min_siblings,
nosplitin = nosplitin,
verbose = verbose,
have_col_fnotes = have_cfnotes,
div_height = dheight,
col_gap = col_gap,
has_rowlabels = TRUE
)
}
copy_title_footer <- function(to, from, newptitle) {
main_title(to) <- main_title(from)
subtitles(to) <- subtitles(from)
page_titles(to) <- c(page_titles(from), newptitle)
main_footer(to) <- main_footer(from)
prov_footer(to) <- prov_footer(from)
to
}
pag_btw_kids <- function(tt) {
pref <- ptitle_prefix(tt)
lapply(
tree_children(tt),
function(tbl) {
tbl <- copy_title_footer(
tbl, tt,
paste(pref, obj_label(tbl), sep = ": ")
)
labelrow_visible(tbl) <- FALSE
tbl
}
)
}
force_paginate <- function(tt,
force_pag = vapply(tree_children(tt), has_force_pag, NA),
verbose = FALSE) {
## forced pagination is happening at this
if (has_force_pag(tt)) {
ret <- pag_btw_kids(tt)
return(unlist(lapply(ret, force_paginate)))
}
chunks <- list()
kinds <- seq_along(force_pag)
while (length(kinds) > 0) {
if (force_pag[kinds[1]]) {
outertbl <- copy_title_footer(
tree_children(tt)[[kinds[1]]],
tt,
NULL
)
chunks <- c(chunks, force_paginate(outertbl))
kinds <- kinds[-1]
} else {
tmptbl <- tt
runend <- min(which(force_pag[kinds]), length(kinds))
useinds <- 1:runend
tree_children(tmptbl) <- tree_children(tt)[useinds]
chunks <- c(chunks, tmptbl)
kinds <- kinds[-useinds]
}
}
unlist(chunks, recursive = TRUE)
}
#' @importFrom formatters do_forced_paginate
setMethod(
"do_forced_paginate", "VTableTree",
function(obj) force_paginate(obj)
)
non_null_na <- function(x) !is.null(x) && is.na(x)
#' @inheritParams formatters::vert_pag_indices
#' @inheritParams formatters::page_lcpp
#' @inheritParams formatters::toString
#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination.
#' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal
#' pagination should be done regardless of page size.
#'
#' @rdname paginate
#' @aliases paginate_table
#' @export
paginate_table <- function(tt,
page_type = "letter",
font_family = "Courier",
font_size = 8,
lineheight = 1,
landscape = FALSE,
pg_width = NULL,
pg_height = NULL,
margins = c(top = .5, bottom = .5, left = .75, right = .75),
lpp = NA_integer_,
cpp = NA_integer_,
min_siblings = 2,
nosplitin = character(),
colwidths = NULL,
tf_wrap = FALSE,
max_width = NULL,
fontspec = font_spec(font_family, font_size, lineheight),
col_gap = 3,
verbose = FALSE) {
new_dev <- open_font_dev(fontspec)
if (new_dev) {
on.exit(close_font_dev())
}
if ((non_null_na(lpp) || non_null_na(cpp)) &&
(!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
pg_lcpp <- page_lcpp(
page_type = page_type,
font_family = font_family,
font_size = font_size,
lineheight = lineheight,
pg_width = pg_width,
pg_height = pg_height,
margins = margins,
landscape = landscape,
fontspec = fontspec
)
if (non_null_na(lpp)) {
lpp <- pg_lcpp$lpp
}
if (is.na(cpp)) {
cpp <- pg_lcpp$cpp
}
} else {
if (non_null_na(cpp)) {
cpp <- NULL
}
if (non_null_na(lpp)) {
lpp <- 70
}
}
if (is.null(colwidths)) {
colwidths <- propose_column_widths(
matrix_form(
tt,
indent_rownames = TRUE,
fontspec = fontspec,
col_gap = col_gap
),
fontspec = fontspec
)
}
if (!tf_wrap) {
if (!is.null(max_width)) {
warning("tf_wrap is FALSE - ignoring non-null max_width value.")
}
max_width <- NULL
} else if (is.null(max_width)) {
max_width <- cpp
} else if (identical(max_width, "auto")) {
## XXX this 3 is column sep width!!!!!!!
max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1)
}
if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
warning("max_width specified is wider than characters per page width (cpp).")
}
## taken care of in vert_pag_indices now
## if(!is.null(cpp))
## cpp <- cpp - table_inset(tt)
force_pag <- vapply(tree_children(tt), has_force_pag, TRUE)
if (has_force_pag(tt) || any(force_pag)) {
spltabs <- do_forced_paginate(tt)
spltabs <- unlist(spltabs, recursive = TRUE)
ret <- lapply(spltabs, paginate_table,
lpp = lpp,
cpp = cpp,
min_siblings = min_siblings,
nosplitin = nosplitin,
colwidths = colwidths,
tf_wrap = tf_wrap,
max_width = max_width,
fontspec = fontspec,
verbose = verbose,
col_gap = col_gap
)
return(unlist(ret, recursive = TRUE))
}
inds <- paginate_indices(tt,
page_type = page_type,
fontspec = fontspec,
## font_family = font_family,
## font_size = font_size,
## lineheight = lineheight,
landscape = landscape,
pg_width = pg_width,
pg_height = pg_height,
margins = margins,
lpp = lpp,
cpp = cpp,
min_siblings = min_siblings,
nosplitin = nosplitin,
colwidths = colwidths,
tf_wrap = tf_wrap,
max_width = max_width,
col_gap = col_gap,
verbose = verbose
) ## paginate_table apparently doesn't accept indent_size
res <- lapply(
inds$pag_row_indices,
function(ii) {
subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]
lapply(
inds$pag_col_indices,
function(jj) {
subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]
}
)
}
)
res <- unlist(res, recursive = FALSE)
res
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.