tests/testthat/test-utils.R

In tailor: Iterative Steps for Postprocessing Model Predictions

test_that("is_tune works", {
  expect_false(is_tune(1))
  expect_false(is_tune("x"))
  expect_false(is_tune(quote(x)))
  expect_false(is_tune(quote(f(x))))
  expect_false(is_tune(NULL))
  expect_false(is_tune(list()))

  expect_true(is_tune(quote(tune())))
  expect_true(is_tune(quote(tune("my_param"))))
})

test_that("check_tailor raises informative error", {
  expect_snapshot(error = TRUE, adjust_probability_threshold("boop"))
  expect_no_condition(tailor() |> adjust_probability_threshold(.5))
})

test_that("check_calibration_type errors informatively", {
  expect_no_error(check_calibration_type("numeric", "numeric", "regression"))
  expect_no_error(
    check_calibration_type("probability", "probability", "binary")
  )
  expect_no_error(
    check_calibration_type("probability", "probability", "multiclass")
  )

  expect_snapshot(
    error = TRUE,
    check_calibration_type("probability", "numeric", "regression")
  )

  expect_snapshot(
    error = TRUE,
    check_calibration_type("numeric", "probability", "binary")
  )

  expect_snapshot(
    error = TRUE,
    check_calibration_type("numeric", "probability", "multiclass")
  )
})

test_that("errors informatively without probably installed", {
  testthat::local_mocked_bindings(requireNamespace = function(...) {
    FALSE
  })

  expect_snapshot(error = TRUE, tailor() |> adjust_numeric_calibration())
})

test_that("tailor_fully_trained works", {
  skip_if_not_installed("modeldata")
  data("two_class_example", package = "modeldata")
  expect_false(tailor_fully_trained(tailor()))
  expect_false(
    tailor_fully_trained(tailor() |> adjust_probability_threshold(.5))
  )
  expect_false(
    tailor_fully_trained(
      tailor() |>
        adjust_probability_calibration("logistic") |>
        fit(
          two_class_example,
          outcome = "truth",
          estimate = predicted,
          probabilities = tidyselect::contains("Class")
        ) |>
        adjust_probability_threshold(.5)
    )
  )

  expect_true(
    tailor_fully_trained(
      tailor() |>
        adjust_probability_calibration("logistic") |>
        fit(
          two_class_example,
          outcome = "truth",
          estimate = predicted,
          probabilities = tidyselect::contains("Class")
        )
    )
  )
  expect_true(
    tailor_fully_trained(
      tailor() |>
        adjust_probability_threshold(.5) |>
        fit(
          two_class_example,
          outcome = "truth",
          estimate = "predicted",
          probabilities = tidyselect::contains("Class")
        )
    )
  )
})

test_that("tailor_requires_fit works", {
  skip_if_not_installed("probably")

  expect_false(tailor_requires_fit(tailor()))
  expect_false(
    tailor_requires_fit(tailor() |> adjust_probability_threshold(.5))
  )
  expect_true(
    tailor_requires_fit(
      tailor() |>
        adjust_probability_calibration("logistic")
    )
  )
  expect_true(
    tailor_requires_fit(
      tailor() |>
        adjust_probability_calibration("logistic") |>
        adjust_probability_threshold(.5)
    )
  )
})

test_that("fit.tailor() errors informatively with incompatible outcome", {
  skip_if_not_installed("modeldata")
  library(modeldata)

  two_class_example$test_numeric <- two_class_example$Class1 + 1
  two_class_example$test_date <- as.POSIXct(
    two_class_example$Class1,
    origin = "1970-01-01"
  )

  # supply a numeric outcome to a binary tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_probability_threshold(.1),
      two_class_example,
      outcome = c(test_numeric),
      estimate = c(predicted),
      probabilities = c(Class1, Class2)
    )
  )

  # supply a factor outcome to a regression tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_numeric_range(lower_limit = .1),
      two_class_example,
      outcome = c(truth),
      estimate = c(Class1)
    )
  )

  # supply a totally wild outcome to a regression tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_probability_threshold(.1),
      two_class_example,
      outcome = c(test_date),
      estimate = c(predicted),
      probabilities = c(Class1, Class2)
    )
  )

  # supply a totally wild outcome to an unknown tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_predictions_custom(hey = "there"),
      two_class_example,
      outcome = c(test_date),
      estimate = c(predicted),
      probabilities = c(Class1)
    )
  )
})

