tests/testthat/test-tabmeta.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

testthat::test_that("tabmeta fits raw binary OR meta-analysis", {
  testthat::skip_if_not_installed("metafor")
  d <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  out <- tabmeta(
    data = d,
    study = study,
    event1 = event_treat, n1 = n_treat,
    event0 = event_control, n0 = n_control,
    or = TRUE,
    full = FALSE, plot = FALSE, show = FALSE
  )

  testthat::expect_s3_class(out, "r4vn_meta")
  testthat::expect_true(is.data.frame(out$table))
  testthat::expect_true(is.data.frame(out$heterogeneity))
  testthat::expect_true(is.data.frame(out$significance_tests))
  testthat::expect_equal(nrow(out$significance_tests), 2L)
  testthat::expect_equal(
    out$significance_tests$Test,
    c("Pooled effect", "Heterogeneity (Cochran's Q)")
  )
  testthat::expect_false("Statistically significant" %in%
                           names(out$significance_tests))
  testthat::expect_false("Conclusion" %in% names(out$significance_tests))
  testthat::expect_true(is.finite(out$overall$estimate))
  testthat::expect_gt(out$overall$estimate, 0)
})

testthat::test_that("tabmeta accepts generic effect plus CI", {
  testthat::skip_if_not_installed("metafor")
  d <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  out <- tabmeta(
    data = d,
    study = study,
    effect = OR, lower = LCI, upper = UCI,
    or = TRUE,
    full = FALSE, plot = FALSE, show = FALSE
  )

  testthat::expect_s3_class(out, "r4vn_meta")
  testthat::expect_equal(out$effect_type, "OR")
  testthat::expect_equal(out$primary_model$k, nrow(d))
})

testthat::test_that("subgroup and cumulative results are created", {
  testthat::skip_if_not_installed("metafor")
  d <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  out <- tabmeta(
    data = d,
    study = study,
    effect = OR, lower = LCI, upper = UCI,
    or = TRUE,
    by = region,
    cumulative = year,
    full = FALSE, plot = FALSE, show = FALSE
  )

  testthat::expect_true(is.list(out$subgroup))
  testthat::expect_true(is.data.frame(out$subgroup$table))
  testthat::expect_true(all(c(
    "Studies", "Effect (95% CI)", "Test statistic", "df effect",
    "p-value effect", "95% prediction interval", "Q heterogeneity",
    "df heterogeneity", "p-value heterogeneity",
    "I-squared (95% CI)", "Tau-squared (95% CI)"
  ) %in% names(out$subgroup_long)))
  testthat::expect_false("Statistically significant" %in%
                           names(out$subgroup_long))
  testthat::expect_true(all(nzchar(out$subgroup_long$`p-value effect`)))
  testthat::expect_true(all(nzchar(
    out$subgroup_long$`p-value heterogeneity`
  )))
  testthat::expect_identical(names(out$tables$Subgroup)[1L], "Statistic")
  testthat::expect_equal(
    setdiff(names(out$tables$Subgroup), "Statistic"),
    out$subgroup$levels
  )
  testthat::expect_true(all(c("Studies", "Effect (95% CI)") %in%
                              out$tables$Subgroup$Statistic))
  testthat::expect_true(is.list(out$cumulative))
  testthat::expect_true(is.data.frame(out$cumulative$table))
})

testthat::test_that("full mode includes appropriate diagnostics", {
  testthat::skip_if_not_installed("metafor")
  d <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  out <- tabmeta(
    data = d,
    study = study,
    effect = OR, lower = LCI, upper = UCI,
    or = TRUE,
    full = TRUE, plot = FALSE, show = FALSE
  )

  testthat::expect_true(is.list(out$bias))
  testthat::expect_true(is.data.frame(out$bias$table))
  testthat::expect_true(is.list(out$leaveout))
  testthat::expect_true(is.list(out$influence))
  testthat::expect_true(out$prediction)
})

testthat::test_that("tabmeta uses active data", {
  testthat::skip_if_not_installed("metafor")
  d <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  usedf(d, quiet = TRUE)
  on.exit(usedf(clear = TRUE, quiet = TRUE), add = TRUE)

  out <- tabmeta(
    study = study,
    effect = OR, lower = LCI, upper = UCI,
    or = TRUE,
    full = FALSE, plot = FALSE, show = FALSE
  )

  testthat::expect_s3_class(out, "r4vn_meta")
})

testthat::test_that("tabmeta rejects multiple effect selectors", {
  testthat::skip_if_not_installed("metafor")
  d <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  testthat::expect_error(
    tabmeta(
      data = d,
      study = study,
      effect = OR, lower = LCI, upper = UCI,
      or = TRUE, rr = TRUE,
      full = FALSE, plot = FALSE, show = FALSE
    ),
    "Choose only one effect"
  )
})

