Better saving of GP information in tune_bayes (#964)

* code to remove tmp files * updates to GP objects that are optionally saved * number the saved objects * Revert "number the saved objects" This reverts commit 0fc17ed. * change name of gp object and test saves --------- Co-authored-by: ‘topepo’ <‘[email protected]’>
tidymodels · Nov 14, 2024 · fec77ef · fec77ef
1 parent e16bb0d
commit fec77ef
Show file tree

Hide file tree

Showing 4 changed files with 29 additions and 6 deletions.
diff --git a/R/acquisition.R b/R/acquisition.R
@@ -125,6 +125,7 @@ exp_improve <- function(trade_off = 0, eps = .Machine$double.eps) {
 }
 
 #' @export
+# NOTE `maximize` is the direction of the metric, not the acquisition function
 predict.exp_improve <- function(object, new_data, maximize, iter, best, ...) {
   check_bool(maximize)
   check_number_decimal(best, allow_infinite = FALSE)

diff --git a/R/tune_bayes.R b/R/tune_bayes.R
@@ -281,6 +281,7 @@ tune_bayes_workflow <- function(object,
                                 ...,
                                 call = caller_env()) {
 
+    clear_gp_results()
     start_time <- proc.time()[3]
 
     initialize_catalog(control = control)
@@ -407,8 +408,6 @@ tune_bayes_workflow <- function(object,
 
       gp_mod <- check_gp_failure(gp_mod, prev_gp_mod)
 
-      save_gp_results(gp_mod, param_info, control, i, iter)
-
       check_time(start_time, control$time_limit)
 
       set.seed(control$seed[1] + i + 1)
@@ -437,6 +436,8 @@ tune_bayes_workflow <- function(object,
 
       check_and_log_flow(control, candidates)
 
+      save_gp_results(gp_mod, param_info, control, i, iter, candidates, score_card)
+
       candidates <- pick_candidate(candidates, score_card, control)
       if (score_card$uncertainty >= control$uncertain) {
         score_card$uncertainty <- -1 # is updated in update_score_card() below
@@ -868,16 +869,26 @@ reup_rs <- function(resamples, res) {
 
 ## -----------------------------------------------------------------------------
 
-save_gp_results <- function(x, pset, ctrl, i, iter) {
+save_gp_results <- function(x, pset, ctrl, i, iter, candidates, score_card) {
   if (!ctrl$save_gp_scoring) {
     return(invisible(NULL))
   }
 
   nm <- recipes::names0(iter, "gp_candidates_")[i]
-  file_name <- paste0(nm, ".RData")
-  res <- try(save(x, pset, i, file = file.path(tempdir(), file_name)), silent = TRUE)
+  file_name <- glue::glue("{tempdir()}/{nm}.RData")
+  gp_fit <- x
+  res <- try(save(gp_fit, pset, i, candidates, score_card, file = file_name),
+             silent = TRUE)
   if (inherits(res, "try-error")) {
-    rlang::warn(paste("Could not save GP results:", as.character(res)))
+    cli::cli_warn("Could not save GP results at iteration {i}: {as.character(res))}")
   }
   invisible(res)
 }
+
+
+clear_gp_results <- function() {
+  gp_files <-
+    list.files(tempdir(), pattern = "gp_candidates_", full.names = TRUE)
+  res <- try(unlink(gp_files), silent = TRUE)
+  invisible(res)
+}
diff --git a/tests/testthat/_snaps/bayes.md b/tests/testthat/_snaps/bayes.md
@@ -445,6 +445,13 @@
 
 # retain extra attributes and saved GP candidates
 
+    Code
+      setdiff(new_obj, current_objs)
+    Output
+      [1] "candidates" "gp_fit"     "i"          "score_card"
+
+---
+
     Code
       res2 <- tune_bayes(wflow, resamples = folds, param_info = pset, initial = iter1,
         iter = iter2, control = control_bayes(save_workflow = TRUE))

diff --git a/tests/testthat/test-bayes.R b/tests/testthat/test-bayes.R
@@ -482,6 +482,10 @@ test_that("retain extra attributes and saved GP candidates", {
   files <- list.files(path = tempdir(), pattern = "^gp_candidates")
   expect_true(length(files) == iter2)
 
+  current_objs <- c(ls(), "current_objs")
+  load(file.path(tempdir(), "gp_candidates_1.RData"))
+  new_obj <- ls()
+  expect_snapshot(setdiff(new_obj, current_objs))
 
   expect_snapshot(
     res2 <- tune_bayes(