test: refactor and speed up, skip some on cran

sumny · sumny · commit e9392a440957 · 2022-11-17T11:09:06.000+01:00
diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R
@@ -1,18 +1,6 @@
 lapply(list.files(system.file("testthat", package = "mlr3"),
   pattern = "^helper.*\\.[rR]", full.names = TRUE), source)
 
-with_seed = function(seed, expr) {
-  old_seed = get0(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)
-  if (is.null(old_seed)) {
-    runif(1L)
-    old_seed = get0(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)
-  }
-
-  on.exit(assign(".Random.seed", old_seed, globalenv()), add = TRUE)
-  set.seed(seed)
-  force(expr)
-}
-
 # Simple 1D Functions
 PS_1D = ParamSet$new(list(
   ParamDbl$new("x", lower = -1, upper = 1)
@@ -108,9 +96,9 @@ MAKE_DESIGN = function(instance, n = 4L) {
 
 if (requireNamespace("mlr3learners") && requireNamespace("DiceKriging") && requireNamespace("rgenoud")) {
   library(mlr3learners)
-  REGR_KM_NOISY = lrn("regr.km", covtype = "matern3_2", optim.method = "gen", control = list(trace = FALSE), nugget.estim = TRUE, jitter = 1e-12)
+  REGR_KM_NOISY = lrn("regr.km", covtype = "matern3_2", optim.method = "gen", control = list(trace = FALSE, max.generations = 2), nugget.estim = TRUE, jitter = 1e-12)
   REGR_KM_NOISY$encapsulate = c(train = "callr", predict = "callr")
-  REGR_KM_DETERM = lrn("regr.km", covtype = "matern3_2", optim.method = "gen", control = list(trace = FALSE), nugget.stability = 10^-8)
+  REGR_KM_DETERM = lrn("regr.km", covtype = "matern3_2", optim.method = "gen", control = list(trace = FALSE, max.generations = 2), nugget.stability = 10^-8)
   REGR_KM_DETERM$encapsulate = c(train = "callr", predict = "callr")
 }
 REGR_FEATURELESS = lrn("regr.featureless")
@@ -207,3 +195,4 @@ expect_acqfunction = function(acqf) {
   expect_string(acqf$label)
   expect_man_exists(acqf$man)
 }
+
diff --git a/tests/testthat/teardown.R b/tests/testthat/teardown.R
@@ -1,2 +1,3 @@
 lg$set_threshold(old_threshold_bbotk)
 lg_mlr3$set_threshold(old_threshold_mlr3)
+
diff --git a/tests/testthat/test_AcqFunction.R b/tests/testthat/test_AcqFunction.R
@@ -10,3 +10,4 @@ test_that("AcqFunction API works", {
   expect_equal(acqf$direction, "same")
   expect_equal(acqf$domain, inst$search_space)
 })
+
diff --git a/tests/testthat/test_AcqFunctionCB.R b/tests/testthat/test_AcqFunctionCB.R
@@ -5,7 +5,7 @@ test_that("AcqFunctionCB works", {
   expect_acqfunction(acqf)
 
   expect_r6(acqf$codomain, "ParamSet")
-  expect_equal(acqf$codomain$ids(), "acq_cb")
+  expect_equal(acqf$codomain$ids(), acqf$id)
   expect_equal(acqf$surrogate_max_to_min, c(y = 1))
   expect_equal(acqf$direction, "same")
   expect_equal(acqf$domain, inst$search_space)
@@ -18,6 +18,6 @@ test_that("AcqFunctionCB works", {
   xdt = data.table(x = seq(-1, 1, length.out = 5L))
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
-  expect_named(res, "acq_cb")
+  expect_named(res, acqf$id)
 })
 
diff --git a/tests/testthat/test_AcqFunctionEI.R b/tests/testthat/test_AcqFunctionEI.R
@@ -6,7 +6,7 @@ test_that("AcqFunctionEI works", {
   expect_acqfunction(acqf)
 
   expect_r6(acqf$codomain, "ParamSet")
-  expect_equal(acqf$codomain$ids(), "acq_ei")
+  expect_equal(acqf$codomain$ids(), acqf$id)
   expect_equal(acqf$surrogate_max_to_min, c(y = 1))
   expect_equal(acqf$direction, "maximize")
   expect_equal(acqf$domain, inst$search_space)
@@ -21,7 +21,7 @@ test_that("AcqFunctionEI works", {
   acqf$update()
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
-  expect_named(res, "acq_ei")
+  expect_named(res, acqf$id)
 })
 
 test_that("AcqFunctionEI trafo", {
@@ -47,7 +47,7 @@ test_that("AcqFunctionEI trafo", {
   acqf$update()
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 11L, any.missing = FALSE)
-  expect_named(res, "acq_ei")
+  expect_named(res, acqf$id)
   expect_true(max(res$acq_ei) == res$acq_ei[6])  # at x = 15
 })
 
diff --git a/tests/testthat/test_AcqFunctionEIPS.R b/tests/testthat/test_AcqFunctionEIPS.R
@@ -10,7 +10,7 @@ test_that("AcqFunctionEIPS works", {
   expect_acqfunction(acqf)
 
   expect_r6(acqf$codomain, "ParamSet")
-  expect_equal(acqf$codomain$ids(), "acq_eips")
+  expect_equal(acqf$codomain$ids(), acqf$id)
   expect_equal(acqf$surrogate_max_to_min, c(y = 1, time = 1))  # FIXME: check this
   expect_equal(acqf$direction, "maximize")
   expect_equal(acqf$domain, inst$search_space)
@@ -25,6 +25,6 @@ test_that("AcqFunctionEIPS works", {
   acqf$update()
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
-  expect_named(res, "acq_eips")
+  expect_named(res, acqf$id)
 })
 
diff --git a/tests/testthat/test_AcqFunctionMean.R b/tests/testthat/test_AcqFunctionMean.R
@@ -5,7 +5,7 @@ test_that("AcqFunctionMean works", {
   expect_acqfunction(acqf)
 
   expect_r6(acqf$codomain, "ParamSet")
-  expect_equal(acqf$codomain$ids(), "acq_mean")
+  expect_equal(acqf$codomain$ids(), acqf$id)
   expect_equal(acqf$surrogate_max_to_min, c(y = 1))
   expect_equal(acqf$direction, "same")
   expect_equal(acqf$domain, inst$search_space)
@@ -18,6 +18,6 @@ test_that("AcqFunctionMean works", {
   xdt = data.table(x = seq(-1, 1, length.out = 5L))
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
-  expect_named(res, "acq_mean")
+  expect_named(res, acqf$id)
 })
 
diff --git a/tests/testthat/test_AcqFunctionPI.R b/tests/testthat/test_AcqFunctionPI.R
@@ -6,7 +6,7 @@ test_that("AcqFunctionPI works", {
 
 
   expect_r6(acqf$codomain, "ParamSet")
-  expect_equal(acqf$codomain$ids(), "acq_pi")
+  expect_equal(acqf$codomain$ids(), acqf$id)
   expect_equal(acqf$surrogate_max_to_min, c(y = 1))
   expect_equal(acqf$direction, "maximize")
   expect_equal(acqf$domain, inst$search_space)
@@ -21,6 +21,6 @@ test_that("AcqFunctionPI works", {
   acqf$update()
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
-  expect_named(res, "acq_pi")
+  expect_named(res, acqf$id)
 })
 
diff --git a/tests/testthat/test_AcqFunctionSmsEgo.R b/tests/testthat/test_AcqFunctionSmsEgo.R
@@ -5,7 +5,7 @@ test_that("AcqFunctionSmsEgo works", {
   expect_acqfunction(acqf)
 
   expect_r6(acqf$codomain, "ParamSet")
-  expect_equal(acqf$codomain$ids(), "acq_smsego")
+  expect_equal(acqf$codomain$ids(), acqf$id)
   expect_equal(acqf$surrogate_max_to_min, c(y1 = 1, y2 = 1))
   expect_equal(acqf$direction, "minimize")
   expect_equal(acqf$domain, inst$search_space)
@@ -22,6 +22,6 @@ test_that("AcqFunctionSmsEgo works", {
   acqf$update()
   res = acqf$eval_dt(xdt)
   expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
-  expect_named(res, "acq_smsego")
+  expect_named(res, acqf$id)
 })
 
diff --git a/tests/testthat/test_AcqOptimizer.R b/tests/testthat/test_AcqOptimizer.R
@@ -9,7 +9,7 @@ test_that("AcqOptimizer API works", {
   instance$eval_batch(design)
   acqfun = AcqFunctionEI$new(SurrogateLearner$new(REGR_KM_DETERM, archive = instance$archive))
   acqopt = AcqOptimizer$new(opt("random_search", batch_size = 2L), trm("evals", n_evals = 2L), acq_function = acqfun)
-  with_seed(24, {acqfun$surrogate$update()})
+  acqfun$surrogate$update()
   acqfun$update()
   expect_data_table(acqopt$optimize(), nrows = 1L)
 
diff --git a/tests/testthat/test_OptimizerMbo.R b/tests/testthat/test_OptimizerMbo.R
@@ -1,22 +1,23 @@
 test_that("OptimizerMbo works", {
+  skip_on_cran()
   skip_if_not_installed("mlr3learners")
   skip_if_not_installed("DiceKriging")
   skip_if_not_installed("rgenoud")
   
   optimizer = OptimizerMbo$new()
   expect_r6(optimizer, classes = "OptimizerMbo")
 
-  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 10L))
+  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 5L))
 
-  design = MAKE_DESIGN(instance)
+  design = MAKE_DESIGN(instance, n = 4L)
   instance$eval_batch(design)
 
   res = optimizer$optimize(instance)
   expect_equal(res, instance$result)
 
   opdf = instance$archive$data
-  expect_data_table(opdf, any.missing = TRUE, nrows = 10L)
-  expect_data_table(tail(opdf, - nrow(design)), any.missing = FALSE, nrows = 10L - nrow(design))
+  expect_data_table(opdf, any.missing = TRUE, nrows = 5L)
+  expect_data_table(tail(opdf, - nrow(design)), any.missing = FALSE, nrows = 5L - nrow(design))
   expect_equal(instance$result$y, 0, tolerance = 0.1)
 
   optimizer$optimize(instance)
@@ -72,30 +73,23 @@ test_that("OptimizerMbo works for noisy problems", {
   skip_if_not_installed("DiceKriging")
   skip_if_not_installed("rgenoud")
 
-  instance = OptimInstanceSingleCrit$new(
-    objective = OBJ_2D_NOISY,
-    terminator = trm("evals", n_evals = 20L),
-    search_space = PS_2D
-  )
+ instance = MAKE_INST_1D_NOISY(terminator = trm("evals", n_evals = 5L))
 
   optimizer = OptimizerMbo$new(
     loop_function = bayesopt_ego,
     surrogate = SurrogateLearner$new(REGR_KM_NOISY),
     acq_function = AcqFunctionEI$new(),
-    acq_optimizer = NULL,
+    acq_optimizer = AcqOptimizer$new(opt("random_search", batch_size = 2L), terminator = trm("evals", n_evals = 2L)),
     result_function = result_by_surrogate_design,
   )
 
-  design = MAKE_DESIGN(instance, 12L)
+  design = MAKE_DESIGN(instance, 4L)
   instance$eval_batch(design)
 
   optimizer$optimize(instance)
 
   opdf = instance$archive$data
-  expect_data_table(tail(opdf, -nrow(design)), any.missing = FALSE, nrows = 20L - nrow(design))
-  #FIXME: can we test that the surrogate actually influneces the choice?
-  #expect_true(instance$result$y > min(opdf$y)) # we have not chosen the overoptimistic noisy y
-  #expect_equal(instance$result$y, 0, tolerance = 0.2)
+  expect_data_table(tail(opdf, -nrow(design)), any.missing = FALSE, nrows = 5L - nrow(design))
 })
 
 test_that("OptimizerMbo sugar", {
@@ -105,7 +99,7 @@ test_that("OptimizerMbo sugar", {
 
   result = bb_optimize(
     OBJ_1D,
-    method = opt("mbo", acq_function = acqf("cb")),
+    method = opt("mbo", acq_function = acqf("cb"), acq_optimizer = acqo(opt("random_search", batch_size = 2L), terminator = trm("evals", n_evals = 2L))),
     max_evals = 5L
   )
 
@@ -120,10 +114,10 @@ test_that("OptimizerMbo param_classes", {
 
   optimizer = opt("mbo")
   expect_equal(optimizer$param_classes, c("ParamLgl", "ParamInt", "ParamDbl", "ParamFct"))
-  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 10L))
+  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 5L))
   optimizer$surrogate = default_surrogate(instance)
   expect_equal(optimizer$param_classes, c("ParamLgl", "ParamInt", "ParamDbl"))
-  optimizer$acq_optimizer = AcqOptimizer$new(opt("nloptr"), terminator = trm("evals", n_evals = 10L))
+  optimizer$acq_optimizer = AcqOptimizer$new(opt("nloptr"), terminator = trm("evals", n_evals = 2L))
   expect_equal(optimizer$param_classes, "ParamDbl")
 })
 
@@ -134,7 +128,7 @@ test_that("OptimizerMbo properties", {
 
   optimizer = opt("mbo")
   expect_equal(optimizer$properties, c("dependencies", "single-crit", "multi-crit"))
-  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 10L))
+  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 5L))
   optimizer$surrogate = default_surrogate(instance)
   expect_equal(optimizer$properties, c("single-crit", "multi-crit"))
   optimizer$loop_function = bayesopt_ego
@@ -150,10 +144,10 @@ test_that("OptimizerMbo packages", {
 
   optimizer = opt("mbo")
   expect_equal(optimizer$packages, "mlr3mbo")
-  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 10L))
+  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 5L))
   optimizer$surrogate = default_surrogate(instance)
   expect_equal(optimizer$packages, c("mlr3mbo", "mlr3", "mlr3learners", "DiceKriging"))
-  optimizer$acq_optimizer = AcqOptimizer$new(opt("nloptr"), terminator = trm("evals", n_evals = 10L))
+  optimizer$acq_optimizer = AcqOptimizer$new(opt("nloptr"), terminator = trm("evals", n_evals = 2L))
   expect_equal(optimizer$packages, c("mlr3mbo", "mlr3", "mlr3learners", "DiceKriging", "bbotk", "nloptr"))
   optimizer$surrogate = SurrogateLearner$new(lrn("regr.ranger"))
   expect_equal(optimizer$packages, c("mlr3mbo", "mlr3", "mlr3learners", "ranger", "bbotk", "nloptr"))
@@ -167,20 +161,20 @@ test_that("OptimizerMbo args", {
   expect_equal(optimizer$args, list(test = 1))
   optimizer$loop_function = bayesopt_ego
   expect_error(optimizer$args, "Must be a subset of \\{'init_design_size','random_interleave_iter'\\}, but has additional elements \\{'test'\\}.")
-  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 10L))
+  instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 5L))
   expect_error(optimizer$optimize(instance), "Must be a subset of \\{'init_design_size','random_interleave_iter'\\}, but has additional elements \\{'test'\\}.")
   expect_equal(instance$archive$data, data.table())
   optimizer$args = list(random_interleave_iter = 1L)
   optimizer$optimize(instance)
-  expect_equal(nrow(instance$archive$data), 10L)
+  expect_equal(nrow(instance$archive$data), 5L)
   expect_true(optimizer$acq_function$id %nin% colnames(instance$archive$data))
 })
 
 test_that("OptimizerMbo reset", {
   skip_if_not_installed("mlr3learners")
   skip_if_not_installed("DiceKriging")
 
-  optimizer = opt("mbo")
+  optimizer = opt("mbo", acq_optimizer = acqo(opt("random_search", batch_size = 2L), terminator = trm("evals", n_evals = 2L)))
   instance = MAKE_INST_1D(terminator = trm("evals", n_evals = 5L))
   optimizer$optimize(instance)
 
diff --git a/tests/testthat/test_SurrogateLearner.R b/tests/testthat/test_SurrogateLearner.R
@@ -35,7 +35,7 @@ test_that("predict_types are recognized", {
 
   learner = lrn("regr.rpart")
   learner$predict_type = "response"
-  surrogate = SurrogateLearner$new(learner = lrn("regr.rpart"), archive = inst$archive)
+  surrogate = SurrogateLearner$new(learner = learner, archive = inst$archive)
   surrogate$update()
   expect_named(surrogate$predict(xdt), "mean")
 })
@@ -74,7 +74,7 @@ test_that("insample_perf", {
   expect_number(surrogate$insample_perf, lower = -Inf, upper = 1)
   expect_equal(names(surrogate$insample_perf), surrogate$param_set$values$perf_measure$id)
 
-  surrogate_constant = SurrogateLearner$new(learner = lrn("regr.featureless"), archive = inst$archive)
+  surrogate_constant = SurrogateLearner$new(learner = REGR_FEATURELESS, archive = inst$archive)
   surrogate_constant$param_set$values$assert_insample_perf = TRUE
   surrogate_constant$param_set$values$perf_threshold = 0.5
   surrogate$param_set$values$perf_measure = mlr_measures$get("regr.rsq")
diff --git a/tests/testthat/test_SurrogateLearnerCollection.R b/tests/testthat/test_SurrogateLearnerCollection.R
@@ -79,7 +79,7 @@ test_that("insample_perf", {
   expect_double(surrogate$insample_perf, lower = -Inf, upper = 1, any.missing = FALSE, len = 2L)
   expect_equal(names(surrogate$insample_perf), map_chr(surrogate$param_set$values$perf_measures, "id"))
 
-  surrogate_constant = SurrogateLearnerCollection$new(learner = list(lrn("regr.featureless"), lrn("regr.featureless")), archive = inst$archive)
+  surrogate_constant = SurrogateLearnerCollection$new(learner = list(REGR_FEATURELESS, REGR_FEATURELESS$clone(deep = TRUE)), archive = inst$archive)
   surrogate_constant$param_set$values$assert_insample_perf = TRUE
   surrogate_constant$param_set$values$perf_thresholds = c(0.5, 0.5)
   surrogate_constant$param_set$values$perf_measures = list(mlr_measures$get("regr.rsq"), mlr_measures$get("regr.rsq"))
diff --git a/tests/testthat/test_TunerMbo.R b/tests/testthat/test_TunerMbo.R
diff --git a/tests/testthat/test_bayesopt_mpcl.R b/tests/testthat/test_bayesopt_mpcl.R
diff --git a/tests/testthat/test_mbo_defaults.R b/tests/testthat/test_mbo_defaults.R
diff --git a/tests/testthat/test_mlr_acqfunctions.R b/tests/testthat/test_mlr_acqfunctions.R
diff --git a/tests/testthat/test_mlr_loop_functions.R b/tests/testthat/test_mlr_loop_functions.R
diff --git a/tests/testthat/test_result_by_surrogate_design.R b/tests/testthat/test_result_by_surrogate_design.R

Original file line number	Diff line number	Diff line change
`@@ -1,2 +1,3 @@`
`1`	`1`	`lg$set_threshold(old_threshold_bbotk)`
`2`	`2`	`lg_mlr3$set_threshold(old_threshold_mlr3)`
	`3`	`+`