tests/testthat/test-Event.R

In cifmodeling: Visualization and Polytomous Modeling of Survival and Competing Risks

test_that("Event() allowed NA and retained length; use na.omit as necessary", {
  df <- createTestData2()
  df$t[1]      <- NA
  df$status[2] <- NA

  ev <- with(df, Event(t, status))
  expect_s3_class(ev, "Event")
  expect_equal(nrow(ev), nrow(df))
  expect_true(any(is.na(ev[,1])))
  expect_true(any(is.na(ev[,2])))

  mf <- model.frame(Event(t, status) ~ x, data = df, na.action = na.omit)
  y  <- model.extract(mf, "response")
  expect_true(nrow(y) < nrow(df))
  expect_false(any(is.na(y)))
})

test_that("util_normalize_time_event() allowed only expected codes for events", {
  df  <- createTestData2()
  tt6 <- df$t[1:6]
  res <- util_normalize_time_event(tt6, c(0L,1L,NA,0L,1L,2L), allowed = c(0,1,2))
  expect_equal(length(res$event), 6L)

  expect_error(
    util_normalize_time_event(tt6, c(0,-1,1,0,1,0)),
    class = "cifmodeling_ev_codes"
  )
  expect_error(
    util_normalize_time_event(tt6, c(0, 1.2, 1, 0, 1, 0)),
    class = "cifmodeling_ev_codes"
  )
})

test_that("util_read_surv() handled strata/weights as expected", {
  df <- createTestData2()
  df$t[1]      <- NA
  df$status[2] <- NA
  df$x[3]      <- NA
  df$w[4]      <- NA

  out <- util_read_surv(Event(t, status) ~ x, data = df, weights = "w", na.action = na.omit)
  k <- length(out$t)
  expect_equal(unname(lengths(out[c("epsilon","d","d0","d1","d2","w","strata")])), rep(k, 7))
  expect_false(any(is.na(out$t)))
  expect_false(any(is.na(out$epsilon)))
})

test_that("reg_read_exposure_design() allowed only expected codes for exposure", {
  df  <- createTestData2()
  de1 <- reg_read_exposure_design(df, exposure = "x", code.exposure.ref = 0)
  expect_true(is.matrix(de1$x_a))
  expect_equal(nrow(de1$x_a), nrow(df))
  expect_true(all(colnames(de1$x_a) != "a__2"))

  df$x <- factor(0)
  expect_error(reg_read_exposure_design(df, "x"), "only one level")
})

test_that("util_check_outcome_type() / reg_check_effect.measure() / check_error()", {
  expect_equal(util_check_outcome_type("s"), "survival")
  expect_equal(util_check_outcome_type("competing risk"), "competing-risk")

  em <- reg_check_effect.measure("rr", "Or")
  expect_equal(em$effect.measure1, "RR")
  expect_equal(em$effect.measure2, "OR")

  expect_equal(curve_check_error(NULL, "survival"), "greenwood")
  expect_equal(curve_check_error(NULL, "competing-risk"), "delta")

  expect_warning(res1 <- curve_check_error(x="bad", outcome.type="survival"))
  expect_equal(res1, "greenwood")

  expect_warning(res2 <- curve_check_error(x="bad", outcome.type="competing-risk"))
  expect_equal(res2, "delta")
})

test_that("outcome.type normalization accepts legacy and returns canonical", {
  expect_identical(util_check_outcome_type("COMPETING-RISK"), "competing-risk")
  expect_identical(util_check_outcome_type("C"), "competing-risk")
  expect_identical(util_check_outcome_type("surv"), "survival")
  expect_identical(util_check_outcome_type("BIN"), "binomial")
  expect_identical(util_check_outcome_type("PC"), "proportional-competing-risk")
  expect_identical(util_check_outcome_type("PS"), "proportional-survival")
})

test_that("reg_read_time.point() yields expected outputs according to outcome.type", {
  set.seed(1)
  n = 20
  df <- data.frame(
    t = rexp(n, rate = 0.2),
    d = sample(c(0L, 1L), n, replace = TRUE),
    sex = factor(sample(c("F","M"), n, replace = TRUE)),
    fruitq1 = factor(sample(c(0,1,2), n, replace = TRUE)),
    strata = factor(sample(letters[1:2], n, replace = TRUE)),
    w = stats::runif(n, 0.5, 1.5),
    stringsAsFactors = FALSE
  )
  expect_error(reg_read_time.point(Event(t,d)~1, df, matrix(1, nrow(df), 1),
                                   "survival", code.censoring = 0,
                                   terminate.time.point = TRUE,
                                   time.point = NULL),
               "`?time\\.point`?\\s+is\\s+required"
  )
  tp <- reg_read_time.point(Event(t,d)~1, df, matrix(1, nrow(df), 1),
                            "binomial", code.censoring = 0,
                            terminate.time.point = TRUE,
                            time.point = NULL)
  expect_true(is.infinite(tp))

  x_a <- model.matrix(~ fruitq1, data = df)[, -1, drop = FALSE]
  tp2 <- reg_read_time.point(Event(t,d)~sex, df, x_a,
                             "proportional-survival", code.censoring = 0,
                             terminate.time.point = TRUE,
                             time.point = NULL)
  expect_true(all(tp2 >= 0))
  expect_true(is.unsorted(tp2, strictly = FALSE) == FALSE)
})

