tests/testthat/test-tabscale.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# Tests for R4VN::tabscale()

test_that("internal base64 encoding used by Viewer PNG plots is valid", {
  expect_identical(.r4vn_ts_base64(charToRaw("Man")), "TWFu")
  expect_identical(.r4vn_ts_base64(charToRaw("Ma")), "TWE=")
  expect_identical(.r4vn_ts_base64(charToRaw("M")), "TQ==")
})

test_that("tabscale performs reliability, subscale, EFA, and ROC analysis", {
  set.seed(20260806)
  n <- 320
  f1 <- rnorm(n)
  f2 <- 0.35 * f1 + rnorm(n, sd = sqrt(1 - 0.35^2))
  make_item <- function(z) {
    as.integer(cut(z, breaks = stats::quantile(z, 0:5 / 5),
                   include.lowest = TRUE, labels = FALSE))
  }

  dat <- data.frame(
    q1 = make_item(0.90 * f1 + rnorm(n, sd = 0.60)),
    q2 = make_item(0.80 * f1 + rnorm(n, sd = 0.65)),
    q3 = make_item(0.75 * f1 + rnorm(n, sd = 0.70)),
    q4 = make_item(-0.85 * f1 + rnorm(n, sd = 0.60)),
    q5 = make_item(0.90 * f2 + rnorm(n, sd = 0.60)),
    q6 = make_item(0.80 * f2 + rnorm(n, sd = 0.65)),
    q7 = make_item(0.75 * f2 + rnorm(n, sd = 0.70)),
    q8 = make_item(0.85 * f2 + rnorm(n, sd = 0.60))
  )
  dat$gold <- factor(ifelse(f1 + f2 + rnorm(n, sd = 0.8) > 0, "Yes", "No"),
                     levels = c("No", "Yes"))
  dat$q1[c(2, 17)] <- NA_integer_
  dat$q6[c(9, 41, 88)] <- NA_integer_

  attr(dat$q1, "label") <- "Domain 1 item 1"
  attr(dat$q5, "label") <- "Domain 2 item 1"

  out <- tabscale(
    dat,
    vars = vars(q1, q2, q3, q4, q5, q6, q7, q8),
    factor = list(
      Domain1 = vars(q1, q2, q3, q4),
      Domain2 = vars(q5, q6, q7, q8)
    ),
    reverse = vars(q4),
    range = c(1, 5),
    score = "mean",
    min_valid = c(Domain1 = 3, Domain2 = 3, Total = 6),
    efa = TRUE,
    nfactor = 2,
    rotation = "promax",
    parallel_iter = 20,
    gold = gold,
    event = "Yes",
    plot = FALSE,
    show = FALSE
  )

  expect_s3_class(out, "r4vn_tabscale")
  expect_s3_class(out, "r4vn_tab")
  expect_true(file.exists(out$file))
  expect_equal(nrow(out$descriptive), 8L)
  expect_identical(names(out$scores), c("Domain1", "Domain2", "Total"))
  expect_true(all(c("Domain1", "Domain2", "Total") %in% out$reliability_summary$Scale))
  expect_true(is.finite(out$reliability_summary$Alpha[out$reliability_summary$Scale == "Total"]))
  expect_equal(out$efa$nfactor, 2L)
  expect_equal(nrow(out$efa$loadings), 8L)
  expect_identical(out$validity$type, "roc")
  expect_true(all(out$validity$table$AUC >= 0 & out$validity$table$AUC <= 1))
  expect_true(is.data.frame(out$data) && nrow(out$data) > 0L)
})

test_that("tabscale can create total and subscale score variables", {
  set.seed(44)
  dat <- as.data.frame(matrix(sample(1:5, 160, replace = TRUE), ncol = 4))
  names(dat) <- paste0("q", 1:4)

  out <- tabscale(
    dat,
    vars = vars(q1, q2, q3, q4),
    factor = list(First = vars(q1, q2), Second = vars(q3, q4)),
    range = c(1, 5),
    name = "wellbeing",
    plot = FALSE,
    show = FALSE
  )

  expect_true(all(c("wellbeing_First", "wellbeing_Second", "wellbeing_total") %in% names(dat)))
  expect_identical(out$created, c("wellbeing_First", "wellbeing_Second", "wellbeing_total"))
  # Compare score values independently of metadata attributes.
  expect_equal(as.numeric(dat$wellbeing_total), as.numeric(out$scores$Total))
  # The created variable should retain a useful R4VN variable label.
  expect_identical(attr(dat$wellbeing_total, "label"), "Total scale score (mean)")
})

