Test every component print, the APA reports, and the legacy paths

tests/testthat/test-component-print.R

@@ -79,3 +79,124 @@ test_that("a similarity matrix prints formatted and still feeds content_structur
   expect_match(shown(sim), "Every pair was sorted by the same 5 judges.", fixed = TRUE)
   expect_s3_class(content_structure(sim), "contentvalid_structure")
 })
+
+test_that("pairs sorted by different numbers of judges are reported as a range", {
+  d <- data.frame(item = rep(paste0("I", 1:4), each = 5), rater = rep(1:5, 4),
+                  assigned_construct = c(rep("A", 10), rep("B", 10)),
+                  stringsAsFactors = FALSE)
+  d <- d[!(d$item == "I4" & d$rater == 5), ]
+  expect_match(shown(similarity_from_sort(d)),
+               "Pairs were sorted by 4 to 5 judges", fixed = TRUE)
+})
+
+ratings_within <- function() {
+  set.seed(3)
+  d <- expand.grid(item = c("A1", "B1"), rater = 1:12,
+                   construct = c("A", "B", "C"), stringsAsFactors = FALSE)
+  d$target_construct <- ifelse(d$item == "B1", "B", "A")
+  d$rating <- ifelse(d$construct == d$target_construct,
+                     sample(4:5, nrow(d), TRUE), sample(1:3, nrow(d), TRUE))
+  d
+}
+
+test_that("the construct-rating components print as APA tables", {
+  d <- ratings_within()
+  out_htc <- shown(htc(d, scale_min = 1, scale_max = 5))
+  expect_match(out_htc, "Hinkin-Tracey correspondence (HTC", fixed = TRUE)
+  expect_match(out_htc, "share of the 5-point scale", fixed = TRUE)
+  expect_false(grepl(" 0[.][0-9]", out_htc))
+
+  out_htd <- shown(htd(d, scale_min = 1, scale_max = 5))
+  expect_match(out_htd, "Hinkin-Tracey distinctiveness (HTD", fixed = TRUE)
+  expect_match(out_htd, "competitor mean", fixed = TRUE)
+  expect_match(out_htd, "averages the gap over every other construct", fixed = TRUE)
+
+  within <- shown(anova_content(d))
+  expect_match(within, "Greenhouse-Geisser corrected", fixed = TRUE)
+  expect_match(within, "F[(][0-9.]+, [0-9.]+[)] = [0-9.]+")
+  # A between-judges design has whole-number degrees of freedom and no
+  # Greenhouse-Geisser note.
+  between <- d
+  between$rater <- paste0(between$rater, "-", between$construct)
+  out_between <- shown(anova_content(between, design = "between"))
+  expect_match(out_between, "Content-validity ANOVA", fixed = TRUE)
+  expect_false(grepl("Greenhouse-Geisser corrected", out_between, fixed = TRUE))
+})
+
+test_that("the item-sort and expert components print their notes", {
+  csv <- shown(compute_csv(sorts))
+  expect_match(csv, "Coefficient of substantive validity (Csv", fixed = TRUE)
+  expect_match(csv, "18/20 B 2/20 .80", fixed = TRUE)
+  expect_match(csv, "divided by the number of judges", fixed = TRUE)
+
+  # Without an interval there is no interval column or interval note.
+  no_ci <- shown(compute_psa(sorts, ci = "none"))
+  expect_false(grepl("95% CI", no_ci, fixed = TRUE))
+  # Missing assignments are counted in a note.
+  gappy <- sorts
+  gappy$assigned_construct[1] <- NA
+  expect_match(shown(compute_psa(gappy)), "Missing assignments: 1", fixed = TRUE)
+
+  R <- matrix(c(4, 4, 3, 4, 3, 4, 4, 4, 4), 3,
+              dimnames = list(NULL, paste0("I", 1:3)))
+  expect_match(shown(aikens_v(R, lo = 1, hi = 4)),
+               "Penfield-Giacobbi score (Penfield & Giacobbi, 2004)", fixed = TRUE)
+  expect_false(grepl("Interval:", shown(aikens_v(R, lo = 1, hi = 4, ci = "none")),
+                     fixed = TRUE))
+  expect_match(shown(aikens_v(R, lo = 1, hi = 4, ci = "bootstrap", B = 50,
+                              seed = 1)),
+               "Interval: percentile bootstrap.", fixed = TRUE)
+
+  d <- expand.grid(item = c("I1", "I2"), judge = 1:4, objective = c("A", "B"))
+  d$score <- ifelse((d$item == "I1") == (d$objective == "A"), 1, -1)
+  out_ioc <- shown(ioc(d))
+  expect_match(out_ioc, "Item-objective congruence (IOC", fixed = TRUE)
+  expect_match(out_ioc, "I1 A 4 1.00", fixed = TRUE)
+})
+
+test_that("the Colquitt functions print their bands", {
+  bands <- shown(interpret_colquitt(c(.70, .40), "csv"))
+  expect_match(bands, "Benchmark bands (Colquitt et al., 2019)", fixed = TRUE)
+  expect_match(bands, "Csv .70 Strong", fixed = TRUE)
+  expect_match(bands, "not a universal cutoff", fixed = TRUE)
+  # Expert judges get no band.
+  expect_match(shown(interpret_colquitt(.70, "csv", judge_type = "expert")),
+               "not applied", fixed = TRUE)
+
+  norms <- shown(colquitt_benchmarks("htd"))
+  expect_match(norms, "Benchmarks for HTD (Colquitt et al., 2019)", fixed = TRUE)
+  expect_match(norms, "Lack of 0th-19th none", fixed = TRUE)
+})
+
+test_that("the two-by-two helpers print their statistics", {
+  pred <- c(TRUE, TRUE, FALSE, FALSE, TRUE, FALSE)
+  act <- c(TRUE, FALSE, FALSE, FALSE, TRUE, TRUE)
+  sig <- shown(signal_detection(pred, act))
+  expect_match(sig, "Retention decisions compared with the actual outcome",
+               fixed = TRUE)
+  expect_match(sig, "accuracy = ", fixed = TRUE)
+  expect_match(sig, "chi-square(1) = ", fixed = TRUE)
+  rep_out <- shown(reproducibility_phi(pred, act))
+  expect_match(rep_out, "Retention decisions in two pretests", fixed = TRUE)
+  expect_match(rep_out, "phi = ", fixed = TRUE)
+  # When chi-square cannot be computed, only phi is reported.
+  flat <- shown(reproducibility_phi(rep(TRUE, 4), rep(TRUE, 4)))
+  expect_false(grepl("chi-square", flat, fixed = TRUE))
+})
+
+test_that("a csv_binom_test result saved before 0.9.0 still prints", {
+  b <- unclass(csv_binom_test(15, 20))
+  b[c("n_target", "N", "p0", "alpha")] <- NULL
+  class(b) <- c("contentvalid_binom", "contentvalid_component")
+  expect_match(shown(b), "Psa = .75, p = .021. Decision: significant.",
+               fixed = TRUE)
+})
+
+test_that("each component print falls back to a plain print after subsetting", {
+  d <- ratings_within()
+  expect_match(shown(htd(d, scale_min = 1, scale_max = 5)[, c("item", "htd")]),
+               "item", fixed = TRUE)
+  expect_false(grepl("Hinkin-Tracey", shown(htc(d, scale_min = 1,
+                                                  scale_max = 5)[, c("item", "htc")]),
+                     fixed = TRUE))
+})

