tests/testthat/test-core-coverage-gaps.R

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

# Tests targeting uncovered line ranges in R/mfrm_core.R
# Each test_that block documents which lines it targets.

with_null_device <- function(expr) {
  grDevices::pdf(NULL)
  on.exit(grDevices::dev.off(), add = TRUE)
  force(expr)
}

# ---------------------------------------------------------------------------
# Helper: build a small reusable fit + diagnostics pair
# ---------------------------------------------------------------------------
build_test_fit <- function(model = "RSM", method = "JML", seed = 42) {
  set.seed(seed)
  d <- mfrmr:::sample_mfrm_data(seed = seed)
  suppressWarnings(
    mfrmr::fit_mfrm(
      data    = d,
      person  = "Person",
      facets  = c("Rater", "Task", "Criterion"),
      score   = "Score",
      method  = method,
      model   = model,
      maxit   = 20,
      quad_points = 7
    )
  )
}

# ===========================================================================
# 1. expand_facet_with_constraints: grouped k>1 branch  (lines 149-152)
#    AND ungrouped m==1 centered branch                  (line 162)
# ===========================================================================
test_that("expand_facet_with_constraints handles group k>1 and ungrouped m==1", {
  expand_fn <- mfrmr:::expand_facet_with_constraints

  # ---- grouped, k > 1 (lines 149-152) ----
  spec_grouped <- list(
    anchors      = c(A = NA, B = NA, C = 1.5),
    groups       = c(A = "g1", B = "g1", C = NA),
    group_values = list(g1 = 0),
    centered     = TRUE
  )
  # Two free in group => uses lines 149-152

  result <- expand_fn(c(0.3), spec_grouped)
  expect_equal(length(result), 3)
  expect_equal(result[["C"]], 1.5)
  # group constraint: mean of A,B,C in group g1 = 0 * 2 levels in group
  # but only A,B are in group, and both are free => k=2
  # target_sum = 0*2 = 0; anchor_sum = 0 (both NA); seg = 0.3; last = 0 - 0 - 0.3 = -0.3
  expect_equal(result[["A"]], 0.3)
  expect_equal(result[["B"]], -0.3)

  # ---- ungrouped m == 1, centered => line 162 (value = 0) ----
  spec_single_centered <- list(
    anchors      = c(X = NA),
    groups       = c(X = NA),
    group_values = list(),
    centered     = TRUE
  )
  result2 <- expand_fn(numeric(0), spec_single_centered)
  expect_equal(result2[["X"]], 0)
})

# ===========================================================================
# 2. build_param_sizes: PCM with bad step_facet (lines 188-190)
# ===========================================================================
test_that("build_param_sizes errors for PCM without valid step_facet", {
  build_param_sizes <- mfrmr:::build_param_sizes

  mock_config <- list(
    model       = "PCM",
    method      = "JMLE",
    facet_names = c("Rater", "Task"),
    facet_specs = list(
      Rater = list(n_params = 2),
      Task  = list(n_params = 3)
    ),
    theta_spec  = list(n_params = 5),
    step_facet  = "BadFacet",
    n_cat       = 5
  )
  expect_error(build_param_sizes(mock_config), "PCM model requires")
  # Also test NULL step_facet
  mock_config$step_facet <- NULL
  expect_error(build_param_sizes(mock_config), "PCM model requires")
})

# ===========================================================================
# 3. prepare_mfrm_data: duplicate column names in data (lines 263-268)
#    AND no facet columns (lines 270-273)
#    AND score recoding branch (lines 328-330)
# ===========================================================================
test_that("prepare_mfrm_data errors on duplicate required cols in data", {
  prep_fn <- mfrmr:::prepare_mfrm_data

  # Duplicate column names in data, where a required column is duplicated
  # Build df with columns: Person, Score, Rater, Person (duplicate)
  df_dup <- data.frame(Person = c("A", "B"), Score = c(1, 2),
                       Rater = c("R1", "R2"), Person2 = c("X", "Y"))
  names(df_dup) <- c("Person", "Score", "Rater", "Person")  # force duplicate on "Person"

  expect_error(
    prep_fn(df_dup, person_col = "Person", facet_cols = "Rater",
            score_col = "Score"),
    "duplicate"
  )
})

test_that("prepare_mfrm_data errors when no facet columns given", {
  prep_fn <- mfrmr:::prepare_mfrm_data
  df <- data.frame(Person = c("A", "B"), Score = c(1, 2), Rater = c("R1", "R2"))
  expect_error(
    prep_fn(df, person_col = "Person", facet_cols = character(0),
            score_col = "Score"),
    "No facet columns"
  )
})

