tests/testthat/test-conditional_infit.R

In easyRasch2: Psychometric Analysis with Rasch Measurement Theory

test_that("RMitemInfit errors when iarm is not installed", {
  skip_if(
    requireNamespace("iarm", quietly = TRUE),
    "iarm is installed; skipping missing-package error path test"
  )
  set.seed(42)
  df <- as.data.frame(matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5))
  expect_error(RMitemInfit(df), regexp = "iarm")
})

test_that("RMitemInfit errors when data does not start at 0", {
  skip_if_not_installed("iarm")
  df <- as.data.frame(matrix(sample(1:3, 200, replace = TRUE), nrow = 40, ncol = 5))
  expect_error(RMitemInfit(df), regexp = "scored starting at 0")
})

test_that("RMitemInfit errors when data is all NA", {
  skip_if_not_installed("iarm")
  df <- as.data.frame(matrix(NA_integer_, nrow = 10, ncol = 4))
  expect_error(RMitemInfit(df), regexp = "No complete|no non-missing")
})

test_that("RMitemInfit errors when data is not a data.frame or matrix", {
  skip_if_not_installed("iarm")
  expect_error(RMitemInfit(list(a = 1:5)), regexp = "data.frame or matrix")
})

test_that("RMitemInfit errors when no complete cases", {
  skip_if_not_installed("iarm")
  set.seed(42)
  df <- as.data.frame(matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5))
  # Make all rows have at least one NA by cycling through columns
  df[cbind(seq_len(nrow(df)), ((seq_len(nrow(df)) - 1L) %% ncol(df)) + 1L)] <- NA
  expect_error(RMitemInfit(df), regexp = "No complete cases")
})

test_that("RMitemInfit output = 'dataframe' returns correct structure (dichotomous)", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  result <- RMitemInfit(df, output = "dataframe")

  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 5L)
  expect_equal(names(result), c("Item", "Infit_MSQ", "Relative_location"))
  expect_equal(result$Item, colnames(df))
  expect_true(all(result$Infit_MSQ > 0))
})

test_that("RMitemInfit output = 'kable' returns knitr_kable with complete-cases caption", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)
  df[1, 1] <- NA # one incomplete row so the caption shows the drop + label

  result <- RMitemInfit(df, output = "kable")
  expect_s3_class(result, "knitr_kable")
  cap <- attr(result, "caption")
  if (is.null(cap)) cap <- paste(as.character(result), collapse = "\n")
  expect_true(grepl("of 40 respondents \\(complete cases\\)", cap))
})

test_that("RMitemInfit sort = 'infit' sorts by Infit_MSQ descending", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  result_sorted   <- RMitemInfit(df, output = "dataframe", sort = "infit")
  result_unsorted <- RMitemInfit(df, output = "dataframe")

  expect_true(
    all(diff(result_sorted$Infit_MSQ) <= 0),
    info = "Rows should be in descending order of Infit_MSQ"
  )
  expect_setequal(result_sorted$Item, result_unsorted$Item)
})

# ---------------------------------------------------------------------------
# cutoff parameter tests
# ---------------------------------------------------------------------------

test_that("RMitemInfit cutoff = NULL (default) behaves as before", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  result <- RMitemInfit(df, cutoff = NULL, output = "dataframe")
  expect_equal(names(result), c("Item", "Infit_MSQ", "Relative_location"))
})

test_that("RMitemInfit with mock cutoff data.frame adds expected columns", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  mock_cutoff <- data.frame(
    Item        = paste0("Item", 1:5),
    infit_low   = rep(0.7, 5),
    infit_high  = rep(1.3, 5),
    outfit_low  = rep(0.7, 5),
    outfit_high = rep(1.3, 5),
    stringsAsFactors = FALSE
  )

  result <- RMitemInfit(df, cutoff = mock_cutoff, output = "dataframe")
  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 5L)
  expect_equal(
    names(result),
    c("Item", "Infit_MSQ", "Infit_low", "Infit_high", "Flagged", "Relative_location")
  )
  expect_type(result$Flagged, "character")
  expect_true(all(result$Flagged %in% c("overfit", "underfit", "")))
  expect_true(all(result$Infit_low  == 0.7))
  expect_true(all(result$Infit_high == 1.3))
})

test_that("RMitemInfit with cutoff list (from RMitemInfitCutoff shape) extracts item_cutoffs", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  mock_cutoff_list <- list(
    item_cutoffs = data.frame(
      Item        = paste0("Item", 1:5),
      infit_low   = rep(0.7, 5),
      infit_high  = rep(1.3, 5),
      outfit_low  = rep(0.7, 5),
      outfit_high = rep(1.3, 5),
      stringsAsFactors = FALSE
    ),
    actual_iterations = 100L
  )

  result_df <- RMitemInfit(df, cutoff = mock_cutoff_list, output = "dataframe")
  expect_equal(
    names(result_df),
    c("Item", "Infit_MSQ", "Infit_low", "Infit_high", "Flagged", "Relative_location")
  )

  result_kable <- RMitemInfit(df, cutoff = mock_cutoff_list, output = "kable")
  expect_s3_class(result_kable, "knitr_kable")
  cap <- attr(result_kable, "caption")
  if (is.null(cap)) cap <- paste(as.character(result_kable), collapse = "\n")
  expect_true(grepl("100 simulation iterations", cap))
})

