tests/testthat/test-design.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

test_that("sample-size registry is broad and IDs are unique", {
  tab <- .r4vn_ss_registry_table()
  expect_gte(nrow(tab), 60)
  expect_identical(anyDuplicated(tab$id), 0L)
  expect_true(all(nzchar(tab$name)))
  expect_true(any(grepl("Cronbach", tab$name, fixed=TRUE)))
  expect_true(any(tab$category == "Prediction models"))
  expect_true(any(tab$category == "Cluster & multilevel designs"))
})

test_that("one-proportion precision substitutes numbers and rounds upward", {
  m <- .r4vn_ss_get_method("prop_abs")
  z <- .r4vn_ss_calculate(m, list(p=.20,d=.05,alpha=.05), loss=0, design_effect=1, population=NA_real_)
  expect_equal(z$base_n, stats::qnorm(.975)^2*.2*.8/.05^2, tolerance=1e-8)
  expect_equal(z$final_n, 246)
  expect_match(z$formula, "frac", fixed=TRUE)
  expect_match(z$substitution, "0.2000", fixed=TRUE)
})

test_that("loss adjustment uses division by retention", {
  m <- .r4vn_ss_get_method("prop_abs")
  z <- .r4vn_ss_calculate(m, list(p=.20,d=.05,alpha=.05), loss=.10, design_effect=1, population=NA_real_)
  expect_equal(z$final_n, ceiling(z$base_n/.90))
})

test_that("PPS inclusion probabilities sum to requested fixed sample size", {
  mos <- c(100,200,300,400,500,600)
  pi <- .r4vn_sampling_pps_pi(mos,3)
  expect_equal(sum(pi),3,tolerance=1e-8)
  expect_true(all(pi>=0 & pi<=1))
})

test_that("simple random sampling is reproducible from manifest", {
  d <- data.frame(id=sprintf("P%03d",1:100), x=seq_len(100))
  a <- .r4vn_sampling_run(d,"simple","id",seed=12345,params=list(n=20))
  b <- .r4vn_sampling_reproduce(a,d)
  expect_identical(as.character(a$selected$id),as.character(b$selected$id))
  expect_true(.r4vn_sampling_verify_frame(a,d)$ok)
})

test_that("changed sampling frame blocks exact reproduction", {
  d <- data.frame(id=sprintf("P%03d",1:20), x=seq_len(20))
  a <- .r4vn_sampling_run(d,"simple","id",seed=123,params=list(n=5))
  d2 <- d[c(2:20,1),]
  expect_false(.r4vn_sampling_verify_frame(a,d2)$ok)
  expect_error(.r4vn_sampling_reproduce(a,d2),"does not match")
})

test_that("sampling project manifest excludes frame data", {
  d <- data.frame(id=sprintf("P%03d",1:20), x=seq_len(20))
  a <- .r4vn_sampling_run(d,"simple","id",seed=123,params=list(n=5))
  m <- .r4vn_sampling_manifest(a)
  expect_null(m[["selected"]])
  expect_null(m[["full"]])
  expect_identical(m$selected_ids, as.character(a$selected$id))
  expect_true(m$manifest_only)
})



test_that("sampling manifest prevents partial matching of removed data fields", {
  d <- data.frame(id=sprintf("P%03d",1:20), x=seq_len(20))
  a <- .r4vn_sampling_run(d,"simple","id",seed=123,params=list(n=5))
  m <- .r4vn_sampling_manifest(a)
  expect_null(m$selected)
  expect_null(m$full)
  expect_identical(m$selected_ids, as.character(a$selected$id))
})

test_that("study design cascade returns reasoned recommendations", {
  x <- .r4vn_design_recommend_study("association",list(selection_basis="outcome"))
  expect_identical(x$design,"Case-control study")
  expect_gt(length(x$why),1)
  y <- .r4vn_design_recommend_study("scale",list(scale_stage="validation"))
  expect_match(y$design,"Psychometric")
})

test_that("stripped sampling manifest retains enough information to verify a rerun", {
  d <- data.frame(id=sprintf("P%03d",1:40), x=seq_len(40))
  a <- .r4vn_sampling_run(d,"simple","id",seed=9876,params=list(n=12))
  m <- .r4vn_sampling_manifest(a)
  b <- .r4vn_sampling_reproduce(m,d)
  expect_identical(as.character(b$selected$id), m$selected_ids)
})