test_that("prepare_mfrm_data recodes non-contiguous scores (lines 328-330)", {
  prep_fn <- mfrmr:::prepare_mfrm_data
  df <- data.frame(
    Person = rep(paste0("P", 1:4), each = 3),
    Rater  = rep(paste0("R", 1:3), 4),
    Score  = rep(c(1, 3, 5), 4)  # non-contiguous
  )
  result <- prep_fn(df, person_col = "Person", facet_cols = "Rater",
                    score_col = "Score", keep_original = FALSE)
  # After recoding, should be contiguous starting at rating_min
  expect_true(all(result$data$score_k %in% 0:2))
})

# ===========================================================================
# 4. format_tab_template (lines 412-425)
# ===========================================================================
test_that("format_tab_template produces tab-separated text", {
  fmt_fn <- mfrmr:::format_tab_template
  df <- data.frame(A = c("hello", "world"), B = c(1, NA))
  out <- fmt_fn(df)
  expect_true(is.character(out))
  expect_true(grepl("\t", out))
  expect_true(grepl("hello", out))
  # NA should become ""
  lines <- strsplit(out, "\n")[[1]]
  expect_equal(length(lines), 3)  # header + 2 rows
})

# ===========================================================================
# 5. sanitize_dummy_facets (related to lines 700-703)
# ===========================================================================
test_that("sanitize_dummy_facets filters to valid facet names", {
  fn <- mfrmr:::sanitize_dummy_facets
  expect_equal(fn(NULL, c("Rater", "Task")), character(0))
  expect_equal(fn("Rater", c("Rater", "Task")), "Rater")
  expect_equal(fn("BadName", c("Rater", "Task")), character(0))
  expect_equal(fn(c("Rater", "BadName"), c("Rater", "Task")), "Rater")
  expect_equal(fn("Person", c("Rater", "Task")), "Person")
})

# ===========================================================================
# 6. read_flexible_table (lines 778-783) file_input path
# ===========================================================================
test_that("read_flexible_table reads from file_input", {
  read_fn <- mfrmr:::read_flexible_table
  tmp <- tempfile(fileext = ".csv")
  on.exit(unlink(tmp), add = TRUE)
  write.csv(data.frame(X = 1:3, Y = letters[1:3]), tmp, row.names = FALSE)

  file_input <- list(datapath = tmp, name = "test.csv")
  result <- read_fn(text_value = NULL, file_input = file_input)
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 3)
  expect_true("X" %in% names(result))

  # Also test .tsv extension triggers tab separator
  tmp_tsv <- tempfile(fileext = ".tsv")
  on.exit(unlink(tmp_tsv), add = TRUE)
  writeLines("A\tB\n1\t2\n3\t4", tmp_tsv)
  file_input_tsv <- list(datapath = tmp_tsv, name = "test.tsv")
  result_tsv <- read_fn(text_value = NULL, file_input = file_input_tsv)
  expect_true(is.data.frame(result_tsv))
})

# ===========================================================================
# 7. summarize_unexpected_response_table empty path (lines 1889-1898)
# ===========================================================================
test_that("summarize_unexpected_response_table returns zero-row summary for NULL input", {
  summarize_fn <- mfrmr:::summarize_unexpected_response_table
  result <- summarize_fn(NULL, total_observations = 100, abs_z_min = 2, prob_max = 0.30, rule = "either")
  expect_true(is.data.frame(result))
  expect_equal(result$UnexpectedN, 0L)
  expect_equal(result$TotalObservations, 100)
  expect_equal(result$Rule, "either")

  # Empty tibble
  result2 <- summarize_fn(dplyr::tibble(), total_observations = 50)
  expect_equal(result2$UnexpectedN, 0L)
})

# ===========================================================================
# 8. calc_displacement_table: measures=NULL path (lines 2000-2001)
#    AND anchor_tbl empty path (lines 2005-2006)
# ===========================================================================
test_that("calc_displacement_table handles NULL measures", {
  fit <- build_test_fit()
  diag <- mfrmr::diagnose_mfrm(fit)
  obs_df <- diag$obs

  calc_fn <- mfrmr:::calc_displacement_table
  result <- calc_fn(obs_df, res = fit, measures = NULL)
  expect_true(is.data.frame(result))
  expect_true("Displacement" %in% names(result))
  # Since measures=NULL, Estimate column should be NA
  expect_true(all(is.na(result$Estimate)))
})

# ===========================================================================
# 9. summarize_displacement_table empty path (lines 2057-2066)
# ===========================================================================
test_that("summarize_displacement_table returns default for NULL/empty input", {
  summarize_fn <- mfrmr:::summarize_displacement_table
  result <- summarize_fn(NULL)
  expect_true(is.data.frame(result))
  expect_equal(result$Levels, 0L)
  expect_equal(result$AnchoredLevels, 0L)
  expect_true(is.na(result$MaxAbsDisplacement))

  result2 <- summarize_fn(dplyr::tibble())
  expect_equal(result2$Levels, 0L)
})

