Nothing
context("Case variables")
with_mock_crunch({
ds <- cachedLoadDataset("test ds")
test_that("Case list validator", {
case <- list(name = "Dudes", expression = ds$gender == "Male")
case_out <- list(
id = NULL, name = "Dudes",
expression = ds$gender == "Male",
numeric_value = NULL,
missing = FALSE,
date = NULL
)
expect_equal(ensureValidCase(case), case_out)
expect_error(ensureValidCase("case"), "A case must be a list")
expect_error(
ensureValidCase(list(expression = CrunchLogicalExpr())),
"a case's name must be a character"
)
expect_error(
ensureValidCase(list(name = "name")),
"a case's expression must be a CrunchLogicalExpr"
)
expect_error(
ensureValidCase(list(
name = c("name", "name2"),
expression = CrunchLogicalExpr()
)),
"There is more than one attribute for name"
)
expect_error(
ensureValidCase(list(
name = "name",
expression = c(
CrunchLogicalExpr(),
CrunchLogicalExpr()
)
)),
"There is more than one attribute for expression"
)
expect_error(
ensureValidCase(list(
name = "name",
expression = CrunchLogicalExpr(),
id = 0.8
)),
"a case's id must be an integer"
)
expect_error(
ensureValidCase(list(
name = "name",
expression = CrunchLogicalExpr(),
numeric_value = "nope"
)),
"a case's numeric_value must be a numeric"
)
expect_error(
ensureValidCase(list(
name = "name",
expression = CrunchLogicalExpr(),
missing = "nope"
)),
"a case's missing must be a logical"
)
expect_error(
ensureValidCase(list(
name = "name",
expression = CrunchLogicalExpr(),
date = 2
)),
"a case's date must be a character"
)
expect_error(
ensureValidCase(list(not_right = "not")),
paste(
"each case must have at most an id, name, expression,",
"numeric_value, and missing element. The errant",
"arguments were: not_right"
)
)
else_case <- list(name = "Dudes", expression = "else")
else_case_out <- list(
id = NULL, name = "Dudes",
numeric_value = NULL, missing = FALSE, date = NULL
)
expect_equal(ensureValidCase(else_case), else_case_out)
})
case_output <- list(
name = "Super clever segmentation",
derivation = list(
`function` = "case",
args = list(
list(
column = I(1:2),
type = list(
value = list(
class = "categorical",
categories = list(
list(
id = 1, name = "Dudes",
numeric_value = NULL, missing = FALSE
),
list(
id = 2, name = "Old women",
numeric_value = NULL, missing = FALSE
)
)
)
)
),
list(
`function` = "==",
args = list(
list(variable = "https://app.crunch.io/api/datasets/1/variables/gender/"),
list(value = 1)
)
), list(
`function` = "<",
args = list(
list(variable = "https://app.crunch.io/api/datasets/1/variables/birthyr/"),
list(value = 1950)
)
)
)
)
)
test_that("evalSide works with and without data", {
expect_equal(
evalSide(expression(birthyr), ds, eval_env = environment()),
ds$birthyr
)
expect_equal(evalSide(expression(ds$birthyr), eval_env = environment()), ds$birthyr)
})
test_that("Case variable definition", {
expect_json_equivalent(
makeCaseVariable(
cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$birthyr < 1950, name = "Old women")
),
name = "Super clever segmentation"
),
case_output
)
expect_json_equivalent(
makeCaseVariable(
cases = list(
list(expression = gender == "Male", name = "Dudes"),
list(expression = birthyr < 1950, name = "Old women")
),
data = ds,
name = "Super clever segmentation"
),
case_output
)
expect_json_equivalent(
makeCaseVariable(
`Dudes` = gender == "Male",
`Old women` = birthyr < 1950,
data = ds,
name = "Super clever segmentation"
),
case_output
)
})
test_that("makeCaseVariable works with ... specification", {
expect_json_equivalent(
makeCaseVariable(
`Dudes` = ds$gender == "Male",
`Old women` = ds$birthyr < 1950,
name = "Super clever segmentation"
),
case_output
)
})
test_that("makeCaseVariable works with more than one CrunchLogicalExpr", {
case_output$derivation$args[[3]] <- list(
`function` = "and",
"args" = list(
list(
`function` = "<",
args = list(
list(variable = "https://app.crunch.io/api/datasets/1/variables/birthyr/"),
list(value = 1950)
)
),
list(
`function` = "==",
args = list(
list(variable = "https://app.crunch.io/api/datasets/1/variables/gender/"),
list(value = 2)
)
)
)
)
expect_json_equivalent(
makeCaseVariable(
`Dudes` = ds$gender == "Male",
`Old women` = ds$birthyr < 1950 &
ds$gender == "Female",
name = "Super clever segmentation"
),
case_output
)
})
test_that("makeCaseVariable works with ids pre-specified", {
expect_json_equivalent(
makeCaseVariable(
cases = list(
list(id = 1L, expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$birthyr < 1950, name = "Old women")
),
name = "Super clever segmentation"
),
case_output
)
case_output$derivation$args[[1]]$column <- I(10:11)
case_output$derivation$args[[1]]$type$value$categories[[1]]$id <- 10L
case_output$derivation$args[[1]]$type$value$categories[[1]]$numeric_value <- 0
case_output$derivation$args[[1]]$type$value$categories[[2]]$id <- 11L
case_output$derivation$args[[1]]$type$value$categories[[2]]$missing <- TRUE
expect_json_equivalent(
makeCaseVariable(
cases = list(
list(
id = 10L, expression = ds$gender == "Male",
name = "Dudes", numeric_value = 0
),
list(
id = 11L, expression = ds$birthyr < 1950,
name = "Old women", missing = TRUE
)
),
name = "Super clever segmentation"
),
case_output
)
})
test_that("makeCaseVariable works with an else pre-specified", {
case_output$derivation$args[[1]]$column[[3]] <- 5L
case_output$derivation$args[[1]]$type$value$categories[[3]] <- list(
id = 5L, name = "Other", numeric_value = NULL, missing = FALSE
)
expect_json_equivalent(
makeCaseVariable(
cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$birthyr < 1950, name = "Old women"),
list(expression = "else", name = "Other", id = 5L)
),
name = "Super clever segmentation"
),
case_output
)
})
test_that("makeCaseVariable has a number of ways to specify else", {
case_output$derivation$args[[1]]$column[[3]] <- 3L
case_output$derivation$args[[1]]$type$value$categories[[3]] <- list(
id = 3L, name = "Other", numeric_value = NULL, missing = FALSE
)
expect_json_equivalent(
makeCaseVariable(
cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$birthyr < 1950, name = "Old women"),
list(expression = "else", name = "Other")
),
name = "Super clever segmentation"
),
case_output
)
expect_json_equivalent(
makeCaseVariable(
`Dudes` = ds$gender == "Male",
`Old women` = ds$birthyr < 1950,
`Other` = "else",
name = "Super clever segmentation"
),
case_output
)
})
test_that("makeCaseVariable errors gracefully", {
expect_error(
makeCaseVariable(cases = list(
list(expression = ds$gender == "Male", name = "Dudes")
)),
'argument "name" is missing, with no default'
)
expect_error(
makeCaseVariable(
`Old women` = ds$birthyr < 1950,
cases = list(
list(expression = ds$gender == "Male", name = "Dudes")
), name = ""
),
paste(
"can't have case conditions both in", dQuote("..."),
"as well as in the", dQuote("cases"),
"argument, please use one or the other."
)
)
expect_error(
makeCaseVariable(name = "Dudes"),
paste(
"must supply case conditions in either", dQuote("..."),
"or the", dQuote("cases"),
"argument, please use one or the other."
)
)
expect_error(
makeCaseVariable(name = "Dudes"),
paste(
"must supply case conditions in either", dQuote("..."),
"or the", dQuote("cases"),
"argument, please use one or the other."
)
)
expect_error(
makeCaseVariable(
cases = list(list(ds$gender == "Male", name = "Dudes")),
name = ""
),
paste(
"could not find correct names for a case; this",
"might be because the cases were embedded in too",
"many lists or because not all the elements of the",
"cases have names. The first offending case is:.*"
)
)
expect_error(
makeCaseVariable(cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = "else", name = "name", id = 0.8)
), name = ""),
"id must be an integer"
)
expect_error(
makeCaseVariable(cases = list(list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$gender == "Female", name = "Not Dudes"),
list(expression = "else", name = "else1")
)), name = ""),
paste(
"could not find correct names for a case; this might be",
"because the cases were embedded in too many lists or",
"because not all the elements of the cases have names. The",
"first offending case is:.*"
)
)
expect_error(
makeCaseVariable(
cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = "else", name = "other"),
list(expression = "else", name = "other2")
),
name = ""
),
paste(
"you can only provide a single else case; you have more than",
"one in either"
)
)
expect_error(
makeCaseVariable(cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = "else", name = "else1"),
list(expression = ds$gender == "Female", name = "Not Dudes")
), name = ""),
paste(
"The else case must be the last element of", dQuote("cases"),
"or", dQuote("...")
)
)
expect_error(
makeCaseVariable(cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = "else", name = "name", id = 99999999)
), name = ""),
paste(
"id must be less than 32,768, this might be a result of too",
"many cases being used."
)
)
expect_error(
makeCaseVariable(cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = "else", name = "name", id = -10)
), name = ""),
"id must not be less than 1"
)
expect_error(
makeCaseVariable(
cases = list(
list(id = 1, expression = ds$gender == "Male", name = "Dudes"),
list(id = 1, expression = ds$birthyr < 1950, name = "Old women")
),
name = "Super clever segmentation"
),
"there are duplicate ids provided: 1 and 1"
)
expect_error(
makeCaseVariable(
cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$birthyr < 1950, name = "Dudes")
),
name = "Super clever segmentation"
),
"there are duplicate names provided: Dudes and Dudes"
)
expect_error(
makeCaseVariable(
cases = list(
list(expression = ds$gender == "Male", name = "Dudes"),
list(expression = ds$gender == "Male", name = "Dudes again")
),
name = "Super clever segmentation"
),
paste(
"there are duplicate condition expressions provided:",
'gender == "Male" and gender == "Male"'
)
)
expect_error(
makeCaseVariable(
cases = list(
list(
expression = ds$gender == "Male",
name = "Dudes", missing = NA
)
),
name = "Super clever segmentation"
),
"a case's missing must be a logical"
)
})
})
with_test_authentication({
ds <- newDatasetFromFixture("apidocs")
test_that("makeCaseVariables", {
ds$catdog <- makeCaseVariable(
`Cats` = ds$q1 == "Cat",
`Dogs` = ds$q1 == "Dog",
name = "Cats or Dogs",
description = "Describe cats and dogs"
)
expect_equal(
as.vector(ds$catdog)[1:10],
factor(c(
NA, "Cats", NA, "Dogs", "Dogs", NA, NA, NA,
"Cats", "Dogs"
), levels = (c("Cats", "Dogs")))
)
expect_equal(name(ds$catdog), "Cats or Dogs")
expect_equal(description(ds$catdog), "Describe cats and dogs")
expect_equal(ids(categories(ds$catdog)), c(1, 2, -1))
expect_equal(names(categories(ds$catdog)), c("Cats", "Dogs", "No Data"))
ds$catdog2 <- makeCaseVariable(
cases = list(
list(expression = ds$q1 == "Cat", name = "Cats"),
list(expression = ds$q1 == "Dog", name = "Dogs"),
list(expression = "else", id = 99L, name = "Other", missing = FALSE)
),
name = "Cats or Dogs2"
)
expect_equal(
as.vector(ds$catdog2)[1:10],
factor(c(
"Other", "Cats", "Other", "Dogs", "Dogs",
"Other", "Other", "Other", "Cats", "Dogs"
),
levels = (c("Cats", "Dogs", "Other"))
)
)
expect_equal_temp_nodata(
ids(categories(ds$catdog2)), c(1, 2, 99, -1)
)
expect_identical_temp_nodata(
names(categories(ds$catdog2)), c("Cats", "Dogs", "Other", "No Data")
)
# positive ids can be missing
ds$catdog3 <- makeCaseVariable(
cases = list(
list(expression = ds$q1 == "Cat", name = "Cats"),
list(id = 99L, expression = ds$q1 == "Dog", name = "Dogs", missing = TRUE)
),
name = "Cats or Dogs3",
description = "Describe cats and dogs"
)
expect_equal(
as.vector(ds$catdog3)[1:10],
factor(c(
NA, "Cats", NA, NA, NA, NA, NA, NA,
"Cats", NA
), levels = (c("Cats")))
)
expect_equal(description(ds$catdog3), "Describe cats and dogs")
expect_equal(ids(categories(ds$catdog3)), c(1, 99, -1))
expect_equal(names(categories(ds$catdog3)), c("Cats", "Dogs", "No Data"))
})
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.