tests/testthat/test-regressions.R

In rtables: Reporting Tables

context("regression tests")


test_that("unlisting rtables has no effect on them", {

  t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))

  expect_identical(t1, unlist(t1))
})


test_that("manually created label l rows are always visible",
          expect_true(rtables:::labelrow_visible(rrow(""))))


## was error before rtables 0.3.2.16
test_that("printing table with 0 rows works", {
    norows <- rtable(c("hi", "lo"))
    capture.output({prout <- print(norows)})
    expect_identical(prout, norows)
})



test_that("inclNAs argument works as expected", {

    tinydat <- data.frame(RSP = c(TRUE, FALSE, NA, TRUE),
                          ARM = factor(c("A", "A", "B", "B")))
    tbl1 <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze(vars = "RSP", inclNAs = FALSE) %>%
        build_table(df = tinydat)

    expect_equal(tbl1[1, 2, drop = TRUE], 1)
    tbl2 <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze(vars = "RSP", inclNAs = TRUE) %>%
        build_table(df = tinydat)

    expect_true(is.na(tbl2[1, 2, drop = TRUE]))
})

test_that("head/tail work", {
    tbl <- rtable(c("hi", "lo"),
                  rrow("rn", 5, 5))
    expect_false(is.null(head(tbl)))
    expect_false(is.null(tail(tbl)))
    tbl_none <- tbl
    top_left(tbl) <- "hiya"
    main_title(tbl) <- "title"
    subtitles(tbl) <- c("subt 1", "subt2")
    main_footer(tbl) <- "footer"
    prov_footer(tbl) <- "prov"
    ## 335
    .check_em <- function(t, tbl) {
        expect_identical(top_left(t), top_left(tbl))
        expect_identical(main_title(t), main_title(tbl))
        expect_identical(subtitles(t), subtitles(tbl))
        expect_identical(top_left(t), top_left(tbl))
        expect_identical(top_left(t), top_left(tbl))
        expect_identical(top_left(t), top_left(tbl))
        TRUE
    }
    t_h <- head(tbl)
    .check_em(head(tbl), tbl)
    .check_em(tail(tbl), tbl)
    .check_em(head(tbl, keep_topleft = FALSE, keep_titles = FALSE),
              tbl_none)
    .check_em(tail(tbl, keep_topleft = FALSE, keep_titles = FALSE),
              tbl_none)
})

test_that("sort does not clobber top-level siblings", {
    lyt <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze("AGE") %>%
        split_rows_by("SEX") %>%
        analyze("AGE", function(x) in_rows(mean = mean(x), "mean+5" = mean(x) + 5))

    tbl <- build_table(lyt, rawdat)

    stbl <- sort_at_path(tbl, c("SEX", "*", "AGE"), function(tt) sum(unlist(row_values((tt)))), decreasing = TRUE)

    expnms <- c("Mean", "M", "mean+5", "mean", "F", "mean+5", "mean")
    expect_identical(row.names(stbl), expnms)
})


test_that("repeated multi-var analyzes work as expected", {
    works <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze(c("SEX", "RACE", "STRATA1"), afun = list_wrap_x(table)) %>%
        analyze("COUNTRY", afun = list_wrap_x(table)) %>%
        build_table(DM)

    fails <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze(c("SEX", "RACE"), afun = list_wrap_x(table)) %>%
        analyze(c("STRATA1", "COUNTRY"), afun = list_wrap_x(table)) %>%
        build_table(DM)

    expect_identical(works, fails)
})


test_that("summarize_row_groups after analyze call(s) work", {
    lyt1 <- basic_table() %>%
        analyze("SEX") %>%
        split_rows_by("SEX") %>%
        analyze("SEX")
    tbl1 <- build_table(lyt1, DM)
    expect_equal(dim(tbl1), c(24, 1))

    ## further regression when we have multiple analyze calls
    lyt2 <- basic_table() %>%
        analyze("SEX") %>%
        analyze("STRATA1") %>%
        split_rows_by("SEX") %>%
        analyze("SEX")
    tbl2 <- build_table(lyt2, DM)
    expect_equal(dim(tbl2), c(29, 1))
})