# ===========================================================================
# 10. calc_bias_interactions: empty pairs (lines 2228-2231)
# ===========================================================================
test_that("calc_bias_interactions returns empty for empty pairs list", {
  calc_fn <- mfrmr:::calc_bias_interactions
  df <- data.frame(
    Rater = c("R1", "R2", "R1", "R2"),
    Task  = c("T1", "T1", "T2", "T2"),
    Observed = c(1, 2, 3, 4),
    Expected = c(1.5, 1.5, 3.5, 3.5),
    Weight   = rep(1, 4)
  )
  # empty pairs => tibble()
  result <- calc_fn(df, facet_cols = c("Rater", "Task"), pairs = list())
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 0)
})

# ===========================================================================
# 11. estimate_eta_from_target edge cases (lines 2506-2520)
# ===========================================================================
test_that("estimate_eta_from_target handles edge cases", {
  est_fn <- mfrmr:::estimate_eta_from_target
  step_cum_4 <- c(0, -0.5, 0.0, 0.5)  # 4 categories
  # target <= rating_min => -Inf
  expect_equal(est_fn(target = 1, step_cum = step_cum_4, rating_min = 1, rating_max = 4), -Inf)
  # target >= rating_max => Inf
  expect_equal(est_fn(target = 4, step_cum = step_cum_4, rating_min = 1, rating_max = 4), Inf)
  # non-finite target => NA
  expect_true(is.na(est_fn(target = NA, step_cum = step_cum_4, rating_min = 1, rating_max = 4)))
  # empty step_cum => NA
  expect_true(is.na(est_fn(target = 2.5, step_cum = numeric(0), rating_min = 1, rating_max = 4)))
  # normal case - should return a finite number
  result <- est_fn(target = 2.5, step_cum = step_cum_4, rating_min = 1, rating_max = 4)
  expect_true(is.finite(result))
})

# ===========================================================================
# 12. expected_score_from_eta edge cases (lines 2498-2502)
# ===========================================================================
test_that("expected_score_from_eta returns NA for bad inputs", {
  fn <- mfrmr:::expected_score_from_eta
  expect_true(is.na(fn(eta = NA, step_cum = c(0, 0.5, 1.0), rating_min = 1)))
  expect_true(is.na(fn(eta = 1.0, step_cum = numeric(0), rating_min = 1)))
  # normal case with 3 categories (step_cum has 3 elements)
  result <- fn(eta = 0, step_cum = c(0, 0.5, 1.0), rating_min = 1)
  expect_true(length(result) == 1)
  expect_true(is.numeric(result))
})

# ===========================================================================
# 13. extract_bias_facet_spec: FacetA_Level/FacetB_Level path (lines 1634-1651)
# ===========================================================================
test_that("extract_bias_facet_spec handles FacetA/FacetB columns", {
  extract_fn <- mfrmr:::extract_bias_facet_spec

  tbl <- dplyr::tibble(
    FacetA = c("Rater", "Rater"),
    FacetB = c("Task", "Task"),
    FacetA_Level = c("R1", "R2"),
    FacetB_Level = c("T1", "T1"),
    FacetA_Index = c(1L, 2L),
    FacetB_Index = c(1L, 1L),
    FacetA_Measure = c(0.5, -0.5),
    FacetB_Measure = c(0.0, 0.0),
    FacetA_SE = c(0.1, 0.1),
    FacetB_SE = c(0.2, 0.2),
    `Bias Size` = c(0.3, -0.3)
  )
  bias_results <- list(
    table = tbl,
    interaction_facets = NULL,
    facet_a = NULL,
    facet_b = NULL
  )
  result <- extract_fn(bias_results)
  expect_true(is.list(result))
  expect_equal(result$facets, c("Rater", "Task"))
  expect_equal(result$level_cols, c("FacetA_Level", "FacetB_Level"))
})

test_that("extract_bias_facet_spec returns NULL when facets < 2", {
  extract_fn <- mfrmr:::extract_bias_facet_spec
  # FacetA/FacetB with insufficient facet names
  tbl <- dplyr::tibble(
    FacetA_Level = c("R1"),
    FacetB_Level = c("T1"),
    `Bias Size` = c(0.1)
  )
  bias_results <- list(table = tbl, interaction_facets = NULL, facet_a = NULL, facet_b = NULL)
  # facets extracted are empty, length < 2 => NULL
  result <- extract_fn(bias_results)
  expect_null(result)
})

