tests/testthat/test-tablong.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# tests/testthat/test-tablong.R

test_that("tablong handles repeated cross-sectional continuous data without optional packages", {
  set.seed(1)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 60),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 30), 2)),
    age = rnorm(120, 45, 10)
  )
  d$score <- 50 +
    2 * (d$period == "After") +
    3 * (d$group == "Intervention") +
    4 * (d$period == "After" & d$group == "Intervention") +
    0.1 * d$age + rnorm(120, 0, 6)

  z <- tablong(
    d,
    vars = vars(c.score),
    time = period,
    by = group,
    adjusted = vars(c.age),
    show = FALSE
  )

  expect_s3_class(z, "r4vn_tablong")
  expect_s3_class(z, "r4vn_tab")
  expect_identical(z$input_format, "long")
  expect_identical(z$design, "repeated cross-sectional")
  expect_true(is.data.frame(z$data))
  expect_true(is.data.frame(z$long_data))
  expect_true(any(grepl("Time x group", z$data$Time, fixed = TRUE)))
  expect_true(file.exists(z$file))
})

test_that("tablong wide continuous data become long internally", {
  set.seed(2)
  n <- 80
  d <- data.frame(
    id = 1:n,
    group = factor(sample(c("Control", "Intervention"), n, TRUE)),
    age = rnorm(n, 45, 10)
  )
  d$sbp0 <- rnorm(n, 140, 12)
  d$sbp3 <- d$sbp0 - 3 - 4 * (d$group == "Intervention") + rnorm(n, 0, 7)
  d$sbp6 <- d$sbp0 - 5 - 7 * (d$group == "Intervention") + rnorm(n, 0, 7)

  z <- tablong(
    d,
    vars = vars(c.sbp0, c.sbp3, c.sbp6),
    time = c("Baseline", "Month 3", "Month 6"),
    id = id,
    by = group,
    adjusted = vars(c.age),
    show = FALSE
  )

  expect_identical(z$input_format, "wide")
  expect_identical(z$design, "longitudinal")
  expect_equal(nrow(z$long_data), n * 3)
  expect_true(all(c("Baseline", "Month 3", "Month 6") %in% as.character(z$long_data$.time)))
  expect_true(length(z$models) == 1L)
})

test_that("tablong long repeated continuous data use recommended mixed model or robust fallback", {
  set.seed(3)
  n <- 60
  d <- expand.grid(
    id = 1:n,
    visit = factor(c("Baseline", "Month 3", "Month 6"),
                   levels = c("Baseline", "Month 3", "Month 6"))
  )
  d <- d[order(d$id, d$visit), ]
  subject <- rnorm(n, 0, 8)
  d$group <- factor(rep(sample(c("Control", "Intervention"), n, TRUE), each = 3))
  d$age <- rep(rnorm(n, 45, 10), each = 3)
  d$sex <- factor(rep(rep(c("Female", "Female", "Male", "Male"), length.out = n), each = 3))
  time_num <- c(Baseline = 0, `Month 3` = -3, `Month 6` = -5)
  d$sbp <- 140 + subject[d$id] + time_num[as.character(d$visit)] -
    4 * (d$group == "Intervention" & d$visit != "Baseline") +
    0.1 * d$age + rnorm(nrow(d), 0, 6)

  z <- tablong(
    d,
    vars = vars(c.sbp),
    time = visit,
    id = id,
    by = group,
    adjusted = vars(c.age, sex),
    show = FALSE
  )

  expect_identical(z$design, "longitudinal")
  expect_true(inherits(z$models[[1]], "lme") || inherits(z$models[[1]], "lm"))
  expect_true(is.finite(z$tests[[1]]$p_time) || is.na(z$tests[[1]]$p_time))
})

