Nothing
context("Accessing and subsetting tables")
test_that("cell_values function works as desired", {
l <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("SEX") %>%
split_rows_by("RACE") %>%
summarize_row_groups() %>%
split_rows_by("STRATA1") %>%
analyze("AGE", afun = function(x, .N_col, .N_row) rcell(c(.N_row, .N_col), format = "(xx.x, xx.x)"))
ourdat <- DM
ourdat$SEX <- droplevels(ourdat$SEX)
ourdat$RACE <- droplevels(ourdat$RACE)
tbl <- build_table(l, ourdat)
armsextab <- table(ourdat$SEX, ourdat$ARM)
armaval <- "A: Drug X"
cvres1 <- cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M"))
contcount <- nrow(subset(ourdat, RACE == "ASIAN" & ARM == armaval & SEX == "M"))
asianstrata <- table(subset(ourdat, RACE == "ASIAN")$STRATA1)
expect_equal(
unname(cvres1),
list(
list("A: Drug X.M" = c(
contcount,
contcount / armsextab["M", armaval]
)),
list("A: Drug X.M" = c(
unname(asianstrata["A"]),
armsextab["M", armaval]
)),
list("A: Drug X.M" = c(
unname(asianstrata["B"]),
armsextab["M", armaval]
)),
list("A: Drug X.M" = c(
unname(asianstrata["C"]),
armsextab["M", armaval]
))
)
)
cvres2 <- cell_values(
tbl, c("RACE", "ASIAN", "STRATA1"),
c("ARM", "A: Drug X", "SEX", "M")
)
expect_identical(unname(cvres1[2:4]), unname(cvres2))
cvres3 <- cell_values(
tbl, c("RACE", "ASIAN", "STRATA1", "B"),
c("ARM", "A: Drug X", "SEX", "M")
)
expect_identical(cvres3, cvres1[[3]])
## any arm, male columns from the ASIAN content (i.e. summary) row
cvres4 <- cell_values(tbl, c("RACE", "ASIAN", "@content"))
expect_identical(cvres4[2], cvres1[[1]])
cvres5 <- cell_values(
tbl, c("RACE", "ASIAN", "@content"),
c("ARM", "*", "SEX", "M")
)
expect_identical(cvres5, cvres4[seq(2, 6, by = 2)])
## all columns
cvres6 <- cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B"))
## all columns for the Combination arm
cvres7 <- cell_values(
tbl, c("RACE", "ASIAN", "STRATA1", "B"),
c("ARM", "C: Combination")
)
expect_identical(
cvres6[5:6],
cvres7
)
cvres8 <- cell_values(
tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE"),
c("ARM", "C: Combination", "SEX", "M")
)
vares8 <- value_at(
tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE"),
c("ARM", "C: Combination", "SEX", "M")
)
expect_identical(cvres8[[1]], vares8)
expect_error(value_at(
tbl, c("RACE", "ASIAN", "STRATA1", "B"),
c("ARM", "C: Combination", "SEX", "M")
))
expect_error(value_at(
tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE"),
c("ARM", "C: Combination", "SEX")
))
expect_error(value_at(
tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE"),
c("ARM", "C: Combination")
))
allrows <- collect_leaves(tbl, TRUE, TRUE)
crow <- allrows[[1]]
lrow <- allrows[[2]]
expect_error(
cell_values(crow, rowpath = "@content"),
"cell_values on TableRow objects must have NULL rowpath"
)
expect_error(
cell_values(lrow),
"cell_values on LabelRow is not meaningful"
)
})
test_colpaths <- function(tt) {
cdf <- make_col_df(tt, visible_only = TRUE)
cdf2 <- make_col_df(tt, visible_only = FALSE)
res3 <- lapply(cdf$path, function(pth) rtables:::subset_cols(tt, pth))
res4 <- lapply(cdf2$path, function(pth) rtables:::subset_cols(tt, pth))
expect_identical(res3, res4[!is.na(cdf2$abs_pos)])
expect_identical(res3, lapply(
seq_len(ncol(tt)),
function(j) tt[, j]
))
TRUE
}
test_rowpaths <- function(tt, visonly = TRUE) {
cdf <- make_row_df(tt, visible_only = visonly)
res3 <- lapply(cdf$path, function(pth) cell_values(tt, pth)) # nolint
TRUE
}
test_that("make_row_df, make_col_df give paths which all work", {
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")
tab <- build_table(lyt, rawdat)
rdf1a <- make_row_df(tab)
rdf1b <- make_row_df(tab, visible_only = FALSE)
expect_true(
all.equal(rdf1a, rdf1b[!is.na(rdf1b$abs_rownumber), ],
check.attributes = FALSE
), ## rownames ugh
"visible portions of row df not identical between
visible_only and not"
)
allcvs <- cell_values(tab)
allcvs_un <- unname(allcvs)
pathres <- lapply(rdf1b$path, function(pth) unname(cell_values(tab, pth)))
expect_identical(
pathres,
list(
allcvs_un,
allcvs_un[1:2], ## XXX this probably shouldn't be here
unname(allcvs_un[[1]]),
unname(allcvs_un[[1]]),
unname(allcvs_un[[2]]),
unname(allcvs_un[[2]]),
allcvs_un[3:6], ## RACE
allcvs_un[3:4], ## WHITE Tabletree
allcvs_un[3:4], ## WHITE LabelRow
unname(allcvs_un[[3]]), ## white age ElemtaryTable
unname(allcvs_un[[3]]), ## white age DataRow
unname(allcvs_un[[4]]), ## white compare ElemtaryTable
unname(allcvs_un[[4]]), ## white compare DataRow
allcvs_un[5:6], ## BLACK TableTree
allcvs_un[5:6], ## BLACK LabelRow
unname(allcvs_un[[5]]), ## black ageElemtaryTable
unname(allcvs_un[[5]]), ## black age DataRow
unname(allcvs_un[[6]]), ## black compare ElemtaryTable
unname(allcvs_un[[6]])
)
) ## black compare DataRow
test_colpaths(tab)
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()
)
l2 <- basic_table(show_colcounts = TRUE) %>%
split_cols_by(
"ARM",
split_fun = add_combo_levels(combodf, keep_levels = c("A_", "B_C"))
) %>%
analyze(c("AGE", "AGE"),
afun = list(mean, range),
show_labels = "hidden", table_names = c("AGE mean", "AGE range")
)
tab2 <- build_table(l2, DM)
test_colpaths(tab2)
cdf2 <- make_col_df(tab2)
## res5 <- lapply(cdf2$path, function(pth) subset)cols
})
test_that("Duplicate colvars path correctly", {
l <- basic_table() %>%
split_cols_by_multivar(c("AGE", "BMRKR1", "AGE"), varlabels = c("Age", "Biomarker 1", "Second Age")) %>%
analyze_colvars(mean)
tbl <- build_table(l, DM)
matform <- matrix_form(tbl)
expect_identical(
matrix(
c(
"", "Age", "Biomarker 1", "Second Age",
"mean", mean(DM$AGE), mean(DM$BMRKR1), mean(DM$AGE)
),
nrow = 2, byrow = TRUE
),
matform$strings
)
res <- cell_values(tbl, colpath = c("multivars", "AGE._[[2]]_."))
expect_identical(
list("AGE._[[2]]_." = mean(DM$AGE, na.rm = TRUE)),
res
)
})
test_that("top_left, title, footers retention behaviors are correct across all scenarios", {
# topleft
tlval <- "hi"
# title
ti <- "ti"
sti <- "sti"
# footers
mf <- "mf"
pf <- "pf"
rf <- "rf"
lyt <- basic_table(
title = ti, subtitles = sti,
main_footer = mf, prov_footer = pf
) %>%
split_cols_by("ARM") %>%
append_topleft(tlval) %>%
split_rows_by("SEX") %>%
analyze("AGE", mean)
tbl <- build_table(lyt, DM)
fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "mean")) <- rf
fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "mean")) <- rf
# topleft
expect_identical(top_left(tbl), tlval)
expect_identical(top_left(tbl[, 1]), tlval) ## default column-only subsetting is TRUE
expect_identical(top_left(tbl[, 1, keep_topleft = FALSE]), character())
expect_identical(top_left(tbl[, 1, keep_topleft = TRUE]), tlval)
expect_identical(top_left(tbl[1, ]), character()) ## default with any row subsetting is FALSE
expect_identical(top_left(tbl[1, , keep_topleft = FALSE]), character())
expect_identical(top_left(tbl[1, , keep_topleft = TRUE]), tlval)
expect_identical(top_left(tbl[1:2, 1:2]), character())
expect_identical(top_left(tbl[1:2, 1:2, keep_topleft = FALSE]), character())
expect_identical(top_left(tbl[1:2, 1:2, keep_topleft = TRUE]), tlval)
# drop = TRUE works
expect_identical(suppressWarnings(tbl[1, 1, drop = TRUE]), NULL)
expect_warning(tbl[1, 1, drop = TRUE])
expect_equal(tbl[2, 1, drop = TRUE], 33.71, tolerance = 0.01)
# referential footnotes
expect_identical(
mf_rfnotes(matrix_form(tbl[2, 1])),
paste0("{1} - ", rf)
)
expect_identical(
mf_rfnotes(matrix_form(tbl[4, 1])),
paste0("{1} - ", rf)
)
expect_identical(
mf_rfnotes(matrix_form(tbl[4, 1, reindex_refs = FALSE])),
paste0("{1} - ", rf)
)
expect_identical(mf_rfnotes(matrix_form(tbl[1, 1])), character())
# titles and footers
expect_identical(main_title(tbl[1, 1]), "")
expect_identical(main_title(tbl[1, 1, keep_titles = FALSE]), "")
expect_identical(main_footer(tbl[1, 1, keep_titles = FALSE]), character())
expect_identical(main_title(tbl[1, 1, keep_titles = TRUE]), ti)
expect_identical(subtitles(tbl[1, 1, keep_titles = TRUE]), sti)
expect_identical(main_footer(tbl[1, 1, keep_footers = TRUE]), mf)
expect_identical(prov_footer(tbl[1, 1, keep_footers = TRUE]), pf)
# Further testing drop = TRUE
tbl1 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
analyze("AGE", function(x) list("m (sd)" = c(mean(x), sd(x)))) %>%
build_table(DM)
tbl2 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX", child_labels = "hidden") %>%
analyze("AGE", mean) %>%
build_table(DM)
# row with only numbers -> warning
expect_warning(tbl[4, , drop = TRUE])
# warnings for label row
expect_warning(tbl[, 1, drop = TRUE])
expect_warning(tbl[3, , drop = TRUE])
# warnings for more than one values
expect_warning(tbl1[4, , drop = TRUE])
expect_warning(tbl1[2, 1:2, drop = TRUE])
})
test_that("setters work ok", {
tlval <- "hi"
lyt <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
summarize_row_groups() %>%
analyze("AGE", mean)
tbl <- build_table(lyt, DM)
tbl2 <- tbl
tbl2[1, 1] <- CellValue(c(1, .1))
matform2 <- matrix_form(tbl2)
expect_identical("1 (10.0%)", matform2$strings[2, 2])
tbl3 <- tbl
tbl3[3, 1:2] <- list(CellValue(c(1, 1)), CellValue(c(1, 1)))
matform3 <- matrix_form(tbl3)
expect_identical(rep("1 (100.0%)", 2), matform3$strings[4, 2:3])
tbl2 <- tbl
tt_at_path(tbl2, c("SEX", "UNDIFFERENTIATED")) <- NULL
expect_equal(nrow(tbl2), 6)
tbl3 <- tbl
tt_at_path(tbl3, c("SEX", "UNDIFFERENTIATED", "AGE", "mean")) <- NULL
expect_equal(nrow(tbl3), 7)
lyt4 <- basic_table() %>%
split_cols_by("ARM") %>%
split_rows_by("SEX") %>%
analyze("AGE", mean)
tbl4 <- build_table(lyt4, DM)
tbl4[5:6, ] <- list(rrow("new label"), rrow("new mean", 5, 7, 8))
mform4 <- matrix_form(tbl4)
expect_identical(
mform4$strings[6, , drop = TRUE],
c("new label", "", "", "")
)
expect_identical(
cell_values(tbl4)[["U.AGE.mean"]],
list(5, 7, 8)
)
})
test_that("cell_values and value_at work on row objects", {
tbl <- basic_table() %>%
split_cols_by("ARM") %>%
split_cols_by("STRATA2") %>%
analyze("AEDECOD") %>%
build_table(ex_adae, ex_adsl)
first_row <- collect_leaves(tbl)[[1]]
va <- value_at(first_row, colpath = c("ARM", "A: Drug X", "STRATA2", "S2"))
cv <- cell_values(first_row, colpath = c("ARM", "C: Combination"))
expect_identical(va, 33L)
expect_identical(
cv,
setNames(
list(32L, 56L),
c(
"C: Combination.S1",
"C: Combination.S2"
)
)
)
})
test_that("label_at_path works", {
lyt <- make_big_lyt()
tab <- build_table(lyt, rawdat)
orig_labs <- row.names(tab)
tab4 <- tab
label_at_path(tab4, c("root", "RACE", "WHITE", "FACTOR2", "B", "AGE")) <- NA_character_
expect_identical(row.names(tab4), orig_labs[-9])
tab5 <- tab
newlab5 <- "race var label"
label_at_path(tab5, c("root", "RACE")) <- newlab5
expect_identical(row.names(tab5), c(newlab5, orig_labs))
rps <- row_paths(tab)
labs <- vapply(rps, function(pth) label_at_path(tab, pth), "",
USE.NAMES = FALSE
)
expect_identical(labs, orig_labs)
newthangalangs <- paste(orig_labs, "redux")
tab7 <- tab
for (i in seq_along(orig_labs)) label_at_path(tab7, rps[[i]]) <- newthangalangs[i]
expect_identical(
newthangalangs,
row.names(tab7)
)
})
test_that("insert_row_at_path works", {
lyt <- basic_table() %>%
split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
summarize_row_groups() %>%
analyze("AGE")
tab <- build_table(lyt, DM)
orig_rns <- row.names(tab)
tab2 <- insert_row_at_path(
tab, c("COUNTRY", "CHN", "AGE", "Mean"),
rrow("new row", 555)
)
expect_identical(
row.names(tab2),
c(
orig_rns[1],
"new row",
orig_rns[-1]
)
)
tab3 <- insert_row_at_path(tab2, c("COUNTRY", "CHN", "AGE", "Mean"),
rrow("new row redux", 888),
after = TRUE
)
expect_identical(
row.names(tab3),
c(
orig_rns[1],
"new row",
orig_rns[2],
"new row redux",
orig_rns[-c(1:2)]
)
)
myrow <- rrow("whaaat", 578)
rps <- row_paths(tab)
msg <- "path must resolve fully to a non-content data row."
expect_error(insert_row_at_path(tab, c("root", "COUNTRY"), myrow), msg)
expect_error(insert_row_at_path(tab, c("root", "COUNTRY", "CHN"), myrow), msg)
expect_error(insert_row_at_path(tab, c("root", "COUNTRY", "CHN", "AGE"), myrow), msg)
expect_error(insert_row_at_path(tab, rps[[1]], myrow), msg)
lyt4 <- basic_table() %>%
split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
analyze("AGE")
tab4 <- build_table(lyt4, DM)
expect_identical(
label_at_path(tab4, c("COUNTRY", "CHN")),
"CHN"
)
label_at_path(tab4, c("COUNTRY", "CHN")) <- "China"
expect_identical(
row.names(tab4),
c("China", "Mean", "USA", "Mean")
)
label_at_path(tab4, c("COUNTRY", "CHN", "AGE", "Mean")) <- "Age Mean"
expect_identical(
row.names(tab4),
c("China", "Age Mean", "USA", "Mean")
)
})
test_that("bracket methods all work", {
tbl <- tt_to_export()
nrtot <- nrow(tbl)
tbl_a_white <- tbl[1:19, ]
expect_identical(
tbl[rep(c(TRUE, FALSE), c(19, nrtot - 19)), ],
tbl_a_white
)
expect_identical(
tt_at_path(tbl_a_white, c("STRATA1", "A", "RACE", "WHITE")),
tt_at_path(tbl, c("STRATA1", "A", "RACE", "WHITE"))
)
tbl_sub1 <- tbl[1:25, c(1, 4, 6)]
expect_identical(
tbl_sub1,
tbl[
rep(c(TRUE, FALSE), c(25, nrtot - 25)),
c(TRUE, FALSE, FALSE, TRUE, FALSE, TRUE)
]
)
expect_identical(
tbl[, c(1, 4, 6)],
tbl[, c(TRUE, FALSE, FALSE, TRUE, FALSE, TRUE)]
)
})
test_that("tt_at_path and cell_values work with values even if they differ in naming", {
# see issue #794
tbl <- basic_table() %>%
split_cols_by(var = "ARM", split_label = "asdar") %>%
# split_rows_by(var = "SEX") %>%
add_colcounts() %>%
analyze("AGE",
afun = function(x) {
out_list <- list(a = mean(x), b = 3)
labs <- c("argh", "argh2")
attr(out_list[[1]], "label") <- "aa"
attr(out_list[[2]], "label") <- "aa2"
in_rows(.list = out_list, .labels = labs, .names = labs)
},
show_labels = "visible", table_names = "nope"
) %>%
build_table(df = DM)
rdf <- make_row_df(tbl)
names(rdf$path[[2]]) <- c("a", "b")
expect_silent(tt_at_path(tbl, rdf$path[[2]]))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.