## tests/testthat/test-api-final-coverage.R ## Targeted coverage tests for api.R uncovered lines. # ── shared fixtures ────────────────────────────────────────────────────────── local({ old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) }) # --------------------------------------------------------------------------- # Fixture: fast JML fit with sample data # --------------------------------------------------------------------------- test_that("fixture: build shared fit/dx objects", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) fit <<- suppressWarnings(mfrmr::fit_mfrm( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", method = "JML", model = "RSM", maxit = 15 )) expect_s3_class(fit, "mfrm_fit") dx <<- mfrmr::diagnose_mfrm(fit, residual_pca = "both", pca_max_factors = 3) expect_s3_class(dx, "mfrm_diagnostics") bias_res <<- mfrmr::estimate_bias( fit, dx, facet_a = "Rater", facet_b = "Criterion", max_iter = 2 ) expect_true(is.list(bias_res)) }) # --------------------------------------------------------------------------- # 1. Error guards: fit_mfrm input validation (stop branches) # --------------------------------------------------------------------------- test_that("error guards on *_table() functions reject non-mfrm_fit input", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) bad <- list(summary = data.frame()) # interrater_agreement_table (line 1521) expect_error(mfrmr::interrater_agreement_table(bad), "mfrm_fit") # facets_chisq_table (line 1664) expect_error(mfrmr::facets_chisq_table(bad), "mfrm_fit") # unexpected_response_table (line 1783) expect_error(mfrmr::unexpected_response_table(bad), "mfrm_fit") # fair_average_table (line 1889) expect_error(mfrmr::fair_average_table(bad), "mfrm_fit") # displacement_table (line 1981) expect_error(mfrmr::displacement_table(bad), "mfrm_fit") # measurable_summary_table (line 2081) expect_error(mfrmr::measurable_summary_table(bad), "mfrm_fit") # rating_scale_table (line 2197) expect_error(mfrmr::rating_scale_table(bad), "mfrm_fit") # unexpected_after_bias_table (line 2507) expect_error(mfrmr::unexpected_after_bias_table(bad, bias_res), "mfrm_fit") }) # --------------------------------------------------------------------------- # 2. Internal diagnostics auto-invocation (lines where diagnostics = NULL triggers diagnose_mfrm) # --------------------------------------------------------------------------- test_that("table functions auto-invoke diagnostics when NULL", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # These call diagnose_mfrm(fit) internally when diagnostics = NULL: # interrater_agreement_table line 1524 ir <- mfrmr::interrater_agreement_table(fit, diagnostics = NULL, rater_facet = "Rater") expect_s3_class(ir, "mfrm_interrater") # facets_chisq_table line 1667 chi <- mfrmr::facets_chisq_table(fit, diagnostics = NULL) expect_s3_class(chi, "mfrm_facets_chisq") # unexpected_response_table line 1786 t4 <- mfrmr::unexpected_response_table(fit, diagnostics = NULL, top_n = 5) expect_s3_class(t4, "mfrm_unexpected") # fair_average_table line 1892 t12 <- mfrmr::fair_average_table(fit, diagnostics = NULL) expect_s3_class(t12, "mfrm_fair_average") # displacement_table line 1984 disp <- mfrmr::displacement_table(fit, diagnostics = NULL) expect_s3_class(disp, "mfrm_displacement") # measurable_summary_table line 2084 t5 <- mfrmr::measurable_summary_table(fit, diagnostics = NULL) expect_s3_class(t5, "mfrm_measurable") # rating_scale_table line 2200 t8 <- mfrmr::rating_scale_table(fit, diagnostics = NULL) expect_s3_class(t8, "mfrm_rating_scale") # unexpected_after_bias_table line 2513 t10 <- mfrmr::unexpected_after_bias_table(fit, bias_res, diagnostics = NULL, top_n = 5) expect_s3_class(t10, "mfrm_unexpected_after_bias") }) # --------------------------------------------------------------------------- # 3. Error guards on bias_count_table and unexpected_after_bias_table # --------------------------------------------------------------------------- test_that("bias_count_table rejects NULL/empty bias_results", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 2325 expect_error(mfrmr::bias_count_table(NULL), "estimate_bias") # line 2510 expect_error( mfrmr::unexpected_after_bias_table(fit, list(table = data.frame())), "estimate_bias" ) }) # --------------------------------------------------------------------------- # 4. make_anchor_table: non-mfrm_fit error + facets filter (lines 1309, 1344-1346) # --------------------------------------------------------------------------- test_that("make_anchor_table error guard and facets filter", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) expect_error(mfrmr::make_anchor_table(list()), "mfrm_fit") anchor_tbl <- mfrmr::make_anchor_table(fit) expect_true(nrow(anchor_tbl) > 0) # Filter by specific facets (line 1344-1346) anchor_sub <- mfrmr::make_anchor_table(fit, facets = "Rater") expect_true(all(anchor_sub$Facet == "Rater")) # Include person estimates anchor_person <- mfrmr::make_anchor_table(fit, include_person = TRUE) expect_true("Person" %in% anchor_person$Facet) }) # --------------------------------------------------------------------------- # 5. describe_mfrm_data with agreement (lines 428, 477, 480, 490, 494, 511-512) # --------------------------------------------------------------------------- test_that("describe_mfrm_data agreement path and error guards", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) # include_agreement = TRUE triggers the agreement block (lines 469+) desc <- mfrmr::describe_mfrm_data( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", include_agreement = TRUE, rater_facet = "Rater", agreement_top_n = 5 ) expect_s3_class(desc, "mfrm_data_description") expect_true(desc$agreement$settings$included) expect_equal(desc$agreement$settings$top_n, 5L) # include_person_facet = TRUE (line 428) desc2 <- mfrmr::describe_mfrm_data( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", include_person_facet = TRUE ) expect_s3_class(desc2, "mfrm_data_description") # Error: rater_facet = "Person" (line 480) expect_error( mfrmr::describe_mfrm_data( data = d, person = "Person", facets = c("Rater", "Task"), score = "Score", include_agreement = TRUE, rater_facet = "Person" ), "Person" ) # Error: unknown context_facets (line 490) expect_error( mfrmr::describe_mfrm_data( data = d, person = "Person", facets = c("Rater", "Task"), score = "Score", include_agreement = TRUE, rater_facet = "Rater", context_facets = c("Nonexistent") ), "Unknown" ) # Error: context_facets same as rater_facet (line 494) expect_error( mfrmr::describe_mfrm_data( data = d, person = "Person", facets = c("Rater", "Task"), score = "Score", include_agreement = TRUE, rater_facet = "Rater", context_facets = c("Rater") ), "context_facets" ) }) # --------------------------------------------------------------------------- # 6. summary/print methods for data_description (line 649, 670) # --------------------------------------------------------------------------- test_that("summary/print for mfrm_data_description covers lines 649, 670", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) desc <- mfrmr::describe_mfrm_data( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", include_agreement = TRUE, rater_facet = "Rater" ) s <- summary(desc) expect_s3_class(s, "summary.mfrm_data_description") out <- capture.output(print(s)) expect_true(any(grepl("mfrm Data Description Summary", out, fixed = TRUE))) }) # --------------------------------------------------------------------------- # 7. plot.mfrm_data_description error guards (lines 765, 787, 812) # --------------------------------------------------------------------------- test_that("plot.mfrm_data_description error guards for empty data", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) empty_desc <- structure( list( score_distribution = data.frame(), facet_level_summary = data.frame(), missing_by_column = data.frame() ), class = "mfrm_data_description" ) # line 765 expect_error(plot(empty_desc, type = "score_distribution", draw = FALSE), "not available") # line 787 expect_error(plot(empty_desc, type = "facet_levels", draw = FALSE), "not available") # line 812 expect_error(plot(empty_desc, type = "missing", draw = FALSE), "not available") }) # --------------------------------------------------------------------------- # 8. anchor_audit print/summary (lines 970-971, 1051, 1055, 1076) # --------------------------------------------------------------------------- test_that("anchor audit print and summary cover lines 970-1076", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) # Create audit with anchors that trigger issues anchor_tbl <- mfrmr::make_anchor_table(fit, facets = "Rater") aud <- mfrmr::audit_mfrm_anchors( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", anchors = anchor_tbl ) expect_s3_class(aud, "mfrm_anchor_audit") # print covers lines 970-971 if there are nonzero issue counts out_print <- capture.output(print(aud)) expect_true(any(grepl("mfrm anchor audit", out_print, fixed = TRUE))) # summary covers lines 1051, 1055, 1076 s <- summary(aud) expect_s3_class(s, "summary.mfrm_anchor_audit") out_sum <- capture.output(print(s)) expect_true(any(grepl("mfrm Anchor Audit Summary", out_sum, fixed = TRUE))) }) # --------------------------------------------------------------------------- # 9. format_anchor_audit_message edge cases (lines 260, 265) # --------------------------------------------------------------------------- test_that("format_anchor_audit_message handles edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 260: NULL/empty issue_counts msg1 <- mfrmr:::format_anchor_audit_message(list(issue_counts = NULL)) expect_match(msg1, "no issues") # line 265: all N == 0 msg2 <- mfrmr:::format_anchor_audit_message( list(issue_counts = data.frame(Issue = "dup", N = 0L)) ) expect_match(msg2, "no issues") }) # --------------------------------------------------------------------------- # 10. interrater_agreement_table error guards (lines 1543, 1546) # --------------------------------------------------------------------------- test_that("interrater_agreement_table rejects bad rater_facet", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 1543: rater_facet not in known facets expect_error( mfrmr::interrater_agreement_table(fit, rater_facet = "Nonexistent"), "rater_facet" ) # line 1546: rater_facet = "Person" expect_error( mfrmr::interrater_agreement_table(fit, rater_facet = "Person"), "Person" ) }) # --------------------------------------------------------------------------- # 11. facets_chisq_table top_n filter (lines 1682-1683, 1688) # --------------------------------------------------------------------------- test_that("facets_chisq_table top_n filter works", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) chi <- mfrmr::facets_chisq_table(fit, diagnostics = dx, top_n = 1) expect_s3_class(chi, "mfrm_facets_chisq") expect_lte(nrow(chi$table), 1) }) # --------------------------------------------------------------------------- # 12. rating_scale_table with drop_unused (line 2208) # --------------------------------------------------------------------------- test_that("rating_scale_table drop_unused parameter", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) t8 <- mfrmr::rating_scale_table(fit, diagnostics = dx, drop_unused = TRUE) expect_s3_class(t8, "mfrm_rating_scale") expect_true(all(t8$category_table$Count > 0)) }) # --------------------------------------------------------------------------- # 13. Legacy table functions (table1_specifications, table2_data_summary, etc.) # --------------------------------------------------------------------------- test_that("legacy table1_specifications (lines 2792, 2798, 2884)", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 2792: non-mfrm_fit input expect_error(mfrmr:::table1_specifications(list()), "mfrm_fit") # Normal invocation covers lines 2798, 2884 t1 <- mfrmr:::table1_specifications(fit, title = "Test run") expect_true(is.list(t1)) expect_true("header" %in% names(t1)) expect_true("anchor_summary" %in% names(t1)) }) test_that("legacy table2_data_summary without raw data (lines 2973, 3018-3028)", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 2973: non-mfrm_fit expect_error(mfrmr:::table2_data_summary(list()), "mfrm_fit") # Without raw data, include_fixed = TRUE -> lines 3018-3028 t2 <- mfrmr:::table2_data_summary(fit, include_fixed = TRUE) expect_true(is.list(t2)) expect_true("fixed" %in% names(t2)) expect_true(nchar(t2$fixed) > 0) }) test_that("legacy table2_data_summary WITH raw data (lines 3034-3093)", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) # Inject some missing values / out-of-range to trigger audit branches d_bad <- d d_bad$Score[1:3] <- NA # missing_score d_bad$Person[4] <- NA # missing_person d_bad$Score[5] <- 99 # out of range t2 <- mfrmr:::table2_data_summary( fit, data = d_bad, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score" ) expect_true(is.list(t2)) expect_true(nrow(t2$row_audit) > 0) # line 3034: data is not a data.frame expect_error( mfrmr:::table2_data_summary(fit, data = "not_a_df", person = "Person", facets = c("Rater"), score = "Score"), "data.frame" ) # line 3038: missing columns expect_error( mfrmr:::table2_data_summary(fit, data = data.frame(X = 1), person = "Person", facets = c("Rater"), score = "Score"), "missing required" ) }) # --------------------------------------------------------------------------- # 14. table6_subsets_listing legacy (lines 3357-3385) # --------------------------------------------------------------------------- test_that("legacy table6_subsets_listing covers lines 3358-3385", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 3358: non-mfrm_fit error expect_error(mfrmr:::table6_subsets_listing(list()), "mfrm_fit") # Normal call, auto-diagnose t6 <- mfrmr:::table6_subsets_listing(fit) expect_true(is.list(t6)) expect_true("summary" %in% names(t6)) expect_true("listing" %in% names(t6)) }) # --------------------------------------------------------------------------- # 15. table6_2_facet_statistics legacy (lines 3514-3537) # --------------------------------------------------------------------------- test_that("legacy table6_2_facet_statistics covers lines 3514-3537", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 3514: non-mfrm_fit expect_error(mfrmr:::table6_2_facet_statistics(list()), "mfrm_fit") t62 <- mfrmr:::table6_2_facet_statistics(fit, diagnostics = dx) expect_true(is.list(t62)) }) # --------------------------------------------------------------------------- # 16. facets_output_file_bundle error guards (lines 4072, 4078, 4081, 4089, 4094, 4097, 4100) # --------------------------------------------------------------------------- test_that("facets_output_file_bundle input validation", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 4072: non-mfrm_fit expect_error(mfrmr::facets_output_file_bundle(list()), "mfrm_fit") # line 4078: bad include values expect_error( mfrmr::facets_output_file_bundle(fit, include = c("badval")), "Unsupported" ) # line 4081: empty include expect_error( mfrmr::facets_output_file_bundle(fit, include = character(0)), "include" ) # line 4089: empty file_prefix out <- mfrmr::facets_output_file_bundle(fit, file_prefix = "") expect_s3_class(out, "mfrm_output_bundle") # line 4094: write_files = TRUE but no output_dir expect_error( mfrmr::facets_output_file_bundle(fit, write_files = TRUE, output_dir = NULL), "output_dir" ) }) # --------------------------------------------------------------------------- # 17. analyze_residual_pca (lines 4382, 4386, 4391-4393, 4426) # --------------------------------------------------------------------------- test_that("analyze_residual_pca error guards and facets filter", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 4382: non-list diagnostics expect_error(mfrmr::analyze_residual_pca("not_a_list"), "diagnose_mfrm") # line 4386: empty obs expect_error( mfrmr::analyze_residual_pca(list(obs = data.frame())), "empty" ) # line 4391-4393: facets filter with nonexistent facets expect_error( mfrmr::analyze_residual_pca(dx, facets = "NonExistent"), "No matching facets" ) # Normal call with specific facets (line 4426 / subset filter) pca <- mfrmr::analyze_residual_pca(dx, mode = "facet", facets = "Rater") expect_s3_class(pca, "mfrm_residual_pca") expect_equal(pca$facet_names, "Rater") # Calling with mfrm_fit directly (line 4373-4378) pca2 <- mfrmr::analyze_residual_pca(fit, mode = "overall") expect_s3_class(pca2, "mfrm_residual_pca") }) # --------------------------------------------------------------------------- # 18. extract_pca_eigenvalues and build_pca_variance_table (lines 4231, 4238-4241, 4249) # --------------------------------------------------------------------------- test_that("extract_pca_eigenvalues edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 4231: NULL input expect_equal(mfrmr:::extract_pca_eigenvalues(NULL), numeric(0)) # line 4238-4241: fallback to cor_matrix fake_pca <- list(cor_matrix = matrix(c(1, 0.5, 0.5, 1), 2, 2)) eig <- mfrmr:::extract_pca_eigenvalues(fake_pca) expect_true(length(eig) > 0) # line 4249: build_pca_variance_table with empty eigenvalues empty_tbl <- mfrmr:::build_pca_variance_table(NULL) expect_equal(nrow(empty_tbl), 0) }) # --------------------------------------------------------------------------- # 19. extract_loading_table (lines 4462, 4466-4467, 4471, 4474) # --------------------------------------------------------------------------- test_that("extract_loading_table edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 4462: NULL input tbl0 <- mfrmr:::extract_loading_table(NULL) expect_equal(nrow(tbl0), 0) # line 4471: NULL rownames fake_loads <- matrix(c(0.8, 0.5, -0.3), ncol = 1) fake_pca <- list(pca = list(loadings = fake_loads)) tbl1 <- mfrmr:::extract_loading_table(fake_pca) expect_true(nrow(tbl1) > 0) expect_true("V1" %in% tbl1$Variable || "V2" %in% tbl1$Variable || "V3" %in% tbl1$Variable) }) # --------------------------------------------------------------------------- # 20. summary.mfrm_apa_outputs (lines 6421-6501) # --------------------------------------------------------------------------- test_that("summary.mfrm_apa_outputs covers lines 6421-6501", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) apa <- mfrmr::build_apa_outputs(fit, dx) expect_s3_class(apa, "mfrm_apa_outputs") s <- summary(apa) expect_s3_class(s, "summary.mfrm_apa_outputs") expect_true("overview" %in% names(s)) expect_true("components" %in% names(s)) expect_true("DraftContractPass" %in% names(s$overview)) expect_true(any(grepl("contract completeness", s$notes, fixed = TRUE))) # error guard (line 6421): non-mfrm_apa_outputs expect_error(summary.mfrm_apa_outputs(list()), "mfrm_apa_outputs") }) # --------------------------------------------------------------------------- # 21. summary.mfrm_bundle dispatch to specialized summarizers # --------------------------------------------------------------------------- test_that("summary.mfrm_bundle dispatches to specialized summarizers", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # bias_count -> summarize_bias_count_bundle t11 <- mfrmr::bias_count_table(bias_res, branch = "original") s11 <- summary(t11) expect_s3_class(s11, "summary.mfrm_bundle") # measurable_summary -> generic bundle t5 <- mfrmr::measurable_summary_table(fit, diagnostics = dx) s5 <- summary(t5) expect_s3_class(s5, "summary.mfrm_bundle") # rating_scale -> generic bundle t8 <- mfrmr::rating_scale_table(fit, diagnostics = dx) s8 <- summary(t8) expect_s3_class(s8, "summary.mfrm_bundle") }) # --------------------------------------------------------------------------- # 22. print.summary.mfrm_bundle (lines 8748-8763) bias_count path # --------------------------------------------------------------------------- test_that("print.summary.mfrm_bundle bias_count path", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) t11 <- mfrmr::bias_count_table(bias_res, branch = "original") s11 <- summary(t11) out <- capture.output(print(s11)) expect_true(any(grepl("Bias Count", out, fixed = TRUE))) }) # --------------------------------------------------------------------------- # 23. bundle_settings_table helper (line 7863, 7866) # --------------------------------------------------------------------------- test_that("bundle_settings_table handles edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 7863: NULL input tbl0 <- mfrmr:::bundle_settings_table(NULL) expect_equal(nrow(tbl0), 0) # line 7866: unnamed settings tbl1 <- mfrmr:::bundle_settings_table(list("a", 1, TRUE)) expect_true(nrow(tbl1) == 3) expect_true(all(grepl("Setting", tbl1$Setting))) # nested list & data.frame values tbl2 <- mfrmr:::bundle_settings_table( list( a = NULL, b = data.frame(x = 1:3), c = list(1, 2), d = "hello" ) ) expect_equal(nrow(tbl2), 4) }) # --------------------------------------------------------------------------- # 24. bundle_preview_table (lines 7893, 7905, 7908, 7911) # --------------------------------------------------------------------------- test_that("bundle_preview_table covers edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 7893: empty table obj_empty <- list(table = data.frame()) r1 <- mfrmr:::bundle_preview_table(obj_empty) expect_equal(nrow(r1$table), 0) # line 7905: no names obj_no_names <- list() r2 <- mfrmr:::bundle_preview_table(obj_no_names) expect_true(is.na(r2$name)) }) # --------------------------------------------------------------------------- # 25. resolve_palette (lines 11656, 11662-11664) # --------------------------------------------------------------------------- test_that("resolve_palette handles edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 11656: empty defaults r0 <- mfrmr:::resolve_palette(NULL, character(0)) expect_length(r0, 0) # line 11662-11664: unnamed palette overrides positionally r1 <- mfrmr:::resolve_palette( palette = c("red", "blue"), defaults = c(a = "green", b = "yellow", c = "white") ) expect_equal(r1[["a"]], "red") expect_equal(r1[["b"]], "blue") expect_equal(r1[["c"]], "white") }) # --------------------------------------------------------------------------- # 26. signal_legacy_name_deprecation (lines 2702, 2712) # --------------------------------------------------------------------------- test_that("signal_legacy_name_deprecation edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # suppress_if_called_from suppresses warning for specific callers (line 2712) result <- mfrmr:::signal_legacy_name_deprecation( "old_func", "new_func", suppress_if_called_from = NULL ) expect_null(result) }) # --------------------------------------------------------------------------- # 27. as_mfrm_bundle edge case (line 2735) # --------------------------------------------------------------------------- test_that("as_mfrm_bundle handles non-list input", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 2735: non-list expect_equal(mfrmr:::as_mfrm_bundle(42, "test"), 42) # normal list bnd <- mfrmr:::as_mfrm_bundle(list(a = 1), "test_class") expect_true(inherits(bnd, "test_class")) expect_true(inherits(bnd, "mfrm_bundle")) }) # --------------------------------------------------------------------------- # 28. summary/print for mfrm_fit (lines 11053, 11100, 11143) # --------------------------------------------------------------------------- test_that("summary.mfrm_fit covers person SD + convergence notes", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) s <- summary(fit) expect_s3_class(s, "summary.mfrm_fit") expect_true("facet_overview" %in% names(s)) expect_true("person_overview" %in% names(s)) expect_true("step_overview" %in% names(s)) expect_true("notes" %in% names(s)) # print out <- capture.output(print(s)) expect_true(any(grepl("Many-Facet Rasch Model Summary", out, fixed = TRUE))) }) # --------------------------------------------------------------------------- # 29. summary/print for mfrm_diagnostics (lines 10689, 10753, 10759) # --------------------------------------------------------------------------- test_that("summary.mfrm_diagnostics covers lines 10689-10759", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) s <- summary(dx) expect_s3_class(s, "summary.mfrm_diagnostics") expect_true("flags" %in% names(s)) expect_true("notes" %in% names(s)) out <- capture.output(print(s)) expect_true(any(grepl("Diagnostics Summary", out, fixed = TRUE))) }) # --------------------------------------------------------------------------- # 30. summary/print for mfrm_bias (lines 10867, 10883, 10913, 10939, 10964) # --------------------------------------------------------------------------- test_that("summary.mfrm_bias covers lines 10867-10964", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) s <- summary(bias_res) expect_s3_class(s, "summary.mfrm_bias") expect_true("overview" %in% names(s)) expect_true("top_rows" %in% names(s)) out <- capture.output(print(s)) expect_true(any(grepl("Bias Summary", out, fixed = TRUE))) # line 10867: empty bias expect_error(summary.mfrm_bias(list(table = data.frame())), "non-empty") }) # --------------------------------------------------------------------------- # 31. compute_iteration_state (lines 2608, 2619-2620, 2639, 2643, 2667, 2677) # --------------------------------------------------------------------------- test_that("table3_iteration_report / compute_iteration_state covers iteration lines", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # This triggers compute_iteration_state internally t3 <- mfrmr:::table3_iteration_report(fit, max_iter = 3, include_prox = TRUE) expect_true(is.list(t3)) expect_true("table" %in% names(t3)) expect_true(nrow(t3$table) > 0) }) # --------------------------------------------------------------------------- # 32. plot.mfrm_bundle dispatch (lines 10396-10416) # --------------------------------------------------------------------------- test_that("plot.mfrm_bundle dispatches with type argument", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # fair_average (line 10396) t12 <- mfrmr::fair_average_table(fit, diagnostics = dx) p12 <- plot(t12, type = "scatter", draw = FALSE) expect_s3_class(p12, "mfrm_plot_data") # displacement (line 10401) disp <- mfrmr::displacement_table(fit, diagnostics = dx) p_disp <- plot(disp, type = "lollipop", draw = FALSE) expect_s3_class(p_disp, "mfrm_plot_data") # interrater (line 10406) ir <- mfrmr::interrater_agreement_table(fit, diagnostics = dx, rater_facet = "Rater") p_ir <- plot(ir, draw = FALSE) expect_s3_class(p_ir, "mfrm_plot_data") # facets_chisq (line 10411) chi <- mfrmr::facets_chisq_table(fit, diagnostics = dx) p_chi <- plot(chi, draw = FALSE) expect_s3_class(p_chi, "mfrm_plot_data") # bias_interaction (line 10416) - pass bias_results as x bi <- mfrmr::bias_interaction_report( x = bias_res, facet_a = "Rater", facet_b = "Criterion" ) p_bi <- plot(bi, draw = FALSE) expect_s3_class(p_bi, "mfrm_plot_data") }) # --------------------------------------------------------------------------- # 33. step_index_from_label (lines 11229, 11231-11232) # --------------------------------------------------------------------------- test_that("step_index_from_label handles edge cases", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 11229: all non-numeric labels idx1 <- mfrmr:::step_index_from_label(c("abc", "def")) expect_equal(idx1, 1:2) # line 11231-11232: partially numeric idx2 <- mfrmr:::step_index_from_label(c("Step_1", "abc", "Step_3")) expect_true(all(is.finite(idx2))) expect_equal(length(idx2), 3) }) # --------------------------------------------------------------------------- # 34. build_step_curve_spec edge cases (lines 11240, 11246, 11250, 11272, 11301) # --------------------------------------------------------------------------- test_that("build_step_curve_spec from fit object", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) spec <- mfrmr:::build_step_curve_spec(fit) expect_true(is.list(spec)) expect_equal(spec$model, "RSM") expect_true(length(spec$groups) > 0) # line 11240: empty step table bad_fit <- fit bad_fit$steps <- data.frame() expect_error(mfrmr:::build_step_curve_spec(bad_fit), "Step estimates") }) # --------------------------------------------------------------------------- # 35. build_wright_map_data (lines 11348, 11352, 11365, 11379-11383) # --------------------------------------------------------------------------- test_that("build_wright_map_data from fit", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) wd <- mfrmr:::build_wright_map_data(fit, top_n = 5) expect_true(is.list(wd)) expect_true("person" %in% names(wd)) expect_true("locations" %in% names(wd)) expect_lte(nrow(wd$locations), 5) }) # --------------------------------------------------------------------------- # 36. truncate_axis_label (line 11620+) # --------------------------------------------------------------------------- test_that("truncate_axis_label truncates long labels", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) short <- mfrmr:::truncate_axis_label("short", width = 28L) expect_equal(short, "short") long <- mfrmr:::truncate_axis_label(paste(rep("A", 40), collapse = ""), width = 10) expect_true(grepl("\\.\\.\\.$", long)) expect_true(nchar(long) <= 10) }) # --------------------------------------------------------------------------- # 37. normalize_bias_plot_input (lines 5105, 5113, 5115-5116, 5118, 5121, 5135) # --------------------------------------------------------------------------- test_that("normalize_bias_plot_input error guards", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 5105: mfrm_fit without facet_a/facet_b expect_error( mfrmr:::normalize_bias_plot_input(fit), "interaction_facets" ) # line 5113: interaction_facets with only one element expect_error( mfrmr:::normalize_bias_plot_input(fit, interaction_facets = "Rater"), "at least two" ) # line 5135: non-fit, non-bias input expect_error( mfrmr:::normalize_bias_plot_input("junk"), "estimate_bias" ) # Successful call with fit + interaction_facets result <- mfrmr:::normalize_bias_plot_input( fit, interaction_facets = c("Rater", "Criterion") ) expect_true(is.list(result)) expect_true("table" %in% names(result)) }) # --------------------------------------------------------------------------- # 38. bundle_summary_labels (lines 8696, 8730) # --------------------------------------------------------------------------- test_that("bundle_summary_labels handles unknown key", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 8730: unknown key falls through to defaults labels <- mfrmr:::bundle_summary_labels("unknown_class") expect_equal(labels$title, "mfrmr Bundle Summary") # line 8696: empty key labels2 <- mfrmr:::bundle_summary_labels("") expect_equal(labels2$title, "mfrmr Bundle Summary") # Known key labels3 <- mfrmr:::bundle_summary_labels("mfrm_unexpected") expect_true(grepl("Unexpected", labels3$title)) }) # --------------------------------------------------------------------------- # 39. print_bundle_section (lines 8735-8736) # --------------------------------------------------------------------------- test_that("print_bundle_section handles NULL/empty table", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 8736: NULL table r1 <- mfrmr:::print_bundle_section("Test", NULL) expect_null(r1) # line 8736: empty data.frame r2 <- mfrmr:::print_bundle_section("Test", data.frame()) expect_null(r2) # Non-empty out <- capture.output(mfrmr:::print_bundle_section("Test Section", data.frame(A = 1:3))) expect_true(any(grepl("Test Section", out))) }) # --------------------------------------------------------------------------- # 40. summarize_parity_bundle / parity report paths (lines 8319-8332) # --------------------------------------------------------------------------- test_that("facets_parity_report summary covers lines 8319-8332", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) parity <- mfrmr::facets_parity_report(fit, diagnostics = dx, bias_results = bias_res) expect_s3_class(parity, "mfrm_parity_report") s <- summary(parity) expect_s3_class(s, "summary.mfrm_bundle") expect_true("notes" %in% names(s)) }) # --------------------------------------------------------------------------- # 41. specifications_report / plot (lines 9393-9430, 9439-9446) # --------------------------------------------------------------------------- test_that("specifications_report and plot cover spec lines", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) spec <- mfrmr::specifications_report(fit) expect_s3_class(spec, "mfrm_specifications") s <- summary(spec) expect_s3_class(s, "summary.mfrm_bundle") # plot with draw = FALSE p <- plot(spec, type = "convergence", draw = FALSE) expect_s3_class(p, "mfrm_plot_data") }) # --------------------------------------------------------------------------- # 42. data_quality_report plot (lines 9511, 9532, 9534) # --------------------------------------------------------------------------- test_that("data_quality_report and plot cover lines 9511-9534", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) dq <- mfrmr::data_quality_report(fit, data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score") expect_s3_class(dq, "mfrm_data_quality") # plot type = "category_counts" (line 9511) p1 <- plot(dq, type = "category_counts", draw = FALSE) expect_s3_class(p1, "mfrm_plot_data") # plot type = "missing_rows" (line 9532) p2 <- plot(dq, type = "missing_rows", draw = FALSE) expect_s3_class(p2, "mfrm_plot_data") }) # --------------------------------------------------------------------------- # 43. estimation_iteration_report plot (lines 9572, 9575, 9581) # --------------------------------------------------------------------------- test_that("estimation_iteration_report plot covers lines 9572-9581", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) iter_rep <- mfrmr::estimation_iteration_report(fit, max_iter = 3) expect_s3_class(iter_rep, "mfrm_iteration_report") p1 <- plot(iter_rep, type = "residual", draw = FALSE) expect_s3_class(p1, "mfrm_plot_data") p2 <- plot(iter_rep, type = "logit_change", draw = FALSE) expect_s3_class(p2, "mfrm_plot_data") }) # --------------------------------------------------------------------------- # 44. visual_summaries / plot path (lines 8014, 8018, 10281-10295) # --------------------------------------------------------------------------- test_that("build_visual_summaries summary and plot", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) vs <- mfrmr::build_visual_summaries(fit, diagnostics = dx) expect_s3_class(vs, "mfrm_visual_summaries") s <- summary(vs) expect_s3_class(s, "summary.mfrm_bundle") out <- capture.output(print(s)) expect_true(any(grepl("Visual", out))) }) # --------------------------------------------------------------------------- # 45. infer_facet_names (line 4264+) # --------------------------------------------------------------------------- test_that("infer_facet_names from different sources", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # Normal path: facet_names directly available fn <- mfrmr:::infer_facet_names(dx) expect_true(length(fn) > 0) # Fallback: measures$Facet dx_mini <- list( measures = data.frame(Facet = c("Rater", "Task", "Person"), stringsAsFactors = FALSE) ) fn2 <- mfrmr:::infer_facet_names(dx_mini) expect_true("Rater" %in% fn2) expect_false("Person" %in% fn2) }) # --------------------------------------------------------------------------- # 46. with_legacy_name_warning_suppressed (line 2728+) # --------------------------------------------------------------------------- test_that("with_legacy_name_warning_suppressed suppresses warnings", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) result <- mfrmr:::with_legacy_name_warning_suppressed({ 1 + 1 }) expect_equal(result, 2) }) # --------------------------------------------------------------------------- # 47. resolve_pca_input (lines 4452-4457) # --------------------------------------------------------------------------- test_that("resolve_pca_input handles different inputs", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 4453: NULL expect_error(mfrmr:::resolve_pca_input(NULL), "NULL") # line 4457: invalid input (non-list, non-fit) expect_error(mfrmr:::resolve_pca_input(list(a = 1))) # mfrm_fit input (line 4455) pca <- mfrmr:::resolve_pca_input(fit) expect_true(!is.null(pca$overall_table)) # diagnostics input (line 4456) pca2 <- mfrmr:::resolve_pca_input(dx) expect_true(!is.null(pca2$overall_table)) }) # --------------------------------------------------------------------------- # 48. plot.mfrm_fit type guards (lines 13075, 13081, 13126, 13136, 13146, 13150, 13162) # --------------------------------------------------------------------------- test_that("plot.mfrm_fit error guards", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) # line 13081: bad theta_range expect_error( plot(fit, theta_range = c(5, 2), draw = FALSE), "theta_range" ) # line 13162: facet filter p_facet <- plot(fit, type = "facet", facet = "Rater", draw = FALSE) expect_s3_class(p_facet, "mfrm_plot_data") # line 13150: nonexistent facet filter expect_error( plot(fit, type = "facet", facet = "Nonexistent", draw = FALSE), "not found" ) }) # --------------------------------------------------------------------------- # 49. category_structure_report and category_curves_report # --------------------------------------------------------------------------- test_that("category_structure_report and category_curves_report cover bundle lines", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) cs <- mfrmr::category_structure_report(fit, diagnostics = dx) expect_s3_class(cs, "mfrm_category_structure") s_cs <- summary(cs) expect_s3_class(s_cs, "summary.mfrm_bundle") cc <- mfrmr::category_curves_report(fit) expect_s3_class(cc, "mfrm_category_curves") s_cc <- summary(cc) expect_s3_class(s_cc, "summary.mfrm_bundle") }) # --------------------------------------------------------------------------- # 50. fit_mfrm with anchor_policy = "warn" (line 226) # --------------------------------------------------------------------------- test_that("fit_mfrm with anchor_policy error triggers error", { skip_on_cran() old_opt <- options(lifecycle_verbosity = "quiet") on.exit(options(old_opt), add = TRUE) d <- mfrmr:::sample_mfrm_data(seed = 42) # Create anchors with a nonexistent level to trigger an audit issue bad_anchor <- data.frame( Facet = c("Rater", "Rater"), Level = c("R1", "R_NONEXIST"), Anchor = c(0.5, -0.5), stringsAsFactors = FALSE ) expect_error( mfrmr::fit_mfrm( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", method = "JML", maxit = 15, anchors = bad_anchor, anchor_policy = "error" ), regexp = "anchor|Anchor|audit|issue", ignore.case = TRUE ) # Also test anchor_policy = "silent" path for code coverage # This should continue after removing invalid rows. result <- suppressWarnings( suppressWarnings(mfrmr::fit_mfrm( data = d, person = "Person", facets = c("Rater", "Task", "Criterion"), score = "Score", method = "JML", maxit = 15, anchors = bad_anchor, anchor_policy = "silent" )) ) expect_s3_class(result, "mfrm_fit") })