test_that("extract_bias_facet_spec returns NULL for data_cols mismatch (line 1650-1651)", {
  extract_fn <- mfrmr:::extract_bias_facet_spec
  tbl <- dplyr::tibble(
    FacetA = c("Rater"),
    FacetB = c("Task"),
    FacetA_Level = c("R1"),
    FacetB_Level = c("T1"),
    FacetA_Index = c(1L),
    FacetB_Index = c(1L),
    FacetA_Measure = c(0.5),
    FacetB_Measure = c(0.0),
    FacetA_SE = c(0.1),
    FacetB_SE = c(0.2),
    `Bias Size` = c(0.3)
  )
  bias_results <- list(table = tbl, interaction_facets = NULL, facet_a = NULL, facet_b = NULL)
  # data_cols mismatch - facets don't appear in data_cols
  result <- extract_fn(bias_results, data_cols = c("SomethingElse"))
  expect_null(result)
})

# ===========================================================================
# 14. extract_bias_facet_spec: NULL / empty table (line 1591-1593)
# ===========================================================================
test_that("extract_bias_facet_spec returns NULL for empty inputs", {
  extract_fn <- mfrmr:::extract_bias_facet_spec
  expect_null(extract_fn(NULL))
  expect_null(extract_fn(list(table = NULL)))
  expect_null(extract_fn(list(table = dplyr::tibble())))
})

# ===========================================================================
# 15. category_warnings_text: disordered thresholds (lines 3158-3161)
# ===========================================================================
test_that("category_warnings_text reports disordered thresholds", {
  warnings_fn <- mfrmr:::category_warnings_text
  cat_tbl <- dplyr::tibble(
    Category = 1:5,
    Count = c(50, 60, 70, 80, 90),
    AvgPersonMeasure = c(-1, -0.5, 0, 0.5, 1)
  )
  step_tbl <- dplyr::tibble(
    StepFacet = c("Common", "Common", "Common", "Common"),
    Step      = paste0("Step_", 1:4),
    Estimate  = c(-1.5, -0.5, 0.5, -0.2),  # step 4 is disordered
    StepIndex = 1:4,
    Spacing   = c(NA, 1.0, 1.0, -0.7),
    Ordered   = c(NA, TRUE, TRUE, FALSE)
  )
  result <- warnings_fn(cat_tbl, step_tbl)
  expect_true(grepl("Disordered thresholds", result))
  expect_true(grepl("Common:Step_4", result))
})

# ===========================================================================
# 16. get_extreme_levels: facet not in obs_df (lines 3174-3176)
# ===========================================================================
test_that("get_extreme_levels returns empty for missing facet column", {
  get_fn <- mfrmr:::get_extreme_levels
  obs_df <- dplyr::tibble(
    Rater    = c("R1", "R2"),
    Observed = c(1, 5)
  )
  result <- get_fn(obs_df, facet_names = c("Rater", "MissingFacet"),
                   rating_min = 1, rating_max = 5)
  expect_equal(result$MissingFacet, character(0))
  expect_true(is.character(result$Rater))
})

# ===========================================================================
# 17. estimate_bias_interaction: short-circuit paths (lines 3218-3220)
# ===========================================================================
test_that("estimate_bias_interaction returns empty for insufficient facets", {
  fn <- mfrmr:::estimate_bias_interaction
  fit <- build_test_fit()
  diag <- mfrmr::diagnose_mfrm(fit)

  # selected_facets < 2 => empty list
  result1 <- fn(res = fit, diagnostics = diag,
                facet_a = NULL, facet_b = NULL,
                interaction_facets = "Rater")
  expect_equal(result1, list())

  # selected_facets not all in facet_names => empty list
  result2 <- fn(res = fit, diagnostics = diag,
                interaction_facets = c("Rater", "NotAFacet"))
  expect_equal(result2, list())

  # NULL res => empty list
  result3 <- fn(res = NULL, diagnostics = diag,
                interaction_facets = c("Rater", "Task"))
  expect_equal(result3, list())
})

# ===========================================================================
# 18. estimate_bias_interaction: PCM branch (lines 3237-3238)
# ===========================================================================
test_that("estimate_bias_interaction works with PCM model", {
  set.seed(99)
  d <- mfrmr:::sample_mfrm_data(seed = 99)
  # Use only 2 facets: one will serve as step_facet
  d2 <- d[, c("Person", "Rater", "Task", "Score")]
  fit_pcm <- suppressWarnings(
    mfrmr::fit_mfrm(
      data    = d2,
      person  = "Person",
      facets  = c("Rater", "Task"),
      score   = "Score",
      method  = "JML",
      model   = "PCM",
      step_facet = "Rater",
      maxit   = 20,
      quad_points = 7
    )
  )
  diag_pcm <- mfrmr::diagnose_mfrm(fit_pcm)
  # This triggers PCM path in estimate_bias_interaction (line 3237-3238)
  bias_pcm <- mfrmr::estimate_bias(
    fit_pcm, diag_pcm,
    interaction_facets = c("Rater", "Task"),
    max_iter = 1
  )
  expect_true(is.list(bias_pcm))
})

