tests/testthat/test-event-level.R

In tidymodels/tune: Tidy Tuning Tools

test_that("`event_level` is passed through in tune_grid()", {
  skip_if_not_installed("modeldata")
  skip_if_not_installed("kernlab")

  set.seed(123)

  data("two_class_dat", package = "modeldata")
  dat <- two_class_dat[1:50, ]

  spec <- parsnip::svm_linear(mode = "classification", cost = tune()) %>%
    parsnip::set_engine("kernlab")

  control <- control_grid(event_level = "second", save_pred = TRUE)
  resamples <- rsample::bootstraps(dat, times = 1)
  set <- yardstick::metric_set(yardstick::roc_auc, yardstick::sens)
  grid <- tibble::tibble(cost = 2L)

  result <- tune_grid(
    spec,
    Class ~ .,
    resamples = resamples,
    metrics = set,
    grid = grid,
    control = control
  )

  metrics <- result$.metrics[[1]]
  estimates <- metrics$.estimate
  predictions <- result$.predictions[[1]]

  expected_sens <- yardstick::sens_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_class,
    event_level = "second"
  )

  expected_roc_auc <- yardstick::roc_auc_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_Class2,
    event_level = "second"
  )

  expect_identical(estimates[metrics$.metric == "sens"], expected_sens)
  expect_identical(estimates[metrics$.metric == "roc_auc"], expected_roc_auc)
})

test_that("`event_level` is passed through in fit_resamples()", {
  skip_if_not_installed("modeldata")
  skip_if_not_installed("kernlab")

  set.seed(123)

  data("two_class_dat", package = "modeldata")
  dat <- two_class_dat[1:50, ]

  spec <- parsnip::svm_linear(mode = "classification", cost = 2) %>%
    parsnip::set_engine("kernlab")

  control <- control_resamples(event_level = "second", save_pred = TRUE)
  resamples <- rsample::bootstraps(dat, times = 1)
  set <- yardstick::metric_set(yardstick::roc_auc, yardstick::sens)

  result <- fit_resamples(
    spec,
    Class ~ .,
    resamples = resamples,
    metrics = set,
    control = control
  )

  metrics <- result$.metrics[[1]]
  estimates <- metrics$.estimate
  predictions <- result$.predictions[[1]]

  expected_sens <- yardstick::sens_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_class,
    event_level = "second"
  )

  expected_roc_auc <- yardstick::roc_auc_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_Class2,
    event_level = "second"
  )

  expect_identical(estimates[metrics$.metric == "sens"], expected_sens)
  expect_identical(estimates[metrics$.metric == "roc_auc"], expected_roc_auc)
})

test_that("`event_level` is passed through in tune_bayes()", {
  skip_if_not_installed("modeldata")
  skip_if_not_installed("kernlab")

  set.seed(123)

  data("two_class_dat", package = "modeldata")
  dat <- two_class_dat[1:50, ]

  spec <- parsnip::svm_linear(mode = "classification", cost = tune()) %>%
    parsnip::set_engine("kernlab")

  control_grid <- control_grid(save_pred = TRUE)
  control <- control_bayes(event_level = "second", save_pred = TRUE)
  resamples <- rsample::bootstraps(dat, times = 1)
  set <- yardstick::metric_set(yardstick::roc_auc, yardstick::sens)

  result <- tune_bayes(
    spec,
    Class ~ .,
    resamples = resamples,
    metrics = set,
    iter = 1,
    control = control
  )

  result <- result[result$.iter == 1, ]

  metrics <- result$.metrics[[1]]
  estimates <- metrics$.estimate
  predictions <- result$.predictions[[1]]

  expected_sens <- yardstick::sens_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_class,
    event_level = "second"
  )

  expected_roc_auc <- yardstick::roc_auc_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_Class2,
    event_level = "second"
  )

  expect_identical(estimates[metrics$.metric == "sens"], expected_sens)
  expect_identical(estimates[metrics$.metric == "roc_auc"], expected_roc_auc)
})

test_that("`event_level` is passed through in last_fit()", {
  skip_if_not_installed("modeldata")
  skip_if_not_installed("kernlab")

  set.seed(123)

  data("two_class_dat", package = "modeldata")
  dat <- two_class_dat[1:10, ]

  spec <- parsnip::svm_linear(mode = "classification", cost = 0.5) %>%
    parsnip::set_engine("kernlab")

  control <- control_last_fit(event_level = "second")
  split <- rsample::initial_split(dat)
  set <- yardstick::metric_set(yardstick::roc_auc, yardstick::sens)

  result <- last_fit(
    spec,
    Class ~ .,
    split = split,
    metrics = set,
    control = control
  )

  metrics <- result$.metrics[[1]]
  estimates <- metrics$.estimate
  predictions <- result$.predictions[[1]]

  expected_sens <- yardstick::sens_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_class,
    event_level = "second"
  )

  expected_roc_auc <- yardstick::roc_auc_vec(
    truth = predictions$Class,
    estimate = predictions$.pred_Class2,
    event_level = "second"
  )

  expect_identical(estimates[metrics$.metric == "sens"], expected_sens)
  expect_identical(estimates[metrics$.metric == "roc_auc"], expected_roc_auc)

})