context("Variable transformations")
insrts_list <- list(
list(
anchor = 6, name = "Low",
`function` = "subtotal", args = c(1, 2)
),
list(
anchor = 7, name = "High",
`function` = "subtotal", args = c(9, 10)
)
)
insrts <- Insertions(data = insrts_list)
test_that("Can make a transforms object from Insertions or lists", {
expect_true(is.Insertions(insrts))
expect_true(is.list(insrts_list) & !is.Insertions(insrts_list))
trans <- Transforms(insertions = insrts)
expect_equal(trans, Transforms(insertions = insrts_list))
expect_equal(trans[["insertions"]], insrts)
})
test_that("Transforms validation", {
expect_error(
Transforms(foo = "bar"),
paste(
"Transforms must have at least one of",
serialPaste(dQuote(c("insertions", "categories", "elements")), "or")
)
)
expect_error(
Transforms(insertions = "foo"),
paste0(
"invalid class ", dQuote("Insertions"),
" object: Invalid insertions: 1 element is not a Crunch Insertion object\\."
)
)
expect_error(
Transforms(categories = "foo"),
paste0(
"invalid class ", dQuote("Categories"),
" object: Invalid categories: 1 element is not a Crunch category object\\."
)
)
})
cats_list <- mapply(function(i, n, m) list(id = i, name = n, missing = m),
i = c(1:10), n = LETTERS[c(1:10)],
m = c(rep(FALSE, 6), TRUE, TRUE, FALSE, FALSE),
SIMPLIFY = FALSE
)
cats <- Categories(data = cats_list)
abs_cats <- AbstractCategories()
abs_cats@.Data <- c(cats@.Data, list(AbstractCategory(name = "__fake__bottom__category__")))
insrts_list <- list(
list(
anchor = "top", name = "First one",
`function` = "subtotal", args = c(3, 4)
),
list(
anchor = "bottom", name = "Last one",
`function` = "subtotal", args = c(5, 6)
),
list(
anchor = 10, name = "High",
`function` = "subtotal", args = c(9, 10)
),
list(
anchor = 2, name = "Low",
`function` = "subtotal", args = c(1, 2)
),
list(
anchor = 8, name = "missing anchor",
`function` = "subtotal", args = c(2, 3)
),
list(
anchor = 4, name = "missing categories",
`function` = "subtotal", args = c(7, 8)
)
)
insrts <- Insertions(data = insrts_list)
test_that("findInsertPosition", {
expect_equal(findInsertPosition(insrts[["First one"]], abs_cats), 0)
expect_equal(findInsertPosition(insrts[["Last one"]], abs_cats), 11)
expect_equal(findInsertPosition(insrts[["High"]], abs_cats), 10)
expect_equal(findInsertPosition(insrts[["Low"]], abs_cats), 2)
expect_equal(findInsertPosition(insrts[["missing anchor"]], abs_cats), 11)
expect_equal(findInsertPosition(insrts[["missing categories"]], abs_cats), 4)
})
test_that("collateCats places at beginning", {
new_cats <- collateCats(insrts["First one"], cats)
expect_equivalent(new_cats[c(2:11)], cats)
expect_equivalent(new_cats[1], insrts["First one"])
})
test_that("collateCats places at end", {
new_cats <- collateCats(insrts["Last one"], cats)
expect_equivalent(new_cats[c(1:10)], cats)
expect_equivalent(new_cats[11], insrts["Last one"])
})
test_that("collateCats places at end if the id is improbably high", {
new_cats <- collateCats(insrts["High"], cats)
expect_equivalent(new_cats[c(1:10)], cats)
expect_equivalent(new_cats[11], insrts["High"])
})
test_that("collateCats places after index 2", {
new_cats <- collateCats(insrts["Low"], cats)
expect_equivalent(new_cats[c(1, 2, 4:11)], cats)
expect_equivalent(new_cats[3], insrts["Low"])
})
test_that("collateCats places a missing anchor at end", {
new_cats <- collateCats(insrts["missing anchor"], cats)
expect_equivalent(new_cats[c(1:10)], cats)
expect_equivalent(new_cats[11], insrts["missing anchor"])
})
test_that("collateCats places at an anchor even if the combo categories are na", {
new_cats <- collateCats(insrts["missing categories"], cats)
expect_equivalent(new_cats[c(1:4, 6:11)], cats)
expect_equivalent(new_cats[5], insrts["missing categories"])
})
test_that("collateCats works all together", {
new_cats <- collateCats(insrts, cats)
expect_length(new_cats, 16)
expect_equivalent(new_cats[c(2, 3, 5, 6, 8, 9, 10, 11, 12, 13)], cats)
expect_equivalent(new_cats[c(1, 15, 14, 4, 16, 7)], insrts)
# indices for new_cats to name map
# 1 - First one
# 14 - High
# 7 - missing categories
# 4 - Low
# 15 - Last one
# 16 - missing anchor
})
test_that("collateCats errors when given bad input", {
expect_error(
collateCats(insrts["missing categories"], Categories()),
"Can't collateCats with no categories"
)
})
insrt_heads <- Insertions(data = list(list(name = "Subtitle", anchor = "top")))
# turn into subclassed insertions
test_that("Converting insertions to subtypes works", {
insrts_subtyped <- subtypeInsertions(insrts)
insrt_heads_subtyped <- subtypeInsertions(insrt_heads)
# the lengths are the same, we aren't missing anything
expect_equal(length(insrts), length(insrts_subtyped))
expect_equal(length(insrt_heads), length(insrt_heads_subtyped))
# the types are correct
expect_true(is.Subtotal(insrts_subtyped[[1]]))
expect_true(is.Heading(insrt_heads_subtyped[[1]]))
expect_true(is.category(cats[[1]])) # we need cats for collation later
# we can check the full object and get back a vector of logicals
expect_true(all(are.Subtotals(insrts_subtyped)))
expect_true(all(are.Headings(insrt_heads_subtyped)))
expect_true(all(unlist(lapply(cats, is.category))))
# we can re-subtype with no harm
expect_true(all(are.Subtotals(subtypeInsertions(insrts_subtyped))))
expect_true(all(are.Headings(subtypeInsertions(insrt_heads_subtyped))))
# collate and check
collated <- collateCats(c(insrts_subtyped, insrt_heads_subtyped), cats)
expect_true(all(are.Subtotals(collated[c(1, 5, 8, 15, 16, 17)])))
expect_true(all(are.Headings(collated[2])))
expect_true(all(unlist(lapply(
collated[c(3, 4, 6, 7, 9, 10, 11, 12, 13, 14)],
is.category
))))
expect_error(subtypeInsertion("foo"), "Must provide an object of type Insertion")
expect_error(subtypeInsertions("foo"), "Must provide an object of type Insertions")
})
test_that("calcTransform rejects nd arrays", {
ary2d <- array(c(1, 2, 3, 4, 5, 6),
dim = c(2, 3),
dimnames = list(
"foo1" = c("bar", "baz"),
"foo2" = c("bar", "baz", "qux")
)
)
expect_error(
calcTransforms(
ary2d, Transforms(insertions = insrts),
Categories(
list(name = "one", id = 1),
list(name = "two", id = 2)
)
),
paste0(
"Calculating varaible transforms is not ",
"implemented for dimensions greater than 1."
)
)
})
with_mock_crunch({
ds <- cachedLoadDataset("test ds")
test_that("Can get transform", {
expect_equivalent(
transforms(ds$location),
Transforms(
insertions = list(
Subtotal(
name = "London+Scotland", after = 3,
categories = c(1, 2)
)
),
categories = NULL,
elements = NULL
)
)
loc_ary <- array(c(7, 10, 17),
dim = 3,
dimnames = list(c(
"London", "Scotland",
"London+Scotland"
))
)
expect_prints(expect_equivalent(showTransforms(ds$location), loc_ary))
})
test_that("Can set transform (with Insertions)", {
expect_null(transforms(ds$gender))
trans_insert <- Transforms(insertions = Insertions(
Insertion(
anchor = 3, name = "Male+Female",
`function` = "subtotal", args = c(1, 2)
)
))
expect_PATCH(
transforms(ds$gender) <- trans_insert,
"https://app.crunch.io/api/datasets/1/variables/gender/",
'{"element":"shoji:entity","body":{"view":{"transform":{',
'"insertions":[{"anchor":3,"name":"Male+Female","function"',
':"subtotal","args":[1,2],"id":1}]}}}}'
)
})
test_that("Can set transform (with Subtotal)", {
trans_insert <- Transforms(insertions = Insertions(
Subtotal(
after = 3, name = "Male+Female",
categories = c(1, 2)
)
))
expect_PATCH(
transforms(ds$gender) <- trans_insert,
"https://app.crunch.io/api/datasets/1/variables/gender/",
'{"element":"shoji:entity","body":{"view":{"transform":{',
'"insertions":[{"anchor":3,"name":"Male+Female","function"',
':"subtotal","args":[1,2],"kwargs":{"positive":[1,2]},"id":1}]}}}}'
)
})
test_that("Can set transform (with Heading)", {
trans_insert <- Transforms(insertions = Insertions(
Heading(after = 3, name = "Male+Female")
))
expect_PATCH(
transforms(ds$gender) <- trans_insert,
"https://app.crunch.io/api/datasets/1/variables/gender/",
'{"element":"shoji:entity","body":{"view":{"transform":{',
'"insertions":[{"anchor":3,"name":"Male+Female"}]}}}}'
)
})
test_that("Can add a MR insertion via `Insertion()`", {
expect_PATCH(
subtotals(ds$mymrset) <- list(
Insertion(
anchor = "top",
`function` = "any_selected",
name = "s1 or s2",
id = 1,
kwargs = list(
variable = "mymrset",
subvariable_ids = c("subvar1", "subvar2")
)
)
),
"https://app.crunch.io/api/datasets/1/variables/mymrset/",
'{"view":{"transform":{"insertions":[{"anchor":"top","function":"any_selected",',
'"name":"s1 or s2","id":1,"kwargs":{"variable":"mymrset","subvariable_ids":',
'["subvar1","subvar2"]}}]}}}'
)
})
test_that("Can add a MR insertion via `Insertion()` via transforms()<-", {
expect_PATCH(
transforms(ds$mymrset) <- Transforms(
insertions = list(Insertion(
anchor = "top",
`function` = "any_selected",
name = "s1 or s2",
id = 1,
kwargs = list(
variable = "mymrset",
subvariable_ids = c("subvar1", "subvar2")
)
))
),
"https://app.crunch.io/api/datasets/1/variables/mymrset/",
'{"element":"shoji:entity","body":{"view":{"transform":{"insertions"',
':[{"anchor":"top","function":"any_selected","name":"s1 or s2",',
'"id":1,"kwargs":{"variable":"mymrset","subvariable_ids":["subvar1",',
'"subvar2"]}}]}}}}'
)
})
test_that("Can delete transform", {
expect_PATCH(
transforms(ds$location) <- NULL,
"https://app.crunch.io/api/datasets/1/variables/location/",
'{"element":"shoji:entity","body":{"view":{"transform":{}}}}'
)
})
test_that("Non-combine insertions are ignored", {
loc_var <- ds$location
trns <- transforms(loc_var)
trns[["insertions"]][[1]] <- Insertion(
name = "London+Scotland",
anchor = 3, args = c(1, 2),
`function` = "foobar"
)
loc_ary <- c(7, 10, NA)
names(loc_ary) <- c("London", "Scotland", "London+Scotland")
expect_warning(
insert_funcs <- makeInsertionFunctions(
categories(ds$location)[!is.na(categories(ds$location))],
trns
),
paste0(
"Transform functions other than subtotal are ",
"not supported. Applying only subtotals and ",
"ignoring foobar"
)
)
expect_equivalent(calcTransforms(table(loc_var), insert_funcs), loc_ary)
})
test_that("Transform respects anchors", {
loc_var <- ds$location
trns <- transforms(loc_var)
trns[["insertions"]][[1]][["after"]] <- 1
insert_funcs <- makeInsertionFunctions(
categories(ds$location)[!is.na(categories(ds$location))],
trns
)
# No Data is no longer here ??? what made it be here in the first place?
loc_ary <- c(7, 17, 10)
names(loc_ary) <- c("London", "London+Scotland", "Scotland")
expect_equivalent(calcTransforms(table(loc_var), insert_funcs), loc_ary)
})
test_that("Transform works without a function (that is, with a heading)", {
loc_var <- ds$location
trns <- transforms(loc_var)
trns[["insertions"]][[1]] <- Heading(name = "London+Scotland", after = 3)
insert_funcs <- makeInsertionFunctions(
categories(ds$location)[!is.na(categories(ds$location))],
trns
)
# No Data is no longer here ??? what made it be here in the first place?
loc_ary <- c(7, 10, NA)
names(loc_ary) <- c("London", "Scotland", "London+Scotland")
expect_equivalent(
calcTransforms(table(loc_var), insert_funcs),
loc_ary
)
})
})
with_test_authentication({
ds <- newDataset(df)
test_that("Can get and set transforms", {
trans <- Transforms(insertions = list(
Subtotal(
after = 3, name = "B+C",
categories = c(1, 2)
)
))
expect_null(transforms(ds$v4))
transforms(ds$v4) <- trans
trans_resp <- trans
trans_resp["categories"] <- list(NULL)
trans_resp["elements"] <- list(NULL)
expect_json_equivalent(transforms(ds$v4), trans_resp)
v4_ary <- array(c(10, 10, 20),
dim = 3,
dimnames = list(c("B", "C", "B+C"))
)
expect_prints(expect_equivalent(showTransforms(ds$v4), v4_ary))
})
test_that("Can remove transforms", {
transforms(ds$v4) <- NULL
v4_notrans <- array(c(10, 10),
dim = 2,
dimnames = list(c("B", "C"))
)
expect_null(transforms(ds$v4))
expect_prints(expect_equivalent(showTransforms(ds$v4), v4_notrans))
})
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.