# ===========================================================================
# 19. PCM model fit triggers compute_obs_table PCM path (lines 1532-1533)
#     AND compute_prob_matrix_with_bias PCM (lines 1731-1732)
#     AND compute_obs_table_with_bias PCM (lines 1745, 1751, 1766-1767)
# ===========================================================================
test_that("PCM model triggers PCM code paths in obs table functions", {
  set.seed(99)
  d <- mfrmr:::sample_mfrm_data(seed = 99)
  d2 <- d[, c("Person", "Rater", "Task", "Score")]
  fit_pcm <- suppressWarnings(
    mfrmr::fit_mfrm(
      data    = d2,
      person  = "Person",
      facets  = c("Rater", "Task"),
      score   = "Score",
      method  = "JML",
      model   = "PCM",
      step_facet = "Rater",
      maxit   = 20,
      quad_points = 7
    )
  )

  # compute_obs_table PCM path (lines 1532-1533)
  obs <- mfrmr:::compute_obs_table(fit_pcm)
  expect_true(is.data.frame(obs))
  expect_true("Observed" %in% names(obs))

  # expected_score_table PCM path
  exp_tbl <- mfrmr:::expected_score_table(fit_pcm)
  expect_true(is.data.frame(exp_tbl))
  expect_true("Expected" %in% names(exp_tbl))
})

# ===========================================================================
# 20. MML method paths: person estimates from EAP (lines 1745, 1751, 1759)
# ===========================================================================
test_that("MML method triggers EAP person estimate paths", {
  d <- mfrmr:::sample_mfrm_data(seed = 42)
  fit_mml <- suppressWarnings(
    mfrmr::fit_mfrm(
      data    = d,
      person  = "Person",
      facets  = c("Rater", "Task", "Criterion"),
      score   = "Score",
      method  = "MML",
      model   = "RSM",
      maxit   = 20,
      quad_points = 7
    )
  )
  # MML triggers theta from res$facets$person$Estimate
  diag_mml <- mfrmr::diagnose_mfrm(fit_mml)
  expect_true(is.data.frame(diag_mml$obs))
  expect_true("Observed" %in% names(diag_mml$obs))

  # compute_obs_table_with_bias MML path (line 1745, 1751, 1759)
  obs_bias <- mfrmr:::compute_obs_table_with_bias(fit_mml, bias_results = NULL)
  expect_true(is.data.frame(obs_bias))

  # compute_prob_matrix_with_bias MML path
  probs <- mfrmr:::compute_prob_matrix_with_bias(fit_mml, bias_results = NULL)
  expect_true(is.matrix(probs))
})

# ===========================================================================
# 21. facet_anchor_status (around lines 2525-2537)
# ===========================================================================
test_that("facet_anchor_status reports correct status", {
  fn <- mfrmr:::facet_anchor_status
  fit <- build_test_fit()
  # Without anchors, should return empty strings
  result <- fn("Rater", c("R1", "R2", "R3"), fit$config)
  expect_true(is.character(result))
  expect_equal(length(result), 3)
})

# ===========================================================================
# 22. compute_pca_by_facet: wide table too small (lines 3805-3807, 3812-3814)
# ===========================================================================
test_that("compute_pca_by_facet handles too-small data", {
  pca_fn <- mfrmr:::compute_pca_by_facet
  # Minimal obs_df with only 1 person => facet PCA should return a no-data bundle
  obs_df <- dplyr::tibble(
    Person     = "P1",
    Rater      = "R1",
    StdResidual = 0.5
  )
  result <- pca_fn(obs_df, facet_names = "Rater", max_factors = 3)
  expect_true(is.list(result[["Rater"]]))
  expect_null(result[["Rater"]]$pca)
  expect_true(nzchar(if (is.null(result[["Rater"]]$error)) "" else result[["Rater"]]$error))
})

test_that("compute_pca_by_facet handles single-column wide matrix", {
  pca_fn <- mfrmr:::compute_pca_by_facet
  # Multiple persons but only one level of the facet => no usable facet PCA
  obs_df <- dplyr::tibble(
    Person      = c("P1", "P2", "P3"),
    Rater       = c("R1", "R1", "R1"),
    StdResidual = c(0.1, 0.2, 0.3)
  )
  result <- pca_fn(obs_df, facet_names = "Rater", max_factors = 3)
  expect_true(is.list(result[["Rater"]]))
  expect_null(result[["Rater"]]$pca)
  expect_true(nzchar(if (is.null(result[["Rater"]]$error)) "" else result[["Rater"]]$error))
})

