tests/testthat/test-hurdle_utils.R

In beezdemand: Behavioral Economic Easy Demand

# Tests for utility functions

test_that("calc_omax_pmax returns correct values for valid parameters", {
  # With k >= e, local maximum exists
  result <- calc_omax_pmax(Q0 = 10, k = 3, alpha = 0.5)

  expect_true(is.list(result))
  expect_true(all(c("Pmax", "Omax", "Qmax") %in% names(result)))
  expect_true(is.numeric(result$Pmax))
  expect_true(is.numeric(result$Omax))
  expect_true(result$Pmax > 0)
  expect_true(result$Omax > 0)
})

test_that("calc_omax_pmax handles k < e with numerical fallback", {
  # With k < e, no closed-form Lambert W solution exists,

  # but numerical optimization can still find the maximum.
  # Per EQUATIONS_CONTRACT.md: implementation should fall back to numerical methods.

  # Expect a warning about k < e and numerical optimization
  expect_warning(
    result <- calc_omax_pmax(Q0 = 10, k = 2, alpha = 0.5),
    "k.*< e.*numerical optimization"
  )

  # Numerical fallback should still return valid values
  expect_true(is.numeric(result$Pmax))
  expect_true(is.numeric(result$Omax))
  expect_true(!is.na(result$Pmax))
  expect_true(!is.na(result$Omax))
  expect_true(result$Pmax > 0)
  expect_true(result$Omax > 0)

  # Should have a note explaining the fallback
  expect_true(!is.null(result$note))
})

test_that("calc_omax_pmax handles edge cases", {
  # NA alpha
  result1 <- calc_omax_pmax(Q0 = 10, k = 3, alpha = NA)
  expect_true(is.na(result1$Pmax))

  # Zero alpha
  result2 <- calc_omax_pmax(Q0 = 10, k = 3, alpha = 0)
  expect_true(is.na(result2$Pmax))

  # NA Q0
  result3 <- calc_omax_pmax(Q0 = NA, k = 3, alpha = 0.5)
  expect_true(is.na(result3$Pmax))
})

test_that("calc_omax_pmax_vec works for multiple subjects", {
  Q0_vec <- c(10, 15, 20)
  k_vec <- c(3, 3, 3)
  alpha_vec <- c(0.5, 0.3, 0.1)

  result <- calc_omax_pmax_vec(Q0_vec, k_vec, alpha_vec)

  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 3)
  expect_true(all(c("Pmax", "Omax", "Qmax") %in% names(result)))
})

test_that("calc_group_metrics works on fitted model", {
  skip_on_cran()
  skip_if_not_installed("TMB")

  sim_data <- simulate_hurdle_data(n_subjects = 30, seed = 123)
  fit <- fit_demand_hurdle(
    sim_data,
    y_var = "y",
    x_var = "x",
    id_var = "id",
    random_effects = c("zeros", "q0"),
    verbose = 0
  )

  metrics <- calc_group_metrics(fit)

  expect_true(is.list(metrics))
  expect_true(all(c("Pmax", "Omax", "Qmax") %in% names(metrics)))
})

test_that("get_subject_pars returns data frame", {
  skip_on_cran()
  skip_if_not_installed("TMB")

  sim_data <- simulate_hurdle_data(n_subjects = 30, seed = 123)
  fit <- fit_demand_hurdle(
    sim_data,
    y_var = "y",
    x_var = "x",
    id_var = "id",
    random_effects = c("zeros", "q0"),
    verbose = 0
  )

  pars <- get_subject_pars(fit)

  expect_true(is.data.frame(pars))
  expect_equal(nrow(pars), 30)
  expect_true(all(c("Q0", "alpha", "Pmax", "Omax") %in% names(pars)))
})

test_that("compare_hurdle_models performs LRT correctly", {
  skip_on_cran()
  skip_if_not_installed("TMB")

  # Simulate data with 3 RE
  sim_data <- simulate_hurdle_data(
    n_subjects = 50,
    n_random_effects = 3,
    seed = 789
  )

  # Fit both models
  fit3 <- fit_demand_hurdle(
    sim_data,
    y_var = "y",
    x_var = "x",
    id_var = "id",
    random_effects = c("zeros", "q0", "alpha"),
    verbose = 0
  )
  fit2 <- fit_demand_hurdle(
    sim_data,
    y_var = "y",
    x_var = "x",
    id_var = "id",
    random_effects = c("zeros", "q0"),
    verbose = 0
  )

  # Compare
  result <- expect_output(
    compare_hurdle_models(fit3, fit2),
    "Likelihood Ratio Test"
  )

  expect_true(is.list(result))
  expect_true("lr_stat" %in% names(result))
  expect_true("p_value" %in% names(result))
  expect_true("model_comparison" %in% names(result))
  expect_true(result$lr_stat >= 0) # LRT stat should be non-negative
  expect_true(result$df > 0)
})

test_that("compare_hurdle_models errors for non-hurdle objects", {
  expect_error(
    compare_hurdle_models(list(), list()),
    "must be beezdemand_hurdle objects"
  )
})

test_that("zhao_exponential Pmax values are finite and positive (2-RE)", {
  skip_on_cran()
  skip_if_not_installed("TMB")

  sim_data <- simulate_hurdle_data(n_subjects = 30, seed = 42)
  fit <- fit_demand_hurdle(
    sim_data,
    y_var = "y",
    x_var = "x",
    id_var = "id",
    part2 = "zhao_exponential",
    random_effects = c("zeros", "q0"),
    verbose = 0
  )

  pars <- get_subject_pars(fit)
  expect_true(all(is.finite(pars$Pmax)), info = "All 2-RE Pmax values should be finite")
  expect_true(all(pars$Pmax > 0), info = "All 2-RE Pmax values should be positive")
  expect_true(all(is.finite(pars$Omax)), info = "All 2-RE Omax values should be finite")
  expect_true(all(pars$Omax > 0), info = "All 2-RE Omax values should be positive")
})

test_that("zhao_exponential Pmax values are finite and positive (3-RE)", {
  skip_on_cran()
  skip_if_not_installed("TMB")

  sim_data <- simulate_hurdle_data(
    n_subjects = 50,
    n_random_effects = 3,
    seed = 789
  )
  fit <- fit_demand_hurdle(
    sim_data,
    y_var = "y",
    x_var = "x",
    id_var = "id",
    part2 = "zhao_exponential",
    random_effects = c("zeros", "q0", "alpha"),
    verbose = 0
  )

  pars <- get_subject_pars(fit)
  expect_true(all(is.finite(pars$Pmax)), info = "All 3-RE Pmax values should be finite")
  expect_true(all(pars$Pmax > 0), info = "All 3-RE Pmax values should be positive")
  expect_true(all(is.finite(pars$Omax)), info = "All 3-RE Omax values should be finite")
  expect_true(all(pars$Omax > 0), info = "All 3-RE Omax values should be positive")
})