test_that("formula preview is immediately available for direct methods", {
  m <- .r4vn_ss_get_method("prop_abs")
  p <- .r4vn_ss_formula_preview(m, list(p=.20,d=.05,alpha=.05))
  expect_true(p$math)
  expect_true(p$exact)
  expect_match(p$formula, "frac", fixed=TRUE)
  expect_match(p$substitution, "0.2000", fixed=TRUE)
})

test_that("generated population supports sampling without an uploaded frame", {
  d <- .r4vn_sampling_generated_frame(500)
  expect_equal(nrow(d), 500)
  expect_identical(d$ID, seq_len(500))
  a <- .r4vn_sampling_run(d,"simple","ID",seed=2468,params=list(n=100,source_mode="generated",generated_population_n=500))
  expect_equal(nrow(a$selected), 100)
  b <- .r4vn_sampling_reproduce(a,d)
  expect_identical(as.character(a$selected$ID), as.character(b$selected$ID))
})

test_that("permuted-block randomization enforces exact allocation ratio and records actual block size", {
  d <- .r4vn_sampling_generated_frame(100)
  a <- .r4vn_sampling_run(d,"rct_block","ID",seed=13579,
                          params=list(groups="Control,Intervention",ratio="1,1",block_sizes="2,4,6",source_mode="generated"))
  tab <- .r4vn_randomization_print_table(a)
  expect_equal(nrow(tab), 100)
  expect_true(all(c("Sequence","Group","Block","Block size") %in% names(tab)))
  expect_false("Participant_ID" %in% names(tab))
  expect_equal(length(unique(tab$Sequence)), 100)
  expect_equal(as.integer(table(tab$Group)[c("Control","Intervention")]), c(50L,50L))
  expect_true(all(tab[["Block size"]] %in% c(2,4,6)))
  for(b in unique(tab$Block)) {
    zz <- tab[tab$Block==b,,drop=FALSE]
    expect_equal(nrow(zz), unique(zz[["Block size"]]))
    expect_equal(length(unique(zz[["Block size"]])), 1)
    expect_equal(as.integer(table(zz$Group)[c("Control","Intervention")]), as.integer(rep(nrow(zz)/2,2)))
  }
})

test_that("randomization blocks incompatible totals instead of truncating a final block", {
  d <- .r4vn_sampling_generated_frame(101)
  expect_error(
    .r4vn_sampling_run(d,"rct_block","ID",seed=13579,
      params=list(groups="Control,Intervention",ratio="1,1",block_sizes="2,4,6",source_mode="generated")),
    "Exact allocation|required|incompatible"
  )
})

test_that("randomization methods paragraph documents ratio and block sizes", {
  d <- .r4vn_sampling_generated_frame(20)
  a <- .r4vn_sampling_run(d,"rct_block","ID",seed=123,
                          params=list(groups="Control,Intervention",ratio="1,1",block_sizes="2,4,6"))
  z <- .r4vn_randomization_method_paragraph(a)
  expect_match(z,"1:1",fixed=TRUE)
  expect_match(z,"permuted-block",fixed=TRUE)
  expect_match(z,"2, 4, 6",fixed=TRUE)
  expect_match(z,"Exact final group totals",fixed=TRUE)
})

test_that("R4VN design project keeps sampling and randomization as separate results", {
  p <- .r4vn_design_project_new("Example")
  expect_null(p$sampling)
  expect_null(p$randomization)
})


test_that("permuted block allocation completes exact 1:1 totals for N=100", {
  set.seed(1)
  z <- .r4vn_sampling_block_allocate(100, c("Control","Intervention"), c(1,1), c(2,4,6))
  expect_equal(length(z$group), 100)
  expect_equal(as.integer(table(z$group)[c("Control","Intervention")]), c(50L,50L))
  expect_true(all(z$block_size %in% c(2L,4L,6L)))
  for(b in unique(z$block)) {
    ix <- z$block == b
    expect_equal(sum(ix), unique(z$block_size[ix]))
    expect_equal(as.integer(table(z$group[ix])[c("Control","Intervention")]), as.integer(rep(sum(ix)/2,2)))
  }
})

test_that("sampling methods text reports systematic interval", {
  d <- data.frame(ID=1:100)
  z <- .r4vn_sampling_run(d, "systematic", "ID", 123, list(n=20, source_mode="generated"))
  txt <- .r4vn_sampling_method_paragraph(z)
  expect_match(txt, "sampling interval")
  expect_match(txt, "100/20")
  expect_match(txt, "random start")
})