tests/testthat/test-bridge.R

In rbiogeme: Interface to 'Biogeme'

bridge_available <- function() {
  nzchar(Sys.getenv("RBIOGEME_PYTHON", unset = "")) &&
    rbiogeme_test_configure_python()
}

test_that("a logit model is compiled into native Biogeme objects", {
  skip_if_not(bridge_available(), "A compatible Python Biogeme environment is not available")

  database <- biogeme_database(
    "toy",
    data.frame(
      choice = c(1, 2, 1, 2),
      income = c(10, 20, 15, 25),
      stringsAsFactors = FALSE
    )
  )
  beta <- biogeme_beta("beta_income", start = -0.1)
  model <- logit_model(
    database = database,
    choice = "choice",
    utilities = list(
      `1` = beta * variable("income"),
      `2` = 0
    )
  )

  compiled <- rbiogeme:::biogeme_compile_model(model)
  expect_equal(reticulate::py_to_r(compiled$beta_names), "beta_income")
  expect_equal(reticulate::py_to_r(compiled$alternative_codes), list(`1` = 1L, `2` = 2L))
  expect_true(reticulate::py_has_attr(compiled$log_likelihood, "get_value"))
  expect_match(reticulate::py_repr(compiled$log_likelihood), "LogLogit")
})

test_that("the bridge preserves availability and weights", {
  skip_if_not(bridge_available(), "A compatible Python Biogeme environment is not available")

  database <- biogeme_database(
    "toy_weighted",
    data.frame(choice = c(1, 2, 1, 2), income = c(10, 20, 15, 25), wt = c(1, 2, 1, 2))
  )
  beta <- biogeme_beta("beta_income", start = -0.1)
  model <- logit_model(
    database = database,
    choice = "choice",
    utilities = list(`1` = beta * variable("income"), `2` = 0),
    availability = list(`1` = 1, `2` = variable("wt") / variable("wt")),
    weight = variable("wt")
  )

  compiled <- rbiogeme:::biogeme_compile_model(model)
  expect_true(reticulate::py_has_attr(compiled$weight, "get_value"))
  expect_true(reticulate::py_has_attr(compiled$log_likelihood, "get_value"))
})

test_that("generic alternative-specific catalogs resolve through native Biogeme", {
  skip_if_not(bridge_available(), "A compatible Python Biogeme environment is not available")

  database <- biogeme_database(
    "toy_generic_alt_specific",
    data.frame(
      choice = c(1, 2, 1, 2),
      train = c(1, 2, 3, 4),
      car = c(2, 1, 2, 1),
      FIRST = c(0, 1, 0, 1)
    )
  )
  first <- biogeme_database_segmentation(
    database,
    "FIRST",
    c(`0` = "second", `1` = "first")
  )
  beta <- biogeme_beta("b_time", start = -1)
  catalogs <- generic_alt_specific_catalogs(
    generic_name = "b_time",
    beta_parameters = list(beta),
    alternatives = c("train", "car"),
    potential_segmentations = list(first),
    maximum_number = 1
  )[[1L]]
  log_probability <- logit_log_probability(
    utilities = list(
      `1` = catalogs$train * variable("train"),
      `2` = catalogs$car * variable("car")
    ),
    availability = list(`1` = 1, `2` = 1),
    alternative = variable("choice")
  )
  model <- biogeme_model(database, formula = log_probability)

  expect_equal(count_number_of_specifications(model), 4L)
  selected <- biogeme_native_parameter_names(
    model,
    configuration_id = "b_time:FIRST;b_time_gen_altspec:altspec"
  )
  expect_identical(
    selected$all,
    c(
      "b_time_train_ref", "b_time_train_diff_first",
      "b_time_car_ref", "b_time_car_diff_first"
    )
  )
  compiled <- rbiogeme:::biogeme_compile_model(model)
  expect_true(
    reticulate::py_has_attr(
      reticulate::py_get_item(compiled$availability, 1L),
      "get_value"
    )
  )
})

test_that("catalog configuration identifiers come from native Biogeme", {
  skip_if_not(bridge_available(), "A compatible Python Biogeme environment is not available")

  database <- biogeme_database(
    "toy_catalog_ids",
    data.frame(choice = c(1, 2, 1, 2), income = c(10, 20, 15, 25))
  )
  beta <- biogeme_beta("beta_income", start = -0.1)
  first <- catalog_controller("time", c("linear", "quadratic"))
  expression <- catalog(
    "time",
    list(
      linear = beta * variable("income"),
      quadratic = beta * variable("income") * variable("income")
    ),
    controller = first
  )
  model <- biogeme_model(database, formula = expression)

  expect_setequal(
    catalog_configuration_ids(model),
    c("time:linear", "time:quadratic")
  )
})