context("Cube transformations") # Skip tests on windows (because they're slow and CRAN complains) if (tolower(Sys.info()[["sysname"]]) != "windows") { ############################################################## ### Transforms calculation tests (ie the numbers are right) ############################################################## unicat_trans_cube <- loadCube("cubes/univariate-categorical-with-trans.json") test_that("Can show a simple cube with transform", { loc_array <- cubify(c(10, 5, 15, 5), dims = list("v7" = c("C", "E", "C, E", "D, E")) ) expect_prints(expect_equivalent(showTransforms(unicat_trans_cube), loc_array)) }) complex_trans_cube <- loadCube("cubes/complex-categorical-with-trans.json") test_that("Can show a complex cube with transform", { # "top" and "bottom" anchors, multiple insertions at the same anchor, an # anchor that doesn't exist (and so the insertion should be at the end) loc_array <- cubify( c( 40, 10, 20, 30, 30, 40, 50, 60, 70, 250, 250, 80, 90, 100, 520, 150, 100 ), dims = list("v7" = c( "First!", "A", "B", "Top 2", "C", "D", "E", "F", "G", "Middle 5", "Middle 5 (again)", "H", "I", "J", "Bottom 8", "Middle 3 (missing anchor)", "J and can't see" )) ) expect_prints(expect_equivalent(showTransforms(complex_trans_cube), loc_array)) }) pet_feelings <- loadCube("./cubes/feelings-pets.json") pet_feelings_subdiff <- pet_feelings_headers <- pet_feeling_both <- pet_feelings # add a header for some tests new_trans <- pet_feelings_headers@dims$feelings$references$view$transform new_trans$insertions <- c(new_trans$insertions, list(list(name = "Subtitle", anchor = "top"))) pet_feelings_headers@dims$feelings$references$view$transform <- new_trans test_that("simple with row subtotals", { all <- cubify( c( 9, 5, 12, 12, 21, 17, 12, 7, 10, 10, 11, 12, 21, 22 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(applyTransforms(pet_feelings), all) # can apply to an array of the same shape new_array <- cubeToArray(pet_feelings) - 1 new_all <- all - c(1, 1, 2, 1, 1, 1, 2) # must subtract two from every subtotal expect_equivalent(applyTransforms(pet_feelings, array = new_array), new_all) }) test_that("simple with row subtotals (margins and proportions)", { feelings_margin <- cubify( c(14, 24, 38, 19, 20, 23, 43), dims = list("feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" )) ) expect_equivalent(as.array(margin.table(pet_feelings, 1)), feelings_margin) pets_margin <- cubify(c(54, 46), dims = list("animals" = c("cats", "dogs")) ) expect_equivalent(as.array(margin.table(pet_feelings, 2)), pets_margin) expect_equivalent(margin.table(pet_feelings), 100) feelings_prop <- cubify( c( 9 / 14, 5 / 14, 12 / 24, 12 / 24, 21 / 38, 17 / 38, 12 / 19, 7 / 19, 10 / 20, 10 / 20, 11 / 23, 12 / 23, 21 / 43, 22 / 43 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(as.array(prop.table(pet_feelings, 1)), feelings_prop) pets_prop <- cubify( c( 9 / 54, 5 / 46, 12 / 54, 12 / 46, 21 / 54, 17 / 46, 12 / 54, 7 / 46, 10 / 54, 10 / 46, 11 / 54, 12 / 46, 21 / 54, 22 / 46 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(as.array(prop.table(pet_feelings, 2)), pets_prop) all_prop <- cubify( c( 9 / 100, 5 / 100, 12 / 100, 12 / 100, 21 / 100, 17 / 100, 12 / 100, 7 / 100, 10 / 100, 10 / 100, 11 / 100, 12 / 100, 21 / 100, 22 / 100 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(as.array(prop.table(pet_feelings)), all_prop) }) test_that("applyTransforms can return what is asked for", { all <- cubify( c( NA, NA, 9, 5, 12, 12, 21, 17, 12, 7, 10, 10, 11, 12, 21, 22 ), dims = list( "feelings" = c( "Subtitle", "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(applyTransforms(pet_feelings_headers), all) pet_array <- cubeToArray(pet_feelings_headers) insert_funcs <- makeInsertionFunctions( Categories(data = index(variables(pet_feelings_headers))[[1]]$categories), transforms(pet_feelings_headers)[[1]], include = c("subtotals", "headings") ) tst <- apply(pet_array, 2, calcInsertions, insert_funcs) expect_equivalent(tst, all[c(1, 4, 8), ]) }) test_that("applyTransforms with a cube that has transform but no insertions", { pet_feelings@dims$feelings$references$view$transform$insertions <- list() all <- cubify( c( 9, 5, 12, 12, 12, 7, 10, 10, 11, 12 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "neutral", "somewhat unhappy", "extremely unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(applyTransforms(pet_feelings), all) }) test_that("applyTransforms handles useNA", { # change neutral to missing # TODO: setter methods for variables(cube_object) pet_feelings@dims$feelings$references$categories[[3]]$missing <- TRUE pet_feelings@dims@.Data[[1]]$missing[[3]] <- TRUE pet_feelings@.Data[[3]]$dimensions[[1]]$type$categories[[3]]$missing <- TRUE all_no <- cubify( c( 9, 5, 12, 12, 21, 17, 10, 10, 11, 12, 21, 22 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) # expect silent to catch any warnings that are not raised because of `try` expect_silent( expect_equivalent(applyTransforms(pet_feelings), all_no) ) all_ifany <- cubify( c( 9, 5, 12, 12, 21, 17, 12, 7, 10, 10, 11, 12, 21, 22 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) pet_feelings@useNA <- "ifany" # expect silent to catch any warnings that are not raised because of `try` expect_silent( expect_equivalent(applyTransforms(pet_feelings), all_ifany) ) all_always <- cubify( c( 9, 5, 0, 12, 12, 0, 21, 17, 0, 12, 7, 0, 10, 10, 0, 11, 12, 0, 21, 22, 0, 0, 0, 0 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy", "No Data" ), "animals" = c("cats", "dogs", "No Data") ) ) pet_feelings@useNA <- "always" # expect silent to catch any warnings that are not raised because of `try` expect_silent( expect_equivalent(applyTransforms(pet_feelings), all_always) ) }) # add a subdiff for some tests new_trans <- pet_feelings_subdiff@dims$feelings$references$view$transform new_trans$insertions <- c( new_trans$insertions, list(list( `function` = "subtotal", name = "Subdiff", args = list(1L, 2L), anchor = "top", kwargs = list(positive = list(1L, 4L), negative = list(2L, 5L)) )) ) pet_feelings_subdiff@dims$feelings$references$view$transform <- new_trans test_that("simple subdiff", { all <- cubify( c( 0, -5, 9, 5, 12, 12, 21, 17, 12, 7, 10, 10, 11, 12, 21, 22 ), dims = list( "feelings" = c( "Subdiff", "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(applyTransforms(pet_feelings_subdiff), all) }) test_that("simple with row subdiff (margins & table percent)", { # proportions, non-table percents, and bases are not implemented correctly in R feelings_margin <- cubify( c(-5, 14, 24, 38, 19, 20, 23, 43), dims = list("feelings" = c( "Subdiff", "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" )) ) expect_equivalent(as.array(margin.table(pet_feelings_subdiff, 1)), feelings_margin) pets_margin <- cubify(c(54, 46), dims = list("animals" = c("cats", "dogs")) ) expect_equivalent(as.array(margin.table(pet_feelings_subdiff, 2)), pets_margin) expect_equivalent(margin.table(pet_feelings_subdiff), 100) all_prop <- cubify( c( 0 / 100, -5 / 100, 9 / 100, 5 / 100, 12 / 100, 12 / 100, 21 / 100, 17 / 100, 12 / 100, 7 / 100, 10 / 100, 10 / 100, 11 / 100, 12 / 100, 21 / 100, 22 / 100 ), dims = list( "feelings" = c( "Subdiff", "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(as.array(prop.table(pet_feelings_subdiff)), all_prop) }) # cat by mr with subtotals fixture cat_by_cat <- loadCube("cubes/cat-by-cat-col-subtotals.json") cat_by_cat_dims <- dimnames(cat_by_cat) # drop no data categories, and add in the subtotals cond <- !(cat_by_cat_dims$food_groups %in% c("Don't know", "No Data", "Not asked")) cat_by_cat_dims$food_groups <- cat_by_cat_dims$food_groups[cond] cond <- !(cat_by_cat_dims$offal %in% c("Don't know", "No Data", "Not asked")) cat_by_cat_dims$offal <- cat_by_cat_dims$offal[cond] cat_by_cat_dims_subtotals <- cat_by_cat_dims cat_by_cat_dims_subtotals$food_groups <- c( cat_by_cat_dims_subtotals$food_groups[1], "plant-based", cat_by_cat_dims_subtotals$food_groups[c(2, 3, 4)], "animal-based", "plant-based again, after animal-based" ) test_that("cat by cat with column subtotals", { all <- cubify( # Vegetables plant-based Fruit Grain # Meat animal-based plant-based (again) 115.83196131542, 364.191867955033, 153.417539695033, 94.9423669445809, # Liver 136.201841877585, 136.201841877585, 364.191867955033, 37.5716937475242, 127.869673293253, 48.6141816507989, 41.6837978949296, # Kidney 34.3372374619018, 34.3372374619018, 127.869673293253, 0, 0, 0, 0, 0, 0, 0, # Heart 29.9055007459322, 129.671056693162, 70.2237662859661, 29.5417896612636, # Pancreas 47.0182342996631, 47.0182342996631, 129.671056693162, 66.5763886292179, 205.347046675315, 73.0511594850247, 65.7194985610729, # Thymus 154.487897653589, 154.487897653589, 205.347046675315, 56.9451510924633, 153.827966744574, 62.589746073575, 34.2930695785354, # Snout 43.7522602181583, 43.7522602181583, 153.827966744574, 33.845719287749, 98.0351667619131, 32.5062091544317, 31.6832383197324, # Lung 30.0702030313596, 30.0702030313596, 98.0351667619131, 6.05492419458171, 19.2847236651074, 7.74346718665446, 5.48633228387126, # Tongue 11.4481940114737, 11.4481940114737, 19.2847236651074, dims = cat_by_cat_dims_subtotals ) expect_equivalent(applyTransforms(cat_by_cat), all) # pretty printing tests are large and mostly unreadable for this cube, but # column pretty printing is covered by categorical array tests and row+col # subtotals test }) test_that("cat by cat with column subtotals (margins and proportions)", { row_margin <- cubify( 500.393709832618, # Liver 162.206910755154, # Kidney 0, # Heart 176.689290992825, # Pancreas 359.834944328904, # Thymus 197.580226962732, # Snout 128.105369793273, # Lung 30.7329176765812, # Tongue dims = cat_by_cat_dims_subtotals["offal"] ) expect_equivalent(as.array(margin.table(cat_by_cat, 1)), row_margin) col_margin <- cubify( 346.731339012888, # Vegetables 1098.22750178836, # plant-based 448.146069531484, # Fruit 303.350093243986, # Grain 457.31586855373, # Meat 457.31586855373, # Meat 1098.22750178836, # plant-based (again) dims = cat_by_cat_dims_subtotals["food_groups"] ) expect_equivalent(as.array(margin.table(cat_by_cat, 2)), col_margin) expect_equivalent(as.array(margin.table(cat_by_cat)), 1555.54337034209) expect_equivalent( margin.table(cat_by_cat), margin.table(noTransforms(cat_by_cat)) ) row_prop <- cubify( # Vegetables plant-based Fruit Grain # Meat animal-based plant-based (again) 0.231481649427938, 0.727810643496809, 0.306593661511755, 0.189735332557116, # Liver 0.272189356503191, 0.272189356503191, 0.727810643496809, 0.231628193722506, 0.788312117516789, 0.299704750090335, 0.256979173703948, # Kidney 0.211687882483211, 0.211687882483211, 0.788312117516789, NA, NA, NA, NA, NA, NA, NA, # Heart 0.169254744177714, 0.733893129371534, 0.397442119391479, 0.167196265802341, # Pancreas 0.266106870628466, 0.266106870628466, 0.733893129371534, 0.185019241956569, 0.570670108369519, 0.203012966462348, 0.182637899950602, # Thymus 0.429329891630481, 0.429329891630481, 0.570670108369519, 0.288212803314597, 0.778559520399726, 0.316781426136234, 0.173565290948895, # Snout 0.221440479600274, 0.221440479600274, 0.778559520399726, 0.264202190293559, 0.765269769098011, 0.25374587503153, 0.247321703772922, # Lung 0.234730230901989, 0.234730230901989, 0.765269769098011, 0.197017551613579, 0.627494072253433, 0.251960040636007, 0.178516480003846, # Tongue 0.372505927746567, 0.372505927746567, 0.627494072253433, dims = cat_by_cat_dims_subtotals ) expect_equivalent(as.array(prop.table(cat_by_cat, 1)), row_prop) col_prop <- cubify( # Vegetables plant-based Fruit Grain # Meat animal-based plant-based (again) 0.334068335574115, 0.331617872764962, 0.342338246669047, 0.312979521216821, # Liver 0.297828812081955, 0.297828812081955, 0.331617872764962, 0.108359670788592, 0.116432772886337, 0.108478429146155, 0.13741152161573, # Kidney 0.0750842903625757, 0.0750842903625757, 0.116432772886337, 0, 0, 0, 0, 0, 0, 0, # Heart 0.0862497772225333, 0.118073037218614, 0.156698387111555, 0.0973851345992599, # Pancreas 0.102813476489148, 0.102813476489148, 0.118073037218614, 0.192011454224919, 0.186980426497176, 0.163007475579104, 0.216645717356725, # Thymus 0.33781442603809, 0.33781442603809, 0.186980426497176, 0.16423422023109, 0.140069308493987, 0.13966371754417, 0.113047829363788, # Snout 0.0956718610192244, 0.0956718610192244, 0.140069308493987, 0.0976136722573294, 0.0892667198756835, 0.0725348527287441, 0.104444465406013, # Lung 0.0657536838300782, 0.0657536838300782, 0.0892667198756835, 0.0174628697014222, 0.0175598622632416, 0.0172788912212259, 0.0180858104416621, # Tongue 0.0250334501789297, 0.0250334501789297, 0.0175598622632416, dims = cat_by_cat_dims_subtotals ) expect_equivalent(as.array(prop.table(cat_by_cat, 2)), col_prop) table_prop <- cubify( 0.0744639870053551, 0.234125177670194, 0.0986263338072625, 0.0610348568575762, 0.0875590128018301, 0.0875590128018301, 0.234125177670194, 0.0241534208970731, 0.0822025767530559, 0.0312522187279856, 0.0267969371279971, 0.0220741112826385, 0.0220741112826385, 0.0822025767530559, 0, 0, 0, 0, 0, 0, 0, 0.0192251153623287, 0.0833606180100561, 0.0451442033856779, 0.0189912992620495, 0.0302262445368676, 0.0302262445368676, 0.0833606180100561, 0.0427994422390015, 0.132009849799403, 0.0469618275374473, 0.0422485800229538, 0.0993144264564057, 0.0993144264564057, 0.132009849799403, 0.036607883893292, 0.0988901818344959, 0.0402365805202915, 0.0220457174209124, 0.0281266733235066, 0.0281266733235066, 0.0988901818344959, 0.02175813283837, 0.0630231008861898, 0.0208970124357787, 0.0203679556120411, 0.0193309962323626, 0.0193309962323626, 0.0630231008861898, 0.00389248175912327, 0.0123974194694851, 0.00497798218570502, 0.00352695552465678, 0.0073596109435098, 0.0073596109435098, 0.0123974194694851, dims = cat_by_cat_dims_subtotals ) expect_equivalent(as.array(prop.table(cat_by_cat)), table_prop) }) transforms(pet_feeling_both) <- list( animals = Transforms( insertions = Insertions( Subtotal("felines", categories = "cats", after = "cats"), Subtotal("both", categories = c("cats", "dogs"), after = "dogs") ) ) ) test_that("cat by cat with both column and row subtotals", { all <- cubify( c( 9, 9, 5, 14, 12, 12, 12, 24, 21, 21, 17, 38, 12, 12, 7, 19, 10, 10, 10, 20, 11, 11, 12, 23, 21, 21, 22, 43 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "felines", "dogs", "both") ) ) expect_equivalent(applyTransforms(pet_feeling_both), all) # pretty printing skip_on_local_env("Pretty formatting isn't exactly the same in many terminals") expect_prints( pet_feeling_both, # nolint start paste( " animals", "feelings cats \033[30m\033[3mfelines\033[23m\033[39m dogs \033[30m\033[3m both\033[23m\033[39m", " extremely happy 9 \033[30m\033[3m 9\033[23m\033[39m 5 \033[30m\033[3m 14\033[23m\033[39m", " somewhat happy 12 \033[30m\033[3m 12\033[23m\033[39m 12 \033[30m\033[3m 24\033[23m\033[39m", "\033[30m\033[3m happy 21 \033[30m\033[3m 21\033[3m\033[30m 17 \033[30m\033[3m 38\033[3m\033[30m\033[23m\033[39m", " neutral 12 \033[30m\033[3m 12\033[23m\033[39m 7 \033[30m\033[3m 19\033[23m\033[39m", " somewhat unhappy 10 \033[30m\033[3m 10\033[23m\033[39m 10 \033[30m\033[3m 20\033[23m\033[39m", "extremely unhappy 11 \033[30m\033[3m 11\033[23m\033[39m 12 \033[30m\033[3m 23\033[23m\033[39m", "\033[30m\033[3m unhappy 21 \033[30m\033[3m 21\033[3m\033[30m 22 \033[30m\033[3m 43\033[3m\033[30m\033[23m\033[39m", sep = "\n" ), # nolint end fixed = TRUE ) }) test_that("cat by cat with both column and row subtotals (margins and proportions)", { feelings_margin <- cubify( c(14, 24, 38, 19, 20, 23, 43), dims = list("feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" )) ) expect_equivalent(as.array(margin.table(pet_feeling_both, 1)), feelings_margin) pets_margin <- cubify( c(54, 54, 46, 100), dims = list("animals" = c("cats", "felines", "dogs", "both")) ) expect_equivalent(as.array(margin.table(pet_feeling_both, 2)), pets_margin) expect_equivalent(as.array(margin.table(pet_feeling_both)), 100) feelings_prop <- cubify( c( 9 / 14, 9 / 14, 5 / 14, 14 / 14, 12 / 24, 12 / 24, 12 / 24, 24 / 24, 21 / 38, 21 / 38, 17 / 38, 38 / 38, 12 / 19, 12 / 19, 7 / 19, 19 / 19, 10 / 20, 10 / 20, 10 / 20, 20 / 20, 11 / 23, 11 / 23, 12 / 23, 23 / 23, 21 / 43, 21 / 43, 22 / 43, 43 / 43 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "felines", "dogs", "both") ) ) expect_equivalent(as.array(prop.table(pet_feeling_both, 1)), feelings_prop) pets_prop <- cubify( c( 9 / 54, 9 / 54, 5 / 46, 14 / 100, 12 / 54, 12 / 54, 12 / 46, 24 / 100, 21 / 54, 21 / 54, 17 / 46, 38 / 100, 12 / 54, 12 / 54, 7 / 46, 19 / 100, 10 / 54, 10 / 54, 10 / 46, 20 / 100, 11 / 54, 11 / 54, 12 / 46, 23 / 100, 21 / 54, 21 / 54, 22 / 46, 43 / 100 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "felines", "dogs", "both") ) ) expect_equivalent(as.array(prop.table(pet_feeling_both, 2)), pets_prop) all_prop <- cubify( c( 9 / 100, 9 / 100, 5 / 100, 14 / 100, 12 / 100, 12 / 100, 12 / 100, 24 / 100, 21 / 100, 21 / 100, 17 / 100, 38 / 100, 12 / 100, 12 / 100, 7 / 100, 19 / 100, 10 / 100, 10 / 100, 10 / 100, 20 / 100, 11 / 100, 11 / 100, 12 / 100, 23 / 100, 21 / 100, 21 / 100, 22 / 100, 43 / 100 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "felines", "dogs", "both") ) ) expect_equivalent(as.array(prop.table(pet_feeling_both)), all_prop) }) pet_feeling_bad_feelings <- pet_feeling_bad_animals <- pet_feeling_both test_that("broken row transforms don't break columns", { only_feelings <- cubify( c( 9, 9, 5, 14, 12, 12, 12, 24, 12, 12, 7, 19, 10, 10, 10, 20, 11, 11, 12, 23 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "neutral", "somewhat unhappy", "extremely unhappy" ), "animals" = c("cats", "felines", "dogs", "both") ) ) # malform the transform for animals only pet_feeling_bad_feelings@dims$feelings$references$view$transform$insertions[[2]]$anchor <- NA expect_warning( expect_equivalent(applyTransforms(pet_feeling_bad_feelings), only_feelings), "Transforms for dimensions 1 were malformed and have been ignored." ) # pretty printing skip_on_local_env("Pretty formatting isn't exactly the same in many terminals") expect_warning(expect_prints( pet_feeling_bad_feelings, # nolint start paste( " animals", "feelings cats \033[30m\033[3mfelines\033[23m\033[39m dogs \033[30m\033[3m both\033[23m\033[39m", " extremely happy 9 \033[30m\033[3m 9\033[23m\033[39m 5 \033[30m\033[3m 14\033[23m\033[39m", " somewhat happy 12 \033[30m\033[3m 12\033[23m\033[39m 12 \033[30m\033[3m 24\033[23m\033[39m", " neutral 12 \033[30m\033[3m 12\033[23m\033[39m 7 \033[30m\033[3m 19\033[23m\033[39m", " somewhat unhappy 10 \033[30m\033[3m 10\033[23m\033[39m 10 \033[30m\033[3m 20\033[23m\033[39m", "extremely unhappy 11 \033[30m\033[3m 11\033[23m\033[39m 12 \033[30m\033[3m 23\033[23m\033[39m", sep = "\n" ), # nolint end fixed = TRUE ), "Transforms for dimensions 1 were malformed and have been ignored.") }) test_that("broken column transforms don't break rows", { only_animals <- cubify( c( 9, 5, 12, 12, 21, 17, 12, 7, 10, 10, 11, 12, 21, 22 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("cats", "dogs") ) ) # malform the transform for animals only pet_feeling_bad_animals@dims$animals$references$view$transform$insertions[[2]]$anchor <- NA expect_warning( expect_equivalent(applyTransforms(pet_feeling_bad_animals), only_animals), "Transforms for dimension(s) 2 were malformed and have been ignored." ) # pretty printing skip_on_local_env("Pretty formatting isn't exactly the same in many terminals") expect_warning(expect_prints( pet_feeling_bad_animals, paste( " animals", "feelings cats dogs", " extremely happy 9 5", " somewhat happy 12 12", "\033[30m\033[3m happy 21 17\033[23m\033[39m", " neutral 12 7", " somewhat unhappy 10 10", "extremely unhappy 11 12", "\033[30m\033[3m unhappy 21 22\033[23m\033[39m", sep = "\n" ), fixed = TRUE ), "Transforms for dimension(s) 2 were malformed and have been ignored.") }) test_that("Two bad transforms are both ignored", { only_cube <- cubify( c( 9, 5, 12, 12, 12, 7, 10, 10, 11, 12 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "neutral", "somewhat unhappy", "extremely unhappy" ), "animals" = c("cats", "dogs") ) ) # malform the transform for both pet_feeling_both@dims$feelings$references$view$transform$insertions[[2]]$anchor <- NA pet_feeling_both@dims$animals$references$view$transform$insertions[[2]]$anchor <- NA expect_warning( expect_equivalent(applyTransforms(pet_feeling_both), only_cube), "Transforms for dimension(s) 1 and 2 were malformed and have been ignored." ) }) # cat by mr with subtotals fixture cat_mr <- loadCube("cubes/cat-x-mr-subtotals-on-cat.json") cat_mr_dims <- dimnames(cat_mr) # drop no data categories, and add in the subtotals cond <- !(cat_mr_dims$food_groups %in% c("Don't know", "No Data", "Not asked")) cat_mr_dims$food_groups <- cat_mr_dims$food_groups[cond] cat_mr_dims_subtotals <- cat_mr_dims cat_mr_dims_subtotals$food_groups <- c( cat_mr_dims_subtotals$food_groups[1], "plant-based", cat_mr_dims_subtotals$food_groups[c(2, 3, 4)], "animal-based" ) test_that("cat by mr, with cat subtotals", { all <- cubify( 7.09439811221956, 29.943091432266, 26.594536972556, 104.244359622909, 235.256710642724, 28.3930651341193, 99.907133775628, 121.487888771867, 399.597650747672, 626.93247871747, 16.4723263871271, 41.5273628588211, 58.5641962784524, 183.864543659439, 234.846288302351, 4.82634063477261, 28.4366794845409, 36.3291555208591, 111.488747465324, 156.829479772395, 12.217223612475, 42.1476791820657, 89.3309048228944, 218.631137785724, 171.129707467715, 12.217223612475, 42.1476791820657, 89.3309048228944, 218.631137785724, 171.129707467715, dims = cat_mr_dims_subtotals ) expect_equivalent(applyTransforms(cat_mr), all) # can apply to an array of the same shape new_array <- cubeToArray(cat_mr) - 1 # must subtract one for each category in the subtotal new_all <- all - c(1, 3, 1, 1, 1, 1) expect_equivalent(applyTransforms(cat_mr, array = new_array), new_all) }) test_that("cat by mr, with cat subtotals (margins and proportions)", { row_margin <- cubify( 51.911366492838, 69.0306061146165, 70.6657653721693, 142.042366487671, 253.602877279968, 197.750644752234, 263.820951392254, 276.216370215392, 509.242733468184, 726.557193538396, 93.7790931477866, 121.118408249056, 130.06549190286, 231.730645711963, 279.991871527124, 52.0601851116097, 73.6719370285819, 75.4851129403625, 135.46972126855, 192.962444731304, 70.2849657255216, 94.3678915294494, 135.475226421184, 251.200447977195, 215.124923979429, 70.2849657255216, 94.3678915294494, 135.475226421184, 251.200447977195, 215.124923979429, dims = cat_mr_dims_subtotals ) expect_equivalent(as.array(margin.table(cat_mr, 1)), row_margin) col_margin <- cubify( 40.6102887465943, 142.054812957694, 210.818793594762, 618.228788533396, 798.062186185185, dims = cat_mr_dims_subtotals["nordics"] ) expect_equivalent(as.array(margin.table(cat_mr, 2)), col_margin) table_margin <- cubify( 268.035610477756, 358.188842921703, 411.691596636576, 760.44318144538, 941.682117517826, dims = cat_mr_dims_subtotals["nordics"] ) expect_equivalent(as.array(margin.table(cat_mr)), table_margin) # nolint start row_prop <- cubify( 0.136663674865857, 0.433765442860944, 0.376342587283855, 0.733896246595956, 0.927657892394531, 0.143580139370435, 0.378692947805666, 0.439828706304162, 0.784689941525965, 0.8628811114845, 0.175650305779438, 0.34286582410684, 0.450266980285526, 0.793440777306508, 0.838761093389815, 0.0927069434045541, 0.385990658471605, 0.48127576558786, 0.822979086554057, 0.812746127832161, 0.173824138439307, 0.44663156608636, 0.659389226965898, 0.870345333960438, 0.795489914892794, 0.173824138439307, 0.44663156608636, 0.659389226965898, 0.870345333960438, 0.795489914892794, dims = cat_mr_dims_subtotals ) expect_equivalent(as.array(prop.table(cat_mr, 1)), row_prop) col_prop <- cubify( 0.174694599107339, 0.210785476456778, 0.12614879593551, 0.168617769920104, 0.294784936205628, 0.699159400497994, 0.703299886117777, 0.576266881620586, 0.646358853161181, 0.785568455152935, 0.405619533756911, 0.292333374661432, 0.27779400156812, 0.297405340983255, 0.294270662571973, 0.118845267633744, 0.200181034999566, 0.172324084116957, 0.180335742257822, 0.196512856375335, 0.300840599502006, 0.296700113882224, 0.423733118379414, 0.353641146838819, 0.214431544847065, 0.300840599502006, 0.296700113882224, 0.423733118379414, 0.353641146838819, 0.214431544847065, dims = cat_mr_dims_subtotals ) expect_equivalent(as.array(prop.table(cat_mr, 2)), col_prop) table_prop <- cubify( 0.0264681177981324, 0.0835958238900571, 0.064598202124666, 0.137083692991725, 0.249826036054328, 0.105930197422315, 0.278923075773934, 0.295094409903907, 0.525479957605977, 0.66575808020014, 0.0614557385034259, 0.115937064147748, 0.142252590912489, 0.241786037597137, 0.249390196472437, 0.0180063411207562, 0.0793901877361293, 0.0882436168667512, 0.146610227017115, 0.166541847673375, 0.0455805987521531, 0.117668877786008, 0.216985009052181, 0.287504895987324, 0.181727681012776, 0.0455805987521531, 0.117668877786008, 0.216985009052181, 0.287504895987324, 0.181727681012776, dims = cat_mr_dims_subtotals ) expect_equivalent(as.array(prop.table(cat_mr)), table_prop) # nolint end }) cat_array_cube <- loadCube("./cubes/catarray-with-transforms.json") test_that("categorical arrays with subtotals", { all <- cubify( c( 1, 2, 3, 2, 1, 3, 2, 1, 3 ), dims = list( "CA" = c("mr_1", "mr_2", "mr_3"), "CA" = c("A", "B", "A+B") ) ) # pretty printing expect_equivalent(applyTransforms(cat_array_cube), all) skip_on_local_env("Pretty formatting isn't exactly the same in many terminals") expect_prints( cat_array_cube, paste( " CA ", "CA A B \033[30m\033[3mA+B\033[23m\033[39m", "mr_1 1 2 \033[30m\033[3m 3\033[23m\033[39m", "mr_2 2 1 \033[30m\033[3m 3\033[23m\033[39m", "mr_3 2 1 \033[30m\033[3m 3\033[23m\033[39m", sep = "\n" ), fixed = TRUE ) }) test_that("categorical arrays with subtotals (margins and proportions)", { margin_1 <- cubify( c(3, 3, 3), dims = list("CA" = c("mr_1", "mr_2", "mr_3")) ) expect_equivalent(as.array(margin.table(cat_array_cube, 1)), margin_1) margin_2 <- cubify( c(5, 4, 9), dims = list("CA" = c("A", "B", "A+B")) ) expect_equivalent(as.array(margin.table(cat_array_cube, 2)), margin_2) expect_equivalent( as.array(prop.table(cat_array_cube, 1)), applyTransforms(cat_array_cube) / broadcast(t(margin_1), ncol = 3) ) expect_equivalent( as.array(prop.table(cat_array_cube, 2)), applyTransforms(cat_array_cube) / broadcast(margin_2, dims = c(3, 3)) ) }) test_that("subtotals after cube subsetting", { first_two_rows <- cubify( c( 9, 9, 5, 14, 12, 12, 12, 24, 21, 21, 17, 38, 0, 0, 0, 0 ), dims = list( "feelings" = c("extremely happy", "somewhat happy", "happy", "unhappy"), "animals" = c("cats", "felines", "dogs", "both") ) ) expect_equivalent(applyTransforms(pet_feeling_both[c(1, 2), ]), first_two_rows) one_col <- cubify( c( 5, 5, 0, 12, 12, 0, 17, 17, 0, 7, 7, 0, 10, 10, 0, 12, 12, 0, 22, 22, 0 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ), "animals" = c("dogs", "both", "felines") ) ) # need drop = FALSE to maintain the columns dimension since selection 1 # usually removes the dimension subset <- pet_feeling_both[, c(2), drop = FALSE] expect_equivalent( applyTransforms(pet_feeling_both[, c(2), drop = FALSE]), one_col ) one_col_withdrop <- cubify( c( 5, 12, 17, 7, 10, 12, 22 ), dims = list( "feelings" = c( "extremely happy", "somewhat happy", "happy", "neutral", "somewhat unhappy", "extremely unhappy", "unhappy" ) ) ) expect_equivalent(applyTransforms(pet_feeling_both[, 2]), one_col_withdrop) }) test_that("Can get subtotals alone", { subtotes <- cubify( c( 21, 17, 21, 22 ), dims = list( "feelings" = c("happy", "unhappy"), "animals" = c("cats", "dogs") ) ) expect_equivalent(subtotalArray(pet_feelings_headers), subtotes) }) test_that("Can get subtotals with headers", { subtotes <- cubify( c( NA, NA, 21, 17, 21, 22 ), dims = list( "feelings" = c("Subtitle", "happy", "unhappy"), "animals" = c("cats", "dogs") ) ) expect_equivalent(subtotalArray(pet_feelings_headers, headings = TRUE), subtotes) }) cat <- loadCube("cubes/cat-subtotals-0id.json") cat_dims <- dimnames(cat) # drop no data categories, and add in the subtotals cond <- !(cat_dims$food_groups %in% c("Don't know", "No Data", "Not asked")) cat_dims$food_groups <- cat_dims$food_groups[cond] cat_dims_subtotals <- cat_dims cat_dims_subtotals$food_groups <- c( cat_dims_subtotals$food_groups[1], "plant-based", cat_dims_subtotals$food_groups[c(2, 3, 4)], "animal-based", "plant-based again, after animal-based" ) test_that("subtotals with bases on weighted cube", { unweighted_counts <- cubify( 434, 1223, 495, 294, 433, 433, 1223, dims = cat_dims_subtotals ) expect_equivalent(bases(cat, 0), unweighted_counts) expect_equivalent(bases(cat), 1656) }) ############################################################## ### Transform interaction (getting, setting, anchors, etc) ############################################################## test_that("can retrieve transformations from a cube", { trans <- list( "v7" = Transforms( insertions = Insertions( Subtotal(name = c("C, E"), after = 3, categories = c(1, 3)), Subtotal(name = c("D, E"), after = 3, categories = c(2, 3)) ), categories = NULL, elements = NULL ) ) expect_equivalent(transforms(unicat_trans_cube), trans) }) test_that("can remove transformations from a cube", { # without changing the cube expect_equal( transforms(noTransforms(unicat_trans_cube)), TransformsList("v7" = NULL) ) # with changing the cube transforms(unicat_trans_cube) <- NULL expect_equal(transforms(unicat_trans_cube), TransformsList("v7" = NULL)) }) transforms(pet_feelings) <- NULL feelings_trans <- Transforms( insertions = Insertions( Heading(name = "Fabulous new header", position = "top"), Subtotal( name = "moderately happy", after = "somewhat unhappy", categories = c( "somewhat happy", "neutral", "somewhat unhappy" ) ) ) ) animals_trans <- Transforms( insertions = Insertions( Subtotal("felines", categories = "cats", after = "cats"), Subtotal("both", categories = c("cats", "dogs"), after = "dogs") ) ) test_that("can set transforms on a cube", { expect_equal( transforms(pet_feelings), TransformsList(feelings = NULL, animals = NULL) ) transforms(pet_feelings)[["feelings"]] <- feelings_trans # add empty elements/categories feelings_trans["elements"] <- feelings_trans["categories"] <- list(NULL) # convert to category ids feelings_trans$insertions[["moderately happy"]]$categories <- c(4L, 3L, 5L) feelings_trans$insertions[["moderately happy"]]$after <- 5L # ensure the transforms were set appropriately expect_equal( transforms(pet_feelings), TransformsList(feelings = feelings_trans, animals = NULL) ) all <- cubify( c( NA, NA, 9, 5, 12, 12, 12, 7, 10, 10, 34, 29, 11, 12 ), dims = list( "feelings" = c( "Fabulous new header", "extremely happy", "somewhat happy", "neutral", "somewhat unhappy", "moderately happy", "extremely unhappy" ), "animals" = c("cats", "dogs") ) ) expect_equivalent(applyTransforms(pet_feelings), all) expect_error( transforms(pet_feelings) <- list("not in the var" = Transforms( insertions = Insertions( Heading(name = "Fabulous new header", position = "top"), Subtotal(name = "subtotal", after = 2, categories = c(1, 2)) ) )), paste0( "The names of the transforms supplied .*not in the var.* do not", " match the dimensions of the cube .*feelings.* and .*animals.*" ) ) }) test_that("can remove individual dimensions transforms", { transforms(pet_feelings)[["feelings"]] <- feelings_trans transforms(pet_feelings)[["animals"]] <- animals_trans # add empty elements/categories feelings_trans["elements"] <- feelings_trans["categories"] <- list(NULL) animals_trans["elements"] <- animals_trans["categories"] <- list(NULL) # convert to category ids feelings_trans$insertions[["moderately happy"]]$categories <- c(4L, 3L, 5L) feelings_trans$insertions[["moderately happy"]]$after <- 5L animals_trans$insertions[["felines"]]$categories <- 1L animals_trans$insertions[["felines"]]$after <- 1L animals_trans$insertions[["both"]]$categories <- c(1L, 2L) animals_trans$insertions[["both"]]$after <- 2L # ensure the transforms were set appropriately expect_equal( transforms(pet_feelings), TransformsList(feelings = feelings_trans, animals = animals_trans) ) transforms(pet_feelings)[["feelings"]] <- NULL # ensure the transforms were removed from feelings expect_equal( transforms(pet_feelings), TransformsList(feelings = NULL, animals = animals_trans) ) }) test_that("can set transforms on a cube indexed by numerics", { expect_equal( transforms(pet_feelings), TransformsList(feelings = NULL, animals = NULL) ) transforms(pet_feelings)[[1]] <- feelings_trans # add empty elements/categories feelings_trans["elements"] <- feelings_trans["categories"] <- list(NULL) # convert to category ids feelings_trans$insertions[["moderately happy"]]$categories <- c(4L, 3L, 5L) feelings_trans$insertions[["moderately happy"]]$after <- 5L # ensure the transforms were set appropriately expect_equal( transforms(pet_feelings), TransformsList(feelings = feelings_trans, animals = NULL) ) }) test_that("subtotals with 0 anchor attach to 0 and not top", { all <- cubify( 376.775218800139, 1180.53898816961, 485.589210635439, 318.174558734034, 471.521308228948, 471.521308228948, 1180.53898816961, dims = cat_dims_subtotals ) expect_equivalent(applyTransforms(cat), all) }) ############################################################## ### Integration tests ############################################################## with_test_authentication({ df <- data.frame(pets = c( rep("Dogs", 50), rep("Cats", 45), rep("Birds", 30), rep("Lizards", 25), rep("Rocks", 5), rep(NA, 10) ), stringsAsFactors = TRUE) ds <- newDataset(df) # set rocks to be missing is.na(categories(ds$pets)) <- c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE) insrts_list <- list( list( anchor = "top", name = "First one", `function` = "subtotal", args = c(1, 2) ), list( anchor = "bottom", name = "Toward the end", `function` = "subtotal", args = c(3, 4) ), list( anchor = 3, name = "Dogs+Cats", `function` = "subtotal", args = c(2, 3) ), list( anchor = 4, name = "Birds+Lizards", `function` = "subtotal", args = c(1, 4) ), list( anchor = 5, name = "Cats+Birds (missing anch.)", `function` = "subtotal", args = c(2, 1) ), list( anchor = "bottom", name = "Rocks+Birds (incl. missing)", `function` = "subtotal", args = c(5, 1) ) ) ## test variable-based methods test_that("showTransforms before a transform returns a the standard table", { cat_summary <- cubify(c(30, 45, 50, 25), dims = list(pets = c( "Birds", "Catds", "Dogs", "Lizards" )) ) expect_prints(expect_equivalent(showTransforms(ds$pets), cat_summary)) }) # add transforms transforms(ds$pets) <- Transforms(insertions = Insertions(data = insrts_list)) test_that("summary still works after adding transforms", { cat_summary <- cubify(c(50, 45, 30, 25), dims = list( pets = c( "Dogs", "Catds", "Birds", "Lizards" ), "Count" ) ) class(cat_summary) <- "CategoricalVariableSummary" expect_equivalent(summary(ds$pets), cat_summary) }) test_that("showTransforms works on a variable", { cat_show_trans <- cubify(c(75, 30, 45, 50, 95, 25, 55, 75, 75, NA), dims = list(pets = c( "First one", "Birds", "Cats", "Dogs", "Dogs+Cats", "Lizards", "Birds+Lizards", "Toward the end", "Cats+Birds (missing anch.)", "Rocks+Birds (incl. missing)" )) ) capture.output(trans_pets <- showTransforms(ds$pets)) expect_is(trans_pets, "array") expect_equal(dim(trans_pets), 10) expect_equivalent(trans_pets, cat_show_trans) skip_on_local_env("Pretty formatting isn't exactly the same in many terminals") expect_prints( trans_pets <- showTransforms(ds$pets), paste( " ", " ", "\033[30m\033[3m First one 75\033[23m\033[39m", " Birds 30", " Cats 45", " Dogs 50", "\033[30m\033[3m Dogs+Cats 95\033[23m\033[39m", " Lizards 25", "\033[30m\033[3m Birds+Lizards 55\033[23m\033[39m", "\033[30m\033[3m Toward the end 75\033[23m\033[39m", "\033[30m\033[3m Cats+Birds (missing anch.) 75\033[23m\033[39m", "\033[30m\033[3mRocks+Birds (incl. missing) NA\033[23m\033[39m", sep = "\n" ), fixed = TRUE ) }) test_that("showTransforms works on a variable", { cat_show_trans <- cubify(c(75, 30, 45, 50, 95, 25, 55, 75, 75, 30), dims = list(pets = c( "First one", "Birds", "Cats", "Dogs", "Dogs+Cats", "Lizards", "Birds+Lizards", "Toward the end", "Cats+Birds (missing anch.)", "Rocks+Birds (incl. missing)" )) ) pets_cube <- crtabs(~pets, ds) trans_cube <- applyTransforms(pets_cube) expect_is(trans_cube, "array") expect_equal(dim(showMissing(pets_cube)), 6) expect_equal(dim(pets_cube), 4) expect_equal(dim(trans_cube), 10) expect_equivalent(trans_cube, cat_show_trans) skip_on_local_env("Pretty formatting isn't exactly the same in many terminals") expect_prints( trans_cube <- showTransforms(pets_cube), paste( " ", " ", "\033[30m\033[3m First one 75\033[23m\033[39m", " Birds 30", " Cats 45", " Dogs 50", "\033[30m\033[3m Dogs+Cats 95\033[23m\033[39m", " Lizards 25", "\033[30m\033[3m Birds+Lizards 55\033[23m\033[39m", "\033[30m\033[3m Toward the end 75\033[23m\033[39m", "\033[30m\033[3m Cats+Birds (missing anch.) 75\033[23m\033[39m", "\033[30m\033[3mRocks+Birds (incl. missing) 30\033[23m\033[39m", sep = "\n" ), fixed = TRUE ) }) }) }