tests/testthat/test_subtotal.R

In expss: Tables, Labels and Some Useful Functions from Spreadsheets and 'SPSS' Statistics

context("subtotal")


a = 1:7
expect_known_value(cro(net(a, Bottom = 1:2, Top = 6:7, position = "below")),
                   "rds/subtotal1.rds", update = FALSE)
expect_known_value(cro(net(a, Bottom = function(x) x<3, Top = 6:7, position = "below")),
                   "rds/subtotal1.rds", update = FALSE)
expect_known_value(cro(net(a, Bottom = 1 %thru% 2, Top = greater(5), position = "below")),
                   "rds/subtotal1.rds", update = FALSE)
expect_known_value(cro(net(a, Bottom = 1:2, Top = 6:7, position = "above")),
                   "rds/subtotal2.rds", update = FALSE)
expect_known_value(cro(net(a, Top = 6:7, Bottom = 1:2, position = "top")),
                   "rds/subtotal3.rds", update = FALSE)
expect_known_value(cro(net(a, Bottom = 1:2, Top = 6:7, position = "bottom")),
                   "rds/subtotal4.rds", update = FALSE)

expect_known_value(cro(subtotal(a, Bottom = 1:2, Top = 6:7, position = "below")),
                   "rds/subtotal5.rds", update = FALSE)
expect_error(cro(subtotal(a, Bottom = 1:2 ~ 2.1, Top = 6:7 ~ 7.1, position = "below")))
expect_known_value(cro(subtotal(a, Bottom = 1:2, Top = 6:7, position = "above")),
                   "rds/subtotal6.rds", update = FALSE)
expect_known_value(cro(subtotal(a, Top = 6:7, Bottom = 1:2, position = "top")),
                   "rds/subtotal7.rds", update = FALSE)
expect_known_value(cro(subtotal(a, Bottom = 1:2, Top = 6:7, position = "bottom")),
                   "rds/subtotal8.rds", update = FALSE)



val_lab(a) = c(Three = 3)


expect_known_value(cro(net(a, 2:3, position = "below")),
                   "rds/subtotal9.rds", update = FALSE)
expect_known_value(cro(subtotal(a, 2:3, position = "above", new_label = "first")),
                   "rds/subtotal10.rds", update = FALSE)
expect_known_value(cro(net(a, 2:3, position = "top", prefix = "LAST ", new_label = "last")),
                   "rds/subtotal11.rds", update = FALSE)
expect_known_value(cro(subtotal(a, 2:3, position = "bottom")),
                   "rds/subtotal12.rds", update = FALSE)


var_lab(a) = "My 'a'"
expect_known_value(cro(subtotal(a, Bottom = 1:2, Top = 6:7, 'My new cat' = 98:99, position = "above")),
                   "rds/subtotal8a.rds", update = FALSE)

expect_known_value(cro(subtotal(a, Bottom = 1:2, Top = 6:7, 'My new cat' = gt(90), position = "above")),
                   "rds/subtotal8b.rds", update = FALSE)

expect_known_value(cro(subtotal(a, Bottom = 1:2, Top = 6:7, 'My new cat' = gt(90), position = "top")),
                   "rds/subtotal8c.rds", update = FALSE)

expect_known_value(cro(subtotal(a, Bottom = 1:2, Top2 = 6:7, Top3 = 5:7, 'My new cat' = gt(90), position = "below")),
                   "rds/subtotal8d.rds", update = FALSE)

expect_known_value(cro(net(a, Bottom = 1:2, Top2 = 6:7, Top3 = 5:7, 'My new cat' = gt(90), position = "below")),
                   "rds/subtotal8e.rds", update = FALSE)

b = rev(a)
val_lab(b) = c(Seven = 7)
var_lab(b) = "My 'b'"

my_df = sheet(a, b)

expect_known_value(
    cro(net(my_df, 1:2, Top = 6:7, position = "bottom", prefix = "NET ", new_label = "range")),
    "rds/subtotal12a.rds", update = FALSE)

expect_known_value(
    cro(subtotal(as.list(my_df), 1:2, Top = 6:7, position = "above")),
    "rds/subtotal12b.rds", update = FALSE)

my_letters = c("a", "b", "c", "d", "e", "f")
var_lab(my_letters) = "MY LETTERS"
expect_known_value(cro(subtotal(my_letters, c("b", "c", "d"), c("a", "e"), position = "below")),
                   "rds/subtotal13.rds", update = FALSE)