test_that("tablong binary OR uses marginal logistic regression with clustered robust SE", {
  set.seed(4)
  n <- 70
  d <- expand.grid(
    id = 1:n,
    visit = factor(c("Baseline", "Month 6"),
                   levels = c("Baseline", "Month 6"))
  )
  d <- d[order(d$id, d$visit), ]
  d$group <- factor(rep(sample(c("Control", "Intervention"), n, TRUE), each = 2))
  u <- rnorm(n, 0, .8)
  lp <- -1 + u[d$id] +
    .4 * (d$visit == "Month 6") +
    .8 * (d$group == "Intervention" & d$visit == "Month 6")
  d$controlled <- factor(rbinom(nrow(d), 1, plogis(lp)),
                         levels = c(0, 1), labels = c("No", "Yes"))

  z <- tablong(
    d,
    vars = vars(controlled),
    time = visit,
    id = id,
    by = group,
    event = "Yes",
    show = FALSE
  )

  expect_identical(z$results[[1]]$effect, "OR")
  expect_true(inherits(z$models[[1]], "glm"))
  expect_identical(z$results[[1]]$model_engine, "cluster_robust")
  expect_true(any(z$contrasts[[1]]$type == "change_difference"))
})

test_that("tablong RR uses internal clustered robust modified Poisson", {
  set.seed(5)
  n <- 70
  d <- expand.grid(
    id = 1:n,
    visit = factor(c("Baseline", "Month 6"),
                   levels = c("Baseline", "Month 6"))
  )
  d <- d[order(d$id, d$visit), ]
  d$group <- factor(rep(sample(c("Control", "Intervention"), n, TRUE), each = 2))
  p <- plogis(-1 + .4 * (d$visit == "Month 6") +
                .5 * (d$group == "Intervention" & d$visit == "Month 6"))
  d$event <- factor(rbinom(nrow(d), 1, p), levels = c(0, 1), labels = c("No", "Yes"))

  z <- tablong(
    d,
    vars = vars(event),
    time = visit,
    id = id,
    by = group,
    event = "Yes",
    rr = TRUE,
    show = FALSE
  )

  expect_identical(z$results[[1]]$effect, "RR")
  expect_true(inherits(z$models[[1]], "glm"))
  expect_identical(z$results[[1]]$model_engine, "cluster_robust")
})

test_that("tablong PR does not require geepack and diagnostics do not fail on AIC", {
  set.seed(55)
  n <- 60
  d <- expand.grid(
    id = 1:n,
    visit = factor(c("Baseline", "Month 6"), levels = c("Baseline", "Month 6"))
  )
  d <- d[order(d$id, d$visit), ]
  d$group <- factor(rep(sample(c("Control", "Intervention"), n, TRUE), each = 2))
  p <- plogis(-1 + .3 * (d$visit == "Month 6") +
                .4 * (d$group == "Intervention" & d$visit == "Month 6"))
  d$controlled <- factor(rbinom(nrow(d), 1, p), levels = c(0, 1), labels = c("No", "Yes"))

  z <- tablong(
    d, vars = vars(controlled), time = visit, id = id, by = group,
    event = "Yes", pr = TRUE, diagnostics = TRUE, show = FALSE
  )

  expect_identical(z$results[[1]]$effect, "PR")
  expect_identical(z$results[[1]]$model_engine, "cluster_robust")
  expect_true(inherits(z$models[[1]], "glm"))
  expect_true(is.na(z$diagnostics$AIC[1]))
  expect_true(is.na(z$diagnostics$BIC[1]))
})