test_that("RMitemInfit caption includes HDCI info when cutoff_method = 'hdci'", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  mock_cutoff_hdci <- list(
    item_cutoffs = data.frame(
      Item        = paste0("Item", 1:5),
      infit_low   = rep(0.7, 5),
      infit_high  = rep(1.3, 5),
      outfit_low  = rep(0.7, 5),
      outfit_high = rep(1.3, 5),
      stringsAsFactors = FALSE
    ),
    actual_iterations = 200L,
    cutoff_method     = "hdci",
    hdci_width         = 0.999
  )

  result_kable <- RMitemInfit(df, cutoff = mock_cutoff_hdci, output = "kable")
  cap <- attr(result_kable, "caption")
  if (is.null(cap)) cap <- paste(as.character(result_kable), collapse = "\n")
  expect_true(grepl("200 simulation iterations", cap))
  expect_true(grepl("HDCI", cap))
  expect_true(grepl("99.9", cap))
})

test_that("RMitemInfit caption includes quantile info when cutoff_method = 'quantile'", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  mock_cutoff_quantile <- list(
    item_cutoffs = data.frame(
      Item        = paste0("Item", 1:5),
      infit_low   = rep(0.7, 5),
      infit_high  = rep(1.3, 5),
      outfit_low  = rep(0.7, 5),
      outfit_high = rep(1.3, 5),
      stringsAsFactors = FALSE
    ),
    actual_iterations = 150L,
    cutoff_method     = "quantile",
    hdci_width         = 0.999
  )

  result_kable <- RMitemInfit(df, cutoff = mock_cutoff_quantile, output = "kable")
  cap <- attr(result_kable, "caption")
  if (is.null(cap)) cap <- paste(as.character(result_kable), collapse = "\n")
  expect_true(grepl("150 simulation iterations", cap))
  expect_true(grepl("percentile", cap))
})

test_that("RMitemInfitCutoff errors when cutoff_method = 'hdci' but ggdist is not installed", {
  skip_if(
    requireNamespace("ggdist", quietly = TRUE),
    "ggdist is installed; skipping missing-package error path test"
  )
  set.seed(42)
  df <- as.data.frame(matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5))
  colnames(df) <- paste0("Item", 1:5)
  expect_error(
    RMitemInfitCutoff(df, iterations = 5, parallel = FALSE, seed = 42,
                  cutoff_method = "hdci"),
    regexp = "ggdist"
  )
})

test_that("RMitemInfitCutoff cutoff_method = 'quantile' returns valid cutoffs", {
  skip_on_cran()
  # RMitemInfitCutoff() fits via psychotools (Imports) + iarm; no eRm needed.
  skip_if_not_installed("iarm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 1000, replace = TRUE), nrow = 200, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  res <- RMitemInfitCutoff(df, iterations = 20, parallel = FALSE, seed = 42,
                       cutoff_method = "quantile")

  expect_equal(res$cutoff_method, "quantile")
  # hdci_width is always stored regardless of method, verify it keeps its
  # default (0.95 since 1.2.0, the interval being descriptive rather than a
  # decision rule)
  expect_equal(res$hdci_width, 0.95)
  expect_s3_class(res$item_cutoffs, "data.frame")
  expect_equal(nrow(res$item_cutoffs), 5L)
  expect_true(all(res$item_cutoffs$infit_low < res$item_cutoffs$infit_high))
  expect_true(all(res$item_cutoffs$outfit_low < res$item_cutoffs$outfit_high))
})

test_that("RMitemInfitCutoff cutoff_method = 'hdci' returns valid cutoffs", {
  skip_on_cran()
  skip_if_not_installed("iarm")
  skip_if_not_installed("ggdist")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 1000, replace = TRUE), nrow = 200, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  res <- RMitemInfitCutoff(df, iterations = 20, parallel = FALSE, seed = 42,
                       cutoff_method = "hdci", hdci_width = 0.999)

  expect_equal(res$cutoff_method, "hdci")
  expect_equal(res$hdci_width, 0.999)
  expect_s3_class(res$item_cutoffs, "data.frame")
  expect_equal(nrow(res$item_cutoffs), 5L)
  expect_true(all(res$item_cutoffs$infit_low < res$item_cutoffs$infit_high))
  expect_true(all(res$item_cutoffs$outfit_low < res$item_cutoffs$outfit_high))
})