expect_known_value(cro(subtotal(my_letters, function(x) x %in% c("b", "c", "d"), c("a", "e"), position = "below")),
                   "rds/subtotal13.rds", update = FALSE)

expect_known_value(cro(subtotal(my_letters, perl("b|c|d"), contains("a") | contains("e"), position = "below")),
                   "rds/subtotal13.rds", update = FALSE)


expect_known_value(cro(subtotal(my_letters,  c("a", "e"),  c("b", "c", "d"),position = "above", prefix = "NET ")),
                   "rds/subtotal14.rds", update = FALSE)

expect_known_value(cro(subtotal(my_letters, c("a", "e"), c("b", "c", "d"), position = "top", new_label = "range")),
                   "rds/subtotal15.rds", update = FALSE)
expect_known_value(cro(subtotal(my_letters, c("a", "e"),  c("b", "c", "d"), position = "bottom", 
                                prefix = "NET ", new_label = "first")),
                   "rds/subtotal16.rds", update = FALSE)

expect_known_value(cro(subtotal(my_letters, "My bcd" = c("b", "c", "d"), "My ae" = c("a", "e"), 
                                position = "top", new_label = "range")),
                   "rds/subtotal17.rds", update = FALSE)


expect_known_value(cro(subtotal(my_letters, "My bcd" = c("b", "c", "d"), "My ae" = c("a", "e"), c("x", "y", "z"),
                                position = "above", new_label = "range")),
                   "rds/subtotal18.rds", update = FALSE)

expect_known_value(cro(subtotal(
    set_var_lab(factor(my_letters), var_lab(my_letters)),
    "My bcd" = c("b", "c", "d"), "My ae" = c("a", "e"), c("x", "y", "z"),
                                position = "above", new_label = "range")),
                   "rds/subtotal18.rds", update = FALSE)


expect_known_value(
    cro(net(my_letters, "My ae" = c("a", "e"), c("b", "c", "d"),  
                 position = "top", new_label = "range")),
    "rds/subtotal18a.rds", update = FALSE)

data(mtcars)
mtcars = apply_labels(mtcars,
                      mpg = "Miles/(US) gallon",
                      cyl = "Number of cylinders",
                      disp = "Displacement (cu.in.)",
                      hp = "Gross horsepower",
                      drat = "Rear axle ratio",
                      wt = "Weight (lb/1000)",
                      qsec = "1/4 mile time",
                      vs = "Engine",
                      vs = c("V-engine" = 0,
                             "Straight engine" = 1),
                      am = "Transmission",
                      am = c("Automatic" = 0,
                             "Manual"=1),
                      gear = "Number of forward gears",
                      gear = c(
                          One = 1,
                          Two = 2,
                          Three = 3,
                          Four = 4,
                          Five = 5
                      ),
                      carb = "Number of carburetors"
)

expect_known_value(
mtcars %>% 
    tab_cells(mpg) %>% 
    tab_net_cells("Low mpg" = less(mean(mpg)), "High mpg" = greater_or_equal(mean(mpg))) %>% 
    tab_cols(total(), carb) %>% 
    tab_stat_cases() %>% 
    tab_pivot()
, "rds/subtotal19.rds", update = FALSE)

expect_known_value(
mtcars %>% 
    tab_cells(mpg) %>% 
    tab_net_cells("Low mpg" = less(mean(mpg)), "High mpg" = greater_or_equal(mean(mpg))) %>% 
    tab_cols(gear) %>%
    tab_net_cols(1:2, 3:4, "5 and more" = greater(4)) %>% 
    tab_stat_cases() %>% 
    tab_pivot()
, "rds/subtotal20.rds", update = FALSE)

expect_known_value(
mtcars %>% 
    tab_cells(mpg) %>% 
    tab_rows(gear) %>%
    tab_subtotal_rows(1:2, 3:4, "5 and more" = greater(4), position = "above", prefix = "NET ", new_label = "range") %>% 
    tab_stat_mean() %>% 
    tab_pivot()
, "rds/subtotal21.rds", update = FALSE)

###########