test_that("tablong supports continuous time and random slope", {
  set.seed(6)
  n <- 50
  d <- expand.grid(id = 1:n, month = c(0, 3, 6, 12))
  d <- d[order(d$id, d$month), ]
  d$group <- factor(rep(sample(c("Control", "Intervention"), n, TRUE), each = 4))
  b0 <- rnorm(n, 0, 5)
  b1 <- rnorm(n, 0, .15)
  d$score <- 50 + b0[d$id] + (-.3 + b1[d$id]) * d$month -
    .25 * d$month * (d$group == "Intervention") + rnorm(nrow(d), 0, 3)

  z <- tablong(
    d,
    vars = vars(c.score),
    time = c.month,
    id = id,
    by = group,
    slope = TRUE,
    show = FALSE
  )

  expect_true(z$time$continuous)
  expect_true(any(z$contrasts[[1]]$type == "slope"))
  expect_true(any(z$contrasts[[1]]$type == "slope_difference"))
})

test_that("tablong count outcome produces IRR", {
  set.seed(7)
  n <- 50
  d <- expand.grid(
    id = 1:n,
    visit = factor(c("Baseline", "Month 6"), levels = c("Baseline", "Month 6"))
  )
  d <- d[order(d$id, d$visit), ]
  d$group <- factor(rep(sample(c("Control", "Intervention"), n, TRUE), each = 2))
  d$person_time <- runif(nrow(d), .8, 1.2)
  rate <- exp(.2 + .2 * (d$visit == "Month 6") -
                .3 * (d$group == "Intervention" & d$visit == "Month 6"))
  d$events <- rpois(nrow(d), lambda = rate * d$person_time)

  z <- tablong(
    d,
    vars = vars(c.events),
    time = visit,
    id = id,
    by = group,
    count = TRUE,
    exposure = person_time,
    show = FALSE
  )

  expect_identical(z$results[[1]]$effect, "IRR")
})

test_that("tablong can be exported by tabexport", {
  set.seed(8)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 40),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 20), 2))
  )
  d$score <- rnorm(80, 50 + 3 * (d$period == "After") +
                         4 * (d$group == "Intervention"), 7)

  z <- tablong(d, vars = vars(c.score), time = period, by = group, show = FALSE)
  exported <- tabexport(z)
  expect_true(is.data.frame(exported))
  expect_equal(ncol(exported), ncol(z$data))
})


test_that("tablong combines continuous and binary outcomes in one long-data table", {
  set.seed(9)
  n <- 100
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = n / 2),
                    levels = c("Before", "After")),
    group = factor(rep(c("Control", "Intervention"), times = n / 2))
  )
  d$score <- rnorm(n, 50 + 3 * (d$period == "After"), 7)
  d$positive <- factor(
    rbinom(n, 1, plogis(-1 + .5 * (d$period == "After"))),
    levels = c(0, 1), labels = c("No", "Yes")
  )

  z <- tablong(
    d,
    vars = vars(c.score, positive),
    time = period,
    by = group,
    event = "Yes",
    show = FALSE
  )

  expect_equal(length(z$models), 2L)
  expect_true("Model effect (95% CI)" %in% names(z$data))
  expect_true(all(c("score", "positive") %in% names(z$results)))
})


test_that("tablong exposes the complete publication-ready reporting contract", {
  set.seed(20260902)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 60),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 30), 2)),
    age = rnorm(120, 45, 10)
  )
  d$score <- 50 + 2 * (d$period == "After") +
    3 * (d$group == "Intervention") +
    4 * (d$period == "After" & d$group == "Intervention") +
    0.1 * d$age + rnorm(120, 0, 6)

  z <- tablong(
    d, vars = vars(c.score), time = period, by = group,
    adjusted = vars(c.age), show = FALSE
  )

  expect_true(is.data.frame(z$descriptive))
  expect_true(is.data.frame(z$tests_table))
  expect_true(is.data.frame(z$contrasts_table))
  expect_true(is.data.frame(z$diagnostics))
  expect_true(is.data.frame(z$plot_data))
  expect_true(is.list(z$tables))
  expect_true(is.list(z$plots))
  expect_true(is.list(z$metadata))
  expect_null(z$interpretation)
  expect_null(z$graph)
  expect_identical(formals(tablong)$interpretation, FALSE)
  expect_identical(formals(tablong)$diagnostics, FALSE)
  expect_identical(formals(tablong)$plot, FALSE)
})


