tests/testthat/test-usability-ctt-fit-quality.R

In IRTC: Marginal Maximum Likelihood Estimation for Item Response Models

# IRTC
# Copyright (C) 2026 WEIAN DATA TECH (Beijing) Co., Ltd.
# SPDX-License-Identifier: GPL-2.0-or-later
# See inst/COPYRIGHTS for licensing details.

## File Name: test-usability-ctt-fit-quality.R
## Tests for irtc_ctt(), irtc_itemfit() and irtc_quality().

irtc_test_sim_dich <- function(n=300, k=8, seed=42)
{
    set.seed(seed)
    theta <- stats::rnorm(n)
    b <- seq(-1.5, 1.5, length.out=k)
    resp <- sapply(seq_len(k), function(j) {
        as.numeric(stats::runif(n) < stats::plogis(theta - b[j]))
    })
    colnames(resp) <- paste0("I", seq_len(k))
    as.data.frame(resp)
}

test_that("irtc_ctt computes difficulty, discrimination and alpha", {
    resp <- irtc_test_sim_dich()
    ctt <- irtc_ctt(resp)
    expect_s3_class(ctt, "irtc_ctt")
    expect_equal(nrow(ctt$items), 8L)
    ## difficulty follows the generating b parameters (decreasing p)
    expect_true(ctt$items$pvalue[1L] > ctt$items$pvalue[8L])
    expect_true(all(ctt$items$discr > 0, na.rm=TRUE))
    expect_true(ctt$alpha > 0.3 && ctt$alpha <= 1)
    expect_output(print(ctt))
})

test_that("irtc_ctt scores raw responses when a key is given", {
    resp <- data.frame(Q1=c("A", "A", "B", "A"), Q2=c("C", "D", "C", "C"),
        stringsAsFactors=FALSE)
    ctt <- irtc_ctt(resp, key=c(Q1="A", Q2="C"))
    expect_equal(ctt$items$pvalue, c(0.75, 0.75))
})

test_that("irtc_ctt raises structured errors", {
    cond <- tryCatch(irtc_ctt(data.frame(a=c("A", "B"))),
        condition=function(c) c)
    expect_equal(cond$code, "E305")
    cond2 <- tryCatch(irtc_ctt(data.frame(a=c(0, 1))),
        condition=function(c) c)
    expect_equal(cond2$code, "E302")
    cond3 <- tryCatch(irtc_ctt(1:3), condition=function(c) c)
    expect_equal(cond3$code, "E301")
})

test_that("irtc_itemfit returns sensible fit statistics", {
    resp <- irtc_test_sim_dich()
    mod <- irtc.mml(resp=resp, verbose=FALSE)
    fit <- irtc_itemfit(mod)
    expect_s3_class(fit, "irtc_itemfit")
    expect_equal(nrow(fit), ncol(resp))
    ## data were generated by the model: mean squares near 1
    expect_true(all(fit$outfit > 0.6 & fit$outfit < 1.4, na.rm=TRUE))
    expect_true(all(fit$infit > 0.6 & fit$infit < 1.4, na.rm=TRUE))
    expect_output(print(fit))
})

test_that("irtc_itemfit validates its input", {
    cond <- tryCatch(irtc_itemfit("not a model"), condition=function(c) c)
    expect_equal(cond$code, "E401")

    resp <- irtc_test_sim_dich(n=100, k=4)
    mod <- irtc.mml(resp=resp, verbose=FALSE)
    cond2 <- tryCatch(irtc_itemfit(mod, resp=resp[1:10, ]),
        condition=function(c) c)
    expect_equal(cond2$code, "E403")
})

test_that("irtc_quality rates items and flags bad ones", {
    resp <- irtc_test_sim_dich(n=400, k=8)
    ## sabotage one item: random noise (no discrimination)
    set.seed(7)
    resp$I8 <- stats::rbinom(nrow(resp), 1, 0.5)
    mod <- irtc.mml(resp=resp, verbose=FALSE)
    qual <- irtc_quality(mod)
    expect_s3_class(qual, "irtc_quality")
    expect_equal(nrow(qual), 8L)
    expect_true(all(qual$rating %in%
        c("good", "acceptable", "review", "revise")))
    ## the noise item must not be rated good
    expect_true(qual$rating[8L] != "good")
    expect_true(nzchar(qual$reasons_zh[8L]))
    expect_true(nzchar(qual$reasons_en[8L]))
    expect_output(print(qual))
    expect_output(print(qual, lang="en"))
})

test_that("column subsets of quality tables print without error", {
    resp <- irtc_test_sim_dich(n=200, k=5, seed=51)
    mod <- irtc.mml(resp=resp, verbose=FALSE)
    qual <- irtc_quality(mod)
    ## subsetting keeps the class but drops columns; printing must not fail
    sub <- qual[, c("item", "pvalue", "discr", "rating")]
    expect_s3_class(sub, "irtc_quality")
    expect_output(print(sub), "rating")
})

test_that("quality rating labels are bilingual", {
    expect_equal(irtc_quality_rating_label("good", lang="zh"), "\u597d")
    expect_equal(irtc_quality_rating_label("revise", lang="en"), "Revise")
})