test_that("tabscale output can be consumed by tabexport", {
  skip_if_not(exists("tabexport", mode = "function"))
  set.seed(55)
  dat <- as.data.frame(matrix(sample(1:5, 240, replace = TRUE), ncol = 6))
  names(dat) <- paste0("q", 1:6)
  out <- tabscale(dat, vars = vars(q1, q2, q3, q4, q5, q6),
                  range = c(1, 5), plot = FALSE, show = FALSE)
  exported <- tabexport(out)
  expect_true(is.data.frame(exported))
  expect_equal(nrow(exported), nrow(out$data))
})

test_that("tabscale supports active data", {
  skip_if_not(exists("usedf", mode = "function"))
  set.seed(66)
  active_dat <- as.data.frame(matrix(sample(1:5, 240, replace = TRUE), ncol = 6))
  names(active_dat) <- paste0("q", 1:6)
  usedf(active_dat, quiet = TRUE)
  on.exit(try(usedf(clear = TRUE, quiet = TRUE), silent = TRUE), add = TRUE)

  out <- tabscale(vars = vars(q1, q2, q3, q4, q5, q6),
                  range = c(1, 5), plot = FALSE, show = FALSE)
  expect_s3_class(out, "r4vn_tabscale")
  expect_equal(out$items, paste0("q", 1:6))
})

test_that("tabscale performs optional CFA through lavaan", {
  skip_if_not_installed("lavaan")
  set.seed(77)
  n <- 500
  f1 <- rnorm(n)
  f2 <- 0.40 * f1 + rnorm(n, sd = sqrt(1 - 0.40^2))
  dat <- data.frame(
    q1 = 0.85 * f1 + rnorm(n, sd = 0.50),
    q2 = 0.80 * f1 + rnorm(n, sd = 0.55),
    q3 = 0.75 * f1 + rnorm(n, sd = 0.60),
    q4 = 0.85 * f2 + rnorm(n, sd = 0.50),
    q5 = 0.80 * f2 + rnorm(n, sd = 0.55),
    q6 = 0.75 * f2 + rnorm(n, sd = 0.60)
  )

  out <- suppressWarnings(tabscale(
    dat,
    vars = vars(q1, q2, q3, q4, q5, q6),
    factor = list(Factor1 = vars(q1, q2, q3),
                  Factor2 = vars(q4, q5, q6)),
    cfa = TRUE,
    ordered = FALSE,
    estimator = "MLR",
    plot = FALSE,
    show = FALSE
  ))

  expect_s3_class(out, "r4vn_tabscale")
  expect_false(is.null(out$cfa$fit))
  expect_equal(nrow(out$cfa$loadings), 6L)
  expect_true(all(c("cfi", "tli", "rmsea", "srmr") %in% names(out$cfa$measures)))
})