test_that("tablong interpretation is explicit opt-in", {
  set.seed(20260903)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 50),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 25), 2))
  )
  d$score <- rnorm(100, 50 + 2 * (d$period == "After") +
                         3 * (d$group == "Intervention"), 6)

  z <- tablong(d, vars = vars(c.score), time = period, by = group,
               interpretation = TRUE, show = FALSE)

  expect_true(is.data.frame(z$interpretation))
  expect_true(nrow(z$interpretation) >= 1L)
  expect_true("Interpretation" %in% names(z$tables))
  expect_match(z$html, "Interpretation", fixed = TRUE)
})


test_that("tablong diagnostics can be added to Viewer without changing reusable diagnostics", {
  set.seed(20260904)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 50),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 25), 2))
  )
  d$score <- rnorm(100)

  z0 <- tablong(d, vars = vars(c.score), time = period, by = group,
                show = FALSE)
  z1 <- tablong(d, vars = vars(c.score), time = period, by = group,
                diagnostics = TRUE, show = FALSE)

  expect_identical(z0$diagnostics, z1$diagnostics)
  expect_false(grepl("Model diagnostics", z0$html, fixed = TRUE))
  expect_true(grepl("Model diagnostics", z1$html, fixed = TRUE))
})


test_that("tablong plot is dependency-free, reusable, and embedded in Viewer", {
  set.seed(20260905)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 60),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 30), 2))
  )
  d$score <- rnorm(120, 50 + 3 * (d$period == "After") +
                         2 * (d$group == "Intervention"), 7)

  z <- tablong(d, vars = vars(c.score), time = period, by = group,
               plot = TRUE, show = FALSE)

  expect_true(is.data.frame(z$plot_data))
  expect_s3_class(z$graph, "r4vn_long_plot")
  expect_s3_class(z$plots$trajectory, "r4vn_long_plot")
  expect_match(z$html, "Longitudinal plot", fixed = TRUE)
  expect_true(grepl("<svg|data:image/png", z$html))
  g <- plot(z, ci = FALSE, title = "Observed profile")
  expect_s3_class(g, "r4vn_long_plot")
})


test_that("tablong pairwise table labels multi-group comparisons clearly", {
  set.seed(20260906)
  d <- data.frame(
    period = factor(rep(c("Baseline", "Follow-up"), each = 90),
                    levels = c("Baseline", "Follow-up")),
    arm = factor(rep(rep(c("A", "B", "C"), each = 30), 2))
  )
  d$score <- rnorm(nrow(d), 50 + 2 * (d$period == "Follow-up") +
                         2 * (d$arm == "B") + 4 * (d$arm == "C"), 7)

  z <- tablong(d, vars = vars(c.score), time = period, by = arm,
               pairwise = TRUE, adjust = "holm", show = FALSE)

  expect_true(any(z$contrasts[[1]]$type == "pairwise_group"))
  expect_true(any(z$contrasts[[1]]$type == "pairwise_time"))
  expect_true(any(z$contrasts_table$Type == "Pairwise group comparison"))
  expect_true(any(z$contrasts_table$Type == "Pairwise time comparison"))
})


test_that("tablong descriptive table accounts for missing outcomes", {
  set.seed(20260907)
  d <- data.frame(
    period = factor(rep(c("Before", "After"), each = 50),
                    levels = c("Before", "After")),
    group = factor(rep(rep(c("Control", "Intervention"), each = 25), 2)),
    score = rnorm(100)
  )
  d$score[c(1, 2, 55)] <- NA

  z <- tablong(d, vars = vars(c.score), time = period, by = group,
               missing = TRUE, show = FALSE)

  expect_equal(sum(z$descriptive$Missing), 3L)
  expect_true(any(grepl("[n=", z$descriptive$Summary, fixed = TRUE)))
})