tests/testthat/test-srr-exposure.R

In ReliaGrowR: Reliability Growth Analysis and Repairable Systems Modeling

#' @srrstats {G5.0} Tests use standard recurrent event data.
#' @srrstats {G5.2} Unit tests demonstrate error messages and compare results.
#' @srrstats {G5.2a} Every message produced by stop() is unique.
#' @srrstats {G5.4} Correctness tests with known exposure values.
#' @srrstats {G5.8a} Checks for zero-length data.
#' @srrstats {G5.8b} Checks for unsupported data types.
#' @srrstats {G5.8c} Checks for data with NA fields.

# --- Input validation tests ---

test_that("exposure errors on missing id", {
  expect_error(exposure(time = c(1, 2)),
               "'id' must be provided to exposure().", fixed = TRUE)
})

test_that("exposure errors on missing time", {
  expect_error(exposure(id = c(1, 1)),
               "'time' must be provided to exposure().", fixed = TRUE)
})

test_that("exposure errors on NULL id", {
  expect_error(exposure(id = NULL, time = c(1, 2)),
               "'id' must be provided to exposure().", fixed = TRUE)
})

test_that("exposure errors on NULL time", {
  expect_error(exposure(id = c(1), time = NULL),
               "'time' must be provided to exposure().", fixed = TRUE)
})

test_that("exposure errors on non-numeric time", {
  expect_error(
    exposure(id = c(1, 1), time = c("a", "b")),
    "'time' must be a numeric vector in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on NA in time", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, NA)),
    "'time' contains missing (NA) or NaN values in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on NaN in time", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, NaN)),
    "'time' contains missing (NA) or NaN values in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on non-positive time", {
  expect_error(
    exposure(id = c(1, 1), time = c(0, 100)),
    "All values in 'time' must be finite and > 0 in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on infinite time", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, Inf)),
    "All values in 'time' must be finite and > 0 in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on mismatched id and time lengths", {
  expect_error(
    exposure(id = c(1, 2, 3), time = c(100, 200)),
    "'id' and 'time' must have the same length in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on non-numeric event", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, 200), event = c("a", "b")),
    "'event' must be a numeric vector in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on mismatched event length", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, 200), event = c(1)),
    "'event' and 'time' must have the same length in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on NA in event", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, 200), event = c(1, NA)),
    "'event' contains missing (NA) or NaN values in exposure().", fixed = TRUE
  )
})

test_that("exposure errors on invalid event values", {
  expect_error(
    exposure(id = c(1, 1), time = c(100, 200), event = c(1, 2)),
    "'event' must contain only 0 (censored) or 1 (event) in exposure().", fixed = TRUE
  )
})

# --- Data frame input tests ---

test_that("exposure works with data frame input", {
  df <- data.frame(id = c(1, 1, 2, 2), time = c(100, 200, 150, 300))
  result <- exposure(data = df)
  expect_s3_class(result, "exposure")
  expect_equal(result$n_systems, 2)
  expect_equal(result$total_events, 4)
})

test_that("exposure data frame errors on missing columns", {
  expect_error(
    exposure(data = data.frame(x = 1:3)),
    "'data' must contain a column named 'id' for exposure().", fixed = TRUE
  )
  expect_error(
    exposure(data = data.frame(id = 1:3)),
    "'data' must contain a column named 'time' for exposure().", fixed = TRUE
  )
})

test_that("exposure errors on non-data-frame data", {
  expect_error(
    exposure(data = list(id = 1, time = 1)),
    "'data' must be a data frame when provided to exposure().", fixed = TRUE
  )
})

test_that("exposure data frame with event column works", {
  df <- data.frame(
    id = c(1, 1, 2, 2),
    time = c(100, 200, 150, 300),
    event = c(1, 0, 1, 1)
  )
  result <- exposure(data = df)
  expect_s3_class(result, "exposure")
  expect_equal(result$total_events, 3)
})

# --- Correctness tests ---

test_that("exposure computes correct values for single-system case", {
  # Single system, events at 100 and 200
  # max_time = 200
  # At t=100: cum_exposure = min(100, 200) = 100, cum_events = 1
  # At t=200: cum_exposure = min(200, 200) = 200, cum_events = 2
  id <- c(1, 1)
  time <- c(100, 200)
  result <- exposure(id, time)

  expect_equal(result$time, c(100, 200))
  expect_equal(result$n_at_risk, c(1, 1))
  expect_equal(result$cum_exposure, c(100, 200))
  expect_equal(result$cum_events, c(1, 2))
  expect_equal(result$total_exposure, 200)
  expect_equal(result$total_events, 2)
  expect_equal(result$n_systems, 1)
})

