tests/testthat/test-extended-expressions.R

In rbiogeme: Interface to 'Biogeme'

test_that("comparisons and logical operations remain symbolic", {
  x <- variable("x")
  expression <- ((x >= 1) & (x < 5)) | !(x == 3)

  expect_s3_class(expression, "biogeme_expression")
  expect_equal(rbiogeme:::collect_biogeme_variables(expression), "x")
  expect_match(format(expression), "&&|&")
  expect_match(format(expression), "!")
})

test_that("extended expression nodes format and collect parameters", {
  x <- variable("x")
  beta <- biogeme_beta("lambda")
  expressions <- list(
    logzero(x), normal_cdf(x), normal_pdf(x), sqrt(x), abs(x),
    biogeme_min(x, 0), biogeme_max(x, 0), Elem(list(`1` = x, `2` = beta), x),
    draw("u", "NORMAL_ANTI"), random_variable("z"),
    distributed_parameter("b_rnd", beta + draw("eps", "NORMAL")),
    integrate_normal(x * random_variable("z"), "z"), monte_carlo(x),
    panel_likelihood_trajectory(x), derive(x^2, "x"), boxcox(x, beta),
    piecewise(x, list(NULL, 0, 10, NULL))
  )

  expect_true(all(vapply(expressions, rbiogeme:::is_biogeme_expression, logical(1))))
  expect_equal(rbiogeme:::collect_biogeme_parameters(Elem(list(`1` = x, `2` = beta), x)), "lambda")
  expect_equal(rbiogeme:::collect_biogeme_variables(piecewise(x, list(NULL, 0, 10, NULL))), "x")
  distributed <- distributed_parameter("b_rnd", beta + draw("eps", "NORMAL"))
  expect_equal(rbiogeme:::collect_biogeme_parameters(distributed), "lambda")
  expect_match(format(distributed), "DistributedParameter")
})

test_that("draw metadata can be used as a symbolic node", {
  draws <- biogeme_draws("b_time", "NORMAL", number_of_draws = 64, seed = 42)
  expression <- draws * variable("TIME")

  expect_s3_class(draws, "biogeme_draws")
  expect_s3_class(expression, "biogeme_expression")
  expect_equal(draws$number_of_draws, 64L)
  expect_match(format(expression), "Draws")
})

test_that("Bayesian stored-variable reports stay ordinary R data", {
  fit <- structure(
    list(
      summary = list(
        stored_variables_report = list(
          list(group = "posterior", variable = "b_rnd", dims = list("chain", "draw"), shape = list(2, 8))
        )
      )
    ),
    class = c("biogeme_bayesian_fit", "biogeme_result")
  )
  report <- bayesian_stored_variables(fit)
  expect_s3_class(report, "data.frame")
  expect_equal(report$variable, "b_rnd")
  expect_equal(report$dims, "chain, draw")
  expect_equal(report$shape, "2, 8")
})

test_that("linear utilities preserve term pairing", {
  beta <- biogeme_beta("b")
  term <- linear_term(beta, variable("x"))
  utility <- linear_utility(list(term))

  expect_s3_class(term, "biogeme_linear_term")
  expect_s3_class(utility, "biogeme_expression")
  expect_equal(rbiogeme:::collect_biogeme_parameters(utility), "b")
  expect_equal(rbiogeme:::collect_biogeme_variables(utility), "x")
  expect_match(format(utility), "b \\* x")
})

test_that("catalogs preserve shared controllers and expression contents", {
  controller <- catalog_controller("time", c("linear", "log"))
  expression <- catalog(
    "travel_time",
    list(
      linear = variable("TIME"),
      log = log(variable("TIME"))
    ),
    controller = controller
  )

  expect_s3_class(controller, "biogeme_catalog_controller")
  expect_s3_class(expression, "biogeme_expression")
  expect_equal(expression$controller, controller)
  expect_equal(rbiogeme:::collect_biogeme_variables(expression), "TIME")
  expect_match(format(expression), "Catalog\\(travel_time: linear \\| log\\)")
  expect_error(
    catalog(
      "bad",
      list(linear = variable("TIME"), log = variable("TIME")),
      catalog_controller("other", c("a", "b"))
    ),
    "must match"
  )
})

test_that("generic alternative-specific catalogs preserve native structure", {
  beta <- biogeme_beta("b_time", start = -1)
  catalogs <- generic_alt_specific_catalogs(
    generic_name = "b_time",
    beta_parameters = list(beta),
    alternatives = c("train", "swissmetro", "car")
  )

  expect_named(catalogs, "b_time")
  expect_named(catalogs[[1L]], c("train", "swissmetro", "car"))
  expect_true(all(vapply(catalogs[[1L]], rbiogeme:::is_biogeme_expression, logical(1))))
  expect_equal(
    unname(vapply(catalogs[[1L]], function(x) x$name, character(1))),
    c(
      "b_time_train_gen_altspec",
      "b_time_swissmetro_gen_altspec",
      "b_time_car_gen_altspec"
    )
  )
  expect_identical(
    catalogs[[1L]]$train$controller,
    catalogs[[1L]]$swissmetro$controller
  )
  expect_equal(
    catalogs[[1L]]$train$controller$specification_names,
    c("generic", "altspec")
  )
  expect_equal(
    catalogs[[1L]]$train$expressions$generic$name,
    "b_time"
  )
  expect_equal(
    catalogs[[1L]]$train$expressions$altspec$name,
    "b_time_train"
  )
})