# ===========================================================================
# 23. extract_anchor_tables: anchor and group branches (lines 3638-3651)
# ===========================================================================
test_that("extract_anchor_tables with anchored fit returns source info", {
  d <- mfrmr:::sample_mfrm_data(seed = 42)
  anchor_df <- data.frame(
    Facet  = c("Rater", "Rater"),
    Level  = c("R1", "R2"),
    Anchor = c(0.0, 0.5)
  )
  fit_anch <- suppressWarnings(
    mfrmr::fit_mfrm(
      data    = d,
      person  = "Person",
      facets  = c("Rater", "Task", "Criterion"),
      score   = "Score",
      method  = "JML",
      model   = "RSM",
      anchors = anchor_df,
      maxit   = 20,
      quad_points = 7
    )
  )
  extract_fn <- mfrmr:::extract_anchor_tables
  result <- extract_fn(fit_anch$config)
  expect_true(is.data.frame(result$anchors))
  expect_true(nrow(result$anchors) > 0)
  expect_true("Source" %in% names(result$anchors))
})

# ===========================================================================
# 24. N column fallback (lines 3877-3884 in diagnose_mfrm / mfrm_diagnostics)
# ===========================================================================
test_that("diagnose_mfrm handles N column correctly", {
  fit <- build_test_fit()
  diag <- mfrmr::diagnose_mfrm(fit)
  expect_true(!is.null(diag$measures))
  expect_true("N" %in% names(diag$measures) ||
              "N.x" %in% names(diag$measures) ||
              is.data.frame(diag$measures))
})

# ===========================================================================
# 25. calc_bias_interactions with single facet col (line 2224)
# ===========================================================================
test_that("calc_bias_interactions returns empty tibble for < 2 facet_cols", {
  calc_fn <- mfrmr:::calc_bias_interactions
  df <- data.frame(
    Rater    = c("R1", "R2"),
    Observed = c(1, 2),
    Expected = c(1.5, 1.5),
    Weight   = c(1, 1)
  )
  result <- calc_fn(df, facet_cols = "Rater")
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 0)
})

# ===========================================================================
# 26. calc_step_order (lines 3104-3118)
# ===========================================================================
test_that("calc_step_order handles NULL and missing StepFacet", {
  fn <- mfrmr:::calc_step_order
  expect_equal(nrow(fn(NULL)), 0)
  expect_equal(nrow(fn(dplyr::tibble())), 0)

  # Missing StepFacet column
  step_tbl <- dplyr::tibble(
    Step     = c("Step_1", "Step_2", "Step_3"),
    Estimate = c(-1.0, 0.0, 1.0)
  )
  result <- fn(step_tbl)
  expect_true("StepFacet" %in% names(result))
  expect_true("Ordered" %in% names(result))
  expect_true(all(result$StepFacet == "Common"))
})

# ===========================================================================
# 27. category_warnings_text edge cases (lines 3121-3168)
# ===========================================================================
test_that("category_warnings_text handles no warnings", {
  fn <- mfrmr:::category_warnings_text
  cat_tbl <- dplyr::tibble(
    Category = 1:3,
    Count = c(50, 50, 50),
    AvgPersonMeasure = c(-1, 0, 1)
  )
  result <- fn(cat_tbl, step_tbl = NULL)
  expect_equal(result, "No major category warnings detected.")
})

test_that("category_warnings_text reports unused categories", {
  fn <- mfrmr:::category_warnings_text
  cat_tbl <- dplyr::tibble(
    Category = 1:3,
    Count = c(0, 50, 50),
    AvgPersonMeasure = c(NA, 0, 1)
  )
  result <- fn(cat_tbl)
  expect_true(grepl("Unused categories", result))
})

test_that("category_warnings_text reports non-monotonic averages", {
  fn <- mfrmr:::category_warnings_text
  cat_tbl <- dplyr::tibble(
    Category = 1:4,
    Count = c(50, 50, 50, 50),
    AvgPersonMeasure = c(-1, 0, 1, 0.5)  # not monotonic
  )
  result <- fn(cat_tbl)
  expect_true(grepl("not monotonic", result))
})

test_that("category_warnings_text: NULL input", {
  fn <- mfrmr:::category_warnings_text
  expect_equal(fn(NULL), "No category diagnostics available.")
})

# ===========================================================================
# 28. weighted_mean edge case: all non-finite
# ===========================================================================
test_that("weighted_mean returns NA for all-non-finite inputs", {
  fn <- mfrmr:::weighted_mean
  expect_true(is.na(fn(c(NA, Inf), c(1, 1))))
  expect_true(is.na(fn(c(1, 2), c(0, 0))))
  expect_equal(fn(c(1, 3), c(1, 1)), 2)
})