test_that("exposure computes correct values for multi-system case", {
  # System 1: events at 100, 300; max_time = 300
  # System 2: events at 200; max_time = 200
  #
  # At t=100: n_at_risk=2, cum_exposure = min(100,300) + min(100,200) = 200
  # At t=200: n_at_risk=2, cum_exposure = min(200,300) + min(200,200) = 400
  # At t=300: n_at_risk=1, cum_exposure = min(300,300) + min(300,200) = 500
  id <- c(1, 1, 2)
  time <- c(100, 300, 200)
  result <- exposure(id, time)

  expect_equal(result$time, c(100, 200, 300))
  expect_equal(result$n_at_risk, c(2, 2, 1))
  expect_equal(result$cum_exposure, c(200, 400, 500))
  expect_equal(result$cum_events, c(1, 2, 3))
  expect_equal(result$total_exposure, 500)
  expect_equal(result$total_events, 3)
})

test_that("exposure event rate is correct", {
  id <- c(1, 1, 2)
  time <- c(100, 300, 200)
  result <- exposure(id, time)

  # Event rate = cum_events / cum_exposure
  expect_equal(result$event_rate, result$cum_events / result$cum_exposure)
})

test_that("exposure with censoring correctly limits observation", {
  # System 1: event at 100, censored at 300
  # System 2: event at 200
  # max_times: sys1=300, sys2=200
  id    <- c(1, 1, 2)
  time  <- c(100, 300, 200)
  event <- c(1, 0, 1)
  result <- exposure(id, time, event)

  # Only event times: 100, 200
  expect_equal(result$time, c(100, 200))
  expect_equal(result$cum_events, c(1, 2))
  expect_equal(result$total_events, 2)
  # Total exposure is still sum of max_times = 300 + 200 = 500
  expect_equal(result$total_exposure, 500)
})

test_that("exposure cum_exposure is monotonically non-decreasing", {
  id <- c(1, 1, 1, 2, 2, 3, 3, 3)
  time <- c(100, 200, 400, 150, 350, 50, 250, 500)
  result <- exposure(id, time)
  expect_true(all(diff(result$cum_exposure) >= 0))
})

test_that("exposure cum_events is monotonically non-decreasing", {
  id <- c(1, 1, 1, 2, 2, 3, 3, 3)
  time <- c(100, 200, 400, 150, 350, 50, 250, 500)
  result <- exposure(id, time)
  expect_true(all(diff(result$cum_events) >= 0))
})

test_that("exposure n_at_risk is monotonically non-increasing", {
  id <- c(1, 1, 2, 2, 3)
  time <- c(100, 200, 100, 300, 100)
  result <- exposure(id, time)
  expect_true(all(diff(result$n_at_risk) <= 0))
})

test_that("exposure handles simultaneous events across systems", {
  # All 3 systems have events at t=100
  id <- c(1, 2, 3)
  time <- c(100, 100, 100)
  result <- exposure(id, time)

  expect_equal(result$time, 100)
  expect_equal(result$n_at_risk, 3)
  expect_equal(result$cum_events, 3)
  expect_equal(result$cum_exposure, 300)
  expect_equal(result$total_exposure, 300)
})

# --- Print and plot tests ---

test_that("print.exposure produces output", {
  result <- exposure(c(1, 1, 2, 2), c(100, 200, 150, 300))
  expect_output(print(result), "Exposure Analysis")
})

test_that("print.exposure returns invisible", {
  result <- exposure(c(1, 1, 2, 2), c(100, 200, 150, 300))
  expect_invisible(print(result))
})

test_that("print.exposure errors on wrong class", {
  expect_error(
    print.exposure(list(a = 1)),
    "'x' must be an object of class 'exposure'.", fixed = TRUE
  )
})

test_that("plot.exposure produces a plot without error", {
  result <- exposure(c(1, 1, 2, 2), c(100, 200, 150, 300))
  expect_silent(plot(result))
})

test_that("plot.exposure validates inputs", {
  result <- exposure(c(1, 1, 2, 2), c(100, 200, 150, 300))
  expect_error(plot.exposure(list(a = 1)),
               "'x' must be an object of class 'exposure'.", fixed = TRUE)
  expect_error(plot(result, legend = "yes"),
               "'legend' must be a single logical value in plot.exposure().", fixed = TRUE)
  expect_error(plot(result, legend_pos = 123),
               "'legend_pos' must be a single character string in plot.exposure().", fixed = TRUE)
})

test_that("plot.exposure works with single panels", {
  result <- exposure(c(1, 1, 2, 2), c(100, 200, 150, 300))
  expect_silent(plot(result, which = "exposure"))
  expect_silent(plot(result, which = "at_risk"))
  expect_silent(plot(result, which = "event_rate"))
})

test_that("plot.exposure works without legend", {
  result <- exposure(c(1, 1, 2, 2), c(100, 200, 150, 300))
  expect_silent(plot(result, legend = FALSE))
})