From 3f724fa3b7722cce773aa30421970e2acedd0d1f Mon Sep 17 00:00:00 2001 From: "Joshua Uhalt, Ph.D." Date: Sun, 27 Sep 2026 09:33:30 -0400 Subject: [PATCH] Test every component print, the APA reports, and the legacy paths The 0.9.0 print methods were only half covered: R/component_print.R stood at 57% in CI, which pulled overall coverage from 94.5% (0.8.0) to 92.9%. Tests only; no package code changes. - test-component-print.R: every one of the 14 component prints, with the branches their notes depend on: no interval, missing assignments, a bootstrap interval, a between-judges ANOVA (no Greenhouse-Geisser note), expert judges (no Colquitt band), a chi-square that cannot be computed, pairs sorted by different numbers of judges, a csv_binom_test result saved before 0.9.0, and the plain print after subsetting. - test-reporting.R: the APA report for every workflow and expert mode (construct rating, essentiality, congruence, Delphi, domain), and the note an empty APA report prints. - test-legacy-paths.R (new): the Monte Carlo helpers' argument checks and results, older decision wording mapping onto the shared statuses, the workflow constructor's checks and legacy aliases, and expert objects saved before 0.0.6 in all three modes. Coverage: 95.6% measured locally with covr (92.9% before, 94.5% at 0.8.0). All 2,940 tests pass. Co-Authored-By: Claude Opus 5.5 --- tests/testthat/test-component-print.R | 121 ++++++++++++++++++++++++++ tests/testthat/test-legacy-paths.R | 106 ++++++++++++++++++++++ tests/testthat/test-reporting.R | 53 +++++++++++ 3 files changed, 280 insertions(+) create mode 100644 tests/testthat/test-legacy-paths.R diff --git a/tests/testthat/test-component-print.R b/tests/testthat/test-component-print.R index 78073cc..6c92d65 100644 --- a/tests/testthat/test-component-print.R +++ b/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)) +}) diff --git a/tests/testthat/test-legacy-paths.R b/tests/testthat/test-legacy-paths.R new file mode 100644 index 0000000..13fd0c5 --- /dev/null +++ b/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()) +}) diff --git a/tests/testthat/test-reporting.R b/tests/testthat/test-reporting.R index 794e1e2..40697a0 100644 --- a/tests/testthat/test-reporting.R +++ b/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.") +})