context("Tabulation framework")
test_that("summarize_row_groups works with provided funcs", {
l1 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("RACE") %>%
summarize_row_groups() %>%
analyze("AGE", mean)
tb1 <- build_table(l1, DM)
tbl_str <- toString(tb1)
expect(TRUE, "succeeded")
})
## this
test_that("complex layout works", {
lyt <- make_big_lyt()
## ensure print method works for predata layout
tab <- build_table(lyt, rawdat)
tab_str <- toString(tab)
## XXX TODO this assumes we want no var label on VAR3 subtable
expect_identical(dim(tab), c(28L, 4L))
expect_identical(row.names(tab), complx_lyt_rnames)
tlvals <- c("Ethnicity", "Factor 2")
lyt2 <- lyt %>% append_topleft(tlvals)
tab2 <- build_table(lyt2, rawdat)
expect_identical(top_left(tab2), tlvals)
})
test_that("existing table in layout works", {
thing2 <- basic_table() %>%
split_cols_by("ARM") %>%
## add nested column split on SEX with value labels from gend_label
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
analyze(
c("AGE", "AGE"), c("Age Analysis", "Age Analysis Redux"),
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx",
table_names = c("AGE1", "AGE2")
)
tab2 <- build_table(thing2, rawdat)
thing3 <- basic_table() %>%
split_cols_by("ARM") %>%
## add nested column split on SEX with value labels from gend_label
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
analyze("AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx"
) %>%
## stack an existing table onto the layout and thus the generated table
add_existing_table(tab2)
tab3 <- build_table(thing3, rawdat)
expect_equal(nrow(tab3), 12)
tab3
})
test_that("Nested splits in column space work", {
dat2 <- subset(ex_adsl, SEX %in% c("M", "F"))
tbl2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", split_fun = drop_split_levels) %>%
analyze(c("AGE", "STRATA1")) %>%
build_table(dat2)
mf <- matrix_form(tbl2)
expect_identical(
unname(mf$strings[1, , drop = TRUE]),
c(
"", "A: Drug X", "A: Drug X", "B: Placebo", "B: Placebo",
"C: Combination", "C: Combination"
)
)
expect_identical(
unname(mf$display[1, , drop = TRUE]),
c(TRUE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE)
)
})
test_that("labelkids parameter works", {
yeslabellyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "visible") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label", child_labels = "visible"
) %>%
analyze(
"AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx",
show_labels = "visible"
)
tabyes <- build_table(yeslabellyt, rawdat)
expect_identical(
row.names(tabyes)[1:4],
c("Caucasian", "Caucasian (n)", "Level A", "Age Analysis")
)
misslabellyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "default") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label", child_labels = "default"
) %>%
analyze(
"AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx"
)
tabmiss <- build_table(misslabellyt, rawdat)
expect_identical(
row.names(tabmiss)[1:4],
c("Caucasian (n)", "Level A", "mean", "median")
)
nolabellyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "hidden") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label", child_labels = "hidden"
) %>%
analyze(
"AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx",
show_labels = "hidden"
)
tabno <- build_table(nolabellyt, rawdat)
expect_identical(
row.names(tabno)[1:4],
c("Caucasian (n)", "mean", "median", "mean")
)
mixedlyt2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "hidden") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label", child_labels = "hidden"
) %>%
analyze(
"AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx",
show_labels = "visible"
)
tabmixed2 <- build_table(mixedlyt2, rawdat)
expect_identical(
row.names(tabmixed2)[1:4],
c("Caucasian (n)", "Age Analysis", "mean", "median")
)
mixedlyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "visible") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label", child_labels = "visible"
) %>%
analyze(
"AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx",
show_labels = "hidden"
)
tabmixed <- build_table(mixedlyt, rawdat)
expect_identical(
row.names(tabmixed)[1:4],
c("Caucasian", "Caucasian (n)", "Level A", "mean")
)
varshowlyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label",
label_pos = "visible"
) %>%
analyze(
"AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx",
show_labels = "hidden"
)
varshowtab <- build_table(varshowlyt, rawdat)
expect_identical(
row.names(varshowtab)[1:4],
c("Caucasian (n)", "Factor2", "Level A", "mean")
)
})
test_that("ref_group comparisons work", {
blthing <- basic_table() %>%
split_cols_by("ARM", ref_group = "ARM1") %>%
analyze("AGE", show_labels = "hidden") %>%
analyze("AGE", refcompmean, show_labels = "hidden", table_names = "AGE2")
## function(x) list(mean = mean(x)))
bltab <- build_table(blthing, rawdat)
expect_identical(dim(bltab), c(2L, 2L))
expect_null(bltab[2, 1, drop = TRUE])
c1 <- bltab[1, 1, drop = TRUE]
c2 <- bltab[1, 2, drop = TRUE]
c3 <- bltab[2, 2, drop = TRUE]
expect_equivalent(c2 - c1, c3)
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", ref_group = "F") %>%
analyze("AGE", mean, show_labels = "hidden") %>%
analyze("AGE", refcompmean,
show_labels = "hidden",
table_names = "AGE2a"
) %>%
split_rows_by("RACE",
nested = FALSE,
split_fun = drop_split_levels
) %>%
analyze("AGE", mean, show_labels = "hidden") %>%
analyze("AGE", refcompmean, show_labels = "hidden", table_names = "AGE2b")
bltab2 <- build_table(lyt, DM)
d1 <- bltab2[4, 1, drop = TRUE]
d2 <- bltab2[4, 2, drop = TRUE]
d3 <- bltab2[5, 2, drop = TRUE]
expect_equivalent(d2 - d1, d3)
d4 <- bltab2[1, 3, drop = TRUE]
d5 <- bltab2[1, 4, drop = TRUE]
d6 <- bltab2[2, 4, drop = TRUE]
expect_equivalent(d5 - d4, d6)
d7 <- bltab2[4, 3, drop = TRUE]
d8 <- bltab2[4, 4, drop = TRUE]
d9 <- bltab2[5, 4, drop = TRUE]
expect_equivalent(d8 - d7, d9)
## with combo levels
combodf <- tribble(
~valname, ~label, ~levelcombo, ~exargs,
"A_", "Arm 1", c("A: Drug X"), list(),
"B_C", "Arms B & C", c("B: Placebo", "C: Combination"), list()
)
l3 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by(
"ARM",
split_fun = add_combo_levels(combodf, keep_levels = c("A_", "B_C")),
ref_group = "A_"
) %>%
analyze(c("AGE", "AGE"),
afun = list(mean, refcompmean),
show_labels = "hidden", table_names = c("AGE1", "AGE2")
)
bltab3 <- build_table(l3, DM)
d10 <- bltab3[1, 1, drop = TRUE]
d11 <- bltab3[1, 2, drop = TRUE]
d12 <- bltab3[2, 2, drop = TRUE]
expect_null(cell_values(bltab3, "AGE2", c("ARM", "A_"))[[1]])
expect_identical(d12, d11 - d10)
})
test_that("missing vars caught", {
misscol <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SX", "Gender") %>%
analyze("AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx"
)
expect_error(
build_table(misscol, rawdat),
"Split variable [[]SX[]] not found in data being tabulated."
)
missrsplit <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "gend_label") %>%
split_rows_by("RACER", "ethn_label") %>%
analyze("AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx"
)
expect_error(
build_table(missrsplit, rawdat),
"Split variable [[]RACER[]] not found in data being tabulated."
)
missrsplit <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", "gend_label") %>%
split_rows_by("RACE", "ethnNA_label") %>%
analyze("AGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx"
)
expect_error(
build_table(missrsplit, rawdat),
"Value label variable [[]ethnNA_label[]] not found in data being tabulated."
)
missavar <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", labels_var = "gend_label") %>%
split_rows_by("RACE", labels_var = "ethn_label") %>%
analyze("AGGE", "Age Analysis",
afun = function(x) list(mean = mean(x), median = median(x)),
format = "xx.xx"
)
expect_error(
build_table(missavar, rawdat),
".*variable[(]s[)] [[]AGGE[]] not present in data. [(]AnalyzeVarSplit[)].*"
)
})
# https://github.com/insightsengineering/rtables/issues/329
test_that("error localization works", {
afun <- function(x, .spl_context) {
if (NROW(.spl_context) > 0 && .spl_context[NROW(.spl_context), "value", drop = TRUE] == "WHITE") {
stop("error for white statistics")
}
in_rows(myrow = 5)
}
lyt <- basic_table() %>%
split_rows_by("ARM") %>%
split_rows_by("RACE") %>%
analyze("BMRKR1", afun = afun)
# nolint start
expect_error(
build_table(lyt, DM),
"Error[^)]*analysis function \\(var[^B]*BMRKR1\\): error for white statistics.*ARM\\[A: Drug X\\]->RACE\\[WHITE\\]"
)
# nolint end
cfun <- function(df, labelstr) {
if (labelstr == "B: Placebo") {
stop("placebos are bad")
}
in_rows(val = 5)
}
lyt2 <- basic_table() %>%
split_rows_by("ARM") %>%
summarize_row_groups(cfun = cfun) %>%
split_rows_by("RACE") %>%
analyze("BMRKR1", afun = mean)
expect_error(
build_table(lyt2, DM),
"Error in content.*function: placebos are bad.*path: ARM\\[B: Placebo\\]"
)
splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
stop("oopsie daisy")
}
lyt3 <- basic_table() %>%
split_rows_by("ARM") %>%
summarize_row_groups() %>%
split_rows_by("RACE", split_fun = splfun) %>%
analyze("BMRKR1", afun = mean)
# nolint start
expect_error(
build_table(lyt3, DM),
"Error.*custom split function: oopsie daisy.*VarLevelSplit \\(RACE\\).*path: ARM\\[A: Drug X\\]"
)
# nolint end
})
test_that("cfun args", {
# first arg df
cfun1 <- function(df, labelstr, .N_col, .N_total) {
stopifnot(is(df, "data.frame"))
in_rows(
rcell(nrow(df) * c(1, 1 / .N_col), format = "xx (xx.xx%)"),
.names = labelstr
)
}
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups(cfun = cfun1)
tbl <- build_table(lyt, rawdat)
capture.output(prout <- print(tbl))
expect_identical(prout, tbl)
# first arg x
cfun2 <- function(x, labelstr) {
in_rows(
c(mean(x, trim = 0.2), 0.2),
.formats = "xx.x (xx.x%)",
.labels = sprintf(
"%s (Trimmed mean and trim %%)",
labelstr
)
)
}
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups("AGE", cfun = cfun2)
tbl <- build_table(lyt, rawdat)
capture.output(prout <- print(tbl))
expect_identical(prout, tbl)
})
## regression test for automatically not-nesting
## when a non-analyze comes after an analyze
test_that("split under analyze", {
dontnest <- basic_table(show_colcounts = TRUE) %>%
split_cols_by(var = "ARM") %>%
analyze("AGE") %>%
split_rows_by("VAR3") %>%
analyze("AGE") %>%
build_table(rawdat)
expect_equal(nrow(dontnest), 5)
})
test_that("label_var works as expected", {
yeslblslyt <- basic_table(show_colcounts = TRUE) %>%
split_cols_by(var = "ARM") %>%
split_rows_by("SEX", labels_var = "gend_label") %>%
analyze("AGE")
yeslbls <- build_table(yeslblslyt, rawdat)
expect_identical(row.names(yeslbls)[1], "Male")
nolbls <- basic_table(show_colcounts = TRUE) %>%
split_cols_by(var = "ARM") %>%
split_rows_by("SEX") %>%
analyze("AGE") %>%
build_table(rawdat)
expect_identical(row.names(nolbls)[1], "M")
## create bad label col
rawdat2 <- rawdat
rawdat2$gend_label[5] <- "XXXXX"
## nolint start
## test check for label-value concordance.
expect_error(
build_table(yeslblslyt, rawdat2),
"There does not appear to be a 1-1 correspondence between values in split var \\[SEX\\] and label var \\[gend_label\\]"
)
## nolint end
})
test_that("factors with unobserved levels work as expected", {
## default behavior is that empty levels are NOT dropped
## rows
lyt <- basic_table() %>%
split_rows_by("SEX") %>%
analyze("AGE")
tab <- build_table(lyt, DM)
expect_identical(dim(tab), c(8L, 1L))
## cols
lyt2 <- basic_table() %>%
split_cols_by("SEX") %>%
analyze("AGE")
tab2 <- build_table(lyt2, DM)
expect_identical(dim(tab2), c(1L, 4L))
})
test_that(".N_row argument in afun works correctly", {
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
analyze("AGE", afun = function(x, .N_row) .N_row)
tab <- build_table(lyt, rawdat)
rows <- collect_leaves(tab)
names(rows) <- substr(names(rows), 1, 1)
ans <- tapply(rawdat$AGE, rawdat$SEX, function(x) rep(length(x), 2))
res <- vapply(names(rows), function(nm) isTRUE(all.equal(unname(unlist(row_values(rows[[nm]]))), ans[[nm]])), NA)
expect_true(all(res))
})
test_that("extra args works", {
oldop <- options(warn = 2)
on.exit(options(oldop))
colfuns <- list(
function(x, add = 0, na.rm = TRUE) {
rcell(mean(c(NA, x), na.rm = na.rm) + add, format = "xx.x")
},
function(x, cutoff = .5, na.rm = TRUE) {
rcell(sum(c(NA, x > cutoff), na.rm = na.rm), format = "xx")
}
)
l <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_multivar(c("VALUE", "PCTDIFF")) %>%
analyze_colvars(afun = colfuns)
l
tbl_noex <- build_table(l, rawdat2)
## one for each different function in colfuns, assigned correctly
l2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_multivar(c("VALUE", "PCTDIFF")) %>%
analyze_colvars(afun = colfuns, extra_args = list(list(add = 5), list(cutoff = 100)))
tbl_ex <- build_table(l2, rawdat2)
vals_noex <- row_values(tree_children(tbl_noex)[[1]])
vals_ex <- row_values(tree_children(tbl_ex)[[1]])
expect_identical(
unlist(vals_noex[c(1, 3)]) + 5,
unlist(vals_ex[c(1, 3)])
)
truevals <- tapply(rawdat2$PCTDIFF,
rawdat2$ARM,
function(x) sum(x > 100, na.rm = TRUE),
simplify = FALSE
)
expect_equal(
unname(unlist(truevals)),
unname(unlist(vals_ex[c(2, 4)]))
)
vals_noex <- row_values(tree_children(tbl_noex)[[1]])
vals_ex <- row_values(tree_children(tbl_ex)[[1]])
expect_identical(
unlist(vals_noex[c(1, 3)]) + 5,
unlist(vals_ex[c(1, 3)])
)
truevals <- tapply(rawdat2$PCTDIFF,
rawdat2$ARM,
function(x) sum(x > 100, na.rm = TRUE),
simplify = FALSE
)
expect_equal(
unname(unlist(truevals)),
unname(unlist(vals_ex[c(2, 4)]))
)
## single argument passed to all functions
l2b <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_multivar(c("VALUE", "PCTDIFF")) %>%
analyze_colvars(afun = colfuns, extra_args = list(na.rm = FALSE))
tbl_ex2 <- build_table(l2b, rawdat2)
expect_true(all(is.na(unlist(rtables:::row_values(tree_children(tbl_ex2)[[1]])))))
## one argument for a single function.
lyt <- basic_table() %>%
analyze("Sepal.Length", afun = function(x, a) {
in_rows(mean_a = rcell(mean(x) + a, format = "xx"))
}, extra_args = list(a = 1))
tbl <- build_table(lyt, iris)
expect_equal(tbl[1, 1, drop = TRUE], mean(iris$Sepal.Length) + 1)
## two arguments for a single function
lyt2 <- basic_table() %>%
analyze("Sepal.Length", afun = function(x, a, b) {
in_rows(mean_a = rcell(mean(x) + a + b, format = "xx"))
}, extra_args = list(a = 1, b = 3))
tbl2 <- build_table(lyt2, iris)
expect_equal(tbl2[1, 1, drop = TRUE], mean(iris$Sepal.Length) + 1 + 3)
})
test_that("Colcounts work correctly", {
lyt1 <- basic_table(show_colcounts = TRUE) %>%
analyze("AGE")
tbl1 <- build_table(lyt1, DM)
expect_identical(col_counts(tbl1), nrow(DM))
lyt2 <- lyt1 %>% split_cols_by("ARM")
tbl2 <- build_table(lyt2, DM)
expect_identical(
col_counts(tbl2),
as.integer(table(DM$ARM))
)
DMchar <- DM
DMchar$ARM <- as.character(DM$ARM)
tbl2chr <- build_table(lyt2, DMchar)
tbl3 <- build_table(lyt2, DM, col_counts = c(500L, NA, NA))
expect_identical(
col_counts(tbl3),
c(500L, as.integer(table(DM$ARM))[2:3])
)
expect_error(build_table(lyt2, DMchar, col_counts = c(500L, NA, NA)))
expect_error(build_table(lyt2, DM, col_counts = c(20L, 40L)))
tbl4 <- basic_table(
show_colcounts = TRUE,
colcount_format = "xx (xx%)"
) %>%
split_cols_by("ARM") %>%
build_table(DM)
mf_tbl4_colcounts <- matrix_form(tbl4)$strings[2, ]
expect_identical(mf_tbl4_colcounts, c("", "121 (100%)", "106 (100%)", "129 (100%)"))
## setting col_counts in build_table turns on visibility for leaf col counts
lyt5 <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("STRATA1") %>%
analyze("AGE")
tbl5 <- build_table(lyt5, ex_adsl, col_counts = 1:9)
mpf5 <- matrix_form(tbl5)
expect_identical(mf_strings(mpf5)[3, 2], "(N=1)")
})
first_cont_rowvals <- function(tt) {
row_values(
tree_children(
content_table(
tree_children(tt)[[1]]
)
)[[1]]
)
}
test_that("content extra args for summarize_row_groups works", {
sfun <- function(x, labelstr, .N_col, a = 5, b = 6, c = 7) {
in_rows(
c(a, b),
.formats = "xx - xx",
.labels = labelstr
)
}
## specify single set of args for all columns
l <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups(
cfun = sfun,
extra_args = list(a = 9)
)
tbl1 <- build_table(l, rawdat)
expect_identical(
first_cont_rowvals(tbl1),
list(
ARM1 = c(9, 6),
ARM2 = c(9, 6)
)
)
## specify different arg for each column
l2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups(
cfun = sfun,
extra_args = list(
list(a = 9),
list(b = 3)
)
)
tbl2 <- build_table(l2, rawdat)
expect_identical(
first_cont_rowvals(tbl2),
list(
ARM1 = c(9, 6),
ARM2 = c(5, 3)
)
)
## specify arg for only one col
l3 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups(
cfun = sfun,
extra_args = list(list(a = 9))
)
tbl3 <- build_table(l3, rawdat)
expect_identical(
first_cont_rowvals(tbl3),
list(
ARM1 = c(9, 6),
ARM2 = c(5, 6)
)
)
## works on root split
l4 <- basic_table() %>%
split_cols_by("ARM") %>%
summarize_row_groups(
cfun = sfun,
extra_args = list(a = 9)
)
tbl4 <- build_table(l4, rawdat)
expect_identical(
row_values(tree_children(content_table(tbl4))[[1]]),
list(
ARM1 = c(9, 6),
ARM2 = c(9, 6)
)
)
})
test_that(".df_row analysis function argument works", {
afun <- function(x, labelstr = "", .N_col, .df_row) {
rcell(c(nrow(.df_row), .N_col), format = "(xx.x, xx.x)")
}
l <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
analyze("AGE", afun)
tbl <- build_table(l, rawdat)
rws <- collect_leaves(tbl, add.labrows = FALSE)
nmale <- sum(rawdat$SEX == "M")
nfemale <- sum(rawdat$SEX == "F")
narm1 <- sum(rawdat$ARM == "ARM1")
narm2 <- sum(rawdat$ARM == "ARM2")
expect_identical(
unname(lapply(rws, row_values)),
list(
list(
ARM1 = c(nmale, narm1),
ARM2 = c(nmale, narm2)
),
list(
ARM1 = c(nfemale, narm1),
ARM2 = c(nfemale, narm2)
)
)
)
})
test_that("analysis function arguments work with NA rows in data", {
afun <- function(x, .df_row, ...) {
list(
"number of rows in .df_row" = nrow(.df_row),
"length of x" = length(x)
)
}
df <- data.frame(
a_var = factor(c("a", NA, "b", "b", "a", "a", "b", "c", "a", NA)),
b_var = factor(c(NA, NA, "x", "x", "y", "x", "x", "y", "x", NA))
)
l <- basic_table() %>%
add_overall_col("all pts") %>%
split_rows_by("a_var") %>%
analyze("b_var", afun = afun)
tbl <- build_table(l, df)
rws <- collect_leaves(tbl, add.labrows = FALSE)
na <- sum(!is.na(df$a_var) & df$a_var == "a")
nb <- sum(!is.na(df$a_var) & df$a_var == "b")
nc <- sum(!is.na(df$a_var) & df$a_var == "c")
na_x <- length(df$b_var[!is.na(df$a_var) & df$a_var == "a" & !is.na(df$b_var)])
nb_x <- length(df$b_var[!is.na(df$a_var) & df$a_var == "b" & !is.na(df$b_var)])
nc_x <- length(df$b_var[!is.na(df$a_var) & df$a_var == "c" & !is.na(df$b_var)])
expect_identical(
unlist(lapply(rws, row_values), use.names = FALSE),
c(na, na_x, nb, nb_x, nc, nc_x)
)
})
test_that("analyze_colvars inclNAs works", {
## inclNAs
test <- data.frame(
a = c(1, 2),
b = c(1, NA)
)
l <- basic_table() %>%
split_cols_by_multivar(c("a", "b")) %>%
analyze_colvars(afun = length, inclNAs = TRUE)
# We expect:
ans <- lapply(test, length)
# a b
# 2 2
# But we get:
tab <- build_table(l, test)
res1 <- cell_values(tab)
expect_equal(ans, res1)
l2 <- basic_table() %>%
split_cols_by_multivar(c("a", "b")) %>%
analyze_colvars(afun = length, inclNAs = FALSE)
ans2 <- lapply(test, function(x) sum(!is.na(x)))
tab2 <- build_table(l2, test)
res2 <- cell_values(tab2)
expect_equal(ans2, res2)
})
test_that("analyze_colvars works generally", {
op <- options(warn = 2)
on.exit(options(op))
test <- data.frame(
a = 1,
b = 2,
c = 3,
d = 4,
e = 5
)
l1 <- basic_table() %>%
split_cols_by_multivar(c("a", "b", "c", "d")) %>%
analyze_colvars(afun = identity)
tab1 <- build_table(l1, test)
l2 <- basic_table() %>%
split_cols_by_multivar(c("a", "b", "c", "d", "e")) %>%
analyze_colvars(afun = identity)
tab2 <- build_table(l2, test)
colfuns <- list(
function(x, labelstr) in_rows(summary = 5, .labels = "My Summary Row"),
function(x, labelstr) 6,
function(x, labelstr) 7,
function(x, labelstr) 8
)
l3 <- basic_table() %>%
split_cols_by_multivar(c("a", "b", "c", "d")) %>%
summarize_row_groups(cfun = colfuns, format = "xx") %>%
analyze_colvars(afun = identity)
tab3 <- build_table(l3, test)
expect_identical(
cell_values(content_table(tab3)),
list(a = 5, b = 6, c = 7, d = 8)
)
expect_identical(
obj_label(collect_leaves(tab3, TRUE, TRUE)[[1]]),
c(summary = "My Summary Row")
)
l4 <- basic_table() %>%
split_cols_by_multivar(c("a", "b", "c", "d")) %>%
summarize_row_groups() %>%
analyze_colvars(afun = identity)
tab4 <- build_table(l4, test)
## this broke before due to formatting missmatches
toString(tab4)
rws4 <- collect_leaves(tab4, TRUE, TRUE)
expect_identical(obj_format(rws4[[1]]), "xx (xx.x%)")
expect_identical(obj_format(rws4[[2]]), NULL)
l5 <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_multivar(c("AGE", "BMRKR1")) %>%
split_rows_by("RACE") %>%
summarize_row_groups(
cfun = list(
function(x, labelstr) "first fun",
function(x, labelstr) "second fun"
),
format = "xx"
)
tab5 <- build_table(l5, DM)
toString(tab5)
rws5 <- collect_leaves(tab5, TRUE, TRUE)
expect(
all(vapply(rws5, function(x) identical(x, rws5[[1]]), NA)),
"Multiple content functions didn't recycle properly in nested context"
)
expect_identical(
unname(cell_values(tab5)[[1]]),
rep(list("first fun", "second fun"), length.out = ncol(tab5))
)
## single column in split_cols_by_multivar and analyze_colvars
one_col_lyt <- basic_table() %>%
split_cols_by_multivar(vars = "Sepal.Width") %>%
analyze_colvars(afun = mean)
one_col_tbl <- build_table(one_col_lyt, iris)
expect_identical(
cell_values(one_col_tbl),
list(Sepal.Width = mean(iris$Sepal.Width))
)
# na_str argument works
test$d <- NA
l2 <- basic_table() %>%
split_cols_by_multivar(c("a", "b", "c", "d")) %>%
analyze_colvars(afun = mean, na_str = "no data")
tab2 <- build_table(l2, test)
expect_identical(
toString(tab2[1, 4]),
" d \n——————————————\nmean no data\n"
)
})
test_that("alt_counts_df works", {
minidm <- DM[1, ]
lyt <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups() %>%
analyze("AGE")
tbl <- build_table(lyt, DM, minidm)
## this inherently checks both that the correct counts (0, 1, 0) are
## retrieved and that they propogate to the summary functions
expect_identical(
list(
"A: Drug X" = c(70, Inf), ## 70/0
"B: Placebo" = c(56, 56), ## 56/1
"C: Combination" = c(61, Inf)
), ## 61/0
cell_values(tbl[1, ])
)
## breaks (with useful message) when given incompatible alt_counts_df
expect_error(build_table(lyt, DM, iris), "Offending column subset expression")
})
test_that("deeply nested and uneven column layouts work", {
lyt <- basic_table(show_colcounts = TRUE) %>%
split_cols_by(var = "ARM") %>%
split_cols_by("STRATA1") %>%
split_cols_by("STRATA2") %>%
add_overall_col("All Patients") %>%
analyze("AGE")
tbl <- build_table(lyt, ex_adsl)
## printing machinery works
str <- toString(tbl)
expect_identical(ncol(tbl), 19L)
lyt2 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_cols_by("STRATA1") %>%
split_cols_by("STRATA2", nested = FALSE) %>%
add_overall_col("All Patients") %>%
analyze("AGE")
tbl2 <- build_table(lyt2, ex_adsl)
## printing machinery works
str <- toString(tbl2)
expect_identical(ncol(tbl2), 12L)
})
test_that("topleft label position works", {
lyt <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
## add nested column split on SEX with value lables from gend_label
split_cols_by("SEX", "Gender", labels_var = "gend_label") %>%
## No row splits have been introduced, so this adds
## a root split and puts summary content on it labelled Overall (N)
## add_colby_total(label = "All") %>%
## summarize_row_groups(label = "Overall (N)", format = "(N=xx)") %>%
## add a new subtable that splits on RACE, value labels from ethn_label
split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", label_pos = "topleft") %>%
summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
##
## Add nested row split within Race categories for FACTOR2
## using a split function that excludes level C
## value labels from fac2_label
split_rows_by("FACTOR2", "Factor2",
split_fun = remove_split_levels("C"),
labels_var = "fac2_label",
label_pos = "topleft"
) %>%
## Add count summary within FACTOR2 categories
summarize_row_groups("FACTOR2") %>%
## Add analysis/data rows by analyzing AGE variable
## Note afun is a function that returns 2 values in a named list
## this will create 2 data rows
analyze("AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), format = "xx.xx")
tab <- build_table(lyt, rawdat)
expect_identical(
c("Ethnicity", " Factor2"),
top_left(tab)
)
expect_identical(
14L,
nrow(tab)
)
## https://github.com/insightsengineering/rtables/issues/657
tab2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("RACE", split_fun = drop_split_levels, split_label = "RACE", label_pos = "hidden", page_by = TRUE) %>%
split_rows_by("STRATA1", split_fun = drop_split_levels, split_label = "Strata", label_pos = "topleft") %>%
split_rows_by("SEX", split_fun = drop_split_levels, split_label = "Gender", label_pos = "topleft") %>%
analyze("AGE", mean, var_labels = "Age", format = "xx.xx") %>%
build_table(DM)
ptab <- paginate_table(tab2)
expect_identical(
top_left(ptab[[1]]),
c("Strata", " Gender")
)
## https://github.com/insightsengineering/rtables/issues/651
lyt2 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) %>%
analyze("AGE")
expect_error(build_table(lyt2, DM[0, ]), "Page-by split resulted in zero")
lyt3 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) %>%
split_rows_by("COUNTRY", split_fun = drop_split_levels, page_by = TRUE) %>%
analyze("AGE")
baddm <- DM
baddm$COUNTRY <- NA_character_
## brittle test because I couldn't figure out how to get the regex to handle newlines and check both the path
## part and primary message part
error_msg <- paste0(
"Page-by split resulted in zero pages (no observed values of split variable?). ",
"\n\tsplit: VarLevelSplit (COUNTRY)\n\toccured at path: SEX[F]\n"
)
expect_error(build_table(lyt3, baddm), error_msg, fixed = TRUE)
# Similar error if the problematic split is done on alt_counts_df (related to #651)
lyt4 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) %>%
split_rows_by("COUNTRY", split_fun = drop_split_levels, page_by = TRUE) %>%
analyze("AGE", afun = function(x, .alt_df) mean(x))
error_msg2 <- paste0(
"Following error encountered in splitting alt_counts_df: ",
error_msg
)
expect_error(build_table(lyt4, DM, alt_counts_df = baddm), error_msg2, fixed = TRUE)
})
test_that(".spl_context works in content and analysis functions", {
ageglobmean <- mean(DM$AGE)
cfun <- function(df, labelstr, .spl_context) {
stopifnot("A: Drug X.M" %in% names(.spl_context))
lastrow <- .spl_context[nrow(.spl_context) - 1, ]
in_rows(c(nrow(df), lastrow$cur_col_n),
.names = labelstr,
.labels = sprintf(
"%s (%d)", labelstr,
nrow(lastrow$full_parent_df[[1]])
),
.formats = "xx / xx"
)
}
afun <- function(x, .spl_context) {
stopifnot("A: Drug X.M" %in% names(.spl_context))
## this will break if the root 'split' row isn't there
stopifnot(nrow(.spl_context$full_parent_df[[1]]) == nrow(DM))
lastrow <- .spl_context[nrow(.spl_context), ]
in_rows(c(sum(x >= ageglobmean), lastrow$cur_col_n),
.names = "age_analysis",
.labels = sprintf(
"counts (out of %d)",
nrow(lastrow$full_parent_df[[1]])
),
.formats = "xx / xx"
)
}
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX", split_fun = keep_split_levels(c("M", "F"))) %>%
split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
summarize_row_groups() %>%
split_rows_by("STRATA1") %>%
summarize_row_groups(cfun = cfun) %>%
analyze("AGE", afun = afun)
tab <- build_table(lyt, DM)
strmat <- matrix_form(tab)$strings
rwcount4 <- as.integer(gsub("[^0-9]", "", strmat[4, 1]))
crowvals <- cell_values(tab, c("COUNTRY", "CHN", "@content"))
expect_equal(
rwcount4,
sum(sapply(
crowvals,
`[[`, 1
))
)
expect_equal(
crowvals[[1]][[1]],
cell_values(tab, c("COUNTRY", "CHN", "STRATA1", "A", "@content"))[[1]][[2]]
)
expect_equal(
unname(sapply(
cell_values(tab, c("COUNTRY", "USA", "STRATA1", "B", "@content")),
`[[`, 1L
)),
unname(sapply(
cell_values(tab, c("COUNTRY", "USA", "STRATA1", "B", "AGE", "age_analysis")),
`[[`, 2L
))
)
})
test_that("cut functions work", {
ctnames <- c("young", "medium", "old")
## split_cols_by_cuts
l <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_cuts("AGE",
split_label = "Age",
cuts = c(0, 25, 35, 1000),
cutlabels = ctnames
) %>%
analyze(c("BMRKR2", "STRATA2")) %>%
append_topleft("counts")
tbl <- build_table(l, ex_adsl)
chkvals <- cell_values(tbl, c("BMRKR2", "LOW"), c("ARM", "A: Drug X"))
expect_identical(
unname(unlist(chkvals)),
c(
nrow(subset(ex_adsl, ARM == "A: Drug X" & BMRKR2 == "LOW" & AGE <= 25)),
nrow(subset(ex_adsl, ARM == "A: Drug X" & BMRKR2 == "LOW" & AGE > 25 & AGE <= 35)),
nrow(subset(ex_adsl, ARM == "A: Drug X" & BMRKR2 == "LOW" & AGE > 35))
)
)
mf <- matrix_form(tbl)
expect_identical(
mf$strings[2, , drop = TRUE],
c("counts", rep(ctnames, 3))
)
lcm <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_cuts("AGE",
split_label = "Age",
cuts = c(0, 25, 35, 1000),
cutlabels = c("young", "young+medium", "all"),
cumulative = TRUE
) %>%
analyze(c("BMRKR2", "STRATA2")) %>%
append_topleft("counts")
tblcm <- build_table(lcm, ex_adsl)
medpth <- c("BMRKR2", "MEDIUM")
bpth <- c("ARM", "B: Placebo")
expect_identical(
cumsum(unname(unlist(cell_values(tbl, medpth, bpth)))),
unname(unlist(cell_values(tblcm, medpth, bpth)))
)
## split_rows_by_cuts
l2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by_cuts("AGE",
split_label = "Age",
cuts = c(0, 25, 35, 1000),
cutlabels = ctnames
) %>%
analyze("BMRKR2") %>%
append_topleft("counts")
tbl2 <- build_table(l2, ex_adsl)
mf2 <- matrix_form(tbl2)
expect_identical(
mf2$strings[c(2, 6, 10), 1, drop = TRUE],
ctnames
)
l2cm <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by_cuts("AGE",
split_label = "Age",
cuts = c(0, 25, 35, 1000),
cutlabels = ctnames, cumulative = TRUE
) %>%
analyze("BMRKR2") %>%
append_topleft("counts")
tbl2cm <- build_table(l2cm, ex_adsl)
medlow <- c("AGE", "young", "BMRKR2", "HIGH")
cpth <- c("ARM", "C: Combination")
getvals <- function(tt) {
sapply(
ctnames,
function(pth) {
unname(unlist(cell_values(tt, c("AGE", pth, "BMRKR2", "HIGH"), cpth)))
}
)
}
expect_identical(
getvals(tbl2cm),
cumsum(getvals(tbl2))
)
# split_cols_by_quartiles
l3 <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_cutfun("AGE") %>% ## (quartiles("AGE", split_label = "Age") %>%
analyze("BMRKR2") %>%
append_topleft("counts")
tbl3 <- build_table(l3, ex_adsl)
l3b <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_cuts("AGE", cuts = rtables:::qtile_cuts(ex_adsl$AGE)) %>%
analyze("BMRKR2") %>%
append_topleft("counts")
tbl3b <- build_table(l3b, ex_adsl)
expect_identical(tbl3, tbl3b)
l3c <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_quartiles("AGE") %>%
analyze("BMRKR2") %>%
append_topleft("counts")
tbl3c <- build_table(l3c, ex_adsl)
expect_identical(
unname(unlist(cell_values(tbl3))),
unname(unlist(cell_values(tbl3c)))
)
l3c_cm <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by_quartiles("AGE", cumulative = TRUE) %>%
analyze("BMRKR2") %>%
append_topleft("counts")
tbl3c_cm <- build_table(l3c_cm, ex_adsl)
# split_rows_by_quartiles
l4 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_rows_by_quartiles("AGE", split_label = "Age") %>%
analyze("BMRKR2") %>%
append_topleft(c("Age Quartiles", " Counts BMRKR2"))
tbl4 <- build_table(l4, ex_adsl)
cvs4 <- unlist(cell_values(tbl4))
valslst4 <- unlist(lapply(1:3, function(i) lapply(cvs4, function(lst) lst[i])))
names(valslst4) <- gsub("^(.*)\\.BMRKR2\\.(.*)$", "\\2.\\1", names(valslst4))
valslst3 <- unlist(cell_values(tbl3c))
expect_identical(
valslst3,
valslst4[names(valslst3)]
)
l4cm <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM") %>%
split_rows_by_quartiles("AGE", split_label = "Age", cumulative = TRUE) %>%
analyze("BMRKR2") %>%
append_topleft(c("Age Cumulative Quartiles", " Counts BMRKR2"))
tbl4cm <- build_table(l4cm, ex_adsl)
cvs4cm <- unlist(cell_values(tbl4cm))
valslst4cm <- unlist(lapply(1:3, function(i) lapply(cvs4cm, function(lst) lst[i])))
names(valslst4cm) <- gsub("^(.*)\\.BMRKR2\\.(.*)$", "\\2.\\1", names(valslst4cm))
valslst3cm <- unlist(cell_values(tbl3c_cm))
expect_identical(
valslst3cm,
valslst4cm[names(valslst3cm)]
)
})
## https://github.com/insightsengineering/rtables/issues/323
test_that("empty factor levels represented correctly when ref group is set", {
df <- data.frame(
val = 1:10,
grp = factor(rep("a", 10), levels = c("a", "b"))
)
tbl <- basic_table() %>%
split_cols_by("grp", ref_group = "a") %>%
analyze("val") %>%
build_table(df)
expect_identical(ncol(tbl), 2L)
})
test_that("error on empty level of splitting variable", {
mydf <- data.frame(
x = c("hi", "", "lo"), y = c(5, 10, 20),
stringsAsFactors = FALSE
)
mydf2 <- mydf
mydf2$x <- factor(mydf2$x)
lyt1 <- basic_table() %>%
split_cols_by("x") %>%
analyze("y")
expect_error(
build_table(lyt1, mydf),
"Got empty string level in splitting variable x"
)
expect_error(
build_table(lyt1, mydf2),
"Got empty string level in splitting variable x"
)
lyt2 <- basic_table() %>%
split_rows_by("x") %>%
analyze("y")
expect_error(
build_table(lyt2, mydf),
"Got empty string level in splitting variable x"
)
expect_error(
build_table(lyt2, mydf2),
"Got empty string level in splitting variable x"
)
})
test_that("error when afun gives differing numbers of rows is informative", {
afunconst <- function() {
nr <- 1
function(x, ...) {
nr <<- nr + 1
in_rows(.list = as.list(seq_len(nr)), .names = paste(seq_len(nr)))
}
}
my_broken_afun <- afunconst()
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
analyze("AGE", my_broken_afun)
expect_error(build_table(lyt, DM), "Number of rows generated by analysis function do not match across all columns.")
})
test_that("warning when same name siblings", {
lyt <- basic_table() %>%
analyze("AGE", mean) %>%
analyze("AGE", mean, var_labels = "AGE2")
expect_warning(
tbl <- build_table(lyt, DM),
"Non-unique sibling analysis table names"
)
expect_identical(
row_paths(tbl)[[3]][2],
"AGE2"
)
})
test_that("error when inset < 0 or non-number", {
expect_error(
basic_table(inset = -1),
"invalid table_inset value"
)
expect_error(
expect_warning(basic_table(inset = "haha")),
"invalid table_inset value"
)
})
test_that("error when ref_group value not a level of var when using split_cols_by", {
lyt <- basic_table() %>%
split_cols_by("ARM", ref_group = "test_level")
expect_error(
tbl <- build_table(lyt, DM),
'Reference group "test_level" was not present in the levels of ARM in the data.'
)
})
test_that("counts_wpcts works as expected", {
rows_res <- counts_wpcts(DM$SEX, 400)
rows_exp <- in_rows(
.list = list(
F = rcell(c(187, 187 / 400), format = "xx (xx.x%)"),
M = rcell(c(169, 169 / 400), format = "xx (xx.x%)"),
U = rcell(c(0, 0), format = "xx (xx.x%)"),
UNDIFFERENTIATED = rcell(c(0, 0), format = "xx (xx.x%)")
)
)
expect_identical(rows_res, rows_exp)
})
test_that("counts_wpcts returns error correctly", {
expect_error(
counts_wpcts(DM$AGE, 400),
"using the 'counts_wpcts' analysis function requires factor data to guarantee equal numbers"
)
})
test_that("qtable works", {
nice_comp_table <- function(t1, t2) {
expect_identical(row_paths(t1), row_paths(t2))
expect_identical(col_paths(t1), col_paths(t2))
expect_equal(cell_values(t1), cell_values(t2))
expect_identical(top_left(t1), top_left(t2))
}
summary_list <- function(x, ...) as.list(summary(x))
summary_list2 <- function(x, ...) in_rows(.list = summary_list(x, ...), .formats = "xx.xx")
t0 <- qtable(ex_adsl)
count <- function(df, ...) rcell(NROW(df), label = "count")
count_use_nms <- function(df, .spl_context, ...) {
nm <- tail(.spl_context$value, 1)
rcell(NROW(df), label = nm)
}
t0b <- basic_table(show_colcounts = TRUE) %>%
analyze(names(ex_adsl)[1], count) %>%
build_table(ex_adsl)
nice_comp_table(t0, t0b)
t1 <- qtable(ex_adsl, row_vars = "ARM")
t1b <- basic_table(show_colcounts = TRUE) %>%
split_rows_by("ARM", child_labels = "hidden") %>%
analyze(names(ex_adsl)[1], count_use_nms) %>%
append_topleft("count") %>%
build_table(ex_adsl)
nice_comp_table(t1, t1b)
t2 <- qtable(ex_adsl, col_vars = "ARM")
t2b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", child_labels = "hidden") %>%
analyze(names(ex_adsl)[1], count) %>%
build_table(ex_adsl)
nice_comp_table(t2, t2b)
t3 <- qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM")
t3b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", child_labels = "hidden") %>%
split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) %>%
analyze(names(ex_adsl)[1], count_use_nms) %>%
append_topleft("count") %>%
build_table(ex_adsl)
nice_comp_table(t3, t3b)
t4 <- qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
t4b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", child_labels = "hidden") %>%
split_cols_by("STRATA1") %>%
split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
split_rows_by("SEX", split_fun = drop_split_levels, child_labels = "hidden") %>%
analyze(names(ex_adsl)[1], count_use_nms) %>%
append_topleft("count") %>%
build_table(ex_adsl)
nice_comp_table(t4, t4b)
t5 <- qtable(ex_adsl,
row_vars = c("COUNTRY", "SEX"),
col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
)
mean_use_nm <- function(x, .spl_context, ...) {
rcell(mean(x, ...), format = "xx.xx", label = tail(.spl_context$value, 1))
}
t5b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>%
split_cols_by("STRATA1", split_fun = drop_split_levels) %>%
split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) %>%
analyze("AGE", mean_use_nm) %>%
append_topleft("AGE - mean") %>%
build_table(ex_adsl)
nice_comp_table(t5, t5b)
t6 <- qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list)
t6b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>%
split_rows_by("SEX", split_fun = drop_split_levels) %>%
analyze("AGE", summary_list2) %>%
append_topleft("AGE - summary_list") %>%
build_table(ex_adsl)
nice_comp_table(t6, t6b)
t7 <- suppressWarnings(qtable(ex_adsl,
row_vars = "SEX",
col_vars = "ARM", avar = "AGE", afun = range
))
range_use_nms <- function(x, .spl_context, ...) {
rcell(suppressWarnings(range(x)), label = tail(.spl_context$value, 1), format = "xx.x / xx.x")
}
t7b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>%
split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) %>%
analyze("AGE", range_use_nms) %>%
append_topleft("AGE - range") %>%
build_table(ex_adsl)
nice_comp_table(t7, t7b)
t8 <- qtable(ex_adsl,
row_vars = c("COUNTRY", "SEX"),
col_vars = c("ARM"), avar = "AGE", afun = mean,
summarize_groups = TRUE
)
t9 <- qtable(ex_adsl,
row_vars = c("COUNTRY", "SEX"),
col_vars = c("ARM"), avar = "AGE", afun = summary_list,
summarize_groups = TRUE
)
t9b <- basic_table(show_colcounts = TRUE) %>%
split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>%
split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
summarize_row_groups() %>%
split_rows_by("SEX", split_fun = drop_split_levels) %>%
summarize_row_groups() %>%
analyze("AGE", summary_list2) %>%
append_topleft("AGE - summary_list") %>%
build_table(ex_adsl)
nice_comp_table(t9, t9b)
## regressions tests for https://github.com/insightsengineering/rtables/issues/698
fivenum3 <- function(x) {
as.list(fivenum(x))
}
t10 <- qtable(ex_adsl, col_vars = "ARM", avar = "AGE", afun = fivenum3, row_labels = letters[1:5])
expect_equal(top_left(t10), "AGE - fivenum3")
mpf10 <- matrix_form(t10)
expect_equal(
mf_strings(mpf10)[3:7, 1],
letters[1:5]
)
t11 <- qtable(
ex_adsl,
row_vars = "STRATA2", col_vars = "ARM", avar = "AGE", afun = fivenum3, row_labels = letters[1:5]
)
expect_equal(top_left(t11), "AGE - fivenum3")
mpf11 <- matrix_form(t11)
expect_equal(
mf_strings(mpf11)[4:8, 1],
letters[1:5]
)
t12 <- qtable(ex_adsl, row_vars = "STRATA2", col_vars = "ARM", avar = "AGE", afun = mean, row_labels = "mylabel")
## compactness
expect_equal(top_left(t12), "mylabel")
mpf12 <- matrix_form(t12)
expect_equal(mf_strings(mpf12)[3:4, 1], levels(ex_adsl$STRATA2))
t13 <- qtable(ex_adsl, col_vars = "ARM", avar = "AGE", afun = mean, row_labels = "mylabel")
expect_identical(top_left(t13), character())
mpf13 <- matrix_form(t13)
expect_equal(mf_strings(mpf13)[3, 1], "mylabel")
expect_error(
qtable(ex_adsl,
row_vars = "STRATA2", col_vars = "ARM", avar = "AGE",
afun = mean, row_labels = c("ABC", "EFG", "HIJ")
),
"does not agree with number of rows"
)
expect_error(
qtable(ex_adsl,
col_vars = "ARM", avar = "AGE", afun = fivenum3,
row_labels = "ABC"
),
"does not agree with number of rows"
)
})
## https://github.com/insightsengineering/rtables/issues/671
test_that("problematic labels are caught and give informative error message", {
lyt <- basic_table() %>%
split_rows_by("Species") %>%
analyze("Sepal.Length", afun = make_afun(simple_analysis, .labels = list(Mean = "this is {test}")))
expect_error(build_table(lyt, iris), "Labels cannot contain [{] or [}] due to")
})
## No superfluous warning
test_that("No superfluous warning when ref group is set with custom split fun", {
reorder_facets <- function(splret, spl, fulldf, ...) {
# browser() if you enter here the order of splret seems already correct
ord <- order(names(splret$values))
make_split_result(
splret$values[ord],
splret$datasplit[ord],
splret$labels[ord]
)
}
lyt <- basic_table() %>%
split_cols_by("Species", ref_group = "virginica", split_fun = make_split_fun(post = list(reorder_facets))) %>%
analyze("Sepal.Length")
expect_silent(build_table(lyt, iris))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.