# ===========================================================================
# 29. get_weights: no Weight column (line 22)
# ===========================================================================
test_that("get_weights returns 1s when no Weight column present", {
  fn <- mfrmr:::get_weights
  df <- data.frame(X = 1:5)
  result <- fn(df)
  expect_equal(result, rep(1, 5))

  # With Weight column
  df2 <- data.frame(X = 1:3, Weight = c(1, 2, 0))
  result2 <- fn(df2)
  expect_equal(result2, c(1, 2, 0))
})

# ===========================================================================
# 30. gauss_hermite_normal: n < 1 error
# ===========================================================================
test_that("gauss_hermite_normal errors for n < 1", {
  fn <- mfrmr:::gauss_hermite_normal
  expect_error(fn(0), "n >= 1")
})

# ===========================================================================
# 31. PCM MML model: triggers more branches
# ===========================================================================
test_that("PCM with MML triggers MML-specific PCM paths", {
  set.seed(88)
  d <- mfrmr:::sample_mfrm_data(seed = 88)
  d2 <- d[, c("Person", "Rater", "Task", "Score")]
  fit_pcm_mml <- suppressWarnings(
    mfrmr::fit_mfrm(
      data    = d2,
      person  = "Person",
      facets  = c("Rater", "Task"),
      score   = "Score",
      method  = "MML",
      model   = "PCM",
      step_facet = "Rater",
      maxit   = 20,
      quad_points = 7
    )
  )
  expect_s3_class(fit_pcm_mml, "mfrm_fit")
  expect_equal(fit_pcm_mml$config$model, "PCM")
  expect_equal(fit_pcm_mml$config$method, "MML")

  # compute_obs_table_with_bias with PCM MML => lines 1745, 1751, 1766-1767
  obs_bias <- mfrmr:::compute_obs_table_with_bias(fit_pcm_mml, bias_results = NULL)
  expect_true(is.data.frame(obs_bias))
  expect_true("StdResidual" %in% names(obs_bias))

  # Expected score table PCM MML
  exp_tbl <- mfrmr:::expected_score_table(fit_pcm_mml)
  expect_true(is.data.frame(exp_tbl))
})

# ===========================================================================
# 32. compute_obs_table_with_bias: bias_adj length mismatch (line 1758-1759)
# ===========================================================================
test_that("compute_obs_table_with_bias handles mismatched bias_adj length", {
  fn <- mfrmr:::compute_obs_table_with_bias
  fit <- build_test_fit()
  # Pass bias_results that would create a mismatched length
  # A NULL bias_results produces zeros, but let's confirm it works
  result <- fn(fit, bias_results = NULL)
  expect_true(is.data.frame(result))
  expect_true(all(c("Observed", "Expected", "StdResidual") %in% names(result)))
})

# ===========================================================================
# 33. sample_mfrm_data works with default and custom seed
# ===========================================================================
test_that("sample_mfrm_data produces consistent data", {
  fn <- mfrmr:::sample_mfrm_data
  d1 <- fn(seed = 123)
  d2 <- fn(seed = 123)
  expect_equal(d1, d2)
  expect_true(all(c("Person", "Rater", "Task", "Criterion", "Score") %in% names(d1)))
  expect_equal(nrow(d1), 36 * 3 * 4 * 3)
})

# ===========================================================================
# 34. read_flexible_table: text parsing paths (lines 785-793)
# ===========================================================================
test_that("read_flexible_table handles text input", {
  fn <- mfrmr:::read_flexible_table
  # NULL text => empty tibble
  result <- fn(text_value = NULL, file_input = NULL)
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 0)

  # empty string
  result2 <- fn(text_value = "", file_input = NULL)
  expect_equal(nrow(result2), 0)

  # tab-separated text
  tab_text <- "A\tB\n1\t2\n3\t4"
  result3 <- fn(text_value = tab_text, file_input = NULL)
  expect_true(is.data.frame(result3))
  expect_equal(nrow(result3), 2)

  # comma-separated text
  csv_text <- "A,B\n1,2\n3,4"
  result4 <- fn(text_value = csv_text, file_input = NULL)
  expect_true(is.data.frame(result4))
  expect_equal(nrow(result4), 2)
})

# ===========================================================================
# 35. prepare_mfrm_data: duplicate argument names (lines 250-254)
# ===========================================================================
test_that("prepare_mfrm_data errors on duplicate argument columns", {
  prep_fn <- mfrmr:::prepare_mfrm_data
  df <- data.frame(Person = c("A", "B"), Score = c(1, 2), Rater = c("R1", "R2"))
  expect_error(
    prep_fn(df, person_col = "Person", facet_cols = "Person",
            score_col = "Score"),
    "distinct columns"
  )
})

