tests/testthat/test-mdcev-bridge.R

In rbiogeme: Interface to 'Biogeme'

mdcev_test_database <- function() {
  biogeme_database(
    "mdcev_bridge_test",
    data.frame(
      number_chosen = c(1, 2),
      quantity_1 = c(1, 0),
      quantity_2 = c(0, 1)
    )
  )
}

mdcev_test_specification <- function(model_type = "gamma_profile") {
  database <- mdcev_test_database()
  baseline <- list(`1` = 0, `2` = 0)
  gamma <- list(`1` = 1, `2` = 1)
  alpha <- if (identical(model_type, "gamma_profile")) {
    NULL
  } else {
    list(`1` = 0.5, `2` = 0.5)
  }
  mu <- if (identical(model_type, "non_monotonic")) {
    list(`1` = 0, `2` = 0)
  } else {
    NULL
  }
  biogeme_mdcev_model(
    database = database,
    model_type = model_type,
    baseline_utilities = baseline,
    gamma_parameters = gamma,
    alpha_parameters = alpha,
    mu_utilities = mu,
    number_of_chosen_alternatives = variable("number_chosen"),
    consumed_quantities = list(
      `1` = variable("quantity_1"),
      `2` = variable("quantity_2")
    )
  )
}

test_that("MDCEV specifications validate their alternative maps", {
  database <- mdcev_test_database()
  expect_s3_class(mdcev_test_specification(), "biogeme_mdcev_model")
  expect_error(
    biogeme_mdcev_model(
      database = database,
      model_type = "gamma_profile",
      baseline_utilities = list(`1` = 0, `2` = 0),
      gamma_parameters = list(`1` = 1),
      number_of_chosen_alternatives = variable("number_chosen"),
      consumed_quantities = list(`1` = variable("quantity_1"), `2` = variable("quantity_2"))
    ),
    "exactly the baseline alternatives"
  )
  expect_error(
    biogeme_mdcev_model(
      database = database,
      model_type = "non_monotonic",
      baseline_utilities = list(`1` = 0, `2` = 0),
      gamma_parameters = list(`1` = 1, `2` = 1),
      alpha_parameters = list(`1` = 0.5, `2` = 0.5),
      number_of_chosen_alternatives = variable("number_chosen"),
      consumed_quantities = list(`1` = variable("quantity_1"), `2` = variable("quantity_2"))
    ),
    "requires mu_utilities"
  )
})

test_that("MDCEV parameter definitions preserve names and order", {
  database <- mdcev_test_database()
  model <- biogeme_mdcev_model(
    database = database,
    model_type = "generalized",
    baseline_utilities = list(`1` = biogeme_beta("baseline_1"), `2` = 0),
    gamma_parameters = list(`1` = biogeme_beta("gamma_1", start = 1, lower = 0.0001), `2` = 1),
    alpha_parameters = list(`1` = biogeme_beta("alpha_1", start = 0.5, lower = 0.0001, upper = 0.9999), `2` = 0.5),
    number_of_chosen_alternatives = variable("number_chosen"),
    consumed_quantities = list(`1` = variable("quantity_1"), `2` = variable("quantity_2"))
  )
  expect_equal(names(model$parameters), c("baseline_1", "gamma_1", "alpha_1"))
  expect_equal(biogeme_model_parameters(model)$name, names(model$parameters))
})

test_that("database row extraction preserves identifiers", {
  database <- mdcev_test_database()
  extracted <- biogeme_database_extract_rows(database, c(2L, 1L))
  expect_equal(biogeme_database_nrow(extracted), 2L)
  expect_equal(biogeme_database_row_ids(extracted), c("2", "1"))
  expect_equal(extracted$data$number_chosen, c(2, 1))
})

test_that("all MDCEV variants compile to native Biogeme classes", {
  skip_if_not(
    rbiogeme_test_configure_python(),
    "Set RBIOGEME_PYTHON to a compatible native Biogeme interpreter"
  )
  for (model_type in c("gamma_profile", "generalized", "translated", "non_monotonic")) {
    compiled <- rbiogeme:::biogeme_compile_model(mdcev_test_specification(model_type))
    expect_equal(reticulate::py_to_r(compiled$model_type), model_type)
    expect_equal(reticulate::py_to_r(compiled$mdcev$number_of_alternatives), 2L)
    expect_false(is.null(compiled$log_likelihood))
  }
})

test_that("native MDCEV epsilon generation is reproducible when seeded", {
  skip_if_not(
    rbiogeme_test_configure_python(),
    "Set RBIOGEME_PYTHON to a compatible native Biogeme interpreter"
  )
  model <- mdcev_test_specification()
  first <- mdcev_generate_epsilons(model, 2L, 4L, seed = 123L)
  second <- mdcev_generate_epsilons(model, 2L, 4L, seed = 123L)
  expect_equal(first, second, tolerance = 0)
  expect_equal(dim(first[[1L]]), c(4L, 2L))
})

test_that("native MDCEV estimation and post-estimation operations stay in the bridge", {
  skip_if_not(
    rbiogeme_test_configure_python(),
    "Set RBIOGEME_PYTHON to a compatible native Biogeme interpreter"
  )
  old_directory <- getwd()
  temporary_directory <- tempfile("rbiogeme-mdcev-test-")
  dir.create(temporary_directory)
  setwd(temporary_directory)
  on.exit(setwd(old_directory), add = TRUE)

  database <- mdcev_test_database()
  model <- biogeme_mdcev_model(
    database = database,
    model_type = "gamma_profile",
    baseline_utilities = list(`1` = biogeme_beta("baseline_1", start = 0), `2` = 0),
    gamma_parameters = list(`1` = 1, `2` = 1),
    number_of_chosen_alternatives = variable("number_chosen"),
    consumed_quantities = list(
      `1` = variable("quantity_1"),
      `2` = variable("quantity_2")
    )
  )
  fit <- mdcev_estimate(
    model,
    model_name = "mdcev_bridge_test",
    controls = biogeme_control(
      generate_html = FALSE,
      generate_yaml = FALSE,
      save_iterations = FALSE,
      tolerance = 1e-5
    )
  )
  expect_s3_class(fit, "biogeme_fit")
  expect_true(is.finite(fit$final_log_likelihood))
  expect_match(mdcev_short_summary(fit), "Final log likelihood")
  expect_true("Estimated parameters" %in% names(mdcev_parameter_table(fit)))

  epsilons <- mdcev_generate_epsilons(model, 2L, 1L, seed = 0L)
  forecast_database <- biogeme_database_extract_rows(database, c(1L, 2L))
  forecast <- mdcev_forecast(
    model,
    fit,
    forecast_database,
    total_budget = 10,
    epsilons = epsilons
  )
  expect_s3_class(forecast, "biogeme_mdcev_forecast")
  expect_equal(length(forecast$values), 2L)
  expect_true(mdcev_validate_forecast(
    model,
    fit,
    forecast_database,
    total_budget = 10,
    epsilons = epsilons
  ))
})