res = mtcars %>% 
    tab_cells(mpg) %>% 
    tab_rows(gear) %>%
    tab_subtotal_rows(1:2, hide(3:4), "5 and more" = greater(4), position = "above", prefix = "NET ", new_label = "range") %>% 
    tab_stat_mean() %>% 
    tab_pivot()

reference = structure(list(row_labels = c("Number of forward gears|NET One - Two|Miles/(US) gallon|Mean", 
"Number of forward gears|One|Miles/(US) gallon|Mean", "Number of forward gears|Two|Miles/(US) gallon|Mean", 
"Number of forward gears|NET Three - Four|Miles/(US) gallon|Mean", 
"Number of forward gears|5 and more|Miles/(US) gallon|Mean", 
"Number of forward gears|Five|Miles/(US) gallon|Mean"), `#Total` = c(NA, 
NA, NA, 19.8518518518518, 21.38, 21.38)), row.names = c(NA, -6L
), class = c("etable", "data.frame"))

expect_equal(res, reference)


res = mtcars %>% 
    tab_cells(mpg) %>% 
    tab_rows(gear) %>%
    tab_subtotal_rows(hide(1:2), hide(3:4), "5 and more" = hide(greater(4)), position = "above", prefix = "NET ", new_label = "range") %>% 
    tab_stat_mean() %>% 
    tab_pivot()

reference = structure(list(row_labels = c("Number of forward gears|NET One - Two|Miles/(US) gallon|Mean", 
"Number of forward gears|NET Three - Four|Miles/(US) gallon|Mean", 
"Number of forward gears|5 and more|Miles/(US) gallon|Mean"), 
`#Total` = c(NA, 19.8518518518518, 21.38)), row.names = c(NA, 
-3L), class = c("etable", "data.frame"))
expect_equal(res, reference)

res = mtcars %>% 
    tab_cells(mpg) %>% 
    tab_rows(gear) %>%
    tab_net_rows(unhide(1:2), 3:4, "NET 5 and more" = unhide(greater(4)), position = "below", prefix = "NET ", new_label = "range") %>% 
    tab_stat_mean() %>% 
    tab_pivot()

reference = structure(list(row_labels = c("Number of forward gears|One|Miles/(US) gallon|Mean", 
"Number of forward gears|Two|Miles/(US) gallon|Mean", "Number of forward gears|NET One - Two|Miles/(US) gallon|Mean", 
"Number of forward gears|NET Three - Four|Miles/(US) gallon|Mean", 
"Number of forward gears|Five|Miles/(US) gallon|Mean", "Number of forward gears|NET 5 and more|Miles/(US) gallon|Mean"
), `#Total` = c(NA, NA, NA, 19.8518518518518, 21.38, 21.38)), row.names = c(NA, 
-6L), class = c("etable", "data.frame"))
expect_equal(res, reference)
#####
expect_known_value(
    mtcars %>% 
        tab_cells(mpg) %>% 
        tab_subtotal_cells("Low mpg" = less(mean(mpg)), "High mpg" = greater_or_equal(mean(mpg)), position = "top") %>% 
        tab_cols(total(), carb) %>% 
        tab_stat_cases() %>% 
        tab_pivot()
    , "rds/subtotal22.rds", update = FALSE)

expect_known_value(
    mtcars %>% 
        tab_cells(mpg) %>% 
        tab_net_cells("Low mpg" = less(mean(mpg)), "High mpg" = greater_or_equal(mean(mpg))) %>% 
        tab_cols(gear) %>%
        tab_subtotal_cols(1:2, 3:4, "5 and more" = greater(4), position = "bottom") %>% 
        tab_stat_cases() %>% 
        tab_pivot()
    , "rds/subtotal23.rds", update = FALSE)

expect_known_value(
    mtcars %>% 
        tab_cells(mpg) %>% 
        tab_rows(gear) %>%
        tab_net_rows(1:2, 3:4, "5 and more" = greater(4), position = "above", prefix = "NET ", new_label = "first") %>% 
        tab_stat_mean() %>% 
        tab_pivot()
    , "rds/subtotal24.rds", update = FALSE)


categ = mrset(v1 = c(1, 2, 3, 4), v2 = c(NA, NA, 1, 2))

val_lab(categ) = c(
    One = 1,
    Two = 2,
    Three = 3,
    Four = 4
)

var_lab(categ) = "My multiple"