test_that("summarize_row_groups at top level works", {
    lyt <- basic_table() %>%
        summarize_row_groups("SEX")

    tbl <- build_table(lyt, DM)
    expect_equal(length(tree_children(tbl)), 0)
    expect_equal(dim(tbl), c(1, 1))
})

test_that("CellValue on something with object labels", {
    expect_identical(obj_label(CellValue(with_label(5, "hi"))),
                     "hi")

    expect_identical(obj_label(CellValue(with_label(5, "hi"),
                                         label = "")),
                     "")

    expect_identical(obj_label(CellValue(with_label(5, "hi"),
                                         label = NULL)),
                     "hi")
})


test_that("rcell on CellValue overrides attrs as necessary", {
    val <- CellValue(c(100, .5), format = "xx (xx.x%)", label = "oldlabel",
                     colspan = 2L,
                     indent_mod = 2L)
    val2 <-  CellValue(c(100, .5), format = "xx (xx.xx%)", label = "new label",
                       colspan = 3L,
                       indent_mod = 3L)
    expect_identical(rcell(val, format = "xx (xx.xx%)", label = "new label",
                           colspan = 3L, indent_mod = 3L),
                     val2)
})


test_that("cell-level formats are retained when column subsetting", {
    tbl <- rtable(
        header = c("Treatement\nN=100", "Comparison\nN=300"),
        format = "xx (xx.xx%)",
        rrow("A", c(104, .2), c(100, .4)),
        rrow("B", c(23, .4), c(43, .5)),
        rrow(""),
        rrow("this is a very long section header"),
        rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
        rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2)))

    ## this tests for no warnings, because testthat is terribly designed
    expect_warning(toString(tbl), regexp = NA)
    subset <- tbl[, 1]
    expect_identical(matrix_form(subset)$strings,
                     matrix_form(tbl)$strings[, -3])

})

test_that("row subsetting works on table with only content rows", {
    l <- basic_table() %>%
        split_cols_by("ARM") %>%
        split_rows_by("RACE") %>%
        summarize_row_groups()
    tab <- build_table(l, DM)
    rw <- tab[1, ]
    expect_identical(cell_values(rw),
                     cell_values(tab)[[1]])
    expect_identical(unname(tab[1, 1, drop = TRUE]),
                     79 * c(1, 1 / sum(DM$ARM == "A: Drug X")))
})


test_that("calls to make_afun within loop work correctly", {

    dummy_stats_function <- function(x) {
        list("s_mean" = mean(x))
    }

    dummy_layout <- function(lyt, vv) {

        for (i in seq_along(vv)) {

            afun <- make_afun(
                dummy_stats_function,
                .stats = "s_mean",
                .labels =  c(s_mean = vv[i]), #set labels here to match variable name
                .formats = c(s_mean = "xx.x")
            )

            lyt <- analyze(
                lyt,
                vars = vv[i],
                afun = afun,
                show_labels = "visible"
            )
        }

        lyt
    }

    tab <- basic_table() %>%
        split_cols_by("ARM") %>%
        dummy_layout(vv = c("BMRKR1", "AGE")) %>%
        build_table(DM)

    expect_identical(row.names(tab),
                     c("BMRKR1", "BMRKR1", "AGE", "AGE"))
})


test_that("keeping non-existent levels doesn't break internal machinery", {
    ANL <- DM
    ANL$COUNTRY <- as.character(ANL$COUNTRY)

    sfun <- keep_split_levels("ABC")


    lyt <- basic_table() %>%
        analyze("AGE") %>%
        split_rows_by("COUNTRY", split_fun = sfun) %>%
        summarize_row_groups() %>%
        analyze("AGE")

    result <- build_table(lyt, df = ANL)
    expect_identical(dim(result), c(3L, 1L))
    expect_identical(row.names(result), c("Mean", "ABC", "Mean"))
    cbres <- cbind_rtables(result, result)
    expect_identical(dim(cbres), c(3L, 2L))
    expect_identical(row.names(cbres), c("Mean", "ABC", "Mean"))

    ## because its a factor and "ABC" isn't a real level
    expect_error(build_table(lyt, DM))

    expect_error(cbind_rtables(result[-1, ], result[-3, ]), "Mismatching, non-empty row names")
})