test_that("generic alternative-specific catalogs combine with segmentation catalogs", {
  segmentation <- biogeme_segmentation(
    "FIRST",
    c(`0` = "second", `1` = "first")
  )
  catalogs <- generic_alt_specific_catalogs(
    generic_name = "b_time",
    beta_parameters = list(biogeme_beta("b_time")),
    alternatives = c("train", "car"),
    potential_segmentations = list(segmentation),
    maximum_number = 1
  )

  expect_equal(
    catalogs[[1L]]$train$expressions$generic$controller$specification_names,
    c("no_seg", "FIRST")
  )
  expect_equal(
    catalogs[[1L]]$train$expressions$altspec$name,
    "segmented_b_time_train"
  )
  expect_equal(
    catalogs[[1L]]$train$expressions$altspec$controller$specification_names,
    c("no_seg", "FIRST")
  )
})

test_that("segmentation catalogs follow native option ordering", {
  segmentations <- list(
    biogeme_segmentation("MALE", c(`0` = "female", `1` = "male")),
    biogeme_segmentation("GA", c(`0` = "noGA", `1` = "GA"))
  )
  catalogs <- segmentation_catalogs(
    "asc",
    list(biogeme_beta("asc")),
    segmentations,
    maximum_number = 2
  )

  expect_length(catalogs, 1L)
  expect_equal(
    names(catalogs[[1L]]$expressions),
    c("no_seg", "GA", "MALE", "MALE-GA")
  )
  expect_equal(catalogs[[1L]]$controller$name, "asc")
})

test_that("logit probability expressions preserve alternatives and derivatives", {
  beta <- biogeme_beta("b")
  utilities <- list(`1` = beta * variable("x"), `2` = 0)
  availability <- list(`1` = variable("av1"), `2` = 1)
  probability <- logit_probability(utilities, availability, alternative = 1)
  derivative <- Derive(probability, "x")

  expect_s3_class(probability, "biogeme_expression")
  expect_equal(rbiogeme:::collect_biogeme_parameters(probability), "b")
  expect_equal(
    rbiogeme:::collect_biogeme_variables(probability),
    c("x", "av1")
  )
  expect_match(format(probability), "alternative 1")
  expect_s3_class(derivative, "biogeme_expression")

  log_probability <- logit_log_probability(utilities, availability, alternative = 1)
  expect_equal(log_probability$kind, "logit_log_probability")
  expect_match(format(log_probability), "logit log probability")
})

test_that("ordered logit expressions preserve native structure", {
  eta <- biogeme_beta("b") * variable("x")
  tau1 <- biogeme_beta("tau1", start = -1, upper = 0)
  delta2 <- biogeme_beta("delta2", start = 2, lower = 0)
  expression <- ordered_logit_log_probability(
    eta = eta,
    cutpoints = list(tau1, tau1 + delta2),
    alternative = variable("y"),
    categories = c(1, 2, 3),
    neutral_labels = numeric()
  )

  expect_s3_class(expression, "biogeme_expression")
  expect_equal(
    rbiogeme:::collect_biogeme_parameters(expression),
    c("b", "tau1", "delta2")
  )
  expect_equal(
    rbiogeme:::collect_biogeme_variables(expression),
    c("x", "y")
  )
  expect_match(format(expression), "ordered logit log probability")
  probit <- ordered_probit_log_probability(
    eta = eta,
    cutpoints = list(tau1, tau1 + delta2),
    alternative = variable("y"),
    categories = c(1, 2, 3),
    neutral_labels = numeric()
  )
  expect_equal(probit$kind, "ordered_probit")
  expect_equal(rbiogeme:::collect_biogeme_parameters(probit), c("b", "tau1", "delta2"))
  expect_error(
    ordered_logit_log_probability(eta, list(tau1), variable("y"), categories = c(1, 2, 3)),
    "length 2"
  )
  expect_error(
    ordered_logit_log_probability(eta, list(tau1), variable("y"), eps = 0),
    "positive"
  )
})

test_that("segmented beta names follow native Biogeme naming", {
  male <- biogeme_segmentation(
    "MALE",
    c(`0` = "female", `1` = "male")
  )
  ga <- biogeme_segmentation(
    "GA",
    c(`0` = "without_ga", `1` = "with_ga")
  )
  expression <- segment_beta(
    biogeme_beta("asc_car"),
    list(male, ga)
  )

  expect_s3_class(expression, "biogeme_segmented_beta")
  expect_equal(
    rbiogeme:::collect_biogeme_parameters(expression),
    c("asc_car_ref", "asc_car_diff_male", "asc_car_diff_with_ga")
  )
  expect_equal(
    rbiogeme:::collect_biogeme_variables(expression),
    c("MALE", "GA")
  )
})