expect_known_value(
    cro(subtotal(categ, 1:2, 3:4))
    , "rds/subtotal25.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, 1:2, function(x) x>2))
    , "rds/subtotal25.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, 1:2, 3:4, position = "bottom", prefix = "SUBTOTAL "))
    , "rds/subtotal26.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, lte(2), gte(3), position = "bottom", prefix = "SUBTOTAL "))
    , "rds/subtotal26.rds", update = FALSE)

expect_known_value(
    cro(net(categ, 1:2, "ThreeFour" = 3:4, new_label = "range"))
    , "rds/subtotal27.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, c(1, 3),  c(2, 4), position = "above"))
    , "rds/subtotal27a.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, c(1, 3),  c(2, 4), position = "above"))
    , "rds/subtotal27a.rds", update = FALSE)

# expect_known_value(
#     categ %>% 
#         tab_cells(mrset(v1, v2)) %>% 
#         tab_subtotal_cells("Net One" = c(1, 3),  "Net Two" = c(2, 4), 
#                            position = "above", 
#                            prefix = "NET ", 
#                            new_label = "first") %>% 
#         tab_stat_cases() %>% 
#         tab_pivot()
#     , "rds/subtotal27b.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, c(1, 3),  c(2, 4), position = "top"))
    , "rds/subtotal27c.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, ONE_THREE = c(1, 3),  position = "below"))
    , "rds/subtotal27d.rds", update = FALSE)

expect_known_value(
    cro(subtotal(categ, c(1, 2),  c(3, 4, 5), position = "below"))
    , "rds/subtotal27e.rds", update = FALSE)

################
suppressWarnings(RNGversion("3.5.0"))
set.seed(311265)

brand = sample(c(1:9),100, replace=TRUE)
gender = sample(1:2, 100, replace=TRUE)
wave = rep(1, 50)
data2018 = data.frame(gender, brand, wave)

brand = sample(c(1:9, 15, 21),50, replace=TRUE)
gender = sample(1:2, 50, replace=TRUE)
wave = rep(2,50)
data2019 = data.frame(gender, brand, wave)

data = rbind(data2018, data2019)

val_lab(data$gender) = c("female"=2, "male"=1)
val_lab(data$brand) = c("AA1" = 1, "AA2" = 2, "AA3" = 3, "AA4"=15, "AA5"=21, "BB1" = 4, "BB2" = 5, "BB3" = 6, "CC1" = 7, "CC2" = 8, "CC3" = 9)
val_lab(data$wave) <- c("Wave 2018"=1, "Wave 2019"=2)

expect_known_value(
    data %>%
        tab_cols(wave %nest% gender) %>%
        tab_cells(brand) %>%
        tab_subtotal_cells(c(1:3,15,21), 4:6, 7:9, position = "above", prefix = "GROUP ", new_label = "range") %>%
        tab_stat_cases() %>%
        tab_pivot()
    
    , "rds/subtotal28.rds", update = FALSE)


expect_known_value(
    data %>%
        tab_cols(wave %nest% gender) %>%
        tab_cells(brand) %>%
        tab_subtotal_cells(c(3, 15, 21,2,1), 7:9, position = "above", prefix = "GROUP ", new_label = "range") %>%
        tab_stat_cases() %>%
        tab_pivot() 
    , "rds/subtotal29.rds", update = FALSE)


expect_known_value(
    data %>%
        tab_cols(wave %nest% gender) %>%
        tab_cells(brand) %>%
        tab_subtotal_cells(c(1:3,15,21), 4:6, 7:9, position = "below", prefix = "GROUP ", new_label = "range") %>%
        tab_stat_cases() %>%
        tab_pivot()
    
    , "rds/subtotal30.rds", update = FALSE)


expect_known_value(
    data %>%
        tab_cols(wave %nest% gender) %>%
        tab_cells(brand) %>%
        tab_subtotal_cells(c(3, 15, 21,2,1), 7:9, position = "below", prefix = "GROUP ", new_label = "range") %>%
        tab_stat_cases() %>%
        tab_pivot() 
    , "rds/subtotal31.rds", update = FALSE)


expect_known_value(
    data %>%
        tab_cols(wave %nest% gender) %>%
        tab_cells(brand) %>%
        tab_subtotal_cells(c(1:3,15,21), 4:6, 7:9, position = "top", prefix = "GROUP ", new_label = "range") %>%
        tab_stat_cases() %>%
        tab_pivot()
    
    , "rds/subtotal32.rds", update = FALSE)