testthat::test_that("a b c d input is equivalent to event and total input", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  dat$non_event_treat <- dat$n_treat - dat$event_treat
  dat$non_event_control <- dat$n_control - dat$event_control

  cells <- tabmeta(
    data = dat, study = study,
    a = event_treat, b = non_event_treat,
    c = event_control, d = non_event_control,
    small = "z", profile = "custom", plot = FALSE, show = FALSE
  )
  totals <- tabmeta(
    data = dat, study = study,
    event1 = event_treat, n1 = n_treat,
    event0 = event_control, n0 = n_control,
    or = TRUE, small = "z", profile = "custom",
    plot = FALSE, show = FALSE
  )

  testthat::expect_equal(cells$effect_type, "OR")
  testthat::expect_equal(cells$metadata$input, "a,b,c,d")
  testthat::expect_equal(cells$overall$estimate, totals$overall$estimate)
  testthat::expect_true(is.data.frame(cells$tables$Binary_2x2))
})

testthat::test_that("the c cell argument does not mask base c", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  dat$non_event_treat <- dat$n_treat - dat$event_treat
  dat$non_event_control <- dat$n_control - dat$event_control

  testthat::expect_no_error({
    out <- tabmeta(
      data = dat, study = study,
      a = event_treat, b = non_event_treat,
      c = event_control, d = non_event_control,
      profile = "custom", plot = FALSE, show = FALSE
    )
  })
  testthat::expect_equal(out$analysis_data$.c, dat$event_control)
})

testthat::test_that("tabmeta retains user-facing display defaults", {
  f <- formals(tabmeta)
  pf <- formals(plot.r4vn_meta)
  testthat::expect_identical(f$show, TRUE)
  testthat::expect_identical(f$interpretation, FALSE)
  testthat::expect_identical(f$plot_display, "forest")
  testthat::expect_identical(pf$show_weights, TRUE)
  testthat::expect_identical(pf$show_prediction, FALSE)
  testthat::expect_identical(pf$show_abcd, FALSE)
})

testthat::test_that("tabmeta exposes stable publication result components", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  out <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    plot = FALSE, show = FALSE
  )

  testthat::expect_named(
    out[c("estimates", "tests", "diagnostics", "models", "metadata")],
    c("estimates", "tests", "diagnostics", "models", "metadata")
  )
  testthat::expect_equal(out$profile, "auto")
  testthat::expect_false(isTRUE(out$interpretation))
  testthat::expect_true(is.list(out$bias))
  testthat::expect_true(is.list(out$leaveout))
  testthat::expect_true(is.list(out$influence))
  testthat::expect_true(out$prediction)
  testthat::expect_true(all(c("overall", "heterogeneity", "significance") %in%
                              names(out$tests)))
  testthat::expect_identical(
    out$overall$significant,
    is.finite(out$overall$p) && out$overall$p < (1 - out$ci)
  )
  testthat::expect_false(any(grepl("\\[", out$table$`Effect (95% CI)`)))
})

testthat::test_that("multiple subgroups and moderators are analyzed", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  dat$period <- ifelse(dat$year < stats::median(dat$year),
                       "Earlier", "Later")

  out <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    subgroup = vars(region, period),
    moderator = vars(c.year, region),
    profile = "custom", plot = FALSE, show = FALSE
  )

  testthat::expect_equal(out$by_vars, c("region", "period"))
  testthat::expect_equal(out$reg, c("year", "region"))
  testthat::expect_true(is.data.frame(out$tables$Subgroup))
  testthat::expect_equal(names(out$subgroup_tables), c("region", "period"))
  testthat::expect_true(all(vapply(
    out$subgroup_tables, is.data.frame, logical(1)
  )))
  testthat::expect_true(is.data.frame(out$tables$Subgroup_period))
  testthat::expect_true(is.data.frame(out$tables$Subgroup_test))
  testthat::expect_true(is.data.frame(out$tables$Meta_regression))
  testthat::expect_true(is.data.frame(out$tables$Moderator_univariable))
})

testthat::test_that("few-study and bias sensitivity modules are available", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  few <- tabmeta(
    data = dat[1:8, ], study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    small = "auto", profile = "custom", plot = FALSE, show = FALSE
  )
  testthat::expect_equal(few$test_method, "adhoc")
  testthat::expect_true(is.data.frame(few$tables$Small_sample_inference))
  testthat::expect_true(any(few$tables$Small_sample_inference$Selected == "Yes"))

  bias <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    bias = TRUE,
    bias_methods = c("egger", "begg", "trimfill", "failsafe"),
    profile = "custom", plot = FALSE, show = FALSE
  )
  testthat::expect_true(is.data.frame(bias$tables$Publication_bias))
  testthat::expect_true(all(c("egger", "begg", "trimfill", "failsafe") %in%
                              bias$bias$methods))
  testthat::expect_true(inherits(bias$models$trimfill, "rma.uni") ||
                          is.null(bias$models$trimfill))
})

