tests/testthat/test-models-contract-bridge.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

test_that("model syntax preserves both current and legacy reference contracts", {
  set.seed(20260820)

  n <- 300
  d <- data.frame(
    age = rnorm(n, 45, 10),
    group = factor(sample(c("A", "B", "C"), n, TRUE),
                   levels = c("A", "B", "C")),
    treatment = factor(sample(c("No", "Yes"), n, TRUE),
                       levels = c("No", "Yes"))
  )
  d$y <- factor(
    rbinom(n, 1, .4),
    levels = 0:1,
    labels = c("No", "Yes")
  )

  fit <- logistic(
    y,
    c.age,
    ib2.group*i.treatment,
    data = d,
    event = "Yes",
    show = FALSE
  )

  mf <- stats::model.frame(fit$raw$model)

  # Current contract: ordinary variable name remains available.
  expect_true("group" %in% names(mf))
  expect_identical(levels(mf$group)[1L], "B")

  # Legacy contract: harmless reference alias is also retained.
  ref_col <- grep("r4vn_factor_index", names(mf), value = TRUE)
  expect_true(length(ref_col) >= 1L)
  expect_identical(levels(mf[[ref_col[1L]]])[1L], "B")

  tl <- attr(stats::terms(fit$raw$model), "term.labels")
  expect_true("group:treatment" %in% tl)
})

test_that("lrtest exposes both raw table contracts", {
  set.seed(20260821)

  n <- 350
  d <- data.frame(
    x = rnorm(n),
    z = rnorm(n)
  )
  d$y <- rbinom(n, 1, plogis(-.5 + .4 * d$x))

  m1 <- stats::glm(y ~ x, family = stats::binomial(), data = d)
  m2 <- stats::glm(y ~ x + z, family = stats::binomial(), data = d)

  out <- lrtest(m1, m2, show = FALSE)

  expect_s3_class(out, "r4vn_stat")

  expect_true(is.data.frame(out$raw$table))
  expect_true(all(c("LR", "df", "p") %in% names(out$raw$table)))
  expect_equal(out$raw$table$df[2L], 1L)
  expect_true(is.finite(out$raw$table$LR[2L]))

  expect_true(is.data.frame(out$raw$comparison))
  expect_true(all(c("LR.chi2", "LR.df", "p.value") %in%
                    names(out$raw$comparison)))
  expect_equal(out$raw$comparison$LR.df[2L], 1L)
  expect_true(is.finite(out$raw$comparison$LR.chi2[2L]))
})

test_that("lrtest sample mismatch message satisfies both existing test contracts", {
  set.seed(20260822)

  d <- data.frame(
    y = rbinom(100, 1, .4),
    x = rnorm(100),
    z = rnorm(100)
  )
  d$z[1:10] <- NA_real_

  m1 <- stats::glm(y ~ x, family = stats::binomial(), data = d)
  m2 <- stats::glm(y ~ x + z, family = stats::binomial(), data = d)

  expect_error(
    lrtest(m1, m2, show = FALSE),
    "different observations"
  )
})

test_that("redundant plain categorical main effects are absorbed", {
  set.seed(20260823)

  n <- 320
  d <- data.frame(
    occupation = factor(sample(c("A", "B", "C"), n, TRUE)),
    preterm = factor(sample(c("No", "Yes"), n, TRUE))
  )
  d$outcome <- factor(
    rbinom(n, 1, .35),
    levels = 0:1,
    labels = c("No", "Yes")
  )

  fit <- logistic(
    outcome,
    occupation,
    preterm,
    i.occupation*i.preterm,
    data = d,
    event = "Yes",
    show = FALSE
  )

  mm <- stats::model.matrix(fit$raw$model)
  expect_false(any(is.na(stats::coef(fit$raw$model))))
  expect_equal(qr(mm)$rank, ncol(mm))
})

test_that("R4VN poisson family remains compatible with MASS glm.nb", {
  expect_identical(poisson()$link, "log")
  expect_identical(poisson(link = log)$link, "log")

  skip_if_not_installed("MASS")

  set.seed(20260824)
  d <- data.frame(
    y = MASS::rnegbin(150, mu = 5, theta = 1.3),
    x = rnorm(150)
  )

  expect_no_error(
    fit <- MASS::glm.nb(y ~ x, data = d)
  )
  expect_s3_class(fit, "negbin")
  expect_identical(fit$family$link, "log")
})