context("Multitables") # Skip tests on windows (because they're slow and CRAN complains) if (tolower(Sys.info()[["sysname"]]) != "windows") { test_that("default name for formula", { expect_identical(RHS_string(a + b ~ c + d + rollup(e)), "c + d + rollup(e)") expect_identical(RHS_string("a+b~c+d+rollup(e)"), "c+d+rollup(e)") }) with_mock_crunch({ ds <- cachedLoadDataset("test ds") ## Has 2 multitables ds2 <- cachedLoadDataset("ECON.sav") ## Has no multitables ds_veg <- cachedLoadDataset("Vegetables example") ## Has valid tabbook with_POST("https://app.crunch.io/api/datasets/1/filters/filter1/", { ## Mock the return of that creation f1 <- newFilter("A filter", ds$gender == "Male", catalog = filters(ds)) expect_is(f1, "CrunchFilter") }) with_POST("https://app.crunch.io/api/datasets/1/filters/filter2/", { ## Mock the return of that creation f2 <- newFilter("A filter", ds$gender == "Male", catalog = filters(ds)) expect_is(f2, "CrunchFilter") }) test_that("multitables() getter", { expect_is(multitables(ds), "MultitableCatalog") expect_is(multitables(ds2), "MultitableCatalog") expect_length(multitables(ds), 3) expect_length(multitables(ds2), 1) }) test_that("Extract multitable", { expect_is(multitables(ds)[[2]], "Multitable") expect_is(multitables(ds)[["Shared multitable"]], "Multitable") expect_error(multitables(ds)[[99]], "subscript out of bounds: 99") expect_null(multitables(ds)[["NOTVALID"]]) }) mults <- multitables(ds) test_that("Multitable catalog names", { expect_identical( names(mults), c("My banner", "My team multitable", "Shared multitable") ) ## Note that this PATCHes the entity, not the catalog expect_PATCH( names(mults)[3] <- "New name", "https://app.crunch.io/api/datasets/1/multitables/4de322/", '{"name":"New name"}' ) }) test_that("Multitable catalog is.public", { expect_identical(is.public(mults), c(FALSE, FALSE, TRUE)) expect_identical(is.public(mults[[1]]), FALSE) expect_identical(is.public(mults[[2]]), FALSE) expect_identical(is.public(mults[[3]]), TRUE) ## Note that this PATCHes the entity, not the catalog expect_PATCH( is.public(mults)[3] <- FALSE, "https://app.crunch.io/api/datasets/1/multitables/4de322/", '{"is_public":false}' ) with_PATCH( NULL, is.public(mults)[3] <- FALSE ) expect_no_request(is.public(mults)[3] <- TRUE) }) test_that("Multitable delete requires consent", { expect_error( delete(mults[["Shared multitable"]]), "Must confirm deleting multitable" ) expect_error( mults[["Shared multitable"]] <- NULL, "Must confirm deleting multitable" ) }) with(consent(), { test_that("Multitable delete", { expect_DELETE( delete(mults[["Shared multitable"]]), "https://app.crunch.io/api/datasets/1/multitables/4de322/" ) expect_DELETE( multitables(ds)[["Shared multitable"]] <- NULL, "https://app.crunch.io/api/datasets/1/multitables/4de322/" ) expect_DELETE( multitables(ds)[[3]] <- NULL, "https://app.crunch.io/api/datasets/1/multitables/4de322/" ) expect_silent(multitables(ds)[[999]] <- NULL) expect_error(multitables(ds)[[list(1)]] <- NULL, "invalid subscript type 'list'") expect_error(multitables(ds)[[2i]] <- NULL, "invalid subscript type 'complex'") }) }) test_that("Multitable object methods", { expect_identical(name(mults[[1]]), "My banner") expect_PATCH( name(mults[[1]]) <- "Another name", "https://app.crunch.io/api/datasets/1/multitables/ed30c4/", '{"name":"Another name"}' ) expect_PATCH( is.public(mults[[1]]) <- TRUE, "https://app.crunch.io/api/datasets/1/multitables/ed30c4/", '{"is_public":true}' ) expect_no_request(is.public(mults[[1]]) <- FALSE) }) test_that("newMultitable", { expect_POST( newMultitable(~ gender + mymrset, data = ds, name = "New multitable", is_public = TRUE ), "https://app.crunch.io/api/datasets/1/multitables/", '{"element":"shoji:entity","body":{', '"template":[{"query":[{"variable":"https://app.crunch.io/api/', 'datasets/1/variables/gender/"}]},', '{"query":[{"function":"dimension","args":[{"function":"as_selected",', '"args":[{"variable":"https://app.crunch.io/api/datasets/1/variables/mymrset/"}]},', '{"value":"subvariables"}]},{"function":"as_selected","args":[{"variable":', '"https://app.crunch.io/api/datasets/1/variables/mymrset/"}]}]}]', ',"name":"New multitable","is_public":true}}' ) with_POST("https://app.crunch.io/api/datasets/1/multitables/4de322/", { mtable <- newMultitable(~ gender + mymrset, data = ds, name = "New multitable" ) expect_is(mtable, "Multitable") }) }) test_that("newMultitable provides a default name based on the formula", { expect_POST( newMultitable(~ gender + mymrset, data = ds), "https://app.crunch.io/api/datasets/1/multitables/", '{"element":"shoji:entity","body":{', '"template":[{"query":[{"variable":"https://app.crunch.io/api/datasets', '/1/variables/gender/"}]},', # nolint '{"query":[{"function":"dimension","args":[{"function":"as_selected",', '"args":[{"variable":"https://app.crunch.io/api/datasets/1/variables/mymrset/"}]},', '{"value":"subvariables"}]},{"function":"as_selected","args":[{"variable":', '"https://app.crunch.io/api/datasets/1/variables/mymrset/"}]}]}]', ',"name":"gender + mymrset"}}' ) with_POST("https://app.crunch.io/api/datasets/1/multitables/4de322/", { mtable <- newMultitable(~ gender + mymrset, data = ds, name = "New multitable" ) expect_is(mtable, "Multitable") }) }) test_that("multitable show method", { with_POST("https://app.crunch.io/api/datasets/1/multitables/4de322/", { mtable <- newMultitable(~ gender + mymrset, data = ds, name = "Shared multitable" ) expect_is(mtable, "Multitable") }) expect_prints( mtable, paste(paste0("Multitable ", dQuote("Shared multitable")), "Column variables:", " gender", " mymrset", sep = "\n" ) ) }) test_that("multitable list methods", { expect_POST( multitables(ds)[["mt again"]] <- ~ gender + birthyr, "https://app.crunch.io/api/datasets/1/multitables/", '{"element":"shoji:entity","body":', '{"template":[{"query":[{"variable":', '"https://app.crunch.io/api/datasets/1/variables/gender/"}]},', '{"query":[{"variable":"https://app.crunch.io/api/datasets/1/variables/birthyr/"}]}]', ',"name":"mt again"}}' ) expect_PATCH( multitables(ds)[["Shared multitable"]] <- ~ gender + birthyr, "https://app.crunch.io/api/datasets/1/multitables/4de322/", '{"element":"shoji:entity","body":', '{"template":[{"query":[{"variable":', '"https://app.crunch.io/api/datasets/1/variables/gender/"}]},', '{"query":[{"variable":"https://app.crunch.io/api/datasets/1/variables/birthyr/"}]}]', "}}" ) expect_PATCH( multitables(ds)[[3]] <- ~ gender + birthyr, "https://app.crunch.io/api/datasets/1/multitables/4de322/", '{"element":"shoji:entity","body":', '{"template":[{"query":[{"variable":', '"https://app.crunch.io/api/datasets/1/variables/gender/"}]},', '{"query":[{"variable":"https://app.crunch.io/api/datasets/1/variables/birthyr/"}]}]', "}}" ) expect_error(multitables(ds)[[999]] <- ~ gender + birthyr, "subscript out of bounds: 999") }) test_that("newMultitable validation", { expect_error(newMultitable(), "Must provide a formula") expect_error( newMultitable(.), paste(dQuote("data"), "must be a Dataset") ) expect_error( newMultitable(., data = ""), paste(dQuote("data"), "must be a Dataset") ) }) test_that("can get and set the team for multitables", { team_mult <- multitables(ds)[["My team multitable"]] private_mult <- multitables(ds)[["My banner"]] expect_identical(team(team_mult), getTeams()[["Alpha Team"]]) expect_no_request(team(team_mult) <- getTeams()[["Alpha Team"]]) expect_PATCH( team(team_mult) <- NULL, "https://app.crunch.io/api/datasets/1/multitables/f33123/", '{"team":null}' ) expect_null(team(private_mult)) expect_PATCH( team(private_mult) <- getTeams()[["Alpha Team"]], "https://app.crunch.io/api/datasets/1/multitables/ed30c4/", '{"team":"https://app.crunch.io/api/teams/team1/"}' ) # can also just use a url expect_PATCH( team(private_mult) <- "https://app.crunch.io/api/teams/team1/", "https://app.crunch.io/api/datasets/1/multitables/ed30c4/", '{"team":"https://app.crunch.io/api/teams/team1/"}' ) }) test_that("cache priming (so that requests don't cloud tests below)", { expect_null(weight(ds)) }) test_that("tabBook sets the right request header", { expect_header( expect_POST( tabBook(mults[[1]], data = ds, output_format = "xlsx"), "https://app.crunch.io/api/datasets/1/multitables/ed30c4/export/" ), "Accept: application/vnd.openxmlformats-officedocument.spreadsheetml.sheet" ) expect_header( expect_POST( tabBook(mults[[1]], data = ds, output_format = "json"), "https://app.crunch.io/api/datasets/1/multitables/ed30c4/export/" ), "Accept: application/json" ) }) filts <- filters(ds) test_that("tabBook with no filter of any kind", { expect_equivalent( as.character(toJSON(standardize_tabbook_filter(ds, NULL))), "{}" ) }) test_that("tabBook filter argument with chr name", { expect_equivalent( as.character(toJSON(standardize_tabbook_filter(ds, "Public filter"))), '[{"filter":"https://app.crunch.io/api/datasets/1/filters/filter2/"}]' ) }) test_that("tabBook filter argument with filter expression", { expect_equivalent( as.character(toJSON(standardize_tabbook_filter(ds[ds$gender == "Male",], NULL))), paste0( '[{\"function\":\"==\",\"args\":', '[{\"variable\":\"https://app.crunch.io/api/datasets/1/variables/gender/\"},', '{\"value\":1}],\"name\":\"gender == \\\"Male\\\"\"}]' ) ) }) test_that("tabBook filter argument with filter object", { expect_equivalent( as.character(toJSON(standardize_tabbook_filter(ds, f1))), #f1 mock created at top '[{"filter":"https://app.crunch.io/api/datasets/1/filters/filter1/"}]' ) }) test_that("tabBook filter argument with two chr filter names", { expect_equivalent( as.character(toJSON(standardize_tabbook_filter( ds, c("Occasional Political Interest", "Public filter") ))), paste0( '[{"filter":"https://app.crunch.io/api/datasets/1/filters/filter1/"},', '{"filter":"https://app.crunch.io/api/datasets/1/filters/filter2/"}]' ) ) }) test_that("tabBook filter argument with chr and filter expression", { expect_equivalent( as.character(toJSON(standardize_tabbook_filter( ds[ds$gender == "Male",], "Public filter" ))), paste0( '[{\"filter\":\"https://app.crunch.io/api/datasets/1/filters/filter2/\"},', '{\"function\":\"==\",\"args\":[{\"variable\":', '\"https://app.crunch.io/api/datasets/1/variables/gender/\"},', '{\"value\":1}],\"name\":\"gender == \\\"Male\\\"\"}]' ) ) }) test_that("tabBook filter argument with filter object and filter expression", { expect_equal( as.character(toJSON(standardize_tabbook_filter(ds[ds$gender == "Male",], f1))), paste0( '[{\"filter\":\"https://app.crunch.io/api/datasets/1/filters/filter1/\"},', '{\"function\":\"==\",\"args\":[{\"variable\":', '\"https://app.crunch.io/api/datasets/1/variables/gender/\"},{\"value\":1}],', '\"name\":\"gender == \\\"Male\\\"\"}]' ) ) }) test_that("tabBook filter argument with list of expressions", { expect_equal( as.character(toJSON(standardize_tabbook_filter( ds, list(ds$gender == "Male", ds$gender == "Female")) )), paste0( '[{\"function\":\"==\",\"args\":[{\"variable\":', '\"https://app.crunch.io/api/datasets/1/variables/gender/\"},{\"value\":1}]},', '{\"function\":\"==\",\"args\":[{\"variable\":', '\"https://app.crunch.io/api/datasets/1/variables/gender/\"},{\"value\":2}]}]' ) ) }) test_that("tabBook filter argument with mixed list", { expect_equal( as.character(toJSON(standardize_tabbook_filter( ds, list(ds$gender == "Male", filters(ds)[1])) )), paste0( '[{\"function\":\"==\",\"args\":[{\"variable\":', '\"https://app.crunch.io/api/datasets/1/variables/gender/\"},{\"value\":1}]},', '{\"filter\":\"https://app.crunch.io/api/datasets/1/filters/filter1/\"}]' ) ) }) test_that("tabBook can return a subset of variables", { expect_equivalent(weight(ds2), ds[["birthyr"]]) m <- multitables(ds2)[[1]] expect_header( expect_POST( tabBook(m, data = ds2[c("gender", "starttime")]), "https://app.crunch.io/api/datasets/3/multitables/ed30c4/export/", '{\"filter\":null,', '\"weight\":"https://app.crunch.io/api/datasets/3/variables/birthyr/",', '\"options\":[],"where":{"function":"select","args":[{"map":', '{"66ae9881e3524f7db84970d556c34552":', '{"variable":"https://app.crunch.io/api/datasets/3/variables/gender/"},', '"d7c21314ca9e453c93069168681a285c"', ':{"variable":"https://app.crunch.io/api/datasets/3/variables/starttime/"}}}]}' ), "Accept: application/json" ) }) test_that("tabBook with options", { expect_POST( tabBook(mults[[1]], data = ds, output_format = "json", format = list(pval_colors = TRUE)) , "https://app.crunch.io/api/datasets/1/multitables/ed30c4/export/", '{\"filter\":null,\"weight\":null,\"options\":{"format":{"pval_colors":true}}}' ) }) test_that("tabBook warning when using format argument", { expect_warning( expect_POST( tabBook(mults[[1]], data = ds, format = "json") , "https://app.crunch.io/api/datasets/1/multitables/ed30c4/export/", '{\"filter\":null,\"weight\":null,\"options\":{}}' ), "Use `output_format`" ) }) test_that("tabBook warning when using legacy endpoint", { with(temp.option(crunch = list(use.legacy.tabbook.endpoint = TRUE)), { expect_warning( expect_POST( tabBook(mults[[1]], data = ds, output_format = "json") , "https://app.crunch.io/api/datasets/1/multitables/ed30c4/tabbook/", '{\"filter\":null,\"weight\":null,\"options\":[]}' ), "The legacy tabbook endpoint has been deprecated and will be removed in the future." ) }) }) with_POST( "https://app.crunch.io/api/datasets/veg/multitables/mt_01/cat-mr-tabbook/", { book <- tabBook(mults[[1]], data = ds, output_format = "json") test_that("tabBook JSON returns TabBookResult", { expect_is(book, "TabBookResult") }) test_that("TabBookResult and MultitableResult size/extract methods", { expect_length(book, 5) expect_is(book[[1]], "MultitableResult") expect_length(book[[1]], 3) expect_identical(dim(book), c(5L, 3L)) expect_is(book[[1]][[1]], "CrunchCube") }) test_that("MultitableResult print methods - mr+cat template x cat page", { ## Print method for MultitableResult binds together the Cubes out <- cubify( 85, 42, 56, 80, 85, 0, 120, 41, 68, 88, 0, 120, dims = list( c("No", "Yes"), c("", "Savory", "Spicy", "Sweet", "No", "Yes") ) ) expect_prints(print(book[[2]]), get_output(out)) }) test_that("MultitableResult print methods - mr+cat template x catarray page", { ## Print method for MultitableResult binds together the Cubes ## And rearranges 3d cubes from Cat array out <- structure( c(44, 28, 13, 90, 18, 19, 12, 6, 33, 6, 32, 17, 6, 57, 7, 42, 21, 10, 73, 14, 26, 11, 4, 33, 2, 16, 16, 9, 55, 16, 73, 21, 21, 55, 33, 30, 6, 10, 24, 13, 48, 13, 15, 32, 16, 57, 19, 20, 44, 25, 38, 9, 10, 18, 8, 34, 11, 10, 36, 25, 19, 0, 122, 16, 45, 7, 0, 49, 7, 19, 12, 0, 67, 10, 34, 17, 0, 103, 14, 30, 15, 0, 58, 8, 4, 4, 0, 62, 8, 38, 20, 17, 45, 101, 15, 8, 4, 18, 43, 7, 14, 14, 20, 67, 7, 16, 16, 36, 83, 10, 10, 9, 16, 41, 5, 10, 8, 28, 56, 10), .Dim = c(5L, 6L, 4L), .Dimnames = list( c("Strongly Disagree", "Disagree", "Neither", "Agree", "Strongly Agree"), c("", "Savory", "Spicy", "Sweet", "No", "Yes"), c("Healthy", "Tasty", "Filling", "Environmental") ) ) expect_prints(print(book[[4]]), get_output(out)) }) test_that("MultitableResult print methods - mr+cat template x mr page", { ## Print method for MultitableResult binds together the Cubes out <- cubify( 86, 86, 52, 65, 42, 41, 128, 52, 128, 110, 56, 68, 171, 65, 110, 171, 80, 88, dims = list( c("Savory", "Spicy", "Sweet"), c("", "Savory", "Spicy", "Sweet", "No", "Yes") ) ) expect_prints(print(book[[3]]), get_output(out)) }) test_that("MultitableResult print methods - mr+cat template x numeric page", { ## Print method for MultitableResult binds together the Cubes out <- cubify( 41.83920, 37.21250, 44.41667, 42.09375, 41.64103, 42.18803, dims = list( c("", "Savory", "Spicy", "Sweet", "No", "Yes") ) ) expect_prints(print(book[[1]]), get_output(out)) }) test_that("MultitableResult print methods - mr+cat template x numeric array page", { ## Print method for MultitableResult binds together the Cubes out <- structure( c(72.312195122, 62.3970588235, 75.8719211823, 72.54, 68.0251256281, 86.6734693878, 72.8823529412, 63.9642857143, 75.4634146341, 73.313253012, 70.0253164557, 87.2133333333, 72.192, 61.918699187, 76.0483870968, 74.9024390244, 67.5409836066, 87.1610169492, 72.3076923077, 62.3090909091, 76.2771084337, 71.8086419753, 67.8695652174, 86.8679245283, 71.6235294118, 62.6666666667, 78.6172839506, 69.3780487805, 67.4268292683, 86.95, 72.7913043478, 62.1271186441, 74.2905982906, 74.4513274336, 68.5178571429, 86.4910714286), .Dim = c(6L, 6L), .Dimnames = list( c("Avocado", "Brussel Sprout", "Carrot", "Daikon", "Eggplant", "Fennel"), c("", "Savory", "Spicy", "Sweet", "No", "Yes") ) ) expect_prints(print(book[[5]]), get_output(out)) }) test_that("The first result in a MultitableResult has 2 dimensions", { expect_identical(dim(book[["Healthy Eater"]][[1]]), c(2L, 1L)) }) test_that("prop.table methods", { ## prop.table on a TabBookResult returns a list of lists of prop.tables full_prop_table <- prop.table(book) expect_identical( full_prop_table[[2]][[2]], prop.table(book[[2]][[2]]) ) ## And non-count measures get NULL expect_identical( full_prop_table[["Age"]], NULL ) }) test_that("tab book names", { expect_identical( names(book)[1:2], c("Age", "Healthy Eater") ) expect_is(book[["Healthy Eater"]], "MultitableResult") expect_null(book[["NOTVALID"]]) }) } ) ## TODO: something more with variable metadata? For cubes more generally? ## --> are descriptions coming from backend if they exist? }) with_test_authentication({ ds <- newDatasetFromFixture("apidocs") ds2 <- newDatasetFromFixture("apidocs") test_that("Multitable catalog", { expect_is(multitables(ds), "MultitableCatalog") expect_length(multitables(ds), 0) }) test_that("Can make a multitable", { m <- newMultitable(~ allpets + q1, data = ds) expect_identical(name(m), "allpets + q1") expect_identical(getShowContent(m), c( paste0("Multitable ", dQuote("allpets + q1")), "Column variables:", " allpets", " q1" )) }) test_that("Can make a multitable perserving zcl functions", { m <- newMultitable(~ rollup(wave, "M") + q1, data = ds) expect_identical(name(m), "rollup(wave, \"M\") + q1") expect_identical(getShowContent(m), c( paste0("Multitable ", dQuote("rollup(wave, \"M\") + q1")), "Column variables:", " rollup(wave, \"M\")", " q1" )) # cleanup with_consent(delete(m)) }) test_that("Can make a multitable with a cat array", { m <- newMultitable(~ petloc + q1, data = ds) expect_identical(name(m), "petloc + q1") expect_identical(getShowContent(m), c( paste0("Multitable ", dQuote("petloc + q1")), "Column variables:", " petloc", " q1" )) # cleanup with_consent(delete(m)) }) test_that("Can make a multitable with list methods", { multitables(ds)[["new mt"]] <- ~ country + q3 expect_identical( getShowContent(multitables(ds)[["new mt"]]), c( paste0("Multitable ", dQuote("new mt")), "Column variables:", " country", " q3" ) ) multitables(ds)[["new mt"]] <- ~ country + q1 expect_identical( getShowContent(multitables(ds)[["new mt"]]), c( paste0("Multitable ", dQuote("new mt")), "Column variables:", " country", " q1" ) ) with_consent(multitables(ds)[["new mt"]] <- NULL) expect_false("new mt" %in% names(multitables(refresh(ds)))) }) mult <- multitables(ds)[["allpets + q1"]] test_that("Can make the multitable entity public/personal", { expect_false(is.public(mult)) is.public(mult) <- TRUE expect_true(is.public(refresh(mult))) is.public(mult) <- FALSE expect_false(is.public(refresh(mult))) }) test_that("Can make the multitable public/personal on the catalog", { expect_false(is.public(multitables(ds))[1]) is.public(multitables(ds))[1] <- TRUE expect_true(is.public(refresh(multitables(ds)))[1]) is.public(multitables(ds))[1] <- FALSE expect_false(is.public(refresh(multitables(ds)))[1]) }) test_that("Can edit the multitable name", { expect_identical(name(mult), "allpets + q1") name(mult) <- "A new name" expect_identical(name(mult), "A new name") expect_identical(name(refresh(mult)), "A new name") expect_identical(names(refresh(multitables(ds))), "A new name") names(multitables(ds)) <- "Yet another name" expect_identical(names(multitables(ds)), "Yet another name") expect_identical(names(refresh(multitables(ds))), "Yet another name") }) multitables(ds2)[["new mt"]] <- ~ country + q1 multitables(ds2)[["Yet another name"]] <- ~ country + q3 mults <- multitables(ds2) with(consent(), { test_that("Multitable delete", { delete(mults[["Yet another name"]]) expect_equal(length(multitables(refresh(ds2))), 1) expect_true(!"Yet another name" %in% names(multitables(ds2))) expect_equal(names(multitables(ds2)), "new mt") }) }) test_that("We can get an xlsx tab book", { skip_on_local_backend("Vagrant host doesn't serve files correctly") f <- tempfile() out <- tabBook(mult, data = ds, output_format = "xlsx", file = f) expect_true(file.exists(out)) }) test_that("We can get an json tab book", { skip("multitables and multiple response need more work.") skip_on_local_backend("Vagrant host doesn't serve files correctly") book <- tabBook(mult, data = ds) expect_is(book, "TabBookResult") expect_identical(dim(book), c(ncol(ds), 3L)) expect_identical(names(book), names(variables(ds))) }) test_that("team-sharing of multitables", { multitables(ds)[["team multitable"]] <- ~ allpets + q1 team_multitab <- multitables(ds)[["team multitable"]] expect_null(team(team_multitab)) # set teams to use teams <- getTeams() if (!"A new team for filters" %in% names(teams)) { teams[["A new team for filters"]] <- list() } if (!"A different team for filters" %in% names(teams)) { teams[["A different team for filters"]] <- list() } # can set a team team(team_multitab) <- getTeams()[["A new team for filters"]] expect_identical( team(team_multitab), getTeams()[["A new team for filters"]] ) # can change a team (with a URL this time) team_url <- self(getTeams()[["A different team for filters"]]) team(team_multitab) <- team_url expect_identical( team(team_multitab), getTeams()[["A different team for filters"]] ) # can remove the team team(team_multitab) <- NULL expect_null(team(team_multitab)) }) }) }