test_that("add_overall_col with no col splits works", {

    lyt <- basic_table() %>% add_overall_col("whaaat") %>% analyze("AGE", mean)
    tab <- build_table(lyt, DM) ## previously error
    expect_identical(names(tab), "whaaat")
})


test_that("cell_values works when you path all the way to the row", {
    tbl <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze(c("SEX", "AGE")) %>%
        build_table(ex_adsl)
    res <- cell_values(tbl, c("AGE", "Mean"),  c("ARM", "B: Placebo"))
    expect_identical(res[[1]], mean(subset(ex_adsl, ARM == "B: Placebo")$AGE))
})


test_that("(xx,xx) format works correctly", {

    expect_identical("(2, 5)",
                     format_rcell(rcell(c(2, 5), format = "(xx, xx)")))

})

test_that("inclNAs with empty factor levels behaves", {

    ## no NAs in DM$RACE so following 2 tables should be fully identical

    ## NO TIBBLES!!!!!!!!!!!!!!!!!!!
    dfdm <- as.data.frame(DM)
    tbl <- basic_table() %>%
        split_rows_by("RACE") %>%
        analyze("COUNTRY", function(x) in_rows(nobs = length(x)), inclNAs = TRUE) %>%
        build_table(dfdm)

    tbl2 <- basic_table() %>%
        split_rows_by("RACE") %>%
        analyze("COUNTRY", function(x) in_rows(nobs = length(x)), inclNAs = FALSE) %>%
        build_table(dfdm)
    expect_identical(tbl, tbl2)
})


## #173
test_that("column labeling works correctly when value label var is a factor", {

    ex_adsl$ARMLAB <- factor(ex_adsl$ARM,
                             labels = c("Drug X", "Placebo", "Combination"))
    lyt_orig <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze(c("AGE", "BMRKR2"))
    tbl_orig <- build_table(lyt_orig, ex_adsl)

    lyt_lab <- basic_table() %>%
        split_cols_by("ARM", labels_var = "ARMLAB") %>%
        analyze(c("AGE", "BMRKR2"))
    tbl_lab <- build_table(lyt_lab, ex_adsl)

    tbl_orig
    tbl_lab # wrong labeling here
    expect_identical(names(tbl_lab),
                     names(tbl_orig))
    str <- matrix_form(tbl_lab)$strings
    expect_identical(as.vector(str[1, ]),
                     c("", "Drug X", "Placebo", "Combination"))
})


## pathing regression tests
test_that("pathing works", {
    ## issue https://github.com/insightsengineering/rtables/issues/172
    result_overall <- basic_table(show_colcounts = TRUE) %>%
        split_cols_by("ARM") %>%
        add_overall_col("overall") %>%
        analyze(c("AGE", "SEX")) %>%
        build_table(ex_adsl)

    va <- value_at(result_overall, c("AGE", "Mean"), c("ARM", "C: Combination"))
    expect_identical(va, result_overall[2, 3, drop = TRUE])

    ## issue https://github.com/insightsengineering/rtables/issues/178
    t2 <- basic_table() %>%
        split_cols_by("ARMCD") %>%
        split_rows_by("COUNTRY", split_fun = keep_split_levels("CHN")) %>%
        analyze("SEX") %>%
        analyze("AGE", nested = FALSE) %>%
        analyze("BMRKR1") %>%
        build_table(ex_adsl)

    ## this may get changed, but for now enforce it
    expect_error(cell_values(t2, "AGE"))
    expect_identical(cell_values(t2, c("ma_AGE_BMRKR1", "AGE")),
                     cell_values(t2, c("ma_AGE_BMRKR1", "AGE", "Mean")))
    expect_identical(cell_values(t2, c("ma_AGE_BMRKR1", "AGE")),
                     lapply(split(ex_adsl$AGE, ex_adsl$ARMCD), mean))
})

