tests/testthat/test-gp_helpers.R

In tune: Tidy Tuning Tools

test_that("encoding before model", {
  skip_if_not_installed("dials", minimum_version = "1.4.0")
  knn_set <- readRDS(test_path("data", "knn_set.rds"))
  knn_grid <- readRDS(test_path("data", "knn_grid.rds"))

  knn_encoded <- tune:::encode_set(knn_grid, knn_set)

  expect_true(all(knn_encoded$K >= 0 & knn_encoded$K <= 1))
  expect_true(all(knn_encoded$exponent >= 0 & knn_encoded$exponent <= 1))
  expect_true(is.factor(knn_encoded$weight_func))
  expect_equal(levels(knn_encoded$weight_func), dials::weight_func()$values)
})

# ------------------------------------------------------------------------------

test_that("GP fit - svm - failure", {
  svm_results <- readRDS(test_path("data", "svm_results.rds"))
  svm_set <- attributes(svm_results)$parameters

  expect_snapshot({
    svm_gp <-
      tune:::fit_gp(
        collect_metrics(svm_results),
        pset = svm_set,
        metric = "accuracy",
        control = control_bayes(verbose = TRUE)
      )
  })

  expect_equal(class(svm_gp), "list")
  expect_named(
    svm_gp,
    c("fit", "use", "rsq", "tr")
  )
  expect_false(svm_gp$use)
  expect_named(
    svm_gp$tr,
    c("cost", "X....", "scale_factor", ".outcome")
  )

  curr <-
    collect_metrics(svm_results) |>
    dplyr::filter(.metric == "accuracy") |>
    mutate(.iter = 0)

  expect_snapshot({
    svm_scores <-
      tune:::pred_gp(
        svm_gp,
        pset = svm_set,
        size = 20,
        current = curr,
        control = control_bayes(verbose_iter = TRUE)
      )
  })
})

# ------------------------------------------------------------------------------

test_that("GP scoring with failed model", {
  svm_results <- readRDS(test_path("data", "svm_results.rds"))
  svm_set <- attributes(svm_results)$parameters

  ctrl <- control_bayes(verbose_iter = TRUE)
  curr <-
    collect_metrics(svm_results) |>
    dplyr::filter(.metric == "accuracy") |>
    mutate(.iter = 0)

  expect_snapshot({
    svm_gp <-
      tune:::fit_gp(
        collect_metrics(svm_results),
        pset = svm_set,
        metric = "accuracy",
        control = ctrl
      )
  })

  expect_snapshot({
    svm_scores <-
      tune:::pred_gp(
        svm_gp,
        pset = svm_set,
        size = 20,
        current = curr,
        control = ctrl
      )
  })
  expect_true(tibble::is_tibble(svm_scores))
  expect_named(
    svm_scores,
    c("cost", "%^*#", "scale_factor", ".mean", ".sd")
  )
  expect_equal(nrow(svm_scores), 1)
})


# ------------------------------------------------------------------------------

test_that("pick_candidate() selects best objective when GP succeeds", {
  results <- tibble::tibble(
    x = 1:10,
    .mean = seq(0.1, 1, by = 0.1),
    .sd = rev(seq(0.1, 1, by = 0.1)),
    objective = seq(0.1, 1, by = 0.1)
  )
  info <- list(uncertainty = 0)
  ctrl <- control_bayes(uncertain = 5)

  res <- tune:::pick_candidate(results, info, ctrl)
  expect_identical(nrow(res), 1L)
  expect_identical(res$objective, 1)
})

test_that("pick_candidate() falls back to uncertainty sample when all GP predictions are NA", {
  results <- tibble::tibble(
    x = 1:20,
    .mean = rep(NA_real_, 20),
    .sd = seq(0.05, 1, by = 0.05),
    objective = seq(0.05, 1, by = 0.05)
  )
  info <- list(uncertainty = 0)
  ctrl <- control_bayes(uncertain = 5, verbose_iter = FALSE)

  set.seed(1)
  res <- tune:::pick_candidate(results, info, ctrl)
  expect_identical(nrow(res), 1L)
  # Should pick from top 10% by .sd, not by objective
  expect_gte(res$.sd, 0.9)
})

test_that("pick_candidate() emits uncertainty sample message when verbose", {
  results <- tibble::tibble(
    x = 1:20,
    .mean = rep(NA_real_, 20),
    .sd = seq(0.05, 1, by = 0.05),
    objective = seq(0.05, 1, by = 0.05)
  )
  info <- list(uncertainty = 0)
  ctrl <- control_bayes(uncertain = 5, verbose_iter = TRUE)

  expect_snapshot({
    set.seed(1)
    res <- tune:::pick_candidate(results, info, ctrl)
  })
})

# ------------------------------------------------------------------------------

test_that("GP fit - knn", {
  knn_results <- readRDS(test_path("data", "knn_results.rds"))
  knn_set <- attributes(knn_results)$parameters

  knn_mtr <-
    collect_metrics(knn_results) |>
    dplyr::filter(.metric == "roc_auc")

  set.seed(1)
  knn_gp <-
    tune:::fit_gp(
      knn_mtr,
      pset = knn_set,
      metric = "roc_auc",
      control = control_bayes()
    )

  expect_equal(class(knn_gp), "list")
  expect_named(
    knn_gp,
    c("fit", "use", "rsq", "tr")
  )
  expect_true(knn_gp$use)
  expect_named(
    knn_gp$tr,
    c("K", "weight_func", "exponent", ".outcome")
  )

  expect_snapshot({
    set.seed(1)
    knn_scores <-
      tune:::pred_gp(
        knn_gp,
        pset = knn_set,
        size = 20,
        current = knn_mtr |> mutate(.iter = 0),
        control = control_bayes()
      )
  })

  expect_named(
    knn_scores,
    c("K", "weight_func", "exponent", ".mean", ".sd")
  )
  expect_equal(nrow(knn_scores), 20L)
})