Nothing
context("Pagination")
test_that("Page by splitting works", {
lyt <- basic_table(title = "big title") %>%
split_rows_by("SEX", page_by = TRUE) %>%
analyze("AGE")
tt <- build_table(lyt, DM)
ttlst <- paginate_table(tt)
expect_identical(
names(ttlst),
levels(DM$SEX)
)
expect_error(
{
basic_table(title = "big title") %>%
analyze("AGE") %>%
split_rows_by("SEX", page_by = TRUE) %>%
analyze("AGE")
},
"page_by splits cannot have top-level siblings"
)
expect_error(
{
basic_table() %>%
split_rows_by("SEX") %>%
split_rows_by("ARM", page_by = TRUE) %>%
analyze("AGE")
},
"page_by splits cannot be nested within non-page_by splits"
)
lyt2 <- basic_table(
title = "main title",
subtitles = "subtitle",
main_footer = "main footer",
prov_footer = "provenance footer"
) %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>%
split_rows_by("STRATA1", split_fun = keep_split_levels(c("A", "B")), page_by = TRUE, page_prefix = "Stratum") %>%
split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
summarize_row_groups() %>%
analyze("AGE", afun = function(x, ...) {
in_rows(
"mean (sd)" = rcell(
c(mean(x), sd(x)),
format = "xx.x (xx.x)"
),
"range" = rcell(range(x), format = "xx.x - xx.x")
)
})
tbl2 <- build_table(lyt2, ex_adsl)
ttlst2 <- paginate_table(tbl2, lpp = 16, cpp = 55)
expect_equal(
length(ttlst2),
8
)
txt <- export_as_txt(tbl2, lpp = 16, cpp = 55)
expect_true(grepl("Stratum: B", txt))
})
test_that("export_as_txt prints split level header correctly when using page_by", {
# single level in page_by split
tbl <- basic_table() %>%
split_rows_by("PARAMCD",
labels_var = "PARAMCD", split_label = "aaa",
label_pos = "topleft",
split_fun = drop_split_levels, page_by = TRUE
) %>%
split_rows_by("AVISIT",
label_pos = "topleft",
split_fun = keep_split_levels("SCREENING")
) %>%
analyze("AVAL") %>%
build_table(ex_adlb[ex_adlb$PARAMCD == "ALT", ])
tbl_txt <- tbl %>% export_as_txt(lpp = 100)
expect_true(grepl("^\naaa: ALT", tbl_txt))
# multiple levels in page_by split
tbl <- basic_table() %>%
split_rows_by("PARAMCD",
labels_var = "PARAMCD", split_label = "aaa",
label_pos = "topleft",
split_fun = drop_split_levels, page_by = TRUE
) %>%
split_rows_by("AVISIT",
label_pos = "topleft",
split_fun = keep_split_levels("SCREENING")
) %>%
analyze("AVAL") %>%
build_table(ex_adlb[ex_adlb$PARAMCD != "IGA", ])
tbl_txt <- tbl %>% export_as_txt(lpp = 100)
expect_true(grepl("^\naaa: ALT", tbl_txt))
expect_true(grepl("\naaa: CRP", tbl_txt))
})
test_that("vertical and horizontal pagination work", {
spoof_df <- data.frame(
arm = factor(c("a", "b", "c", "d", "e", "f")),
var1 = 6
)
simple_lyt <- basic_table() %>%
split_cols_by("arm") %>%
analyze("var1", function(x, ...) {
in_rows(
.list = replicate(30, list(1234)),
.names = paste0("mynameis", 1:30)
)
})
simple_tbl <- build_table(simple_lyt, spoof_df)
## rownames take up 10 char, repeated across horiz pag
## colheader takes up 2, repeated across vert pag
## all columns take up 7 (4 for content + 3 for cols sep)
## should be one col per page, i.e. 6 pages
hpag1 <- paginate_table(simple_tbl, lpp = 80, cpp = 17)
expect_equal(
rep(1, 6),
sapply(hpag1, ncol)
)
## 16 is too small to fit any columns (After col divider)
## onto a page with the row names, so this is an error
expect_error(paginate_table(simple_tbl, lpp = 80, cpp = 16))
## 23 is just barely still only enough to fit 1 col per page
hpag2 <- paginate_table(simple_tbl, lpp = 80, cpp = 23)
expect_identical(hpag1, hpag2)
hpag3 <- paginate_table(simple_tbl, lpp = 80, cpp = 24, verbose = TRUE)
expect_equal(
rep(2, 3),
sapply(hpag3, ncol)
)
## preceding siblings <2
expect_error(paginate_table(simple_tbl, lpp = 3, cpp = 120))
vpag1 <- paginate_table(simple_tbl, lpp = 3, cpp = 120, min_siblings = 0)
expect_equal(
rep(1, 30),
sapply(vpag1, nrow)
)
## no lines for rows after header column
expect_error(paginate_table(simple_tbl, lpp = 2, cpp = 120, min_siblings = 0))
## first lpp that allows the default min_siblings = 2 to succeed,
## 3 rows per page, 10 pages
vpag2 <- paginate_table(simple_tbl, lpp = 5, cpp = 120)
expect_equal(
rep(3, 10),
sapply(vpag2, nrow)
)
## uneven pages, 8, 8, 8, 6 rows
vpag3 <- paginate_table(simple_tbl, lpp = 10, cpp = 120)
expect_equal(
c(8, 8, 8, 6),
sapply(vpag3, nrow)
)
## combined pagination
cpag1 <- paginate_table(simple_tbl, lpp = 5, cpp = 17)
expect_equal(
replicate(60, list(c(3, 1))),
lapply(cpag1, dim)
)
## ordering: horizontal pagination first then vertical in resulting list
expect_equal(
sapply(cpag1, names),
rep(c("a", "b", "c", "d", "e", "f"), 10)
)
tt <- tt_to_export()
main_title(tt) <- "main title"
main_footer(tt) <- "main footer"
subtitles(tt) <- c("sub", "titles")
prov_footer(tt) <- "prov footer"
res <- paginate_table(tt, lpp = NULL, cpp = 40)
expect_identical(length(res), 3L)
expect_identical(
tt[, 1:2, keep_titles = TRUE, reindex_refs = FALSE],
res[[1]]
)
## this was lpp = 75, but manual line counting suggests that
## was a bad test, enforcing an off-by-one error.
res2 <- paginate_table(tt, lpp = 76, cpp = 45, verbose = TRUE)
expect_identical(length(res2), 6L)
expect_identical(
res2[[1]],
tt[1:63, 1:2, keep_titles = TRUE, reindex_refs = FALSE]
)
expect_identical(
res2[[2]],
tt[1:63, 3:4, keep_titles = TRUE, reindex_refs = FALSE]
)
expect_identical(
res2[[4]],
tt[c(38, 57, 64:NROW(tt)), 1:2, keep_titles = TRUE, reindex_refs = FALSE]
)
expect_identical(
main_title(tt),
main_title(res[[1]])
)
expect_identical(subtitles(tt), subtitles(res[[2]]))
expect_identical(main_footer(tt), main_footer(res[[3]]))
expect_identical(prov_footer(tt), prov_footer(res[[1]]))
res2b <- paginate_table(tt, lpp = 75, cpp = 45, colwidths = c(12, rep(7, times = 6)))
## XXX TODO do careful analuysis to ensure this is actually right.
expect_identical(nrow(res2b[[1]]), 59L)
expect_identical(vapply(res2b, ncol, 1L), rep(3L, 4))
## topleft perservation
top_left(tt) <- "hahaha I'm a topleft"
res3 <- paginate_table(tt, lpp = 75, cpp = 45)
expect_identical(top_left(tt), top_left(res3[[1]]))
lyt2 <- basic_table() %>%
analyze(
"mpg",
function(x) in_rows(.list = setNames(as.list(x), as.character(seq_along(x))))
)
tt2 <- build_table(lyt2, cbind(mtcars, mtcars))
main_title(tt2) <- paste(
strrep("a", 25),
strrep("A", 25)
)
subtitles(tt2) <- c(
paste(
strrep("a", 25),
strrep("A", 25)
),
"sub titles"
)
main_footer(tt2) <- paste(
strrep("a", 25),
strrep("A", 25)
)
prov_footer(tt2) <- paste(
strrep("a", 25),
strrep("A", 25)
)
res3a <- paginate_table(tt2,
lpp = 29,
cpp = 40, tf_wrap = TRUE
)
res3b <- paginate_table(tt2,
lpp = 25,
cpp = 40, tf_wrap = FALSE
)
expect_true(all(
mapply(function(a, b) identical(dim(a), dim(b)), a = res3a, b = res3b)
))
res3c <- paginate_table(tt2, lpp = 29, cpp = 40, tf_wrap = FALSE)
expect_equal(
nrow(res3a[[1]]),
nrow(res3c[[1]]) - 4
)
})
test_that("inset and pagination work together", {
tt <- tt_to_export()
main_title(tt) <- "main title"
subtitles(tt) <- c("sub", "-------", "titles")
main_footer(tt) <- "main footer"
prov_footer(tt) <- "prov footer"
table_inset(tt) <- 5
res <- paginate_table(tt, lpp = NULL, cpp = 45, verbose = TRUE)
expect_identical(length(res), 3L)
expect_identical(
tt[, 1:2, keep_titles = TRUE, reindex_refs = FALSE],
res[[1]]
)
expect_identical(
main_title(tt),
main_title(res[[1]])
)
expect_identical(subtitles(tt), subtitles(res[[2]]))
expect_identical(main_footer(tt), main_footer(res[[3]]))
expect_identical(prov_footer(tt), prov_footer(res[[1]]))
})
test_that("cell and column wrapping works in pagination", {
# Set colwidths vector
clw <- c(5, 7, 6, 6) + 12
lpp_tmp <- 18
## header mats: 5 [ 1 (title) + 2 (newline + div) + 1 (col labels) + 1 (div)]
## footer mats: 3 [ 1 (footer) + 2 (newline + div)
## adj rlpp: 10
## all rows fit on one page
res1 <- pag_tt_indices(tt_for_wrap, lpp = lpp_tmp)
expect_equal(length(res1), 1L)
## header mats: 7 [ 1 (title) + 2 (newline + div) + 3 (col labels) + 1 (div)]
## footer mats: 3 [ 1 (footer) + 2 (newline + div)
## adj rlpp: 8
## can't break after on BLACK OR AFRICAN AMERICAN row (label)
## 2 pages, one after full asian block, one after full BOAA block
res2 <- pag_tt_indices(tt_for_wrap, lpp = lpp_tmp, colwidths = clw)
expect_identical(
res2,
list(1:5, 6:10)
)
expect_identical(
nlines(col_info(tt_for_wrap), colwidths = clw, fontspec = NULL),
nlines(col_info(tt_for_wrap), fontspec = NULL) + 2L
) ## 2 new lines from wrapping
pdf <- make_row_df(tt_for_wrap, colwidths = clw)
expect_identical(
pdf$self_extent,
c(
1L, 1L, 1L, 1L, 3L,
2L, 1L, 1L, 1L, 3L
)
) ## the 2 is row label wrap, 3s are cell wraps
# propose_column_widths(matrix_form(tt_for_wrap, TRUE))
pg_tbl_w_clw <- paginate_table(tt_for_wrap, lpp = lpp_tmp, cpp = NULL, colwidths = clw)
pg_tbl_no_clw <- paginate_table(tt_for_wrap, lpp = lpp_tmp, cpp = NULL, verbose = TRUE)
res1 <- toString(matrix_form(pg_tbl_no_clw[[1]], TRUE))
res2 <- toString(matrix_form(tt_for_wrap, TRUE))
# The table should have 18 lines and 10 rows when it is not cell wrapped
expect_identical(nrow(pg_tbl_no_clw[[1]]) + nrow(tt_for_wrap), 20L)
expect_identical(.count_chr_from_str(res1, "\n") + .count_chr_from_str(res2, "\n"), 36L)
## entire table takes exactly 25 lines when content is wrapped
result <- paginate_table(tt_for_wrap, colwidths = clw, lpp = 25L, cpp = NULL)
expect_identical(result[[1]], tt_for_wrap)
## paginating at 24 walks up
## 10 row too long with wrap -> 9 label row -> 8 ok
## paginates after row 8 (BOAA -> AGE-> Mean)
result2 <- paginate_table(tt_for_wrap, colwidths = clw, lpp = 24L, cpp = NULL)
expect_identical(
sapply(result2, nrow),
c(8L, 3L)
)
result_str <- toString(result[[1]], widths = clw)
expect_identical(.count_chr_from_str(result_str, "\n"), 25L)
## Testing if the split happens with the right number of lines w/ pagination
# Taking header and footer size (should be 10L with wrapping)
tot_lines_w <- .count_chr_from_str(result_str, "\n") # 25L
nr_res_w <- nrow(tt_for_wrap) + 5L # Cell (+ 2*2 l) and row values wrapping (+1 l)
non_content_lines <- tot_lines_w - nr_res_w
expect_identical(non_content_lines, 10L) # headers and footers with wrapping (+2 l)
# Checking if the pages have the right amount of pages
resw1 <- toString(result2[[1]], widths = clw)
resw2 <- toString(result2[[2]], widths = clw) # context repetition is +2 lines
exp_n_lines1 <- nrow(result2[[1]]) +
non_content_lines +
2L + # Wrap of cell value
1L # Wrap of rowname
exp_n_lines2 <- nrow(result2[[2]]) +
non_content_lines +
2L + # Wrap of cell value
1L # Wrapping of rowname
expect_identical(exp_n_lines1, .count_chr_from_str(resw1, "\n"))
expect_identical(exp_n_lines2, .count_chr_from_str(resw2, "\n"))
# Checking if the global number of lines is correctly split into pages
paginated_lines <- exp_n_lines1 +
exp_n_lines2 -
non_content_lines - # Repeated header and footer
2L # Repeated rowname for context and its wrapping
expect_identical(paginated_lines, tot_lines_w)
})
test_that("Pagination works with section dividers", {
lyt <- basic_table(title = "big title") %>%
split_rows_by("SEX", section_div = "~") %>%
split_rows_by("ARM") %>%
analyze("AGE")
tt <- build_table(lyt, DM)
ttlst <- paginate_table(tt, lpp = 20)
expect_identical(length(ttlst), 2L)
expect_identical(
tt[1:14, keep_titles = TRUE, reindex_refs = FALSE],
ttlst[[1]]
)
expect_identical(
export_as_txt(ttlst[[1]][7:8, keep_titles = TRUE], hsep = "-", paginate = FALSE),
"big title\n\n--------------\n all obs\n--------------\nMean 34.89 \n~~~~~~~~~~~~~~\nM \n"
)
expect_identical(
paste0(
export_as_txt(tail(ttlst[[1]], 1), hsep = "-", paginate = FALSE),
export_as_txt(head(ttlst[[2]], 1), hsep = "-", paginate = FALSE)
),
paste0(
"big title\n\n--------------\n all obs\n--------------\nMean 34.28 \n",
"big title\n\n-----------\n all obs\n-----------\nU \n"
)
)
})
test_that("Pagination works with non-default min_siblings", {
lyt <- basic_table() %>%
analyze("RACE")
tt <- build_table(lyt, DM)
ttlst <- expect_silent(paginate_table(tt, lpp = 3, min_siblings = 0))
expect_identical(length(ttlst), nlevels(DM$RACE))
expect_identical(tt[1], ttlst[[1]])
suppressMessages(
expect_error(
paginate_table(tt, lpp = 3, min_siblings = 1),
".*Unable to find any valid pagination .*between rows 1 and 1.*"
)
)
})
test_that("Pagination works with wrapped titles/footers", {
lyt <- basic_table() %>%
split_cols_by("SEX") %>%
analyze("RACE")
tt <- build_table(lyt, DM)
main_title(tt) <- "title with a\nnewline"
main_footer(tt) <- "wrapped footer with\nnewline"
res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE))
expect_identical(main_title(res[[1]]), main_title(res[[2]]))
expect_identical(main_title(res[[1]]), main_title(tt))
expect_identical(main_footer(res[[1]]), main_footer(res[[2]]))
expect_identical(main_footer(res[[1]]), main_footer(tt))
main_title(tt) <- "this is a long long table title that should be wrapped to a new line"
main_footer(tt) <- "this is an extra long table main footer and should also be wrapped"
res2 <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE))
expect_equal(length(res2), 2)
mf_res2 <- matrix_form(res2[[1]])
nrow_res2 <- nrow(mf_strings(mf_res2)) + 5 + 4 # 5 lines tbl seps/ws + 4 lines title/footer
res2_str1 <- toString(res2[[1]], tf_wrap = TRUE, max_width = 60)
res2_str1_spl <- strsplit(res2_str1, split = "\n")[[1]]
expect_equal(nrow_res2, length(res2_str1_spl))
expect_true(all(nchar(res2_str1_spl)) <= 60)
expect_equal(nchar(res2_str1_spl[1]), 59)
expect_equal(nchar(res2_str1_spl[2]), 8)
expect_equal(nchar(res2_str1_spl[nrow_res2 - 1]), 58)
expect_equal(nchar(res2_str1_spl[nrow_res2]), 7)
res2_str2 <- toString(res2[[2]], tf_wrap = TRUE, max_width = 60)
res2_str2_spl <- strsplit(res2_str2, split = "\n")[[1]]
expect_equal(nrow_res2, length(res2_str2_spl))
expect_true(all(nchar(res2_str2_spl)) <= 60)
expect_equal(nchar(res2_str2_spl[1]), 59)
expect_equal(nchar(res2_str2_spl[2]), 8)
expect_equal(nchar(res2_str2_spl[nrow_res2 - 1]), 58)
expect_equal(nchar(res2_str2_spl[nrow_res2]), 7)
})
test_that("Pagination works with referential footnotes", {
lyt <- basic_table(
title = "main title",
subtitles = "subtitle",
main_footer = "main footer",
prov_footer = "provenance footer"
) %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>%
split_rows_by("STRATA1", split_fun = keep_split_levels(c("A", "B")), page_by = TRUE, page_prefix = "Stratum") %>%
split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
summarize_row_groups() %>%
analyze("AGE", afun = function(x, ...) {
in_rows(
"mean (sd)" = rcell(
c(mean(x), sd(x)),
format = "xx.x (xx.x)"
),
"range" = rcell(range(x), format = "xx.x - xx.x")
)
})
tt <- build_table(lyt, ex_adsl)
fnotes_at_path(tt, rowpath = c("STRATA1", "B", "RACE", "WHITE")) <- "3 Row footnote"
fnotes_at_path(
tt,
rowpath = c("STRATA1", "A", "RACE", "WHITE", "AGE", "range"),
colpath = c("ARM", "C: Combination", "SEX", "M")
) <- "2 Cell footnote"
fnotes_at_path(tt, rowpath = c("STRATA1", "A", "RACE", "ASIAN")) <- "1 Row footnote"
fnotes_at_path(
tt,
rowpath = c("STRATA1", "B", "RACE", "WHITE", "AGE", "mean (sd)"),
colpath = c("ARM", "B: Placebo", "SEX", "F")
) <- "2 Cell footnote"
main_title(tt) <- "title with a\nnewline"
main_footer(tt) <- "wrapped footer with\nnewline"
res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE))
expect_identical(main_title(res[[1]]), main_title(res[[2]]))
expect_identical(main_title(res[[1]]), main_title(tt))
expect_identical(main_footer(res[[1]]), main_footer(res[[2]]))
expect_identical(main_footer(res[[1]]), main_footer(tt))
main_title(tt) <- "this is a long long table title that should be wrapped to a new line"
main_footer(tt) <- "this is an extra long table main footer and should also be wrapped"
res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE))
expect_equal(length(res), 4)
ref_fn_res1 <- matrix_form(res[[1]])$ref_fnote_df
expect_equal(ref_fn_res1$msg, "1 Row footnote")
expect_equal(ref_fn_res1$ref_index, 1)
expect_equal(ref_fn_res1$symbol, "1")
ref_fn_res2 <- matrix_form(res[[2]])$ref_fnote_df
expect_equal(ref_fn_res2$msg, c("1 Row footnote", "2 Cell footnote"))
expect_equal(ref_fn_res2$ref_index, 1:2)
expect_equal(ref_fn_res2$symbol, c("1", "2"))
ref_fn_res3 <- matrix_form(res[[3]])$ref_fnote_df
expect_equal(ref_fn_res3$msg, c("3 Row footnote", "2 Cell footnote"))
expect_equal(ref_fn_res3$ref_index, 1:2)
expect_equal(ref_fn_res3$symbol, c("3", "2"))
ref_fn_res4 <- matrix_form(res[[4]])$ref_fnote_df
expect_equal(ref_fn_res4$msg, "3 Row footnote")
expect_equal(ref_fn_res4$ref_index, 1)
expect_equal(ref_fn_res4$symbol, "3")
})
test_that("setting colgap during pagination works", {
tt <- tt_to_export()
## row labels take up 12, all other columns 10 + 3 (default colgap)
## so 2 cols per page, 3 pages total
pags1 <- paginate_table(tt, lpp = NULL, cpp = 38)
expect_equal(length(pags1), 3)
## increase col_gap by one prevents second column on each page
## so 6 pages
pags2 <- paginate_table(tt, lpp = NULL, cpp = 38, col_gap = 4)
expect_equal(length(pags2), ncol(tt))
## too wide a column gap, no columns fit after labels
expect_error(suppressMessages(paginate_table(tt, lpp = NULL, cpp = 38, col_gap = 26)))
})
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.