test_that("fit.tailor() errors informatively with incompatible estimate", {
  skip_if_not_installed("modeldata")
  library(modeldata)

  two_class_example$test_numeric <- two_class_example$Class1 + 1
  two_class_example$test_date <- as.POSIXct(
    two_class_example$Class1,
    origin = "1970-01-01"
  )

  # supply a numeric estimate to a binary tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_probability_threshold(.1),
      two_class_example,
      outcome = c(predicted),
      estimate = c(test_numeric),
      probabilities = c(Class1, Class2)
    )
  )

  # supply a factor estimate to a regression tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_numeric_range(lower_limit = .1),
      two_class_example,
      outcome = c(Class1),
      estimate = c(truth)
    )
  )

  # supply a totally wild estimate to a regression tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_probability_threshold(.1),
      two_class_example,
      outcome = c(truth),
      estimate = c(test_date),
      probabilities = c(Class1, Class2)
    )
  )

  # supply a totally wild estimate to an unknown tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_predictions_custom(hey = "there"),
      two_class_example,
      outcome = c(truth),
      estimate = c(test_date),
      probabilities = c(Class1)
    )
  )
})

test_that("fit.tailor() errors informatively with incompatible probability", {
  skip_if_not_installed("modeldata")
  library(modeldata)

  two_class_example$test_date <- as.POSIXct(
    two_class_example$Class1,
    origin = "1970-01-01"
  )

  # supply a date probability to a binary tailor
  expect_snapshot(
    error = TRUE,
    fit(
      tailor() |> adjust_probability_threshold(.1),
      two_class_example,
      outcome = c(truth),
      estimate = c(predicted),
      probabilities = c(test_date)
    )
  )
})

test_that("find_tune_id() works", {
  # empty input
  expect_equal(find_tune_id(list()), NA_character_)

  # handles quosures
  x <- rlang::quos(a = 1, b = tune())
  expect_equal(find_tune_id(x), "")

  # non-tunable atomic values
  expect_equal(find_tune_id(1), NA_character_)
  expect_equal(find_tune_id("a"), NA_character_)
  expect_equal(find_tune_id(TRUE), NA_character_)

  # non-tunable names
  expect_equal(find_tune_id(quote(x)), NA_character_)

  # nested lists
  x <- list(a = 1, b = list(c = hardhat::tune(), d = 2))
  expect_equal(find_tune_id(x), "")

  # tune() without id
  expect_equal(find_tune_id(hardhat::tune()), "")

  # tune() with id
  expect_equal(find_tune_id(hardhat::tune("test_id")), "test_id")

  # multiple tunable values
  x <- list(a = hardhat::tune(), b = hardhat::tune())
  expect_snapshot(error = TRUE, find_tune_id(x))
})

test_that("tune_id() works", {
  # works when input is tune
  expect_equal(tune_id(hardhat::tune()), "")
  expect_equal(tune_id(hardhat::tune("param")), "param")

  # returns character NA for non-tunable inputs
  expect_equal(tune_id(NULL), NA_character_)
  expect_equal(tune_id(1), NA_character_)
  expect_equal(tune_id("x"), NA_character_)
  expect_equal(tune_id(quote(x)), NA_character_)
  expect_equal(tune_id(quote(f(x))), NA_character_)
})

test_that("check_selection() errors informatively", {
  expect_snapshot(
    check_selection(quote(contains("boop")), numeric(0), ".data"),
    error = TRUE
  )
})