tests/testthat/test-choice_covariates.R

In choicedata: Working with Choice Data

test_that("choice_covariates can be defined", {

  ### long format
  expect_true(
    choice_covariates(
      data_frame = travel_mode_choice,
      format = "long",
      column_decider = "individual",
      column_occasion = NULL,
      column_alternative = "mode",
      column_ac_covariates = NULL,
      column_as_covariates = NULL,
      delimiter = "_",
      cross_section = TRUE
    ) |> is.choice_covariates()
  )

  ### wide format
  expect_true(
    choice_covariates(
      data_frame = train_choice,
      format = "wide",
      column_decider = "deciderID",
      column_occasion = "occasionID",
      column_alternative = NULL,
      column_ac_covariates = NULL,
      column_as_covariates = NULL,
      delimiter = "_",
      cross_section = FALSE
    ) |> is.choice_covariates()
  )
})

test_that("choice_covariates respects custom delimiters in long format", {
  custom_delimiter <- "-"
  long_covariates <- tibble::tibble(
    individual = rep(1:2, each = 2),
    mode = rep(c("bus", "car"), times = 2),
    cost = c(10, 12, 14, 16),
    wait = c(3, 2, 5, 4)
  )

  result <- choice_covariates(
    data_frame = long_covariates,
    format = "long",
    column_decider = "individual",
    column_occasion = NULL,
    column_alternative = "mode",
    column_ac_covariates = NULL,
    column_as_covariates = c("cost", "wait"),
    delimiter = custom_delimiter,
    cross_section = TRUE
  )

  expect_true(is.choice_covariates(result))
  expect_identical(attr(result, "delimiter"), custom_delimiter)
})

test_that("covariates can be generated", {

  ### using choice effects
  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      formula = choice ~ price | income | comfort,
      error_term = "probit",
      random_effects = c(
        "price" = "cn",
        "income" = "cn"
       )
    ),
    choice_alternatives = choice_alternatives(J = 3)
  )
  x <- generate_choice_covariates(choice_effects = choice_effects)
  expect_s3_class(x, "choice_covariates")
  expect_true(is.choice_covariates(x))

  ### without choice effects
  x <- generate_choice_covariates(labels = c("cost", "age", "time"))
  expect_s3_class(x, "choice_covariates")
  expect_true(is.choice_covariates(x))

})

test_that("covariate names can be deduced from choice effects", {
  choice_effects <- choice_effects(
    choice_formula(choice ~ cost | age | time, error_term = "probit"),
    choice_alternatives(J = 3)
  )
  expect_equal(
    covariate_names(choice_effects),
    c("cost_A", "cost_B", "cost_C", "time_A", "time_B", "time_C", "age")
  )
})

test_that("design matrices can be build", {

  ### simulation case
  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 = 5, Tp = 1:5)
  )
  design_matrices <- design_matrices(
    x = choice_covariates,
    choice_effects = choice_effects
  )

  ### empirical data case (wide)
  choice_data <- choice_data(
    data_frame = train_choice,
    format = "wide",
    column_choice = "choice",
    column_decider = "deciderID",
    column_occasion = "occasionID",
    column_alternative = NULL,
    column_ac_covariates = NULL,
    column_as_covariates = NULL,
    delimiter = "_",
    cross_section = FALSE
  )
  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      choice ~ price + time + change + comfort | 0
    ),
    choice_alternatives = choice_alternatives(
      J = 2, alternatives = c("A", "B")
    )
  )
  design_matrices <- design_matrices(
    x = choice_data,
    choice_effects = choice_effects
  )
  choice_ids <- extract_choice_identifiers(choice_data)
  choice_indices <- extract_choice_indices(
    choice_data = choice_data,
    choice_effects = choice_effects,
    choice_identifiers = choice_ids
  )
  expect_equal(
    unlist(choice_indices),
    match(choice_data[[attr(choice_data, "column_choice")]],
      attr(choice_effects, "choice_alternatives"))
  )

  ### empirical data case (long)
  choice_data <- choice_data(
    data_frame = travel_mode_choice,
    format = "long",
    column_choice = "choice",
    column_decider = "individual",
    column_occasion = NULL,
    column_alternative = "mode",
    delimiter = "_",
    cross_section = TRUE
  )
  choice_effects <- choice_effects(
    choice_formula = choice_formula(
      choice ~ cost | income + size | wait + travel
    ),
    choice_alternatives = choice_alternatives(
      J = 4, alternatives = c("bus", "car", "plane", "train")
    )
  )
  design_matrices <- design_matrices(
    x = choice_data,
    choice_effects = choice_effects
  )
})