tests/testthat/test_AcqFunctionEIPS.R

In mlr3mbo: Flexible Bayesian Optimization

test_that("AcqFunctionEIPS works", {
  objective = ObjectiveRFunDt$new(
    fun = function(xdt) data.table(y = xdt$x^2, time = xdt$x + 10),
    domain = PS_1D,
    codomain = ps(y = p_dbl(tags = "minimize"), time = p_dbl(tags = "time"))
  )
  inst = MAKE_INST(objective = objective, search_space = PS_1D, terminator = trm("evals", n_evals = 5L))
  surrogate = SurrogateLearnerCollection$new(
    list(REGR_FEATURELESS, REGR_FEATURELESS$clone(deep = TRUE)),
    archive = inst$archive,
    cols_y = c("y", "time")
  )
  acqf = AcqFunctionEIPS$new(surrogate = surrogate)
  expect_acqfunction(acqf)

  expect_r6(acqf$codomain, "ParamSet")
  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)
  expect_list(acqf$surrogate$learner, types = "Learner")
  expect_true(acqf$requires_predict_type_se)

  design = MAKE_DESIGN(inst)
  inst$eval_batch(design)

  acqf$surrogate$update()
  xdt = data.table(x = seq(-1, 1, length.out = 5L))
  expect_error(acqf$eval_dt(xdt), "update")
  acqf$update()
  res = acqf$eval_dt(xdt)
  expect_data_table(res, ncols = 1L, nrows = 5L, any.missing = FALSE)
  expect_named(res, acqf$id)

  # eips must actually divide expected improvement by the predicted time
  p = acqf$surrogate$predict(xdt)
  mu = p[[acqf$col_y]]$mean
  se = p[[acqf$col_y]]$se
  mu_t = p[[acqf$col_time]]$mean
  d = acqf$y_best - acqf$surrogate_max_to_min[[acqf$col_y]] * mu
  d_norm = d / se
  ei = d * pnorm(d_norm) + se * dnorm(d_norm)
  expected_eips = ifelse(se < 1e-20 | mu_t < 1e-20, 0, ei / mu_t)
  expect_equal(res[[acqf$id]], expected_eips)
  expect_false(isTRUE(all.equal(res[[acqf$id]], ei)))
})