example_utils.R
In rbiogeme: Interface to 'Biogeme'

# Shared command-line and native-control handling for the Monte Carlo examples.
#
# This helper deliberately contains no model equations.  Each example keeps
# its complete expression tree in the script, while this file makes the
# scripts runnable from any working directory and prevents result recycling.

parse_montecarlo_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
}

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

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

montecarlo_require_even_draws <- function(value) {
  if (value %% 2L != 0L) {
    stop("number_of_draws must be even for antithetic draws.", call. = FALSE)
  }
  value
}

configure_montecarlo_python <- function(python) {
  if (!is.null(python) && nzchar(python)) {
    if (!file.exists(python)) {
      stop("The selected Python executable does not exist: ", python, call. = FALSE)
    }
    biogeme_config(python = python)
  }
}

prepare_montecarlo_example <- function(
    arguments,
    default_number_of_draws,
    default_multiplier = 1L
) {
  options <- parse_montecarlo_arguments(
    arguments,
    defaults = list(
      number_of_draws = Sys.getenv(
        "RBIOGEME_MONTECARLO_DRAWS",
        unset = as.character(default_number_of_draws)
      ),
      multiplier = Sys.getenv(
        "RBIOGEME_MONTECARLO_MULTIPLIER",
        unset = as.character(default_multiplier)
      ),
      seed = Sys.getenv("RBIOGEME_MONTECARLO_SEED", unset = ""),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = "")
    )
  )
  configure_montecarlo_python(options$python)
  seed <- if (is.null(options$seed) || !nzchar(options$seed)) {
    NULL
  } else {
    montecarlo_seed_option(options$seed)
  }
  list(
    number_of_draws = montecarlo_integer_option(
      options$number_of_draws,
      "number_of_draws"
    ),
    multiplier = montecarlo_integer_option(options$multiplier, "multiplier"),
    seed = seed
  )
}

prepare_swissmetro_one_example <- function(
    arguments,
    example_directory,
    default_number_of_draws
) {
  options <- parse_montecarlo_arguments(
    arguments,
    defaults = list(
      data = Sys.getenv(
        "RBIOGEME_SWISSMETRO_DATA",
        unset = file.path(example_directory, "swissmetro.dat")
      ),
      number_of_draws = Sys.getenv(
        "RBIOGEME_MONTECARLO_DRAWS",
        unset = as.character(default_number_of_draws)
      ),
      multiplier = "1",
      seed = Sys.getenv("RBIOGEME_MONTECARLO_SEED", unset = ""),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = "")
    )
  )
  configure_montecarlo_python(options$python)
  if (is.null(options$data) || !nzchar(options$data) || !file.exists(options$data)) {
    stop(
      "Provide --data=/path/to/swissmetro.dat or set RBIOGEME_SWISSMETRO_DATA.",
      call. = FALSE
    )
  }
  seed <- if (is.null(options$seed) || !nzchar(options$seed)) {
    NULL
  } else {
    montecarlo_seed_option(options$seed)
  }
  data <- read.delim(options$data, check.names = FALSE, stringsAsFactors = FALSE)
  if (nrow(data) < 1L) stop("The Swissmetro data file has no observations.", call. = FALSE)
  list(
    data_path = normalizePath(options$data),
    data = data,
    number_of_draws = montecarlo_integer_option(
      options$number_of_draws,
      "number_of_draws"
    ),
    seed = seed
  )
}

prepare_swissmetro_estimation_example <- function(
    arguments,
    example_directory,
    default_model,
    default_number_of_quadrature_points = 30L
) {
  options <- parse_montecarlo_arguments(
    arguments,
    defaults = list(
      data = Sys.getenv(
        "RBIOGEME_SWISSMETRO_DATA",
        unset = file.path(example_directory, "swissmetro.dat")
      ),
      output = "",
      quadrature_points = as.character(default_number_of_quadrature_points),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = "")
    )
  )
  configure_montecarlo_python(options$python)
  if (is.null(options$data) || !nzchar(options$data) || !file.exists(options$data)) {
    stop(
      "Provide --data=/path/to/swissmetro.dat or set RBIOGEME_SWISSMETRO_DATA.",
      call. = FALSE
    )
  }
  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)
  data <- read.delim(options$data, check.names = FALSE, stringsAsFactors = FALSE)
  if (nrow(data) < 1L) stop("The Swissmetro data file has no observations.", call. = FALSE)
  list(
    data_path = normalizePath(options$data),
    data = data,
    output = output,
    number_of_quadrature_points = montecarlo_integer_option(
      options$quadrature_points,
      "quadrature_points"
    )
  )
}

prepare_swissmetro_draw_estimation_example <- function(
    arguments,
    example_directory,
    default_model,
    default_number_of_draws = 10000L
) {
  options <- parse_montecarlo_arguments(
    arguments,
    defaults = list(
      data = Sys.getenv(
        "RBIOGEME_SWISSMETRO_DATA",
        unset = file.path(example_directory, "swissmetro.dat")
      ),
      output = "",
      number_of_draws = Sys.getenv(
        "RBIOGEME_MONTECARLO_DRAWS",
        unset = as.character(default_number_of_draws)
      ),
      seed = Sys.getenv("RBIOGEME_MONTECARLO_SEED", unset = ""),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = "")
    )
  )
  configure_montecarlo_python(options$python)
  if (is.null(options$data) || !nzchar(options$data) || !file.exists(options$data)) {
    stop(
      "Provide --data=/path/to/swissmetro.dat or set RBIOGEME_SWISSMETRO_DATA.",
      call. = FALSE
    )
  }
  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)
  data <- read.delim(options$data, check.names = FALSE, stringsAsFactors = FALSE)
  if (nrow(data) < 1L) stop("The Swissmetro data file has no observations.", call. = FALSE)
  seed <- if (is.null(options$seed) || !nzchar(options$seed)) {
    NULL
  } else {
    montecarlo_seed_option(options$seed)
  }
  list(
    data_path = normalizePath(options$data),
    data = data,
    output = output,
    number_of_draws = montecarlo_integer_option(
      options$number_of_draws,
      "number_of_draws"
    ),
    seed = seed
  )
}

montecarlo_control <- function(model_name, number_of_draws, seed = NULL) {
  arguments <- list(
    model_name = model_name,
    number_of_draws = as.integer(number_of_draws),
    generate_html = FALSE,
    generate_yaml = FALSE,
    save_iterations = FALSE
  )
  if (!is.null(seed)) arguments$seed <- as.integer(seed)
  do.call(biogeme_control, arguments)
}

empty_beta_values <- function() {
  # simulate() requires a named vector even when the model has no Betas.
  setNames(numeric(0), character(0))
}