inst/examples/indicators/indicator_utils.R

In rbiogeme: Interface to 'Biogeme'

# Command-line and output handling for the indicators examples.
#
# This helper deliberately contains no model equations. It makes the scripts
# runnable from any working directory and refuses to use a non-empty output
# directory, so native YAML and iteration files cannot be recycled silently.

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

indicator_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)
}

indicator_flag_option <- function(value, name) {
  value <- tolower(as.character(value))
  if (length(value) != 1L || is.na(value) ||
      !value %in% c("true", "false", "1", "0", "yes", "no")) {
    stop(name, " must be true or false.", call. = FALSE)
  }
  value %in% c("true", "1", "yes")
}

configure_indicator_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_indicator_estimation_example <- function(
    arguments,
    example_directory,
    default_model = "b02estimation",
    default_bootstrap_samples = 100L
) {
  options <- parse_indicator_arguments(
    arguments,
    defaults = list(
      data = Sys.getenv(
        "RBIOGEME_OPTIMA_DATA",
        unset = file.path(example_directory, "optima.dat")
      ),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = ""),
      output = "",
      bootstrap_samples = as.character(default_bootstrap_samples),
      run_bootstrap = "true"
    )
  )
  if (is.null(options$data) || !nzchar(options$data) ||
      !file.exists(options$data) || dir.exists(options$data)) {
    stop(
      "Provide --data=/path/to/optima.dat or set RBIOGEME_OPTIMA_DATA.",
      call. = FALSE
    )
  }
  configure_indicator_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
    )
  }
  list(
    options = options,
    data_path = normalizePath(options$data),
    output = output,
    bootstrap_samples = indicator_integer_option(
      options$bootstrap_samples,
      "bootstrap_samples"
    ),
    run_bootstrap = indicator_flag_option(options$run_bootstrap, "run_bootstrap")
  )
}

# Convert the serialized native bootstrap matrix into the ordinary named
# parameter mappings accepted by biogeme_confidence_intervals(). The bootstrap
# estimates themselves are produced by native Biogeme; this helper only adds
# the parameter names after they cross the bridge.
indicator_bootstrap_parameter_draws <- function(fit) {
  if (!inherits(fit, "biogeme_fit") || is.null(fit$bootstrap) ||
      length(fit$bootstrap) == 0L) {
    stop(
      "This operation requires a fitted model with native bootstrap results.",
      call. = FALSE
    )
  }
  bootstrap <- fit$bootstrap
  rows <- if (is.matrix(bootstrap) || is.data.frame(bootstrap)) {
    lapply(seq_len(nrow(bootstrap)), function(index) bootstrap[index, ])
  } else {
    as.list(bootstrap)
  }
  lapply(rows, function(row) {
    values <- as.numeric(unlist(row, use.names = FALSE))
    if (length(values) != length(fit$beta_names)) {
      stop("Native bootstrap rows do not match the fitted parameter names.", call. = FALSE)
    }
    setNames(values, fit$beta_names)
  })
}