test_that("RMitemInfitCutoff dgp = 'conditional' runs; default is 'resample'", {
  skip_on_cran()
  skip_if_not_installed("iarm")
  set.seed(6)
  df <- as.data.frame(matrix(sample(0:1, 200 * 6, replace = TRUE), 200, 6))
  colnames(df) <- paste0("I", 1:6)

  cu <- RMitemInfitCutoff(df, iterations = 20, parallel = FALSE, seed = 1,
                          dgp = "conditional")
  expect_identical(cu$dgp, "conditional")
  expect_s3_class(cu$item_cutoffs, "data.frame")
  expect_equal(nrow(cu$item_cutoffs), 6L)
  expect_true(all(cu$item_cutoffs$infit_low < cu$item_cutoffs$infit_high))

  # default DGP is unchanged
  cu_def <- RMitemInfitCutoff(df, iterations = 5, parallel = FALSE, seed = 1)
  expect_identical(cu_def$dgp, "resample")

  # the conditional object flows through RMitemInfit()
  skip_if_not_installed("eRm")
  res <- RMitemInfit(df, cutoff = cu, output = "dataframe")
  expect_true(is.data.frame(res))
})

test_that("RMitemInfit with cutoff data.frame (no actual_iterations) uses generic caption", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  mock_cutoff <- data.frame(
    Item        = paste0("Item", 1:5),
    infit_low   = rep(0.7, 5),
    infit_high  = rep(1.3, 5),
    stringsAsFactors = FALSE
  )

  result_kable <- RMitemInfit(df, cutoff = mock_cutoff, output = "kable")
  expect_s3_class(result_kable, "knitr_kable")
  cap <- attr(result_kable, "caption")
  if (is.null(cap)) cap <- paste(as.character(result_kable), collapse = "\n")
  expect_true(grepl("Simulation-based cutoff values applied", cap))
})

test_that("RMitemInfit errors when cutoff item names do not match data", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  bad_cutoff <- data.frame(
    Item        = paste0("X", 1:5),
    infit_low   = rep(0.7, 5),
    infit_high  = rep(1.3, 5),
    stringsAsFactors = FALSE
  )

  expect_error(
    RMitemInfit(df, cutoff = bad_cutoff),
    regexp = "Item names in `cutoff` do not match"
  )
})

test_that("RMitemInfit errors when cutoff data.frame has missing required columns", {
  skip_if_not_installed("iarm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  bad_cutoff <- data.frame(
    Item      = paste0("Item", 1:5),
    infit_low = rep(0.7, 5),
    stringsAsFactors = FALSE
  )

  expect_error(
    RMitemInfit(df, cutoff = bad_cutoff),
    regexp = "missing required columns"
  )
})

test_that("RMitemInfit Flagged column correctly identifies values outside cutoff range", {
  skip_if_not_installed("iarm")
  skip_if_not_installed("eRm")
  set.seed(42)
  df <- as.data.frame(
    matrix(sample(0:1, 200, replace = TRUE), nrow = 40, ncol = 5)
  )
  colnames(df) <- paste0("Item", 1:5)

  # Compute actual infit values to build tight vs. loose cutoffs
  base_result <- RMitemInfit(df, output = "dataframe")
  infit_vals  <- base_result$Infit_MSQ

  # Tight cutoff: all items should be flagged (narrow window around each)
  tight_cutoff <- data.frame(
    Item        = paste0("Item", 1:5),
    infit_low   = infit_vals + 0.1,
    infit_high  = infit_vals + 0.2,
    stringsAsFactors = FALSE
  )
  tight_result <- RMitemInfit(df, cutoff = tight_cutoff, output = "dataframe")
  # each MSQ is below its (MSQ + 0.1) lower bound -> all flagged "overfit"
  expect_true(all(tight_result$Flagged == "overfit"))

  # Loose cutoff: no items should be flagged (window encompasses all values)
  loose_cutoff <- data.frame(
    Item        = paste0("Item", 1:5),
    infit_low   = rep(0.0, 5),
    infit_high  = rep(10.0, 5),
    stringsAsFactors = FALSE
  )
  loose_result <- RMitemInfit(df, cutoff = loose_cutoff, output = "dataframe")
  expect_true(all(loose_result$Flagged == ""))
})

test_that("RMitemInfit drops all-NA respondents instead of erroring", {
  skip_if_not_installed("iarm")
  set.seed(42)
  df <- as.data.frame(matrix(sample(0:2, 60 * 6, replace = TRUE), nrow = 60))
  colnames(df) <- paste0("i", 1:6)
  df[3, ] <- NA

  expect_message(k <- RMitemInfit(df), "no responses dropped")
  # Caption keeps the raw total: complete cases of 60 respondents
  expect_match(paste(as.character(k), collapse = "\n"), "of 60 respondents")
})

test_that("dataframe output is unrounded (kable-only display rounding)", {
  skip_if_not_installed("iarm")
  set.seed(42)
  df <- as.data.frame(matrix(sample(0:2, 60 * 6, replace = TRUE), nrow = 60))
  colnames(df) <- paste0("i", 1:6)

  result <- RMitemInfit(df, output = "dataframe")
  # Must match the raw iarm statistic exactly, not its 3-dp rounding
  fit <- psychotools::pcmodel(as.matrix(df))
  expect_equal(result$Infit_MSQ, as.numeric(iarm::out_infit(fit)$Infit))
})