tests/testthat/test-logit-model.R

In rbiogeme: Interface to 'Biogeme'

test_that("a logit model validates utilities and availability", {
  data <- data.frame(
    CHOICE = c(1, 2, 1, 3),
    TRAIN_TIME = c(10, 20, 15, 12),
    SM_TIME = c(8, 18, 14, 10),
    CAR_TIME = c(12, 16, 13, 11),
    TRAIN_AV = c(1, 1, 0, 1),
    SM_AV = c(1, 1, 1, 1),
    CAR_AV = c(1, 0, 1, 1)
  )
  database <- biogeme_database("logit_data", data)
  b_time <- biogeme_beta("b_time", start = -1)

  model <- logit_model(
    database = database,
    choice = "CHOICE",
    utilities = list(
      train = b_time * variable("TRAIN_TIME"),
      swissmetro = b_time * variable("SM_TIME"),
      car = b_time * variable("CAR_TIME")
    ),
    availability = list(
      train = variable("TRAIN_AV"),
      swissmetro = variable("SM_AV"),
      car = variable("CAR_AV")
    ),
    alternative_codes = c(train = 1, swissmetro = 2, car = 3)
  )

  expect_s3_class(model, "biogeme_logit_model")
  expect_equal(unname(model$alternative_codes), c(1L, 2L, 3L))
  expect_equal(names(model$utilities), c("train", "swissmetro", "car"))
  expect_equal(biogeme_model_parameters(model)$name, "b_time")
})

test_that("integer utility names infer alternative codes", {
  database <- biogeme_database(
    "numeric_alternatives",
    data.frame(CHOICE = c(1, 2), X = c(1, 2))
  )
  model <- logit_model(
    database,
    choice = "CHOICE",
    utilities = list(`1` = variable("X"), `2` = -variable("X"))
  )

  expect_equal(unname(model$alternative_codes), c(1L, 2L))
})

test_that("logit probability accepts a symbolic observed-choice selector", {
  probability <- logit_probability(
    utilities = list(`1` = variable("X"), `2` = -variable("X")),
    availability = list(`1` = 1, `2` = 1),
    alternative = variable("CHOICE")
  )

  expect_s3_class(probability, "biogeme_expression")
  expect_equal(rbiogeme:::collect_biogeme_variables(probability), c("X", "CHOICE"))
  expect_match(rbiogeme:::format_biogeme_expression(probability), "CHOICE")
})

test_that("logit specification catches invalid alternatives and choices", {
  database <- biogeme_database(
    "invalid_logit",
    data.frame(CHOICE = c(1, 2), X = c(1, 2))
  )
  utilities <- list(first = variable("X"), second = -variable("X"))

  expect_error(
    logit_model(database, "MISSING", utilities),
    "not present"
  )
  expect_error(
    logit_model(database, "CHOICE", utilities),
    "alternative_codes"
  )
  expect_error(
    logit_model(
      database,
      "CHOICE",
      utilities,
      alternative_codes = c(first = 1, other = 2)
    ),
    "exactly one code"
  )
  expect_error(
    logit_model(
      database,
      "CHOICE",
      utilities,
      availability = list(first = 1, other = 1),
      alternative_codes = c(first = 1, second = 2)
    ),
    "exactly one expression"
  )
})

test_that("choice values and numeric availability are validated", {
  database <- biogeme_database(
    "choice_values",
    data.frame(CHOICE = c(1, 2), X = c(1, 2))
  )
  utilities <- list(`1` = variable("X"), `2` = -variable("X"))

  expect_error(
    logit_model(
      database,
      "CHOICE",
      utilities,
      availability = list(`1` = 2, `2` = 1)
    ),
    "must be 0 or 1"
  )

  data_with_unknown_choice <- data.frame(CHOICE = c(1, 3), X = c(1, 2))
  unknown_choice_database <- biogeme_database("unknown", data_with_unknown_choice)
  expect_error(
    logit_model(unknown_choice_database, "CHOICE", utilities),
    "not present in utilities"
  )
})