tests/testthat/test-eval-time-single-selection.R

In tidymodels/tune: Tidy Tuning Tools

library(yardstick)

test_that("selecting single eval time - non-survival case", {
  met_reg <- metric_set(rmse)

  times_1 <- 1 / 3
  times_2 <- as.numeric(5:4) / 7

  # eval time is not applicable outside of survival models; return null

  expect_null(first_eval_time(met_reg, eval_time = NULL))
  expect_null(first_eval_time(met_reg, eval_time = times_1))
  expect_null(first_eval_time(met_reg, eval_time = times_2))

})

test_that("selecting single eval time - pure metric sets", {
  met_int <- metric_set(brier_survival_integrated)
  met_dyn <- metric_set(brier_survival)
  met_stc <- metric_set(concordance_survival)

  times_1 <- 1 / 3
  times_2 <- as.numeric(5:4) / 7

  # all static; return NULL and add warning if times are given

  expect_null(first_eval_time(met_stc, eval_time = NULL))
  expect_null(first_eval_time(met_stc, metric = "concordance_survival", eval_time = NULL))

  expect_silent(
    stc_one <- first_eval_time(met_stc, eval_time = times_1)
  )
  expect_null(stc_one)

  expect_silent(
    stc_multi <- first_eval_time(met_stc, eval_time = times_2)
  )
  expect_null(stc_multi)

  # all dynamic; return a single time and warn if there are more and error if
  # there are none

  expect_snapshot(
    first_eval_time(met_dyn, eval_time = NULL),
    error = TRUE
  )
  expect_snapshot(
    first_eval_time(met_dyn, metric = "brier_survival", eval_time = NULL),
    error = TRUE
  )

  expect_equal(
    first_eval_time(met_dyn, eval_time = times_1),
    times_1
  )

  expect_snapshot(
    dyn_multi <- first_eval_time(met_dyn, eval_time = times_2)
  )
  expect_equal(dyn_multi, times_2[1])

  # all integrated; return NULL and warn if there 1+ times

  expect_null(first_eval_time(met_int, eval_time = NULL))
  expect_null(
    first_eval_time(met_int, metric = "brier_survival_integrated", eval_time = NULL)
  )

  expect_silent(
    int_1 <- first_eval_time(met_int, eval_time = times_1)
  )
  expect_null(int_1)

  expect_silent(
    int_multi <- first_eval_time(met_int, eval_time = times_2)
  )
  expect_null(int_multi)

})

test_that("selecting single eval time - mixed metric sets - static first", {
  met_mix_stc <- metric_set(concordance_survival, brier_survival)
  met_mix_stc_all <- metric_set(concordance_survival, brier_survival, brier_survival_integrated)

  times_1 <- 1 / 3
  times_2 <- as.numeric(5:4) / 7

  # static is first but includes dynamic. Should return NULL and add warning
  # if times are given

  expect_null(
    first_eval_time(met_mix_stc, eval_time = NULL)
  )

  expect_silent(
    stc_1 <- first_eval_time(met_mix_stc, eval_time = times_1)
  )
  expect_null(stc_1)

  expect_silent(
    stc_multi <- first_eval_time(met_mix_stc, eval_time = times_2)
  )
  expect_null(stc_multi)

  # static is first but includes dynamic and integrated. Should return NULL and
  # add warning if times are given

  expect_null(
    first_eval_time(met_mix_stc_all, eval_time = NULL)
  )

  expect_silent(
    stc_1 <- first_eval_time(met_mix_stc_all, eval_time = times_1)
  )
  expect_null(stc_1)

  expect_silent(
    stc_multi <- first_eval_time(met_mix_stc_all, eval_time = times_2)
  )
  expect_null(stc_multi)
})

test_that("selecting single eval time - mixed metric sets - dynamic first", {
  met_mix_dyn <- metric_set(brier_survival, concordance_survival)
  met_mix_dyn_all <-
    metric_set(brier_survival,
               brier_survival_integrated,
               concordance_survival)

  times_1 <- 1 / 3
  times_2 <- as.numeric(5:4) / 7

  # dynamic is first but includes static. Should return single time and add warning
  # if 2+ times are given

  expect_snapshot(
    first_eval_time(met_mix_dyn, eval_time = NULL),
    error = TRUE
  )
  expect_equal(
    first_eval_time(met_mix_dyn, eval_time = times_1),
    times_1
  )
  expect_snapshot(
    dyn_multi <- first_eval_time(met_mix_dyn, eval_time = times_2)
  )
  expect_equal(dyn_multi, times_2[1])

  # dynamic is first but includes static and integrated. Should return single
  # time and add warning if 2+ times are given

  expect_snapshot(
    first_eval_time(met_mix_dyn_all, eval_time = NULL),
    error = TRUE
  )
  expect_equal(
    first_eval_time(met_mix_dyn_all, eval_time = times_1),
    times_1
  )
  expect_snapshot(
    dyn_multi <- first_eval_time(met_mix_dyn_all, eval_time = times_2)
  )
  expect_equal(dyn_multi, times_2[1])

})


test_that("selecting single eval time - mixed metric sets - integrated first", {
  met_mix_int <- metric_set(brier_survival_integrated, concordance_survival)
  met_mix_int_all <-
    metric_set(brier_survival_integrated,
               brier_survival,
               concordance_survival)

  times_1 <- 1 / 3
  times_2 <- as.numeric(5:4) / 7

  # integrated is first but includes static. Should return NULL and add warning
  # if 1+ times are given

  expect_null(first_eval_time(met_mix_int, eval_time = NULL))

  expect_silent(
    first_eval_time(met_mix_int, eval_time = times_1)
  )
  expect_silent(
    int_multi <- first_eval_time(met_mix_int, eval_time = times_2)
  )
  expect_null(int_multi)

  # integrated is first but includes static and dynamic. Should return NULL and
  # add warning if 1+ times are given

  expect_null(first_eval_time(met_mix_int_all, eval_time = NULL))

  expect_silent(
    first_eval_time(met_mix_int_all, eval_time = times_1)
  )
  expect_silent(
    int_multi <- first_eval_time(met_mix_int_all, eval_time = times_2)
  )
  expect_null(int_multi)
})


test_that("selecting an evaluation time", {
  # much of this is indirectly tested in show/select best

  surv_res <- readRDS(test_path("data", "surv_boost_tree_res.rds"))

  expect_snapshot(
    choose_eval_time(surv_res, "brier_survival")
  )
  expect_snapshot(
    choose_eval_time(surv_res, "concordance_survival")
  )
  expect_snapshot(
    choose_eval_time(surv_res, "concordance_survival", eval_time = 10)
  )

  data("example_ames_knn")
  expect_snapshot(choose_eval_time(ames_grid_search, "rmse", eval_time = 1))
})