tests/testthat/test-choice_effects.R

In choicedata: Working with Choice Data

test_that("effect overview can be created", {

  ### test 1: MMNP with type-1 covariates only
  choice_formula <- choice_formula(
    formula = choice ~ cov,
    random_effects = c("cov" = "cn", "ASC" = "cn")
  )
  choice_alternatives <- choice_alternatives(
    J = 3,
    alternatives = c("C", "B", "A"),
    base = "B"
  )
  expect_equal(
    choice_effects(
      choice_formula = choice_formula,
      choice_alternatives = choice_alternatives
    ),
    structure(
      list(
        effect_name = c("cov", "ASC_A", "ASC_C"),
        generic_name = c("beta_1", "beta_2", "beta_3"),
        covariate = c("cov", NA, NA),
        alternative = c(NA, "A", "C"),
        as_covariate = c(TRUE, FALSE, FALSE),
        as_effect = c(FALSE, TRUE, TRUE),
        mixing = structure(
          c(1L, 1L, 1L),
          levels = c("cn"),
          class = c("ordered", "factor")
        )
      ),
      row.names = c(NA, 3L),
      class = c("choice_effects", "data.frame"),
      choice_formula = choice_formula,
      choice_alternatives = choice_alternatives,
      delimiter = "_"
    )
  )

  ### test 2: MNP with different types
  choice_formula <- choice_formula(
    formula = choice ~ A | B + 0 | C
  )
  choice_alternatives <- choice_alternatives(
    J = 2,
    alternatives = c("A", "B")
  )
  expect_equal(
    choice_effects(
      choice_formula = choice_formula,
      choice_alternatives = choice_alternatives,
      delimiter = "*"
    ),
    structure(
      list(
        effect_name = c("A", "B*B", "C*A", "C*B"),
        generic_name = c("beta_1", "beta_2", "beta_3", "beta_4"),
        covariate = c("A", "B", "C", "C"),
        alternative = c(NA, "B", "A", "B"),
        as_covariate = c(TRUE, FALSE, TRUE, TRUE),
        as_effect = c(FALSE, TRUE, TRUE, TRUE),
        mixing = structure(
          c(NA_integer_, NA_integer_, NA_integer_, NA_integer_),
          levels = c("cn"),
          class = c("ordered", "factor")
        )
      ),
      row.names = c(NA, -4L),
      class = c("choice_effects", "data.frame"),
      choice_formula = choice_formula,
      choice_alternatives = choice_alternatives,
      delimiter = "*"
    )
  )
})

test_that("misspecified effects can be detected", {
  expect_error(
    choice_effects(),
    "Please specify the input `choice_formula`"
  )
  expect_error(
    choice_effects(choice_formula = choice ~ A),
    "Input `choice_formula` is bad"
  )
  expect_error(
    choice_effects(
      choice_formula = choice_formula(formula = A ~ B)
    ),
    "Please specify the input `choice_alternatives`"
  )
  expect_error(
    choice_effects(
      choice_formula = choice_formula(formula = A ~ B),
      choice_alternatives = 2
    ),
    "Input `choice_alternatives` is bad"
  )
  expect_error(
    choice_effects(
      choice_formula = choice_formula(formula = A ~ B),
      choice_alternatives = choice_alternatives(J = 3),
      delimiter = 1
    ),
    "Input `delimiter` is bad: Must be of type 'string', not 'double'"
  )
  expect_error(
    is.choice_effects(1),
    "is bad"
  )
})

test_that("ordered alternatives restrict effect specification", {
  expect_error(
    choice_effects(
      choice_formula = choice_formula(
        formula = choice ~ 0 | 0 | C
      ),
      choice_alternatives = choice_alternatives(J = 3, ordered = TRUE)
    ),
    "Ordered choice models only support alternative-constant covariates."
  )
  expect_s3_class(
    choice_effects(
      choice_formula = choice_formula(
        formula = choice ~ A | 0
      ),
      choice_alternatives = choice_alternatives(J = 3, ordered = TRUE)
    ),
    "choice_effects"
  )
})

test_that("printing effects works", {
  expect_snapshot(
    choice_effects(
      choice_formula = choice_formula(
        formula = choice ~ price | income | comfort,
        random_effects = c("price" = "cn", "income" = "cn")
      ),
      choice_alternatives = choice_alternatives(J = 3)
    )
  )
})

test_that("number of effects can be computed", {
  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      formula = choice ~ A | B + 0 | C + D,
      random_effects = c("A" = "cn", "D" = "cn")
    ),
    choice_alternatives = choice_alternatives(
      J = 3
    )
  )
  expect_equal(compute_P(choice_effects), 9)
  expect_equal(compute_P_d(choice_effects), 5)
  expect_equal(compute_P_r(choice_effects), 4)
})

test_that("effects can be created with resolving", {
  expect_identical(
    choice_effects(
      choice_formula = choice_formula(
        form = choice ~ comfort
      ),
      choice_alternatives = choice_alternatives(
        J = 2, alternatives = c("A", "B")
      ),
      choice_data = choice_data(
        data_frame = train_choice,
        format = "wide",
        column_occasion = "occasionID"
      )
    )$effect_name,
    c("comfort1", "comfort2", "ASC_B")
  )
})