tests/testthat/test-choice_responses.R

In choicedata: Working with Choice Data

test_that("simulation of probit choice responses works", {
  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      formula = choice ~ X | Y | Z, error_term = "probit"
    ),
    choice_alternatives = choice_alternatives(J = 3)
  )
  choice_covariates <- generate_choice_covariates(
    choice_effects = choice_effects,
    choice_identifiers = generate_choice_identifiers(
      Tp = sample.int(5, 100, replace = TRUE),
    )
  )
  choice_parameters <- generate_choice_parameters(
    choice_effects = choice_effects
  )
  choice_identifiers <- extract_choice_identifiers(choice_covariates)
  choice_preferences <- generate_choice_preferences(
    choice_parameters = choice_parameters,
    choice_effects = choice_effects,
    choice_identifiers = choice_identifiers
  )
  choice_responses <- generate_choice_responses(
    choice_effects = choice_effects,
    choice_covariates = choice_covariates,
    choice_parameters = choice_parameters,
    choice_identifiers = choice_identifiers,
    choice_preferences = choice_preferences,
    column_choice = "choice"
  )
  expect_s3_class(choice_responses, "choice_responses")
  expect_true(is.choice_responses(choice_responses))
  expect_equal(
    nrow(choice_responses),
    sum(choicedata:::read_Tp(choice_identifiers))
  )
  expect_equal(
    sort(unique(choice_responses[[attr(choice_responses, "column_choice")]])),
    sort(as.character(attr(choice_effects, "choice_alternatives")))
  )
})

test_that("simulation of logit choice responses works", {
  data(train_choice)

  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      formula = choice ~ price | time,
      error_term = "logit"
    ),
    choice_alternatives = choice_alternatives(J = 2, alternatives = c("A", "B"))
  )

  covariates <- choice_covariates(
    data_frame = train_choice,
    format = "wide",
    column_decider = "deciderID",
    column_occasion = "occasionID"
  )

  params <- choice_parameters(
    beta = rep(0.1, nrow(choice_effects))
  )

  responses <- generate_choice_responses(
    choice_effects = choice_effects,
    choice_covariates = covariates,
    choice_parameters = params
  )

  expect_s3_class(responses, "choice_responses")
  expect_true(all(responses$choice %in% c("A", "B")))
})

test_that("choice response simulation requires Sigma", {
  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      choice ~ cost | age | time, error_term = "probit"
    ),
    choice_alternatives = choice_alternatives(J = 3)
  )
  choice_covariates <- generate_choice_covariates(
    choice_effects = choice_effects,
    choice_identifiers = generate_choice_identifiers(N = 3, Tp = rep(1, 3))
  )
  expect_error(
    generate_choice_responses(
      choice_effects = choice_effects,
      choice_covariates = choice_covariates,
      choice_parameters = choice_parameters(beta = numeric(nrow(choice_effects))),
      choice_identifiers = extract_choice_identifiers(choice_covariates)
    ),
    "required",
    fixed = TRUE
  )
})

test_that("generate_choice_responses can return ranked columns", {

  set.seed(1)

  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      formula = choice ~ price | time,
      error_term = "logit"
    ),
    choice_alternatives = choice_alternatives(J = 3)
  )

  ids <- generate_choice_identifiers(N = 3, Tp = rep(1L, 3L))
  covariates <- generate_choice_covariates(
    choice_effects = choice_effects,
    choice_identifiers = ids
  )
  params <- generate_choice_parameters(choice_effects = choice_effects)

  ranked_responses <- generate_choice_responses(
    choice_effects = choice_effects,
    choice_covariates = covariates,
    choice_parameters = params,
    choice_identifiers = ids,
    column_choice = "choice",
    choice_type = "ranked"
  )

  expect_s3_class(ranked_responses, "choice_responses")
  expect_identical(attr(ranked_responses, "column_choice"), "choice")

  alt_names <- as.character(attr(choice_effects, "choice_alternatives"))
  rank_cols <- paste0("choice_", alt_names)
  expect_true(all(rank_cols %in% names(ranked_responses)))

  ranking_matrix <- as.matrix(ranked_responses[rank_cols])

  inferred_top <- alt_names[max.col(-ranking_matrix, ties.method = "first")]
  expect_equal(ranked_responses$choice, inferred_top)
})