tests/testthat/test-weighting-audit.R

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

test_that("build_weighting_review returns a structured review bundle", {
  toy <- load_mfrmr_data("example_core")
  keep_people <- unique(toy$Person)[1:12]
  toy <- toy[toy$Person %in% keep_people, , drop = FALSE]

  rasch_fit <- fit_mfrm(
    toy,
    "Person",
    c("Rater", "Criterion"),
    "Score",
    method = "MML",
    model = "RSM",
    quad_points = 7,
    maxit = 25
  )
  gpcm_fit <- suppressWarnings(fit_mfrm(
    toy,
    "Person",
    c("Rater", "Criterion"),
    "Score",
    method = "MML",
    model = "GPCM",
    step_facet = "Criterion",
    slope_facet = "Criterion",
    quad_points = 7,
    maxit = 25
  ))

  audit <- build_weighting_review(rasch_fit, gpcm_fit, theta_points = 31, top_n = 6)

  expect_s3_class(audit, "mfrm_weighting_review")
  expect_s3_class(audit, "mfrm_bundle")
  expect_true(all(c(
    "overview", "status", "model_comparison", "facet_shift", "slope_profile",
    "information_redistribution", "top_reweighted_levels", "plot_map",
    "reporting_map", "support_status", "notes", "settings"
  ) %in% names(audit)))
  expect_true(all(c(
    "Facet", "Level", "ReferenceEstimate", "ComparisonEstimate",
    "DeltaEstimate", "AbsDeltaEstimate", "ReferenceRank", "ComparisonRank",
    "RankShift"
  ) %in% names(audit$facet_shift)))
  expect_true(all(c(
    "SlopeFacet", "Estimate", "LogEstimate", "RelativeWeight",
    "WeightingDirection"
  ) %in% names(audit$slope_profile)))
  expect_true(all(c(
    "Facet", "Level", "ReferenceInfoShare", "ComparisonInfoShare",
    "InfoShareDelta"
  ) %in% names(audit$information_redistribution)))
})

test_that("summary methods for build_weighting_review expose front-door tables", {
  toy <- load_mfrmr_data("example_core")
  keep_people <- unique(toy$Person)[1:12]
  toy <- toy[toy$Person %in% keep_people, , drop = FALSE]

  rasch_fit <- fit_mfrm(
    toy,
    "Person",
    c("Rater", "Criterion"),
    "Score",
    method = "MML",
    model = "PCM",
    step_facet = "Criterion",
    quad_points = 7,
    maxit = 25
  )
  gpcm_fit <- suppressWarnings(fit_mfrm(
    toy,
    "Person",
    c("Rater", "Criterion"),
    "Score",
    method = "MML",
    model = "GPCM",
    step_facet = "Criterion",
    slope_facet = "Criterion",
    quad_points = 7,
    maxit = 25
  ))

  audit <- build_weighting_review(rasch_fit, gpcm_fit, theta_points = 21, top_n = 5)
  sx <- summary(audit, top_n = 3)

  expect_s3_class(sx, "summary.mfrm_weighting_review")
  expect_true(all(c(
    "overview", "status", "key_warnings", "next_actions",
    "top_measure_shifts", "top_reweighted_levels",
    "plot_map", "reporting_map", "support_status"
  ) %in% names(sx)))
  expect_lte(nrow(sx$top_measure_shifts), 3)
  expect_lte(nrow(sx$top_reweighted_levels), 3)
})

test_that("build_weighting_review requires shared prepared response data", {
  toy <- load_mfrmr_data("example_core")
  keep_people <- unique(toy$Person)[1:12]
  toy <- toy[toy$Person %in% keep_people, , drop = FALSE]

  rasch_fit <- fit_mfrm(
    toy,
    "Person",
    c("Rater", "Criterion"),
    "Score",
    method = "MML",
    model = "RSM",
    quad_points = 7,
    maxit = 25
  )

  toy_less <- toy[toy$Person != keep_people[[1]], , drop = FALSE]
  gpcm_fit <- suppressWarnings(fit_mfrm(
    toy_less,
    "Person",
    c("Rater", "Criterion"),
    "Score",
    method = "MML",
    model = "GPCM",
    step_facet = "Criterion",
    slope_facet = "Criterion",
    quad_points = 7,
    maxit = 25
  ))

  expect_error(
    build_weighting_review(rasch_fit, gpcm_fit, theta_points = 21),
    "same prepared response data"
  )
})