test_that("tabscale 2.0 covers reliability and validity modules and uses labels", {
  set.seed(20260902)
  n <- 140
  latent <- rnorm(n)
  make_item <- function(z) as.integer(cut(z, quantile(z, 0:5/5),
    include.lowest = TRUE, labels = FALSE))
  d <- data.frame(
    q1=make_item(.9*latent+rnorm(n)), q2=make_item(.8*latent+rnorm(n)),
    q3=make_item(.8*latent+rnorm(n)), q4=make_item(.7*latent+rnorm(n)))
  for (j in 1:4) {
    d[[paste0("r",j)]] <- pmax(1,pmin(5,d[[paste0("q",j)]]+sample(-1:1,n,TRUE,c(.1,.8,.1))))
    d[[paste0("b",j)]] <- make_item(.75*latent+rnorm(n))
    d[[paste0("p",j)]] <- pmax(1,pmin(5,d[[paste0("q",j)]]+rbinom(n,1,.3)))
    attr(d[[paste0("q",j)]], "label") <- paste("Quality of life item", j)
  }
  d$conv <- latent+rnorm(n,.0,.4)
  d$disc <- rnorm(n)
  d$group <- factor(ifelse(latent>0,"Expected high","Expected low"))
  d$gold <- factor(ifelse(latent+rnorm(n,.0,.7)>0,"Yes","No"), levels=c("No","Yes"))
  d$rater1 <- sample(1:4,n,TRUE); d$rater2 <- d$rater1; d$rater3 <- d$rater1
  d$rater2[sample(n,20)] <- sample(1:4,20,TRUE)
  d$rater3[sample(n,20)] <- sample(1:4,20,TRUE)
  attr(d$conv,"label") <- "Established convergent measure"
  attr(d$group,"label") <- "Prespecified clinical group"
  attr(d$gold,"label") <- "Clinical gold standard"
  experts <- as.data.frame(matrix(sample(2:4,24,TRUE),nrow=6,
    dimnames=list(NULL,paste0("q",1:4))))

  out <- suppressWarnings(tabscale(d, vars=vars(q1,q2,q3,q4), range=c(1,5),
    retest=vars(r1,r2,r3,r4), parallel_form=vars(b1,b2,b3,b4),
    raters=vars(rater1,rater2,rater3), content=experts,
    convergent=vars(conv), discriminant=vars(disc), known_groups=group,
    gold=gold, event="Yes", post=vars(p1,p2,p3,p4),
    efa=FALSE, plot=TRUE, show=FALSE))

  expect_s3_class(out,"r4vn_tabscale")
  expect_identical(out$descriptive$Item, paste("Quality of life item",1:4))
  expect_true(all(c("Alpha CI lower","Ordinal alpha","Omega hierarchical",
    "Greatest lower bound","Guttman lambda 1","Guttman lambda 6") %in%
    names(out$reliability_summary)))
  expect_true(nrow(out$test_retest$table)>0)
  expect_true(nrow(out$parallel_form$table)>0)
  expect_true(nrow(out$inter_rater$table)>0)
  expect_true(nrow(out$content_validity$item)==4)
  expect_identical(out$convergent_validity$Variable,"Established convergent measure")
  expect_true(nrow(out$discriminant_validity)>0)
  expect_true(nrow(out$known_groups$tests)>0)
  expect_identical(out$criterion_validity$gold_label,"Clinical gold standard")
  expect_true(nrow(out$responsiveness$table)>0)
  plot_names <- sub("[.][0-9]+$", "", names(out$plots))
  expect_true(length(out$plots)>=6)
  expect_false(any(plot_names %in% c("items", "distributions", "reliability",
    "external_validity", "known_groups", "responsiveness")))
  expect_equal(out$plots$roc$xlim, c(0, 1))
  expect_equal(out$plots$roc$ylim, c(0, 1))
  expect_true(all(vapply(out$plots$roc$curves, function(z)
    all(z$sensitivity >= 0 & z$sensitivity <= 1 &
        z$specificity >= 0 & z$specificity <= 1), logical(1))))
  expect_match(out$html,"data:image/png;base64,iVBORw0KGgo",fixed=TRUE)
  expect_match(out$html,"class=\"ts-plot-image\"",fixed=TRUE)
  expect_match(out$html,"<th>Statistic</th>",fixed=TRUE)
  expect_false(length(out$interpretation)>0)
})

test_that("tabscale interpretation is opt-in and plot selection is retained", {
  set.seed(902)
  d <- as.data.frame(matrix(sample(1:5,500,TRUE),ncol=5))
  names(d) <- paste0("q",1:5)
  out <- tabscale(d, vars=vars(q1,q2,q3,q4,q5), range=c(1,5),
    efa=FALSE, interpretation=TRUE, plot=TRUE,
    plot_types=c("reliability","scores"), show=FALSE)
  expect_true(length(out$interpretation)>0)
  expect_true(all(sub("[.][0-9]+$","",names(out$plots)) %in% c("reliability","scores")))
})

test_that("tabscale can restore every optional plot without changing auto defaults", {
  set.seed(903)
  d <- as.data.frame(matrix(sample(1:5, 400, TRUE), ncol=4))
  names(d) <- paste0("q", 1:4)
  out <- tabscale(d, vars=vars(q1,q2,q3,q4), range=c(1,5), efa=FALSE,
    plot=TRUE, plot_types="all", show=FALSE)
  plot_names <- sub("[.][0-9]+$", "", names(out$plots))
  expect_true(all(c("items", "distributions", "reliability") %in% plot_names))
})

test_that("tabscale retains SVG as an explicit Viewer option", {
  set.seed(904)
  d <- as.data.frame(matrix(sample(1:5, 400, TRUE), ncol=4))
  names(d) <- paste0("q", 1:4)
  out <- tabscale(d, vars=vars(q1,q2,q3,q4), range=c(1,5), efa=FALSE,
    plot=TRUE, plot_types="scores", viewer_plot_format="svg", show=FALSE)
  expect_match(out$html, "<svg", fixed=TRUE)
})