inst/examples/hybrid_choice_models/example_utils.R

In rbiogeme: Interface to 'Biogeme'

# Shared command-line and output handling for the hybrid-choice examples.
#
# The example scripts source this file by path so that they can be launched
# from any working directory.  It deliberately contains data/path plumbing,
# not model equations: each example keeps its own specification visible.

parse_optima_arguments <- function(arguments, defaults = list()) {
  options <- defaults
  for (argument in arguments) {
    if (!startsWith(argument, "--") || !grepl("=", argument, fixed = TRUE)) {
      stop("Arguments must use the --name=value form: ", argument, call. = FALSE)
    }
    pieces <- strsplit(sub("^--", "", argument), "=", fixed = TRUE)[[1L]]
    key <- gsub("-", "_", pieces[[1L]], fixed = TRUE)
    value <- paste(pieces[-1L], collapse = "=")
    if (!nzchar(key)) stop("Argument names must not be empty.", call. = FALSE)
    options[[key]] <- value
  }
  options
}

optima_integer_option <- function(value, name) {
  result <- suppressWarnings(as.numeric(value))
  if (length(result) != 1L || is.na(result) || result < 1 || result != floor(result)) {
    stop(name, " must be a positive integer.", call. = FALSE)
  }
  as.integer(result)
}

optima_seed_option <- function(value) {
  result <- suppressWarnings(as.numeric(value))
  if (length(result) != 1L || is.na(result) || !is.finite(result)) {
    stop("seed must be one finite numeric value.", call. = FALSE)
  }
  result
}

prepare_optima_example <- function(
    arguments,
    default_model,
    default_data,
    default_number_of_draws = 50000L
) {
  options <- parse_optima_arguments(
    arguments,
    defaults = list(
      data = Sys.getenv("RBIOGEME_OPTIMA_DATA", unset = default_data),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = ""),
      output = "",
      number_of_draws = as.character(default_number_of_draws),
      seed = ""
    )
  )
  if (is.null(options$data) || !nzchar(options$data) || !file.exists(options$data)) {
    stop(
      "Provide --data=/path/to/optima.dat or set RBIOGEME_OPTIMA_DATA. "
        ,
      call. = FALSE
    )
  }
  if (!is.null(options$python) && nzchar(options$python)) {
    if (!file.exists(options$python)) {
      stop("The selected Python executable does not exist: ", options$python, call. = FALSE)
    }
    rbiogeme::biogeme_config(python = options$python)
  }
  if (is.null(options$output) || !nzchar(options$output)) {
    stop("Provide --output=/path/to/output.", call. = FALSE)
  }
  output <- normalizePath(path.expand(options$output), mustWork = FALSE)
  dir.create(output, recursive = TRUE, showWarnings = FALSE)
  existing <- list.files(output, all.files = TRUE, no.. = TRUE)
  if (length(existing) > 0L) {
    stop(
      "Output directory is not empty; use a fresh --output directory to avoid "
        ,
      "reusing old Biogeme result files: ",
      output,
      call. = FALSE
    )
  }
  data <- read.delim(options$data, check.names = FALSE, stringsAsFactors = FALSE)
  number_of_draws <- optima_integer_option(options$number_of_draws, "number_of_draws")
  seed <- if (is.null(options$seed) || !nzchar(options$seed)) {
    NULL
  } else {
    optima_seed_option(options$seed)
  }
  list(
    options = options,
    data = data,
    data_path = normalizePath(options$data),
    output = output,
    number_of_draws = number_of_draws,
    seed = seed
  )
}

optima_estimation_control <- function(
    model_name,
    prepared,
    numerically_safe,
    generate_html = TRUE,
    second_derivatives = "never",
    max_iterations = 5000,
    number_of_draws = NULL
) {
  arguments <- list(
    model_name = model_name,
    output_directory = prepared$output,
    save_iterations = FALSE,
    generate_yaml = TRUE,
    generate_html = generate_html
  )
  if (!is.null(numerically_safe)) arguments$numerically_safe <- numerically_safe
  if (!is.null(second_derivatives)) arguments$second_derivatives <- second_derivatives
  if (!is.null(max_iterations)) arguments$max_iterations <- max_iterations
  if (!is.null(number_of_draws)) arguments$number_of_draws <- number_of_draws
  if (!is.null(prepared$seed)) arguments$seed <- prepared$seed
  do.call(biogeme_control, arguments)
}