tests/testthat/test-itempar.R

In grmtree: Recursive Partitioning for Graded Response Models

library(testthat)
library(mirt)
library(hlt)


## Test that itempar_grmtree works with valid inputs
test_that("itempar_grmtree works with valid inputs", {
  skip_on_cran()
  skip_if_not_installed("mirt")
  skip_if_not_installed("hlt")

  ## ASTI data
  data("asti", package = "hlt")
  asti$resp <- data.matrix(asti[, 1:4])

  tree <- grmtree(resp ~ gender + group, data = asti,
                  control = grmtree.control(minbucket = 30))

  # Default usage
  expect_silent(items <- itempar_grmtree(tree))
  expect_s3_class(items, "data.frame")
  expect_true(nrow(items) > 0)
  expect_equal(names(items),
               c("Node", "Item", "Discrimination", "AvgThreshold", "Thresholds"))

  # Check parameter values
  expect_true(all(items$Discrimination > 0))
  expect_true(is.numeric(items$AvgThreshold)) # Thresholds typically can be positive or negative in GRM

  # Check thresholds list column
  expect_true(is.list(items$Thresholds))
  expect_equal(length(items$Thresholds[[1]]), 2) # n_categories - 1 thresholds

  # Specific nodes
  nodes <- partykit::nodeids(tree, terminal = TRUE)
  if (length(nodes) > 1) {
    expect_silent(items_sub <- itempar_grmtree(tree, node = nodes[1:2]))
    expect_equal(unique(items_sub$Node), nodes[1:2])
  }
})


## Test that itempar_grmtree handles errors appropriately
test_that("itempar_grmtree handles errors appropriately", {
  skip_on_cran()
  skip_if_not_installed("mirt")
  skip_if_not_installed("hlt")

  data("asti", package = "hlt")
  asti$resp <- data.matrix(asti[, 1:4])

  tree <- grmtree(resp ~ gender + group, data = asti,
                  control = grmtree.control(minbucket = 30))

  # Invalid object
  expect_error(itempar_grmtree(list()), "must be a grmtree object")

  # Invalid nodes
  nodes <- partykit::nodeids(tree, terminal = TRUE)
  expect_error(itempar_grmtree(tree, node = 999), "Invalid node IDs")

  # Create a tree with a single non-terminal node
  bad_tree <- tree
  bad_tree$node <- list(
    id = 1L,
    split = NULL,
    kids = NULL,
    surrogates = NULL,
    info = list()
  )
  class(bad_tree$node) <- "partynode"
  expect_error(itempar_grmtree(bad_tree), "No discrimination parameters found in node")

})

## Test that item parameters are consistent with thresholds
test_that("item parameters are consistent with thresholds", {
  skip_on_cran()
  skip_if_not_installed("mirt")
  skip_if_not_installed("hlt")

  data("asti", package = "hlt")
  asti$resp <- data.matrix(asti[, 1:4])

  tree <- grmtree(resp ~ gender + group, data = asti,
                  control = grmtree.control(minbucket = 30))
  items <- itempar_grmtree(tree)
  thresholds <- threshpar_grmtree(tree)

  # Check average thresholds match
  for (i in seq_len(nrow(items))) {
    node <- items$Node[i]
    item <- items$Item[i]
    calc_avg <- mean(unlist(items$Thresholds[i]))
    expect_equal(items$AvgThreshold[i], calc_avg)

    # Cross-check with threshpar output
    thresh_sub <- thresholds[thresholds$Node == node & thresholds$Item == item, ]
    thresh_values <- unlist(thresh_sub[, grep("^b", names(thresh_sub))])
    expect_equal(mean(thresh_values), items$AvgThreshold[i], tolerance = 1e-6)
  }
})