test_that("reg_check_input() handles NA as expected", {
  set.seed(1)
  n = 20
  df <- data.frame(
    t = rexp(n, rate = 0.2),
    d = sample(c(0L, 1L), n, replace = TRUE),
    sex = factor(sample(c("F","M"), n, replace = TRUE)),
    fruitq1 = factor(sample(c(0,1,2), n, replace = TRUE)),
    strata = factor(sample(letters[1:2], n, replace = TRUE)),
    w = stats::runif(n, 0.5, 1.5),
    stringsAsFactors = FALSE
  )
  df$t[1] <- NA; df$d[2] <- NA; df$sex[3] <- NA; df$fruitq1[4] <- NA
  out <- reg_check_input(
    data = df,
    formula = Event(t,d) ~ sex,
    exposure = "fruitq1",
    code.event1 = 1, code.event2 = 2, code.censoring = 0,
    code.exposure.ref = 0,
    outcome.type = "survival",
    conf.int = 0.95,
    report.sandwich.conf = TRUE,
    report.boot.conf = NULL,
    nleqslv.method = "Broyden",
    normalize.covariate = TRUE,
    strata = "strata",
    subset.condition = NULL,
    na.action = na.omit
  )
  expect_true(is.matrix(out$x_a))
  expect_true(ncol(out$x_l) >= 1)
})


testthat::test_that("Event() constructs a Surv-like 2-column object", {
  df <- data.frame(
    t       = c(5,  7,  7,  9, 10, 12, NA,  4),
    status  = c(1,  0,  2,  0,  1,  2,  1,  0),
    x       = c(0,  1,  1,  0,  0,  1,  1,  0),
    strata  = factor(c("A","A","B","B","A","B","A","B")),
    w       = c(1,  2,  1,  1,  0.5, 1,  1,  1),
    stringsAsFactors = FALSE
  )
  y  <- Event(df$t, df$status)

  expect_true(is.matrix(y) || is.data.frame(y))
  expect_equal(ncol(y), 2)
  expect_true(inherits(y, "Event"))
  expect_true(is.numeric(y[,1]))
  expect_true(is.numeric(y[,2]) || is.integer(y[,2]))
  expect_true(all(na.omit(unique(y[,2])) %in% c(0,1,2)))
})


testthat::test_that("Event() works inside model.frame and terms", {
  df <- data.frame(
    t       = c(5,  7,  7,  9, 10, 12, NA,  4),
    status  = c(1,  0,  2,  0,  1,  2,  1,  0),
    x       = c(0,  1,  1,  0,  0,  1,  1,  0),
    strata  = factor(c("A","A","B","B","A","B","A","B")),
    w       = c(1,  2,  1,  1,  0.5, 1,  1,  1),
    stringsAsFactors = FALSE
  )
  f  <- Event(t, status) ~ x

  Terms <- stats::terms(f, specials = c("strata","offset","cluster"), data = df)
  mf    <- stats::model.frame(Terms, data = df, na.action = stats::na.omit)

  y <- stats::model.extract(mf, "response")
  expect_true(inherits(y, "Event"))
  expect_equal(ncol(y), 2)
  expect_equal(nrow(y), sum(stats::complete.cases(df[c("t","status","x")])))
})

testthat::test_that("In Event() NA handling and non-finite times raise as expected", {
  df <- data.frame(
    t       = c(5,  7,  7,  9, 10, 12, NA,  4),
    status  = c(1,  0,  2,  0,  1,  2,  1,  0),
    x       = c(0,  1,  1,  0,  0,  1,  1,  0),
    strata  = factor(c("A","A","B","B","A","B","A","B")),
    w       = c(1,  2,  1,  1,  0.5, 1,  1,  1),
    stringsAsFactors = FALSE
  )

  # NA in time/status should pass through to NA rows; model.frame(..., na.omit) will drop
  y <- Event(df$t, df$status)
  testthat::expect_true(any(is.na(y[,1])))

  # Non-finite time should error at normalization stage (if implemented)
  df2 <- df
  df2$t[1] <- Inf
  expect_error(Event(df2$t, df2$status), regexp = "finite|non[- ]?finite|NA", ignore.case = TRUE)
})

testthat::test_that("In Event() invalid status codes are caught", {
  df <- data.frame(
    t       = c(5,  7,  7,  9, 10, 12, NA,  4),
    status  = c(1,  0,  2,  0,  1,  2,  1,  0),
    x       = c(0,  1,  1,  0,  0,  1,  1,  0),
    strata  = factor(c("A","A","B","B","A","B","A","B")),
    w       = c(1,  2,  1,  1,  0.5, 1,  1,  1),
    stringsAsFactors = FALSE
  )
  df$status[2] <- 9
  expect_error(Event(df$t, df$status), regexp = "code|allowed|invalid", ignore.case = TRUE)
})