tests/testthat/test-legacy-fitcurves.R

In beezdemand: Behavioral Economic Easy Demand

# Legacy Tests for FitCurves() - Schema Stability and Numeric Regression
# WS2.1: Freeze FitCurves() output schema with golden tests

# Expected columns from FitCurves() output
# These must remain stable across refactors
FITCURVES_EXPECTED_COLUMNS <- c(

  "id", "Intensity", "BP0", "BP1", "Omaxe", "Pmaxe",

  "Equation", "Q0d", "K", "Alpha", "R2", "Q0se",
  "Alphase", "N", "AbsSS", "SdRes", "Q0Low", "Q0High",
  "AlphaLow", "AlphaHigh", "EV", "Omaxd", "Pmaxd", "Omaxa",
  "Pmaxa", "Notes"
)

# Additional columns when k = "fit"
FITCURVES_KFIT_EXTRA_COLUMNS <- c("Kse", "KLow", "KHigh")


# Schema Stability Tests -------------------------------------------------

test_that("FitCurves output has expected columns (HS equation)", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "hs", k = 2)
  ))

  expect_s3_class(result, "data.frame")
  expect_true(all(FITCURVES_EXPECTED_COLUMNS %in% names(result)),
    info = paste(
      "Missing columns:",
      paste(setdiff(FITCURVES_EXPECTED_COLUMNS, names(result)), collapse = ", ")
    )
  )
})

test_that("FitCurves output has expected columns (Koff equation)", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "koff", k = 2)
  ))

  expect_s3_class(result, "data.frame")
  expect_true(all(FITCURVES_EXPECTED_COLUMNS %in% names(result)),
    info = paste(
      "Missing columns:",
      paste(setdiff(FITCURVES_EXPECTED_COLUMNS, names(result)), collapse = ", ")
    )
  )
})

test_that("FitCurves output column types are stable", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30), ]


  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "hs", k = 2)
  ))

  # Character columns
  expect_type(result$id, "character")
  expect_type(result$Equation, "character")
  expect_type(result$Notes, "character")

  # Numeric columns
  numeric_cols <- c(
    "Intensity", "Q0d", "K", "Alpha", "R2", "Q0se", "Alphase",
    "AbsSS", "SdRes", "Q0Low", "Q0High", "AlphaLow", "AlphaHigh",
    "EV", "Omaxd", "Pmaxd", "Omaxa", "Pmaxa", "Omaxe", "Pmaxe"
  )
  for (col in numeric_cols) {
    expect_true(is.numeric(result[[col]]),
      info = paste("Column", col, "should be numeric")
    )
  }

  # Integer columns
  expect_true(is.integer(result$N) || is.numeric(result$N),
    info = "Column N should be integer/numeric"
  )
})


# Numeric Regression Tests (Golden Values) --------------------------------

test_that("FitCurves reproduces HS equation golden values", {
  skip_on_cran()

  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30, 38), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "hs", k = 2)
  ))

  # Subject 19 golden values
  row_19 <- result[result$id == "19", ]
  expect_equal(row_19$Q0d, 10.158664, tolerance = 0.01)
  expect_equal(row_19$Alpha, 0.002047574, tolerance = 1e-5)
  expect_equal(row_19$K, 2)
  expect_equal(row_19$R2, 0.9804182, tolerance = 0.01)
  expect_equal(row_19$Pmaxd, 13.86976, tolerance = 0.1)
  expect_equal(row_19$Omaxd, 44.43035, tolerance = 0.1)

  # Subject 30 golden values
  row_30 <- result[result$id == "30", ]
  expect_equal(row_30$Q0d, 2.807366, tolerance = 0.01)
  expect_equal(row_30$Alpha, 0.005865523, tolerance = 1e-5)

  # Subject 38 golden values
  row_38 <- result[result$id == "38", ]
  expect_equal(row_38$Q0d, 4.497456, tolerance = 0.01)
  expect_equal(row_38$Alpha, 0.004203441, tolerance = 1e-5)
})

test_that("FitCurves reproduces Koff equation golden values", {
  skip_on_cran()

  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30, 38), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "koff", k = 2)
  ))

  # Subject 19 golden values
  row_19 <- result[result$id == "19", ]
  expect_equal(row_19$Q0d, 10.072114, tolerance = 0.01)
  expect_equal(row_19$Alpha, 0.002003155, tolerance = 1e-5)
  expect_equal(row_19$K, 2)
  expect_equal(row_19$R2, 0.9676372, tolerance = 0.01)
  expect_equal(row_19$Pmaxd, 14.29914, tolerance = 0.1)
  expect_equal(row_19$Omaxd, 45.41558, tolerance = 0.1)

  # Subject 30 golden values
  row_30 <- result[result$id == "30", ]
  expect_equal(row_30$Q0d, 2.967428, tolerance = 0.01)
  expect_equal(row_30$Alpha, 0.006381213, tolerance = 1e-5)

  # Subject 38 golden values
  row_38 <- result[result$id == "38", ]
  expect_equal(row_38$Q0d, 4.605634, tolerance = 0.01)
  expect_equal(row_38$Alpha, 0.004874198, tolerance = 1e-5)
})


# Edge Case Tests ---------------------------------------------------------

test_that("FitCurves handles single subject", {
  data(apt, package = "beezdemand")
  apt_single <- apt[apt$id == 19, ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_single, equation = "hs", k = 2)
  ))

  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 1)
  expect_true(all(FITCURVES_EXPECTED_COLUMNS %in% names(result)))
})

test_that("FitCurves handles all-zero consumption row gracefully", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id == 19, ]

  # Create subject with all zeros at high prices
  apt_zero <- apt_test
  apt_zero$y[apt_zero$x >= 10] <- 0

  # Should emit warning and handle zeros
  expect_warning(
    result <- suppressMessages(FitCurves(apt_zero, equation = "hs", k = 2)),
    regexp = "Zeros found|Dropping zeros"
  )

  expect_s3_class(result, "data.frame")
})

test_that("FitCurves works with k='fit' and param_space='log10'", {
  skip_on_cran()

  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "koff", k = "fit", param_space = "log10")
  ))

  expect_s3_class(result, "data.frame")
  expect_true(all(FITCURVES_EXPECTED_COLUMNS %in% names(result)))

  # K should vary when k = "fit"
  expect_true(
    !all(is.na(result$K)),
    info = "K values should be estimated when k='fit'"
  )
})


# Aggregation Tests -------------------------------------------------------

test_that("FitCurves agg='Mean' produces single row", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30, 38), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "hs", k = 2, agg = "Mean")
  ))

  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 1)
  expect_equal(result$id[1], "mean")
})

test_that("FitCurves agg='Pooled' produces single row", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id %in% c(19, 30, 38), ]

  result <- suppressMessages(suppressWarnings(
    FitCurves(apt_test, equation = "koff", k = 2, agg = "Pooled")
  ))

  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 1)
  expect_equal(result$id[1], "pooled")
})


# Deprecation Warning Test ------------------------------------------------

test_that("FitCurves emits deprecation warning", {
  data(apt, package = "beezdemand")
  apt_test <- apt[apt$id == 19, ]

  # Reset deprecation state for testing
  rlang::local_options(lifecycle_verbosity = "warning")

  expect_warning(
    FitCurves(apt_test, equation = "hs", k = 2),
    regexp = "superseded|deprecated|fit_demand_fixed",
    ignore.case = TRUE
  )
})