# ===========================================================================
# 36. summarize_displacement_table: table without Flag column (lines 2069-2072)
# ===========================================================================
test_that("summarize_displacement_table handles missing Flag column", {
  fn <- mfrmr:::summarize_displacement_table
  tbl <- dplyr::tibble(
    Facet            = c("Rater", "Rater"),
    Level            = c("R1", "R2"),
    Displacement     = c(0.3, -0.2),
    DisplacementT    = c(1.0, -0.5),
    AnchorType       = c("Anchor", "Free")
  )
  # No "Flag" column => falls back to rep(FALSE, ...) at lines 2069-2072
  result <- fn(tbl)
  expect_true(is.data.frame(result))
  expect_equal(result$FlaggedLevels, 0L)
})

# ===========================================================================
# 37. build_facet_measure_table: extreme level handling (lines 2752-2764)
# ===========================================================================
test_that("diagnostics include facet measure tables with extreme handling", {
  fit <- build_test_fit()
  diag <- mfrmr::diagnose_mfrm(fit)
  # Just verify that measures are produced correctly
  expect_true(is.data.frame(diag$measures))
  expect_true("Estimate" %in% names(diag$measures))
  expect_true("Facet" %in% names(diag$measures))
  expect_true(nrow(diag$measures) > 0)
})

# ===========================================================================
# 38. Full PCM bias/diagnostics round-trip covering PCM conditional paths
# ===========================================================================
test_that("full PCM round-trip covers PCM-specific branches", {
  set.seed(77)
  d <- mfrmr:::sample_mfrm_data(seed = 77)
  d2 <- d[, c("Person", "Rater", "Task", "Score")]

  fit_pcm <- suppressWarnings(
    mfrmr::fit_mfrm(
      data       = d2,
      person     = "Person",
      facets     = c("Rater", "Task"),
      score      = "Score",
      method     = "JML",
      model      = "PCM",
      step_facet = "Rater",
      maxit      = 20,
      quad_points = 7
    )
  )

  diag_pcm <- mfrmr::diagnose_mfrm(fit_pcm, residual_pca = "both",
                                     pca_max_factors = 3)
  expect_s3_class(diag_pcm, "mfrm_diagnostics")
  expect_true(is.data.frame(diag_pcm$obs))

  # Bias estimation with PCM
  bias_pcm <- mfrmr::estimate_bias(
    fit_pcm, diag_pcm,
    interaction_facets = c("Rater", "Task"),
    max_iter = 2
  )
  expect_true(is.list(bias_pcm))
  if (length(bias_pcm) > 0) {
    expect_true("table" %in% names(bias_pcm))
  }
})

# ===========================================================================
# 39. category_warnings_text: DiffPercent and ZSTD warnings
# ===========================================================================
test_that("category_warnings_text reports DiffPercent and ZSTD warnings", {
  fn <- mfrmr:::category_warnings_text
  cat_tbl <- dplyr::tibble(
    Category = 1:3,
    Count = c(50, 50, 50),
    AvgPersonMeasure = c(-1, 0, 1),
    DiffPercent = c(0, 6, -7),
    InfitZSTD = c(0.5, 2.5, 0.5),
    OutfitZSTD = c(0.5, 0.5, 2.5)
  )
  result <- fn(cat_tbl)
  expect_true(grepl("differs by >= 5", result))
  expect_true(grepl("ZSTD", result))
})

# ===========================================================================
# 40. compute_pca_by_facet: correlation matrix issues (lines 3817-3820)
# ===========================================================================
test_that("compute_pca_by_facet handles constant columns gracefully", {
  pca_fn <- mfrmr:::compute_pca_by_facet
  # Data with constant StdResidual for one level => correlation will have NAs
  obs_df <- dplyr::tibble(
    Person      = rep(paste0("P", 1:10), each = 2),
    Rater       = rep(c("R1", "R2"), 10),
    StdResidual = c(rep(0, 10), rnorm(10))  # R1 is constant
  )
  result <- pca_fn(obs_df, facet_names = "Rater", max_factors = 1)
  # Should still produce a result (NAs handled in cor) or NULL
  # The key thing is it doesn't error
  expect_true(is.list(result))
})

# ===========================================================================
# 41. logsumexp
# ===========================================================================
test_that("logsumexp is numerically stable", {
  fn <- mfrmr:::logsumexp
  # Large values that would overflow naive implementation
  result <- fn(c(1000, 1001))
  expect_true(is.finite(result))
  expect_equal(result, 1001 + log(1 + exp(-1)), tolerance = 1e-10)
})