tests/testthat/test-hat_values-fit.R

In tidymodels/applicable: A Compilation of Applicability Domain Methods

test_that("`new_apd_hat_values` arguments are assigned correctly", {
  x <- new_apd_hat_values(
    "XtX_inv",
    "pctls",
    blueprint = hardhat::default_xy_blueprint()
  )

  expect_equal(names(x), c("XtX_inv", "pctls", "blueprint"))
  expect_equal(x$XtX_inv, "XtX_inv")
  expect_equal(x$pctls, "pctls")
  expect_equal(x$blueprint, hardhat::default_xy_blueprint())
})

test_that("XtX_inv is provided", {
  expect_snapshot(error = TRUE,
    new_apd_hat_values(blueprint = hardhat::default_xy_blueprint())
  )
})

test_that("`new_apd_hat_values` fails when blueprint is numeric", {
  expect_snapshot(error = TRUE,
    new_apd_hat_values(XtX_inv = 1, blueprint = 1)
  )
})

test_that("`new_apd_hat_values` returned blueprint is of class hardhat_blueprint", {
  x <- new_apd_hat_values(
    "XtX_inv",
    "pctls",
    blueprint = hardhat::default_xy_blueprint()
  )

  expect_s3_class(x$blueprint, "hardhat_blueprint")
})

test_that("`apd_hat_values` fails when model is not of class apd_hat_values", {
  model <- apd_hat_values(~ Sepal.Length + Species, iris)
  expect_s3_class(model, "apd_hat_values")
})

test_that("`apd_hat_values` fails when model is not of class hardhat_model", {
  model <- apd_hat_values(~ Sepal.Length + Species, iris)
  expect_s3_class(model, "hardhat_model")
})

test_that("`apd_hat_values` is defined for data.frame objects", {
  x <- apd_hat_values(mtcars)
  X <- as.matrix(mtcars)
  XpX <- t(X) %*% X
  XtX_inv <- qr.solve(XpX)
  dimnames(XtX_inv) <- NULL

  expect_equal(class(x), c("apd_hat_values", "hardhat_model", "hardhat_scalar"))
  expect_equal(names(x), c("XtX_inv", "pctls", "blueprint"))
  expect_equal(x$XtX_inv, XtX_inv)
})

test_that("`apd_hat_values` is defined for formula objects", {
  x <- apd_hat_values(~ Sepal.Width + Sepal.Length, iris)
  X <- as.matrix(iris %>% select(Sepal.Width, Sepal.Length))
  XpX <- t(X) %*% X
  XtX_inv <- qr.solve(XpX)
  dimnames(XtX_inv) <- NULL

  expect_equal(class(x), c("apd_hat_values", "hardhat_model", "hardhat_scalar"))
  expect_equal(names(x), c("XtX_inv", "pctls", "blueprint"))
  expect_equal(x$XtX_inv, XtX_inv)
})

test_that("`apd_hat_values` is defined for recipe objects", {
  rec <- recipes::recipe(~ Sepal.Width + Sepal.Length, iris)
  x <- apd_hat_values(rec, data = iris)
  X <- as.matrix(iris %>% select(Sepal.Width, Sepal.Length))
  XpX <- t(X) %*% X
  XtX_inv <- qr.solve(XpX)
  dimnames(XtX_inv) <- NULL

  expect_equal(class(x), c("apd_hat_values", "hardhat_model", "hardhat_scalar"))
  expect_equal(names(x), c("XtX_inv", "pctls", "blueprint"))
  expect_equal(x$XtX_inv, XtX_inv)
})

test_that("`apd_hat_values` is defined for matrix objects", {
  X <- as.matrix(iris %>% select(-Species))
  x <- apd_hat_values(X)
  XpX <- t(X) %*% X
  XtX_inv <- qr.solve(XpX)
  dimnames(XtX_inv) <- NULL

  expect_equal(class(x), c("apd_hat_values", "hardhat_model", "hardhat_scalar"))
  expect_equal(names(x), c("XtX_inv", "pctls", "blueprint"))
  expect_equal(x$XtX_inv, XtX_inv)
})

test_that("`apd_hat_values` is not defined for vectors", {
  cls <- class(mtcars$mpg)[1]
  expected_message <- glue::glue("`x` is not of a recognized type.
     Only data.frame, matrix, recipe, and formula objects are allowed.
     A {cls} was specified.")

  expect_condition(
    apd_hat_values(mtcars$mpg),
    expected_message
  )
})

test_that("`apd_hat_values` fails when matrix has more predictors than samples", {
  bad_data <- mtcars %>%
    slice(1:5)

  expect_snapshot(error = TRUE,
    apd_hat_values(bad_data)
  )
})

test_that("`apd_hat_values` fails when the matrix X^tX is singular", {
  bad_data <- matrix(
    rep(0, 6),
    nrow = 3
  )
  colnames(bad_data) <- c("A", "B")

  expect_snapshot(error = TRUE,
    apd_hat_values(bad_data)
  )
})

test_that("`get_inv` behaves correctly when the input is not a matrix", {
  X <- c(1:5)
  expect_error(get_inv(X), NA)
})