## issue https://github.com/insightsengineering/rtables/issues/175
test_that("pagination works on tables with only 1 row", {
    tt <- rtable(header = " ", rrow("", "NUll report"))
    expect_identical(nrow(tt), 1L)
    expect_identical(pag_tt_indices(tt), list(1L))
})

test_that("in_rows doesn't clobber cell format when only 1 row", {
    afun <- function(x) {
        in_rows("name" = rcell(123.31241231, format = "xx.xx"))
    }
    lyt <- basic_table() %>%
        analyze("AGE", afun = afun)
    tbl <- build_table(lyt, DM)
    mf <- matrix_form(tbl)
    expect_identical(mf$strings[2, 2, drop = TRUE], "123.31")
})


## newlabels works in reorder_split_levels (https://github.com/insightsengineering/rtables/issues/191)

test_that("newlabels works in reorder_split_levels", {

    lyt <- basic_table() %>%
        split_cols_by("ARM") %>%
        split_rows_by(
            "COUNTRY",
            split_fun = reorder_split_levels(
                neworder = c("CAN", "PAK", "BRA"),
                newlabels = c(CAN = "Canada", PAK = "Pakistan", BRA = "Brazil")
            )
        ) %>%
        analyze("AGE")
    tab <- build_table(lyt, ex_adsl)
    expect_identical(c("Canada", "Mean", "Pakistan", "Mean", "Brazil", "Mean"),
                     row.names(tab))

})



## https://github.com/insightsengineering/rtables/issues/198
test_that("no extraneous footnote attribute", {

    r1 <- in_rows(
        .list = list(
            ncols = rcell(5L, "xx", label = "ncol")
        )
    )
    expect_false("footnote" %in% names(attributes(r1$ncols)))

    r2 <- in_rows(
        .list = list(
            ncols = rcell(5L, "xx", label = "ncol"),
            nrows = rcell(10L, "xx", label = "nrow")
        )
    )
    expect_false("footnote" %in% names(attributes(r2$ncols)))

})


## https://github.com/insightsengineering/rtables/issues/200
# nolint start
test_that("no max is -Inf warnings from make_row_df when content rows exist in places that don't have any child rows in the subsequent split", {
# nolint end
    dat2 <- data.frame(
        l1 = factor(c("A", "B")),
        l2 = factor(c("aa1", "bb1")),
        l3 = c("aaa1", "bbb1"),
        stringsAsFactors = FALSE
    )

    lyt <- basic_table() %>%
        split_rows_by("l1") %>%
        summarize_row_groups() %>%
        split_rows_by("l2") %>%
        summarize_row_groups() %>%
        split_rows_by("l3") %>%
        summarize_row_groups()
    tbl <- build_table(lyt, dat2)
    ## again, regexp of NA tests for ***no warnings***
    ## I know, I know, but I didn't design testthat!
    expect_warning(make_row_df(tbl), regexp = NA)

})

