tests/testthat/test-assisted-group3.R

In rbiogeme: Interface to 'Biogeme'

assisted_group3_examples <- function() {
  native_root <- Sys.getenv("RBIOGEME_NATIVE_BIOGEME_ROOT", unset = "")
  data.frame(
    specification = c("b04segmentation", "b05alt_spec_segmentation"),
    script = rbiogeme_example_path(
      "assisted",
      c("plot_b04segmentation.R", "plot_b05alt_spec_segmentation.R")
    ),
    native_script = file.path(
      native_root,
      "docs",
      "source",
      "examples",
      "assisted",
      c("plot_b04segmentation.py", "plot_b05alt_spec_segmentation.py")
    ),
    expected_models = c(12L, 48L),
    stringsAsFactors = FALSE
  )
}

test_that("assisted group 3 examples are self-contained", {
  examples <- assisted_group3_examples()
  expect_true(all(file.exists(examples$script)))
  for (file in examples$script) {
    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")
    expect_match(contents, "COMMUTERS")
    expect_match(contents, "estimate_catalog")
  }
})

native_assisted_group3_results <- function(native_script) {
  runpy <- reticulate::import("runpy", convert = FALSE)
  bridge <- rbiogeme:::biogeme_bridge()
  globals <- runpy$run_path(native_script)
  native_results <- reticulate::py_get_item(globals, "dict_of_results")
  keys <- vapply(
    reticulate::iterate(native_results$keys()),
    as.character,
    character(1)
  )
  serialized <- lapply(keys, function(key) {
    result <- reticulate::py_get_item(native_results, key)
    reticulate::py_to_r(bridge$extract_estimation_results(result))
  })
  names(serialized) <- keys
  pareto_results <- reticulate::py_get_item(globals, "pareto_results")
  list(
    results = serialized,
    non_dominated = vapply(
      reticulate::iterate(pareto_results$keys()),
      as.character,
      character(1)
    )
  )
}

test_that("assisted group 3 scripts match native catalog resolution and estimates", {
  skip_if_not(
    identical(Sys.getenv("RBIOGEME_RUN_INTEGRATION"), "1"),
    "Set RBIOGEME_RUN_INTEGRATION=1 to run full assisted equivalence tests"
  )
  skip_if_not(
    rbiogeme_test_configure_python(),
    "Set RBIOGEME_PYTHON to a compatible native Biogeme interpreter"
  )
  data_path <- rbiogeme_test_swissmetro_path()
  skip_if(!nzchar(data_path), "Set RBIOGEME_SWISSMETRO_DATA to the Swissmetro .dat file")
  examples <- assisted_group3_examples()
  skip_if(
    any(!file.exists(examples$native_script)),
    "Set RBIOGEME_NATIVE_BIOGEME_ROOT to the native Biogeme repository"
  )
  rscript <- file.path(R.home("bin"), "Rscript")

  for (index in seq_len(nrow(examples))) {
    r_directory <- tempfile(paste0("rbiogeme-assisted-", examples$specification[[index]], "-r-"))
    native_directory <- tempfile(paste0("rbiogeme-assisted-", examples$specification[[index]], "-native-"))
    dir.create(r_directory, recursive = TRUE)
    dir.create(native_directory, recursive = TRUE)
    r_output <- system2(
      rscript,
      c(
        "--vanilla",
        examples$script[[index]],
        paste0("--data=", data_path),
        paste0("--python=", Sys.getenv("RBIOGEME_PYTHON")),
        paste0("--output=", r_directory)
      ),
      stdout = TRUE,
      stderr = TRUE
    )
    expect_null(attr(r_output, "status"))
    r_lines <- r_output[grepl("^asc:.*: LL=", r_output)]
    expect_length(r_lines, examples$expected_models[[index]])
    r_keys <- sub(": LL=.*$", "", r_lines)
    r_log_likelihoods <- as.numeric(sub("^.*: LL=([^ ]+) K=.*$", "\\1", r_lines))
    r_parameter_counts <- as.integer(sub("^.* K=([0-9]+)$", "\\1", r_lines))
    expect_false(anyNA(r_log_likelihoods))
    expect_false(anyNA(r_parameter_counts))

    original_directory <- getwd()
    native <- tryCatch(
      {
        setwd(native_directory)
        native_assisted_group3_results(examples$native_script[[index]])
      },
      finally = setwd(original_directory)
    )
    expect_setequal(r_keys, names(native$results))
    for (configuration in names(native$results)) {
      position <- match(configuration, r_keys)
      native_result <- native$results[[configuration]]
      expect_equal(
        r_log_likelihoods[[position]],
        native_result$final_log_likelihood,
        tolerance = 0.01,
        info = configuration
      )
      expect_equal(
        r_parameter_counts[[position]],
        length(native_result$beta_names),
        info = configuration
      )
    }
    marker <- which(trimws(r_output) == "Non dominated models:")
    expect_length(marker, 1L)
    after_marker <- r_output[seq.int(marker[[1L]] + 1L, length(r_output))]
    trimmed_after_marker <- trimws(after_marker)
    r_non_dominated <- unique(
      trimmed_after_marker[grepl("^asc:[^[:space:]]+$", trimmed_after_marker)]
    )
    expect_setequal(r_non_dominated, native$non_dominated)
  }
})