tests/testthat/test-assisted-group5.R

In rbiogeme: Interface to 'Biogeme'

assisted_group5_files <- function() {
  rbiogeme_example_path(
    "assisted",
    c(
      "plot_b08selected_specification.R",
      "plot_b09post_processing.R",
      "plot_b10_parameter_overrides.R"
    )
  )
}

native_assisted_group5_result <- function(native_script, variable_name, working_directory) {
  native_root <- Sys.getenv("RBIOGEME_NATIVE_BIOGEME_ROOT", unset = "")
  native_examples <- file.path(native_root, "docs", "source", "examples", "assisted")
  sys <- reticulate::import("sys", convert = FALSE)
  sys$path$insert(0L, native_examples)
  old_directory <- getwd()
  dir.create(working_directory, recursive = TRUE, showWarnings = FALSE)
  setwd(working_directory)
  on.exit(setwd(old_directory), add = TRUE)

  specification <- reticulate::import(
    "biogeme.catalog.specification",
    convert = FALSE
  )$Specification
  specification$all_results <- reticulate::dict()
  specification$model_names <- NULL

  runpy <- reticulate::import("runpy", convert = FALSE)
  globals <- runpy$run_path(native_script)
  bridge <- rbiogeme:::biogeme_bridge()
  result <- reticulate::py_to_r(
    bridge$extract_estimation_results(
      reticulate::py_get_item(globals, variable_name)
    )
  )
  missing <- if (variable_name == "results") {
    tryCatch(
      as.character(reticulate::py_to_r(
        reticulate::py_get_item(globals, "missing_parameter_names")
      )),
      error = function(error) character()
    )
  } else {
    character()
  }
  list(result = result, missing = missing)
}

test_that("assisted group 5 examples are self-contained", {
  files <- assisted_group5_files()
  expect_true(all(file.exists(files)))
  for (file in files) {
    expect_silent(parse(file = file))
    contents <- paste(readLines(file, warn = FALSE), collapse = "\n")
    expect_match(contents, "biogeme_beta")
    expect_match(contents, "segmentation_catalogs")
    expect_match(contents, "prepare_swissmetro_example")
    expect_match(contents, "filter_purpose = FALSE")
  }
  selected <- paste(readLines(files[[1L]], warn = FALSE), collapse = "\n")
  expect_match(selected, "estimate_configuration")
  expect_match(selected, "my_favorite_model")
  expect_match(selected, "model_catalog:logit")

  post_processing <- paste(readLines(files[[2L]], warn = FALSE), collapse = "\n")
  expect_match(post_processing, "--pareto")
  expect_match(post_processing, "recycle = TRUE")
  expect_match(post_processing, "pareto_post_processing")

  overrides <- paste(readLines(files[[3L]], warn = FALSE), collapse = "\n")
  expect_match(overrides, "selected_name = \"has_pt_subscr\"")
  expect_match(overrides, "parameter_overrides")
  expect_match(overrides, "minus_99")
})

test_that("assisted group 5 native examples run when integration is enabled", {
  skip_if_not(
    identical(Sys.getenv("RBIOGEME_RUN_INTEGRATION"), "1"),
    "Set RBIOGEME_RUN_INTEGRATION=1 to run assisted integration tests"
  )
  skip_if_not(
    rbiogeme_test_configure_python(),
    "Set RBIOGEME_PYTHON to a compatible native Biogeme interpreter"
  )
  native_root <- Sys.getenv("RBIOGEME_NATIVE_BIOGEME_ROOT", unset = "")
  skip_if(
    !nzchar(native_root),
    "Set RBIOGEME_NATIVE_BIOGEME_ROOT to the native Biogeme repository"
  )
  data_path <- rbiogeme_test_swissmetro_path()
  skip_if(!nzchar(data_path), "Set RBIOGEME_SWISSMETRO_DATA to the Swissmetro .dat file")
  rscript <- file.path(R.home("bin"), "Rscript")
  files <- assisted_group5_files()

  selected_output <- tempfile("rbiogeme-assisted-b08-")
  selected <- system2(
    rscript,
    c(
      "--vanilla",
      files[[1L]],
      paste0("--data=", data_path),
      paste0("--python=", Sys.getenv("RBIOGEME_PYTHON")),
      paste0("--output=", selected_output)
    ),
    stdout = TRUE,
    stderr = TRUE
  )
  expect_null(attr(selected, "status"))
  expect_true(any(grepl("Selected specification:", selected, fixed = TRUE)))
  expect_true(any(grepl("Final log likelihood:", selected, fixed = TRUE)))
  selected_native <- native_assisted_group5_result(
    file.path(native_root, "docs", "source", "examples", "assisted", "plot_b08selected_specification.py"),
    "results",
    tempfile("rbiogeme-native-b08-")
  )
  selected_ll <- as.numeric(sub(
    "^Final log likelihood: *",
    "",
    trimws(selected[grepl("^Final log likelihood:", selected)][[1L]])
  ))
  expect_equal(selected_ll, selected_native$result$final_log_likelihood, tolerance = 1e-6)

  overrides_output <- tempfile("rbiogeme-assisted-b10-")
  overrides <- system2(
    rscript,
    c(
      "--vanilla",
      files[[3L]],
      paste0("--data=", data_path),
      paste0("--python=", Sys.getenv("RBIOGEME_PYTHON")),
      paste0("--output=", overrides_output)
    ),
    stdout = TRUE,
    stderr = TRUE
  )
  expect_null(attr(overrides, "status"))
  expect_true(any(grepl("Generated minus_99 parameters:", overrides, fixed = TRUE)))
  expect_true(any(grepl("Parameters remaining after overrides: *$", overrides)))
  expect_true(any(grepl("Final log likelihood:", overrides, fixed = TRUE)))
  overrides_native <- native_assisted_group5_result(
    file.path(native_root, "docs", "source", "examples", "assisted", "plot_b10_parameter_overrides.py"),
    "results",
    tempfile("rbiogeme-native-b10-")
  )
  overrides_ll <- as.numeric(sub(
    "^Final log likelihood: *",
    "",
    trimws(overrides[grepl("^Final log likelihood:", overrides)][[1L]])
  ))
  expect_equal(overrides_ll, overrides_native$result$final_log_likelihood, tolerance = 1e-6)
  missing_line <- overrides[grepl("^Generated minus_99 parameters:", overrides)][[1L]]
  r_missing <- trimws(strsplit(
    sub("^Generated minus_99 parameters: *", "", missing_line),
    ",",
    fixed = TRUE
  )[[1L]])
  expect_setequal(r_missing, overrides_native$missing)
})