tests/testthat/test-adjust-numeric-calibration.R

In tailor: Iterative Steps for Postprocessing Model Predictions

skip_if_not_installed("probably")

test_that("basic adjust_numeric_calibration usage works", {
  skip_if_not_installed("mgcv")

  # fitting and predicting happens without raising conditions
  expect_no_condition(
    tlr <-
      tailor() |>
      adjust_numeric_calibration(method = "linear")
  )

  expect_no_warning(
    tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  )

  expect_no_condition(
    tlr_pred <- predict(tlr_fit, d_reg_test)
  )

  # classes are as expected
  expect_s3_class(tlr, "tailor")
  expect_s3_class(tlr_fit, "tailor")
  expect_s3_class(tlr_pred, "tbl_df")

  # column names are as expected
  expect_equal(colnames(d_reg_test), colnames(tlr_pred))
})

test_that("linear adjust_numeric_calibration usage works", {
  skip_if_not_installed("mgcv")

  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "linear")

  tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  tlr_pred <- predict(tlr_fit, d_reg_test)

  expect_s3_class(
    tlr_fit$adjustments[[1]]$results$fit,
    c("cal_estimate_linear_spline", "cal_regression", "cal_object")
  )
  expect_true(all(d_reg_test$y_pred != tlr_pred$y_pred))
})

test_that("isotonic adjust_numeric_calibration usage works", {
   tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "isotonic")

  tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  tlr_pred <- predict(tlr_fit, d_reg_test)

  expect_s3_class(
    tlr_fit$adjustments[[1]]$results$fit,
    c("cal_estimate_isotonic", "cal_regression", "cal_object")
  )
  expect_true(all(d_reg_test$y_pred != tlr_pred$y_pred))
})


test_that("isotonic boot adjust_numeric_calibration usage works", {

  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "isotonic_boot")

  set.seed(1)
  tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  tlr_pred <- predict(tlr_fit, d_reg_test)

  expect_s3_class(
    tlr_fit$adjustments[[1]]$results$fit,
    c("cal_estimate_isotonic_boot", "cal_regression", "cal_object")
  )
  expect_true(all(d_reg_test$y_pred != tlr_pred$y_pred))
})

test_that("no adjust_numeric_calibration usage works", {

  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "none")

  set.seed(1)
  tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  tlr_pred <- predict(tlr_fit, d_reg_test)

  expect_s3_class(
    tlr_fit$adjustments[[1]]$results$fit,
    c("cal_estimate_none", "cal_regression", "cal_object")
  )
  expect_true(all(d_reg_test$y_pred == tlr_pred$y_pred))
})

test_that("adjust_numeric_calibration() respects `method` argument", {

  expect_no_condition(
    tlr <-
      tailor() |>
      adjust_numeric_calibration(method = "isotonic")
  )

  expect_no_condition(
    tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  )

  expect_no_condition(
    tlr_pred <- predict(tlr_fit, d_reg_test)
  )

  # classes are as expected
  expect_s3_class(tlr, "tailor")
  expect_s3_class(tlr_fit, "tailor")
  expect_s3_class(tlr_pred, "tbl_df")

  # column names are as expected
  expect_equal(colnames(d_reg_test), colnames(tlr_pred))

  # probably actually used an isotonic calibrator
  expect_equal(
    tlr_fit$adjustments[[1]]$results$fit$method,
    "Isotonic regression calibration"
  )
})

test_that("adjustment printing", {
  expect_snapshot(
    tailor() |> adjust_numeric_calibration()
  )
  expect_snapshot(
    tailor() |> adjust_numeric_calibration(method = "isotonic")
  )
  expect_snapshot(
    tailor() |> adjust_numeric_calibration(method = hardhat::tune())
  )

  expect_snapshot(
    tailor() |>
      adjust_numeric_calibration() |>
      fit(mtcars, outcome = mpg, estimate = disp)
  )
})

test_that("errors informatively with bad input", {
  # check for `adjust_numeric_calibration(tailor)` is in `utils.R` tests

  expect_snapshot(error = TRUE, adjust_numeric_calibration(tailor(), "boop"))
  expect_snapshot(
    error = TRUE,
    tailor() |> adjust_numeric_calibration("binary")
  )

  expect_no_condition(adjust_numeric_calibration(tailor()))
  expect_no_condition(adjust_numeric_calibration(tailor(), "linear"))
})

test_that("tunable S3 method", {
  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "linear")
  adj_param <- tunable(tlr$adjustments[[1]])
  exp_tunable <-
    tibble::tibble(
      name = "method",
      call_info = list(list(pkg = "dials", fun = "cal_method_reg")),
      source = "tailor",
      component = "numeric_calibration",
      component_id = "numeric_calibration"
    )
  expect_equal(adj_param, exp_tunable)
})


test_that("tuning the calibration method", {

  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = hardhat::tune())
  expect_true(tailor:::is_tune(tlr$adjustments[[1]]$arguments$method))

  expect_snapshot(
    fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred),
    error = TRUE
  )
})

test_that("too few data", {
  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "linear")

  expect_snapshot(
    fit(tlr, d_reg_calibration[0,], outcome = y, estimate = y_pred)
  )
  expect_snapshot(
    fit(tlr, d_reg_calibration[1,], outcome = y, estimate = y_pred)
  )

})

test_that("passing arguments to adjust_numeric_calibration", {

  expect_no_condition(
    tlr_fit <-
      tailor() |>
      adjust_numeric_calibration(method = "linear", smooth = FALSE) |>
      fit(d_reg_calibration, outcome = y, estimate = y_pred)
  )

  expect_s3_class(
    tlr_fit$adjustments[[1]]$results$fit,
    "cal_estimate_linear"
  )

  expect_snapshot(
    tlr_fit <-
      tailor() |>
      adjust_numeric_calibration(method = "linear", FALSE),
    error = TRUE
  )

  expect_snapshot(
    tlr_fit <-
      tailor() |>
      adjust_numeric_calibration(method = "linear", FALSE, select = TRUE),
    error = TRUE
  )
})

test_that("harden against calibration model failure", {
  skip_if(getRversion() < "4.2.0")

  set.seed(1)
  d_calibration_pred <- tibble(y = rnorm(100), y_pred = NA_real_)
  d_calibration_y <- tibble(y = NA_real_, y_pred = rnorm(100))

  d_test <- tibble(y = rnorm(100), y_pred = y / 2 + rnorm(100))

  tlr <-
    tailor() |>
    adjust_numeric_calibration(method = "linear")

  ###
  expect_snapshot(
    pred_fit <- fit(tlr, d_calibration_pred, outcome = y, estimate = y_pred)
  )

  pred_pred <- predict(pred_fit, d_test)

  expect_true(all(pred_pred$y_pred == d_test$y_pred))

  ###
  expect_snapshot(
    y_fit <- fit(tlr, d_calibration_y, outcome = y, estimate = y_pred)
  )

  y_pred <- predict(y_fit, d_test)

  expect_true(all(y_pred$y_pred == d_test$y_pred))
})

test_that("required packages for adjust_numeric_calibration", {
  skip_if_not_installed("mgcv")

  expect_no_condition(
    tlr <-
      tailor() |>
      adjust_numeric_calibration(method = "linear")
  )

  expect_no_warning(
    tlr_fit <- fit(tlr, d_reg_calibration, outcome = y, estimate = y_pred)
  )

  expect_equal(required_pkgs(tlr), c("probably", "tailor"))
  expect_equal(required_pkgs(tlr_fit), c("mgcv", "probably", "tailor"))

})