inst/examples/swissmetro/plot_b12_panel_bis.R

In rbiogeme: Interface to 'Biogeme'

#!/usr/bin/env Rscript

# b12bis. Mixture of logit with panel data and a segmented ASC
#
# This example mirrors plot_b12_panel_bis.py. It keeps the complete model
# specification in this file: random coefficients and ASCs are native Draws
# nodes, the MALE segmentation is a native comparison expression, and panel
# aggregation and Monte Carlo integration are native Biogeme expressions.

library(rbiogeme)

# prepare_swissmetro_example() is defined in example_utils.R. It parses the
# command line, validates the data/Python paths, configures the bridge, reads
# the data, and creates a fresh output directory. The --data, --python,
# --output, --draws, and --seed options work from any current working directory.
script_path <- commandArgs(trailingOnly = FALSE)
script_path <- sub("^--file=", "", script_path[startsWith(script_path, "--file=")][[1L]])
source(file.path(dirname(normalizePath(script_path)), "example_utils.R"))

build_b12_panel_bis_model <- function(database, number_of_draws, seed) {
  # Parameter names, starting values, and bounds match native b12bis exactly.
  b_cost <- biogeme_beta("b_cost", start = 0, upper = 0)
  b_time <- biogeme_beta("b_time", start = 0, upper = 0)
  b_time_s <- biogeme_beta("b_time_s", start = 1, lower = 1.0e-5)

  asc_car <- biogeme_beta("asc_car", start = 0)
  asc_car_s <- biogeme_beta("asc_car_s", start = 1, lower = 1.0e-5)
  asc_train <- biogeme_beta("asc_train", start = 0)
  asc_train_s <- biogeme_beta("asc_train_s", start = 1, lower = 1.0e-5)
  asc_sm <- biogeme_beta("asc_sm", start = 0)
  asc_sm_s <- biogeme_beta("asc_sm_s", start = 1, lower = 1.0e-5)

  b_time_rnd <- b_time + b_time_s * draw("b_time_rnd", "NORMAL_ANTI")
  asc_car_rnd <- asc_car + asc_car_s * draw("asc_car_rnd", "NORMAL_ANTI")
  asc_train_rnd <- asc_train + asc_train_s * draw("asc_train_rnd", "NORMAL_ANTI")
  asc_sm_rnd_base <- asc_sm + asc_sm_s * draw("asc_sm_rnd", "NORMAL_ANTI")

  # MALE == 1 is compiled as a native Biogeme indicator expression. The
  # same symbolic segment coefficient is used in the Train, Swissmetro, and
  # Car utilities, as in the Python example.
  asc_sm_male <- biogeme_beta("asc_sm_male", start = 0)
  asc_train_male <- biogeme_beta("asc_train_male", start = 0)
  asc_car_male <- biogeme_beta("asc_car_male", start = 0)
  male <- variable("MALE") == 1

  utilities <- list(
    `1` = asc_train_rnd + asc_train_male * male +
      b_time_rnd * variable("TRAIN_TT_SCALED") +
      b_cost * variable("TRAIN_COST_SCALED"),
    `2` = asc_sm_rnd_base + asc_sm_male * male +
      b_time_rnd * variable("SM_TT_SCALED") +
      b_cost * variable("SM_COST_SCALED"),
    `3` = asc_car_rnd + asc_car_male * male +
      b_time_rnd * variable("CAR_TT_SCALED") +
      b_cost * variable("CAR_CO_SCALED")
  )
  availability <- list(
    `1` = variable("TRAIN_AV_SP"),
    `2` = variable("SM_AV"),
    `3` = variable("CAR_AV_SP")
  )

  # The kernel is the probability of the observed choice for one row.
  kernel <- logit_probability(
    utilities = utilities,
    availability = availability,
    alternative = variable("CHOICE")
  )
  # Biogeme multiplies the row probabilities within each ID trajectory, then
  # integrates the resulting individual likelihood over native random draws.
  trajectory_probability <- panel_likelihood_trajectory(kernel)
  log_probability <- log(monte_carlo(trajectory_probability))

  # Metadata controls native draw generation; it does not implement a second
  # random-number engine in R. The four names match the native Draws nodes.
  draws <- list(
    biogeme_draws("b_time_rnd", "NORMAL_ANTI", number_of_draws, seed),
    biogeme_draws("asc_car_rnd", "NORMAL_ANTI", number_of_draws, seed),
    biogeme_draws("asc_train_rnd", "NORMAL_ANTI", number_of_draws, seed),
    biogeme_draws("asc_sm_rnd", "NORMAL_ANTI", number_of_draws, seed)
  )

  biogeme_model(
    database = database,
    formula = log_probability,
    draws = draws,
    control = biogeme_control(
    output_directory = prepared$output,
      model_name = "b12_panel_segmented_male",
      number_of_draws = number_of_draws,
      seed = seed,
      second_derivatives = "never",
      generate_html = TRUE,
      generate_yaml = FALSE,
      save_iterations = FALSE
    )
  )
}

prepared <- prepare_swissmetro_example(
  commandArgs(trailingOnly = TRUE),
  default_model = "b12_panel_bis"
)

number_of_draws <- if (!is.null(prepared$options$draws) && nzchar(prepared$options$draws)) {
  example_integer(prepared$options$draws, "draws")
} else {
  5000L
}
seed <- if (!is.null(prepared$options$seed) && nzchar(prepared$options$seed)) {
  example_integer(prepared$options$seed, "seed")
} else {
  1223L
}

# Always estimate afresh. Remove only exact native artifacts so an old YAML or
# iteration file cannot silently change this run.
stale_files <- c(
  "b12_panel_segmented_male.yaml",
  "__b12_panel_segmented_male.iter",
  "b12_panel_segmented_male.html"
)
stale_files <- file.path(prepared$output, stale_files)
stale_files <- stale_files[file.exists(stale_files)]
if (length(stale_files) > 0L) unlink(stale_files, force = TRUE)

# panel=TRUE declares ID as the panel identifier after the native-equivalent
# Swissmetro filter and derived-variable operations. The bridge validates that
# observations for each ID remain contiguous before constructing Biogeme's
# native panel database.
database <- swissmetro_data(prepared$data, panel = TRUE)
model <- build_b12_panel_bis_model(database, number_of_draws, seed)
report_database <- biogeme_database_materialize(database)

cat(sprintf("Panel identifier: %s\n", database$panel_id))
cat(sprintf("Filtered observations: %d\n", nrow(report_database$data)))
cat(sprintf("Draws per individual: %d\n", number_of_draws))
cat("Database columns:\n")
print(biogeme_database_columns(database))

# estimate() delegates trajectory aggregation, Monte Carlo integration,
# derivatives, optimization, and reporting to native Biogeme.
fit <- estimate(
  model,
  model_name = "b12_panel_segmented_male",
  control = model$control
)
print(summary(fit))
print(coef(fit))

invisible(fit)