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.") +})