optima.R
In rbiogeme: Interface to 'Biogeme'

# Native-equivalent Optima database preparation used by h01--h03.
#
# The filtering and derived columns below mirror optima.py in the native
# Biogeme examples.  The expressions are retained symbolically and applied by
# the Python bridge once, when the database is compiled.  This means that
# defining a variable does not copy or numerically evaluate the data in R.

optima_database <- function(data, name = "optima") {
  database <- biogeme_database(name, data)

  choice <- variable("Choice")
  occupancy <- variable("OccupStat")
  trajectories <- variable("NbTrajects")
  time_pt <- variable("TimePT")
  time_car <- variable("TimeCar")
  distance <- variable("distance_km")
  car_availability <- variable("CarAvail")

  # These initial removals are in the same order as optima.py.  The final
  # removal below corresponds to the native number_of_cars == -1 exclusion.
  database <- biogeme_database_remove(database, choice == -1)
  database <- biogeme_database_remove(database, (occupancy != 1) & (occupancy != 2))
  database <- biogeme_database_remove(database, trajectories == 1)
  database <- biogeme_database_remove(database, time_pt == 0)
  database <- biogeme_database_remove(database, time_car == 0)
  database <- biogeme_database_remove(database, distance == 0)
  database <- biogeme_database_remove(
    database,
    (choice == 1) & (car_availability == 3)
  )

  # normalized_weight is the one derived quantity that needs the sample-wide
  # sum.  Its scalar is computed from the same explicit pre-filter; the column
  # itself remains a native Biogeme expression.  Later model equations use the
  # other derived columns without any R-side data evaluation.
  eligible <- data[data$Choice != -1, , drop = FALSE]
  eligible <- eligible[eligible$OccupStat %in% c(1, 2), , drop = FALSE]
  eligible <- eligible[eligible$NbTrajects != 1, , drop = FALSE]
  eligible <- eligible[eligible$TimePT != 0, , drop = FALSE]
  eligible <- eligible[eligible$TimeCar != 0, , drop = FALSE]
  eligible <- eligible[eligible$distance_km != 0, , drop = FALSE]
  eligible <- eligible[!(eligible$Choice == 1 & eligible$CarAvail == 3), , drop = FALSE]
  weight_scale <- nrow(eligible) / sum(eligible$Weight)

  database <- biogeme_database_define_variable(
    database, "worker", ((occupancy == 1) + (occupancy == 2))
  )
  database <- biogeme_database_define_variable(
    database, "car_is_available", car_availability != 3
  )
  database <- biogeme_database_define_variable(
    database, "normalized_weight", variable("Weight") * weight_scale
  )
  number_of_cars <- variable("NbCar") - (variable("NbCar") == 4) -
    3 * (variable("NbCar") == 6)
  database <- biogeme_database_define_variable(database, "number_of_cars", number_of_cars)
  database <- biogeme_database_remove(database, number_of_cars == -1)

  # Derived variables in the native optima.py.  The h01--h03 scripts use the
  # choice covariates, structural covariates, and indicators declared here;
  # defining the complete set keeps this helper compatible with later groups.
  define <- function(database, name, expression) {
    biogeme_database_define_variable(database, name, expression)
  }
  age <- variable("age")
  calculated_income <- variable("CalculatedIncome")
  nb_household <- variable("NbHousehold")
  nb_car <- variable("NbCar")
  nb_bicy <- variable("NbBicy")
  famil_situ <- variable("FamilSitu")
  resid_child <- variable("ResidChild")
  education <- variable("Education")
  socio_professional <- variable("SocioProfCat")

  database <- define(database, "livesInUrbanArea", variable("UrbRur") == 2)
  database <- define(database, "owningHouse", variable("OwnHouse") == 1)
  database <- define(database, "used_to_go_to_school_by_car", variable("ModeToSchool") == 1)
  database <- define(database, "city_center_as_kid", resid_child == 1)
  database <- define(database, "ScaledIncome", calculated_income / 1000)
  database <- define(database, "age_65_more", age >= 65)
  database <- define(database, "age_30_less", age <= 30)
  database <- define(database, "age_category", 2 - (age <= 30) + (age >= 65))
  database <- define(
    database,
    "household_size",
    3 - 2 * (nb_household == 1) - (nb_household == 2)
  )
  database <- define(
    database,
    "income_category",
    1 + (calculated_income >= 3250) +
      (calculated_income >= 7000) + (calculated_income >= 15000)
  )
  database <- define(database, "distance_category", 1 + (distance >= 50))
  database <- define(database, "moreThanOneCar", nb_car > 1)
  database <- define(database, "moreThanOneBike", nb_bicy > 1)
  database <- define(database, "individualHouse", variable("HouseType") == 1)
  database <- define(database, "male", variable("Gender") == 1)
  database <- define(database, "single", (famil_situ == 1) | (famil_situ == 4))
  database <- define(database, "haveChildren", (famil_situ == 3) | (famil_situ == 4))
  database <- define(database, "haveGA", variable("GenAbST") == 1)
  database <- define(database, "high_education", education >= 6)
  database <- define(database, "low_education", education <= 3)
  database <- define(database, "top_manager", socio_professional == 1)
  database <- define(database, "artisans", socio_professional == 5)
  database <- define(database, "employees", socio_professional == 6)
  database <- define(database, "childCenter", (resid_child == 1) | (resid_child == 2))
  database <- define(database, "childSuburb", (resid_child == 3) | (resid_child == 4))
  database <- define(database, "car_oriented_parents", variable("FreqCarPar") == 4)
  database <- define(database, "TimePT_scaled", time_pt / 200)
  database <- define(database, "TimePT_hour", time_pt / 60)
  database <- define(database, "TimeCar_scaled", time_car / 200)
  database <- define(database, "TimeCar_hour", time_car / 60)
  database <- define(database, "MarginalCostPT_scaled", variable("MarginalCostPT") / 10)
  database <- define(database, "CostCarCHF_scaled", variable("CostCarCHF") / 10)
  database <- define(database, "distance_km_scaled", distance / 5)
  database <- define(database, "PurpHWH", variable("TripPurpose") == 1)
  database <- define(database, "PurpOther", variable("TripPurpose") != 1)
  database <- define(
    database,
    "number_of_trips",
    (trajectories == 1) + 2 * (trajectories == 2) + 3 * (trajectories >= 3)
  )
  database <- define(
    database,
    "urbanization",
    2 - (variable("TypeCommune") <= 3) + (variable("TypeCommune") >= 8)
  )

  # Materializing here gives the user the native filtered row count and keeps
  # the runnable examples independent of the caller's working directory.  All
  # derived columns and filters have still been compiled and applied by native
  # Biogeme, not evaluated by an R callback.
  biogeme_database_materialize(database)
}