## discovered while preparing response for https://github.com/insightsengineering/rtables/issues/307
test_that("specifying function format with no cfun in summarize_row_groups works", {

    formfun <- function(x, output) if(x[1] == 0) "0" else format_value(x, "xx (xx.x%)", output = output)

    lyt <- basic_table() %>%
        split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>%
        split_rows_by("RACE", split_label = "Ethnicity", #5
                      label_pos = "topleft",
                      split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
        summarize_row_groups(format = formfun) %>%                       #4
        analyze("AGE", afun = mean, format = "xx.x")

    tbl <- build_table(lyt, DM[1:15, ]) # WHITE-F is 0  in the first 15 rows...
    mat <- matrix_form(tbl)
    expect_identical(mat$strings[4, 2, drop = TRUE], "0")
})

## https://github.com/insightsengineering/rtables/issues/314
test_that("child_label = hidden does not affect tree structure/pathing", {

    df <- expand.grid(
        ARM = factor(paste("ARM", c("A", "B"))),
        FCT = factor(c("f1", "f2"))
    )
    df <- cbind(df, val = seq_len(NROW(df)))

    df

    s_test <- function(df, ...) in_rows(mn = 1, sd = 2)

    lyt <- basic_table() %>%
        split_cols_by("ARM", ref_group = "ARM A") %>%
        split_rows_by("FCT", child_labels = "hidden") %>%
        analyze("val", afun = s_test)

    tbl <- build_table(lyt, df)

    lyt2 <-  basic_table() %>%
        split_cols_by("ARM", ref_group = "ARM A") %>%
        split_rows_by("FCT") %>%
        analyze("val", afun = s_test)

    tbl2 <- build_table(lyt2, df)

    rdf1 <- make_row_df(tbl)
    rdf2 <- make_row_df(tbl2)
    expect_identical(row_paths(tbl),
                     row_paths(tbl2)[-c(1, 4)])

    expect_identical(make_row_df(tbl, visible_only = FALSE)$path,
                     make_row_df(tbl2, visible_only = FALSE)$path[-c(2, 7)])

    expect_identical(value_at(tbl, c("FCT", "f1", "val", "mn"), c("ARM", "ARM A")),
                     1)
    expect_identical(value_at(tbl2, c("FCT", "f1", "val", "mn"), c("ARM", "ARM A")),
                     1)

})


## ensure nested = FALSE not needed after analyze

test_that("nested = FALSE not needed after analyze", {


    lyt1 <- basic_table() %>%
        analyze("AGE") %>%
        split_rows_by("STRATA1") %>%
        analyze("AGE")

    lyt2 <- basic_table() %>%
        analyze("AGE") %>%
        split_rows_by("STRATA1", nested = FALSE) %>%
        analyze("AGE")

    expect_identical(lyt1, lyt2)
})



test_that("indent mod preserved when paginating between multi-analyses", {
    adsl2 <- ex_adsl
    adsl2$smoker <- factor(NA, levels = c("10 cigarettes", ">10 cigarettes"))
    adsl2$age_grp <- cut(adsl2$AGE, c(18, 65, 75, 1000), labels = c("18 <= to < 65",
                                                                    "65 <= to < 75",
                                                                    "Elderly >= 75"))

    ## make one of the factor levels of SEX variable empty
    adsl2 <- subset(adsl2, SEX != "UNDIFFERENTIATED")

    ## helper that omits the pct entirely if the count is 0
    count_pct <- function(x, .N_col, ...) {
        if(x == 0) {
            rcell(0, format = "xx")
        } else {
            rcell(c(x, x / .N_col), format = "xx (xx.x%)")
        }
    }

    ## analysis function: table factor then apply above to get our cell values
    tab_w_pct <- function(x, .N_col, ...) {
        tab <- as.list(table(x))
        lapply(tab, count_pct, .N_col = .N_col)
    }

    lyt3 <- basic_table() %>%
        split_cols_by("ARM") %>%
        summarize_row_groups("USUBJID", label_fstr = "Number of Patients", format = "xx") %>%
        analyze("SEX", tab_w_pct, var_labels = "Gender", indent_mod = -1) %>%
        analyze("smoker", tab_w_pct, indent_mod = -1) %>%
        analyze("age_grp", tab_w_pct, indent_mod = -1)

    tab <- build_table(lyt3, adsl2)

    res <- paginate_table(tab, lpp = 10, verbose = TRUE)

    rdf <- make_row_df(res[[2]])
    expect_equal(rdf$indent[2], #smoker row
                 0)
})


## https://github.com/insightsengineering/rtables/issues/634
## problem was actually in formatters fixed there in PR #152
test_that("export_as_txt works when there are newlines in column labels (naturally or after wrapping", {
    tbl <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by("ACTARM") %>%
    split_rows_by(
      "PARAMCD",
      labels_var = "PARAM",
      split_fun = drop_split_levels
    ) %>%
    split_rows_by(
      "AVISIT",
      split_fun = drop_split_levels,
      label_pos = "hidden"
    ) %>%
    split_cols_by_multivar(
      vars = c("AVAL", "CHG"),
      varlabels = c("Analysis Value", "Change from\nBaseline")
    ) %>%
    analyze_colvars(afun = mean) %>%
    build_table(formatters::ex_adlb)

    expect_silent({tmp <- export_as_txt(tbl, lpp = 20)})
})