tests/testthat/test-facet-dashboard.R

In mfrmr: Estimation and Diagnostics for Many-Facet Measurement Models

facet_dashboard_fixture <- local({
  old_opt <- options(lifecycle_verbosity = "quiet")
  on.exit(options(old_opt), add = TRUE)

  dat <- mfrmr:::sample_mfrm_data(seed = 321)
  fit <- suppressWarnings(mfrmr::fit_mfrm(
    data = dat,
    person = "Person",
    facets = c("Rater", "Task", "Criterion"),
    score = "Score",
    method = "JML",
    maxit = 20
  ))
  diagnostics <- suppressWarnings(mfrmr::diagnose_mfrm(fit, residual_pca = "none"))
  bias_rater <- suppressWarnings(mfrmr::estimate_bias(
    fit,
    diagnostics,
    facet_a = "Rater",
    facet_b = "Criterion",
    max_iter = 2
  ))
  bias_task <- suppressWarnings(mfrmr::estimate_bias(
    fit,
    diagnostics,
    facet_a = "Task",
    facet_b = "Criterion",
    max_iter = 2
  ))
  dashboard_single <- mfrmr::facet_quality_dashboard(
    fit,
    diagnostics = diagnostics,
    bias_results = bias_rater
  )
  dashboard_list <- mfrmr::facet_quality_dashboard(
    fit,
    diagnostics = diagnostics,
    bias_results = list(rater_criterion = bias_rater, task_criterion = bias_task)
  )

  list(
    fit = fit,
    diagnostics = diagnostics,
    bias_rater = bias_rater,
    bias_task = bias_task,
    dashboard_single = dashboard_single,
    dashboard_list = dashboard_list
  )
})

test_that("facet_quality_dashboard constructs a dashboard bundle with inferred facet", {
  expect_s3_class(facet_dashboard_fixture$dashboard_single, "mfrm_facet_dashboard")
  expect_identical(facet_dashboard_fixture$dashboard_single$facet, "Rater")
  expect_true(all(c("summary", "detail", "flagged", "settings") %in% names(facet_dashboard_fixture$dashboard_single)))
  expect_true(is.data.frame(facet_dashboard_fixture$dashboard_single$overview))
  expect_true(is.data.frame(facet_dashboard_fixture$dashboard_single$summary))
})

test_that("facet_quality_dashboard handles single and named-list bias bundles", {
  dash_single <- facet_dashboard_fixture$dashboard_single
  dash_list <- facet_dashboard_fixture$dashboard_list

  expect_identical(dash_single$detail$BiasCount, dash_list$detail$BiasCount)
  expect_identical(dash_single$detail$BiasSources, dash_list$detail$BiasSources)
  expect_true(any(!dash_list$bias_sources$Used))
  expect_true(any(grepl("target facet not involved", dash_list$bias_sources$Reason, fixed = TRUE)))
  expect_identical(sum(dash_single$detail$AnyFlag, na.rm = TRUE), nrow(dash_single$flagged))
})

test_that("facet_quality_dashboard surfaces failed bias-collection pairs in notes", {
  bias_collection <- structure(
    list(
      by_pair = list(rater_criterion = facet_dashboard_fixture$bias_rater),
      errors = data.frame(
        Interaction = "Task x Criterion",
        Facets = "Task x Criterion",
        Error = "forced pair failure",
        stringsAsFactors = FALSE
      )
    ),
    class = c("mfrm_bias_collection", "mfrm_bundle", "list")
  )

  dash <- mfrmr::facet_quality_dashboard(
    facet_dashboard_fixture$fit,
    diagnostics = facet_dashboard_fixture$diagnostics,
    bias_results = bias_collection
  )

  expect_true(any(grepl("^pair error:", dash$bias_sources$Reason)))
  expect_true(any(grepl("failed", dash$notes, fixed = TRUE)))
})

test_that("summary() returns a compact facet dashboard summary", {
  sum_dash <- summary(facet_dashboard_fixture$dashboard_single, top_n = 5)

  expect_s3_class(sum_dash, "summary.mfrm_facet_dashboard")
  expect_identical(sum_dash$summary_kind, "facet_dashboard")
  expect_true(is.data.frame(sum_dash$overview))
  expect_true(nrow(sum_dash$overview) == 1)
  expect_true(nrow(sum_dash$preview) <= 5)
})

test_that("plot_facet_quality_dashboard returns mfrm_plot_data for severity and flags", {
  severity_plot <- plot_facet_quality_dashboard(
    facet_dashboard_fixture$dashboard_single,
    plot_type = "severity",
    draw = FALSE
  )
  flags_plot <- plot_facet_quality_dashboard(
    facet_dashboard_fixture$fit,
    diagnostics = facet_dashboard_fixture$diagnostics,
    bias_results = facet_dashboard_fixture$bias_rater,
    plot_type = "flags",
    draw = FALSE
  )

  expect_s3_class(severity_plot, "mfrm_plot_data")
  expect_s3_class(flags_plot, "mfrm_plot_data")
  expect_identical(severity_plot$name, "facet_quality_dashboard")
  expect_identical(severity_plot$data$plot, "severity")
  expect_identical(flags_plot$data$plot, "flags")
  expect_true(is.data.frame(severity_plot$data$table))
  expect_true(is.data.frame(flags_plot$data$table))
})