expect_known_value(
    data %>%
        tab_cols(wave %nest% gender) %>%
        tab_cells(brand) %>%
        tab_subtotal_cells(c(3, 15, 21,2,1), 7:9, position = "bottom", prefix = "GROUP ", new_label = "range") %>%
        tab_stat_cases() %>%
        tab_pivot() 
    , "rds/subtotal33.rds", update = FALSE)


suppressWarnings(RNGversion("3.5.0"))
set.seed(12345)
df = data.frame(group = rep(1:5, each = 4),
                 varA = sample(1:4, 20, replace = TRUE),
                 varB = sample(6:9, 20, replace = TRUE))
output = df %>%
    tab_cells(varA, varB) %>%
    tab_cols(total(label = "")) %>% 
    tab_rows(net(group, "Group 1" = 1,  "All Groups" = TRUE, position = "above")) %>%
    tab_stat_fun("Valid N" = w_n, "Mean" = w_mean, "SD" = w_sd,
                 "Median" = w_median, method = list) %>% 
    tab_pivot()

res = structure(list(row_labels = c("Group 1|varA", "Group 1|varB", 
"All Groups|varA", "All Groups|varB", "2|varA", "2|varB", "3|varA", 
"3|varB", "4|varA", "4|varB", "5|varA", "5|varB"), `Valid N` = c(4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L), Mean = c(3.75, 7.75, 
3.75, 7.75, 2, 7.75, 2.25, 7, 2, 7, 2.25, 8), SD = c(0.5, 0.957427107756338, 
0.5, 0.957427107756338, 0.816496580927726, 0.5, 1.5, 1.4142135623731, 
0.816496580927726, 0.816496580927726, 1.25830573921179, 1.4142135623731
), Median = c(4, 7.5, 4, 7.5, 2, 8, 2, 6.5, 2, 7, 2, 8.5)), row.names = c(NA, 
-12L), class = c("etable", "data.frame"))

expect_equal(output, res)

output = df %>%
    tab_cells(varA, varB) %>%
    tab_cols(total(label = "")) %>% 
    tab_rows(net(group, "Group 1" = 1,  "All Groups" = other(), position = "above")) %>%
    tab_stat_fun("Valid N" = w_n, "Mean" = w_mean, "SD" = w_sd,
                 "Median" = w_median, method = list) %>% 
    tab_pivot()


res = structure(list(row_labels = c("Group 1|varA", "Group 1|varB", 
"All Groups|varA", "All Groups|varB"), `Valid N` = c(4L, 4L, 
20L, 20L), Mean = c(3.75, 7.75, 2.45, 7.5), SD = c(0.5, 0.957427107756338, 
1.14593101656986, 1.05131496607569), Median = c(4, 7.5, 2, 7.5
)), row.names = c(NA, -4L), class = c("etable", "data.frame"))
if(as.numeric(version$major) >=4){
    expect_equal(output, res)
}

context("inside_columns with subtotal issue #102")

data(infert)
res = infert %>% 
    tab_cells(parity) %>% 
    tab_cols(
        #total(),
        subtotal(
            education,
            "LESS THAN 12 Y.O." = levels(education)[1:2],
            "GREATER THAN 5 Y.O." = levels(education)[2:3]
        )[,-1]
    ) %>% 
    tab_stat_cases() %>% 
    tab_pivot(
        stat_position = "inside_columns"
    )

expect_identical(res, 
 structure(list(row_labels = c("parity|1", "parity|2", "parity|3", 
 "parity|4", "parity|5", "parity|6", "parity|#Total cases"), `0-5yrs` = c(3, 
 NA, NA, 3, NA, 6, 12), `6-11yrs` = c(42, 42, 21, 12, 3, NA, 120
 ), `LESS THAN 12 Y.O.` = c(45, 42, 21, 15, 3, 6, 132), `6-11yrs` = c(42, 
 42, 21, 12, 3, NA, 120), `12+ yrs` = c(54, 39, 15, 3, 3, 2, 116
 ), `GREATER THAN 5 Y.O.` = c(96, 81, 36, 15, 6, 2, 236)), row.names = c(NA, 
 -7L), class = c("etable", "data.frame"))
)