tests/testthat/test-legacy-paths.R

@@ -0,0 +1,106 @@
+# Paths the everyday tests do not reach: the Monte Carlo helpers kept for
+# older analyses, and the compatibility code that lets objects saved by
+# earlier versions still print and summarize.
+
+test_that("the simulation helpers check their arguments", {
+  expect_error(simulate_csv_power(N = 0), "`N`")
+  expect_error(simulate_csv_power(N = 2.5), "`N`")
+  expect_error(simulate_csv_power(true_p = 1.5), "`true_p`")
+  expect_error(simulate_csv_power(reps = 0), "`reps`")
+  expect_error(simulate_csv_power(alpha = 1), "`alpha`")
+
+  expect_error(simulate_anova_power(n_raters = 1), "`n_raters`")
+  expect_error(simulate_anova_power(mean_diff = NA), "`mean_diff`")
+  expect_error(simulate_anova_power(sd = 0), "`sd`")
+  expect_error(simulate_anova_power(k_constructs = 1), "`k_constructs`")
+  expect_error(simulate_anova_power(reps = 0), "`reps`")
+  expect_error(simulate_anova_power(alpha = 0), "`alpha`")
+})
+
+test_that("the simulation helpers return a power between 0 and 1", {
+  set.seed(8)
+  p_csv <- simulate_csv_power(N = 20, true_p = 0.9, reps = 60)
+  expect_true(p_csv >= 0 && p_csv <= 1)
+  # With 20 judges choosing the target nine times in ten, the exact test
+  # nearly always passes.
+  expect_gt(p_csv, 0.8)
+  set.seed(8)
+  p_anova <- simulate_anova_power(n_raters = 10, mean_diff = 2, sd = 1,
+                                  k_constructs = 3, reps = 20)
+  expect_true(p_anova >= 0 && p_anova <= 1)
+  expect_gt(p_anova, 0.8)
+})
+
+test_that("older decision wording still maps onto the shared statuses", {
+  old <- c("Insufficient judges", "Needs review", "Retained", "Favoured",
+           "Descriptive summary", NA)
+  expect_identical(
+    contentvalidR:::.workflow_status_from_recommendation(old),
+    c("Insufficient data", "Review", "Supported", "Supported",
+      "Descriptive only", NA)
+  )
+})
+
+test_that("the workflow constructor rejects malformed parts", {
+  good <- data.frame(item = "I1", recommendation = "Retain")
+  build <- function(...) {
+    args <- list(subclass = "contentvalid_sort", workflow = "item-sort",
+                 results = good, scale_summary = data.frame(),
+                 settings = list(), design = list())
+    dots <- list(...)
+    args[names(dots)] <- dots
+    do.call(contentvalidR:::.new_contentvalid_workflow, args)
+  }
+  expect_s3_class(build(), "contentvalid_workflow")
+  expect_error(build(results = "x"), "must be a data.frame")
+  expect_error(build(results = data.frame(item = "I1")), "`recommendation` or `status`")
+  expect_error(build(results = data.frame(item = "I1", status = "Maybe")),
+               "must be one of")
+  expect_error(build(scale_summary = "x"), "`scale_summary` must be a data.frame")
+  expect_error(build(settings = "x"), "must be lists")
+  expect_error(build(details = "x"), "`details` must be a list")
+  # Legacy aliases are added without overwriting a current part.
+  fit <- build(legacy = list(scale = data.frame(a = 1), results = "ignored"))
+  expect_identical(fit$scale, data.frame(a = 1))
+  expect_s3_class(fit$results, "data.frame")
+})
+
+test_that("expert objects saved before 0.0.6 still summarize", {
+  rel <- structure(list(
+    mode = "relevance",
+    results = data.frame(item = c("I1", "I2"),
+                         recommendation = c("Strong support", "Review")),
+    scale = data.frame(n_items = 2L, n_experts_min = 5L, n_experts_max = 6L)
+  ), class = c("contentvalid_expert", "contentvalid_workflow"))
+  expect_identical(contentvalidR:::.workflow_name(rel), "expert-panel")
+  d <- contentvalidR:::.workflow_design(rel)
+  expect_identical(d$type, "expert-panel relevance")
+  expect_identical(d$n_judges_max, 6L)
+  s <- contentvalidR:::.workflow_summary_core(rel)
+  expect_identical(c(s$n_supported, s$n_review), c(1L, 1L))
+
+  ess <- structure(list(
+    mode = "essentiality",
+    results = data.frame(item = c("I1", "I2"), N = c(10L, 10L),
+                         recommendation = c("Supported", "Review"))
+  ), class = c("contentvalid_expert", "contentvalid_workflow"))
+  expect_identical(contentvalidR:::.workflow_design(ess)$n_judges, 10L)
+
+  con <- structure(list(
+    mode = "congruence",
+    results = data.frame(item = c("I1", "I1"), recommendation = "Descriptive only"),
+    details = list(cells = data.frame(objective = c("A", "B"),
+                                      n_judges = c(4L, 3L), n_missing = c(0L, 1L)))
+  ), class = c("contentvalid_expert", "contentvalid_workflow"))
+  cd <- contentvalidR:::.workflow_design(con)
+  expect_identical(cd$n_items, 1L)
+  expect_identical(c(cd$n_judges_min, cd$n_judges_max, cd$n_missing), c(3L, 4L, 1L))
+  expect_identical(cd$n_objectives, 2L)
+
+  # Anything else unknown reports no design and no workflow name.
+  other <- structure(list(results = data.frame(recommendation = "Retain")),
+                     class = "contentvalid_workflow")
+  expect_identical(contentvalidR:::.workflow_design(other), list())
+  expect_identical(contentvalidR:::.workflow_name(other), NA_character_)
+  expect_identical(contentvalidR:::.workflow_scale_summary(other), data.frame())
+})

