inst/examples/sampling/example_utils.R

In rbiogeme: Interface to 'Biogeme'

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

prepare_sampling_example <- function(arguments, default_model) {
  options <- parse_sampling_arguments(
    arguments,
    defaults = list(
      alternatives = Sys.getenv("RBIOGEME_SAMPLING_ALTERNATIVES", unset = ""),
      observations = Sys.getenv("RBIOGEME_SAMPLING_OBSERVATIONS", unset = ""),
      python = Sys.getenv("RBIOGEME_PYTHON", unset = ""),
      output = ""
    )
  )
  for (name in c("alternatives", "observations")) {
    if (is.null(options[[name]]) || !nzchar(options[[name]]) ||
        !file.exists(options[[name]])) {
      stop(
        "Provide --", gsub("_", "-", name, fixed = TRUE),
        "=/path/to/file or set the corresponding RBIOGEME_SAMPLING_ environment variable.",
        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)
  alternatives <- read.csv(
    options$alternatives,
    check.names = FALSE,
    stringsAsFactors = FALSE
  )
  observations <- read.csv(
    options$observations,
    check.names = FALSE,
    stringsAsFactors = FALSE
  )
  list(options = options, alternatives = alternatives, observations = observations, output = output)
}

sampling_true_parameters <- function() {
  scale <- 0.5
  c(
    beta_rating = 1.5 * scale,
    beta_price = -0.8 * scale,
    beta_chinese = 1.5 * scale,
    beta_japanese = 2.5 * scale,
    beta_korean = 1.5 * scale,
    beta_indian = 2 * scale,
    beta_french = 1.5 * scale,
    beta_mexican = 2.5 * scale,
    beta_lebanese = 1.5 * scale,
    beta_ethiopian = 1 * scale,
    beta_log_dist = -1.2 * scale,
    mu_asian = 2,
    mu_downtown = 2
  )
}

compare_sampling_parameters <- function(fit, true_parameters) {
  estimated <- coef(fit)
  standard_errors <- fit$standard_errors
  if (is.null(standard_errors)) {
    standard_errors <- setNames(rep(NA_real_, length(estimated)), names(estimated))
  }
  rows <- lapply(names(true_parameters), function(name) {
    if (!name %in% names(estimated)) return(NULL)
    estimate <- unname(estimated[[name]])
    std_error <- unname(standard_errors[[name]])
    data.frame(
      Name = name,
      `True Value` = unname(true_parameters[[name]]),
      `Estimated Value` = estimate,
      `T-Test` = (true_parameters[[name]] - estimate) / std_error,
      check.names = FALSE,
      stringsAsFactors = FALSE
    )
  })
  rows <- Filter(Negate(is.null), rows)
  comparison <- if (length(rows) == 0L) {
    data.frame(
      Name = character(), `True Value` = numeric(),
      `Estimated Value` = numeric(), `T-Test` = numeric(),
      check.names = FALSE
    )
  } else {
    do.call(rbind, rows)
  }
  not_estimated <- setdiff(names(true_parameters), names(estimated))
  message <- if (length(not_estimated) == 0L) {
    ""
  } else {
    paste0("Parameters not estimated: [", paste(not_estimated, collapse = ", "), "]")
  }
  list(data = comparison, message = message)
}