Nothing
tests/testthat/test-lyt-tabulation.R
In rtables: Reporting Tables
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%)"))
})
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("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)))
})
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("", 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))
})
Try the rtables package in your browser
Any scripts or data that you put into this service are public.
rtables documentation built on Aug. 30, 2023, 5:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
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%)"))
})
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("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)))
})
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("", 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))
})
Try the rtables package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.