testthat::test_that("interpretation is detailed and publication plots save", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )

  out <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    subgroup = region, cumulative = year,
    interpretation = TRUE, plot = FALSE, show = FALSE
  )
  testthat::expect_true(is.data.frame(out$tables$Interpretation))
  testthat::expect_true(all(c("Statistically significant", "Conclusion") %in%
                              names(out$tables$Statistical_tests)))
  testthat::expect_true(all(c("Statistically significant", "Conclusion") %in%
                              out$tables$Subgroup$Statistic))
  testthat::expect_true(all(c("Overall effect", "Heterogeneity") %in%
                              out$tables$Interpretation$Section))
  testthat::expect_gt(nrow(out$tables$Interpretation), 2L)

  path <- tempfile(fileext = ".png")
  on.exit(unlink(path), add = TRUE)
  testthat::expect_no_warning(
    plot(
      out, type = "forest", file = path,
      point_color = "#1F4E79", ci_color = "#5B9BD5",
      summary_color = "#C00000", font_family = "sans",
      show_prediction = FALSE,
      row_shade = "zebra", shade_color = "#F5F7FA",
      xlim = c(0.95, 1.05), ticks = c(0.95, 1, 1.05)
    )
  )
  testthat::expect_true(file.exists(path))
  testthat::expect_gt(file.info(path)$size, 0)
})

testthat::test_that("subgroup value labels are used instead of numeric codes", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  dat$group_code <- rep(c(1, 2), length.out = nrow(dat))
  attr(dat$group_code, "label") <- "Clinical subgroup"
  attr(dat$group_code, "labels") <- c("Low risk" = 1, "High risk" = 2)

  out <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    subgroup = group_code,
    profile = "custom", plot = TRUE, plot_display = "none", show = FALSE
  )

  testthat::expect_true(all(out$subgroup_long$Moderator ==
                              "Clinical subgroup"))
  testthat::expect_true(all(out$subgroup_long$Subgroup %in%
                              c("Low risk", "High risk")))
  testthat::expect_equal(
    setdiff(names(out$tables$Subgroup), "Statistic"),
    c("Low risk", "High risk")
  )
  testthat::expect_true("Clinical subgroup" %in% names(out$table))
  testthat::expect_identical(
    attr(out$analysis_data$group_code, "label"), "Clinical subgroup"
  )
  testthat::expect_identical(
    attr(out$analysis_data$group_code, "labels"),
    c("Low risk" = 1, "High risk" = 2)
  )
  testthat::expect_true(all(stats::na.omit(out$table[["Clinical subgroup"]]) %in%
                              c("Low risk", "High risk", "")))
  subgroup_plots <- grep("^forest_subgroup_", names(out$plots), value = TRUE)
  testthat::expect_equal(length(subgroup_plots), 2L)
  testthat::expect_true(all(grepl(
    "Clinical subgroup = (Low risk|High risk)",
    unlist(out$plot_titles[subgroup_plots])
  )))
})

testthat::test_that("a b c d forest columns can be requested", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  dat$b_cell <- dat$n_treat - dat$event_treat
  dat$d_cell <- dat$n_control - dat$event_control
  out <- tabmeta(
    data = dat, study = study,
    a = event_treat, b = b_cell, c = event_control, d = d_cell,
    profile = "custom", plot = FALSE, show = FALSE
  )
  path <- tempfile(fileext = ".png")
  on.exit(unlink(path), add = TRUE)
  testthat::expect_no_warning(plot(
    out, type = "forest", file = path, show_abcd = TRUE,
    abcd_titles = c("a", "b", "c", "d")
  ))
  testthat::expect_true(file.exists(path))
})

testthat::test_that("meta-regression expands intercept and uses labels", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  attr(dat$year, "label") <- "Publication year"
  out <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    moderator = vars(c.year), interpretation = TRUE,
    profile = "custom", plot = FALSE, show = FALSE
  )

  testthat::expect_identical(out$tables$Meta_regression$Moderator[1L],
                             "Intercept")
  testthat::expect_true("Publication year" %in%
                          out$tables$Meta_regression$Moderator)
  testthat::expect_identical(
    out$tables$Moderator_univariable$Moderator[1L], "Publication year"
  )
  testthat::expect_false(any(grepl(
    "intrcpt", out$tables$Meta_regression$Moderator, ignore.case = TRUE
  )))
  testthat::expect_true(all(grepl(
    "^-?[0-9]+\\.[0-9]{2}", out$tables$Meta_regression$`Beta (95% CI)`
  )))
  testthat::expect_false(any(grepl(
    "[0-9]+\\.[0-9]{3}", out$tables$Meta_regression$`Beta (95% CI)`
  )))
})

testthat::test_that("digit controls subgroup and meta-regression estimates", {
  testthat::skip_if_not_installed("metafor")
  dat <- utils::read.csv(
    system.file("extdata", "meta_example.csv", package = "R4VN")
  )
  out <- tabmeta(
    data = dat, study = study,
    effect = OR, lower = LCI, upper = UCI, or = TRUE,
    subgroup = region, moderator = vars(c.year), digit = 4,
    profile = "custom", plot = FALSE, show = FALSE
  )
  testthat::expect_true(all(grepl(
    "^-?[0-9]+\\.[0-9]{4}", out$subgroup_long$`Effect (95% CI)`
  )))
  testthat::expect_true(all(grepl(
    "^-?[0-9]+\\.[0-9]{4}", out$tables$Meta_regression$`Beta (95% CI)`
  )))
})