tests/testthat/test-plot.R

In grmtree: Recursive Partitioning for Graded Response Models

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

## Test that plot.grmtree works correctly
test_that("plot.grmtree works correctly", {
  skip_on_cran()
  skip_if_not_installed("mirt")
  skip_if_not_installed("hlt")

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

  tree <- grmtree(resp ~ gender + group, data = asti)

  # Test basic plot types
  expect_silent(plot(tree, type = "regions"))
  expect_silent(plot(tree, type = "profile"))
  expect_message(plot(tree, type = "histogram"), "Processing node")

  # Test profile plot variants
  expect_silent(plot(tree, type = "profile", what = "item"))
  expect_silent(plot(tree, type = "profile", what = "threshold"))
  expect_silent(plot(tree, type = "profile", what = "discrimination"))

  # Test parameter variations
  expect_silent(plot(tree, tnex = 3))
  expect_silent(plot(tree, drop_terminal = FALSE))
  expect_silent(plot(tree, spacing = 0.2))

  # Test error handling - need to force dispatch to plot.grmtree
  expect_error(plot.grmtree("not_a_tree"), "must be of class 'grmtree'")
  expect_error(plot(tree, type = "invalid"), "should be one of")
  expect_error(plot(tree, what = "invalid"), "should be one of")
  expect_error(plot(tree, tnex = -1), "positive numeric value")
  expect_error(plot(tree, spacing = -0.1), "non-negative numeric value")

  # Test with empty tree (should fail gracefully)
  empty_tree <- structure(
    list(
      node = structure(list(id = 1L), class = "partynode"),
      fitted = data.frame("(fitted)" = factor(1), "(response)" = matrix(0, 1, 4)),
      terms = terms(resp ~ gender + group),
      data = asti,
      info = list()
    ),
    class = c("grmtree", "constparty", "party")
  )
  expect_error(plot(empty_tree, type = "regions"), "Failed to create regions plot")
})

## Test that the lot.grmtree argument validation works
test_that("plot.grmtree argument validation works", {
  # Test input object validation separately
  expect_error(plot.grmtree(), "missing")
  expect_error(plot.grmtree("not_a_tree"), "must be of class 'grmtree'")

  # Improved validation helper function
  validate_plot_args <- function(type = c("regions", "profile", "histogram"),
                                 what = c("item", "threshold", "discrimination"),
                                 tnex = 2L,
                                 drop_terminal = TRUE,
                                 spacing = 0.1) {
    # Input validation checks
    type <- match.arg(type)
    what <- match.arg(what)

    if (!is.numeric(tnex) || length(tnex) != 1 || tnex <= 0 || !is.finite(tnex)) {
      stop("'tnex' must be a single positive numeric value.")
    }

    if (!is.logical(drop_terminal) || length(drop_terminal) != 1 || is.na(drop_terminal)) {
      stop("'drop_terminal' must be a single logical value.")
    }

    if (!is.numeric(spacing) || length(spacing) != 1 || spacing < 0 || !is.finite(spacing)) {
      stop("'spacing' must be a single non-negative numeric value.")
    }

    return(TRUE)
  }

  # Test the validation logic
  expect_silent(validate_plot_args())  # Test default args work

  # Test invalid inputs
  expect_error(
    validate_plot_args(type = "invalid"),
    "should be one of"
  )

  expect_error(
    validate_plot_args(what = "invalid"),
    "should be one of"
  )

  expect_error(
    validate_plot_args(tnex = "a"),
    "must be a single positive numeric value"
  )

  expect_error(
    validate_plot_args(drop_terminal = NA),
    "must be a single logical value"
  )

  expect_error(
    validate_plot_args(spacing = -0.1),
    "must be a single non-negative numeric value"
  )

  # Additional edge cases
  expect_error(
    validate_plot_args(tnex = NA_real_),
    "must be a single positive numeric value"
  )

  expect_error(
    validate_plot_args(spacing = Inf),
    "must be a single non-negative numeric value"
  )
})