tests/testthat/test-formatting.R

In rtables: Reporting Tables

context("value formatting")

test_that("sprintf_format works correctly", {


    myfun <- sprintf_format("hi there %1.4f")

    lyt <- basic_table() %>%
        split_cols_by("Species") %>%
        analyze("Sepal.Width", afun = mean, format = myfun)

    tbl <- build_table(lyt, iris)

    matform <- matrix_form(tbl)

    expect_identical(matform$strings[2, ],
                     c("mean", "hi there 3.4280",
                       myfun(2.77),
                       myfun(mean(subset(iris, Species == "virginica")$Sepal.Width))))
})



test_that("table_shell works", {

    tbl <- rtable(c("A", "B"),
                  rrow("Hiya",
                       rcell(c(2, .2),
                             format = "xx (xx.x%)"),
                       rcell(c(.1, .2)),
                       format = "xx.x - xx.x"),
                  rrow("bye", 5.2345, 17.2),
                  format = "xx.xx")


    tblsh <- rtable(c("A", "B"),
                  rrow("Hiya", "xx (xx.x%)", "xx.x - xx.x"),
                  rrow("bye", "xx.xx", "xx.xx"))

    expect_identical(toString(tblsh),
                     paste0(capture_output(table_shell(tbl)), "\n"))

    tbl2 <-  rtable(c("A", "B"),
                  rrow("Hiya",
                       rcell(c(2, .2),
                             format = function(x, ...) paste0(x)),
                       rcell(c(.1, .2)),
                       format = "xx.x - xx.x"),
                  rrow("bye", 5.2345, 17.2),
                  format = "xx.xx")

    tbl2sh <- rtable(c("A", "B"),
                    rrow("Hiya", "<fnc>", "xx.x - xx.x"),
                    rrow("bye", "xx.xx", "xx.xx"))

    expect_identical(toString(tbl2sh),
                     paste0(capture_output(table_shell(tbl2)), "\n"))

})

test_that("rcell format_na_str functionality works", {

    expect_identical(format_rcell(rcell(NA_real_,
                                        format = "xx.xx",
                                        format_na_str = "hiya")),
                     "hiya")

    ## default still works
    expect_identical(format_rcell(rcell(NA_real_, format = "xx.x")),
                     "NA")

    irs <- in_rows(val1 = NA_real_, val2 = NA_integer_,
                   .formats = list(val1 = "xx.x", val2 = "xx.x"),
                   .format_na_strs = list(val1 = "hiya", val2 = "lowdown"))
})

test_that("format_na_str functionality works in get_formatted_cells (i.e. printing) and make_afun", {

    DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
    DM2$AGE <- NA
    DM2$AGE[1] <- 1

    s_summary <- function(x) {
        stopifnot(is.numeric(x))

        list(
            n = sum(!is.na(x)),
            mean = mean(x),
            min_max = range(x)
        )
    }

    a_summary <- make_afun(
        fun = s_summary,
        .formats = c(n = "xx", mean = "xx.xx", min_max = "xx.xx - xx.xx"),
        .labels = c(n = "n", mean = "Mean", min_max = "min - max")
    )

    a_summary3 <- make_afun(a_summary,
                            .formats = c(mean = "xx.xxx"),
                            .format_na_strs = c(mean = "Ridiculous"))

    l <- basic_table() %>%
        split_cols_by("ARM") %>%
        split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
        summarize_row_groups(label_fstr = "%s (n)") %>%
        analyze("AGE", afun = a_summary3, format = "xx.xx")

    tbl <- suppressWarnings(build_table(l, DM2))
    tbl
    expect_identical(get_formatted_cells(tbl)[3, 1, drop = TRUE],
                     "Ridiculous")
})

test_that("format and na_str inheritance", {
    # Test data
    DM2 <- DM %>%
        filter(ARM != levels(DM$ARM)[3]) %>%
        mutate(ARM = as.factor(as.character(ARM)))
    DM2$AGE[1] <- NA # Adding one NA

    # Manually building the table
    weird_afun <- function(x, ...) {
        in_rows(cell_fmt = rcell(mean(x, na.rm = TRUE), format = "xx.x"),
                no_cell_fmt = rcell(median(x, na.rm = TRUE)),
                no_cell_na_str = rcell(NA, format = "xx.x"),
                cell_na_str_no_cell_fmt = rcell(NA, format_na_str = "what"),
                cell_fmt_range = rcell(range(x, na.rm = TRUE), format = "xx.x - xx.x"),
                cell_na_str_range = rcell(c(NA, 2), format = "xx.x - xx.x", format_na_str = "bah"),
                no_cell_na_str_no_cell_fmt_range = rcell(c(NA, 2), format = "xx.x - xx.x")
                )
    }

    # Main builder
    tbl <- basic_table() %>%
        split_cols_by("ARM") %>%
        analyze("AGE", weird_afun, format = "xx.xx", na_str = "lol") %>%
        build_table(DM2)

    # Get the ASCII table
    result <- get_formatted_cells(tbl) # Main function

    # Expected data-set is built with dplyr
    expected <- DM2 %>%
        dplyr::group_by(ARM) %>%
        summarise(
          m_age = format_value(mean(AGE, na.rm = TRUE), format = "xx.x"),
          me_age = format_value(median(AGE, na.rm = TRUE), format = "xx.xx"),
          m_range = paste(sapply(range(AGE, na.rm = TRUE), format_value, format = "xx.x"), collapse = " - ")
        ) %>%
        mutate(b = "lol", c = "what", d = "bah - 2.0", e = "lol - 2.0") %>%
        select(m_age, me_age, b, c, m_range, d, e) %>%
        mutate_all(as.character) %>%
        t() %>%
        as.matrix()
    dimnames(expected) <- NULL # Fixing attributes

    # Check if it preserves the format and na_str replacements
    expect_identical(result, expected)

    # Get the ASCII table of formats (shell)
    result <- get_formatted_cells(tbl, shell = TRUE) # Main function

    # Expected ASCII table (manual insertion)
    one_col <- c("xx.x", "xx.xx", "xx.x", "xx.xx", "xx.x - xx.x", "xx.x - xx.x", "xx.x - xx.x")
    expected <- cbind(one_col, one_col)
    dimnames(expected) <- NULL # Fixing attributes

    # Check if it preserves the shell format
    expect_identical(result, expected)
})