tests/testthat/test-reporting.R

@@ -210,3 +210,56 @@ test_that("markdown output prints as the table, not as a character vector", {
   expect_false(any(grepl("^[[]1[]]|settings", out)))
   expect_match(out[1], "| Psa | 95% CI |", fixed = TRUE)
 })
+
+test_that("every workflow and expert mode has an APA report with a decision", {
+  set.seed(2)
+  rd <- expand.grid(item = c("A1", "B1"), rater = 1:12,
+                    construct = c("A", "B", "C"), stringsAsFactors = FALSE)
+  rd$target_construct <- ifelse(rd$item == "B1", "B", "A")
+  rd$rating <- ifelse(rd$construct == rd$target_construct,
+                      sample(4:5, nrow(rd), TRUE), sample(1:3, nrow(rd), TRUE))
+  rating <- content_report(rating_validity(rd))
+  expect_identical(names(rating), c("item", "target", "judges", "competitor",
+                                    "HTC", "HTD", "omnibus p", "contrast p",
+                                    "decision"))
+
+  ess <- content_report(expert_validity(c(10, 8), mode = "essentiality", N = 12))
+  expect_identical(names(ess), c("item", "essential", "CVR", "p", "decision"))
+  expect_identical(ess$essential, c("10/12", "8/12"))
+
+  d <- expand.grid(item = c("I1", "I2"), judge = 1:4, objective = c("A", "B"))
+  d$target_objective <- ifelse(d$item == "I1", "A", "B")
+  d$score <- ifelse(d$objective == d$target_objective, 1, -1)
+  con <- content_report(expert_validity(d, mode = "congruence"))
+  expect_identical(names(con), c("item", "target", "target IOC", "competitor",
+                                 "competitor IOC", "margin", "decision"))
+  expect_identical(con$margin, c("2.00", "2.00"))
+
+  long <- function(m, round) {
+    data.frame(expert = paste0("E", seq_len(nrow(m))),
+               item = rep(colnames(m), each = nrow(m)), round = round,
+               rating = as.vector(m), stringsAsFactors = FALSE)
+  }
+  r1 <- cbind(S1 = c(4, 4, 3, 4, 3, 4), S2 = c(3, 4, 3, 2, 4, 3))
+  r2 <- cbind(S1 = c(4, 4, 4, 4, 3, 4), S2 = c(4, 4, 4, 4, 4, 3))
+  delphi <- content_report(delphi_validity(rbind(long(r1, 1), long(r2, 2)),
+                                           lo = 1, hi = 4, B = 0))
+  expect_true(all(c("item", "last round", "experts", "agree", "unchanged",
+                    "decision") %in% names(delphi)))
+
+  dom <- content_report(domain_validity(
+    data.frame(item = paste0("I", 1:3), cell = c("A", "A", "B"),
+               stringsAsFactors = FALSE),
+    domain = c("A", "B", "C")))
+  expect_identical(dom$share, c("67%", "33%", "0%"))
+})
+
+test_that("an APA report with no rows prints a note rather than an empty table", {
+  clean <- sort_validity(data.frame(
+    item = rep("I1", 6), rater = 1:6,
+    assigned_construct = rep("A", 6), target_construct = "A",
+    stringsAsFactors = FALSE
+  ))
+  out <- utils::capture.output(print(content_report(clean, include = "flagged")))
+  expect_identical(out, "No units matched the requested selection.")
+})