attic/smashy/experiments/prepare_mbo.R

In mlr-org/miesmuschel: Mixed Integer Evolution Strategies

source("argparse.R")
options(warn = 1)
options(width=170)
options(error = function() {
  traceback(3)
  if(!interactive())quit("no",status=1,runLast=FALSE)
})

args <- list(
  arg("Seed for evaluation", "seed", "s", "integer", name = "curseed"),
#
  arg("What task set to optimize for", "objectives", "o", "choice", choices = c("lcbench", "rbv2_super", "all"), name = "objective"),
  arg("How many repeated evals to do for each config", "repeat", "r", "integer", 1, name = "reps", checkmate.args = list(lower = 1)),
  arg("Budget factor", "budget", "b", name = "budgetfactor", type = "numeric", default = 30, checkmate.args = list(lower = 0)),
  arg("What meta-opt algo to use", "metaopt", "m", "choice", default = "intermbo", choices = c("intermbo", "random_search", "design_points"), name = "algo"),
  arg("File to save the result under", "file", "f", type = "character", default = "<autogenerated>", name = "filename"),
  arg("Fix mu to a number. 0: no fix", "mu", "M", type = "integer", default = 0, checkmate.args = list(lower = 0)),
  arg("Use numeric search space", "numspace", "N", name = "searchspace.numeric"),
  arg("Search with simulated annealing", "search-siman", "S", name = "siman"),
  arg("Batch-method to search over", "search-batch", "B", type = "choice", default = "smashy", choices = c("smashy", "hb", "any"), name = "batchmethod"),
  arg("What infill method to use", "infill", "I", "choice", default = "rs", choices = c("rs", "vario", "all"), name = "infillsearch"),
  arg("Print help and exit", "help", "h")
)

opts <- argparse(args, helparg = "help")

if (opts$filename == "<autogenerated>") {
  opts$filename <- sprintf("run_%s_seed_%s.rds", gsub(":", "-", gsub(" ", "_", Sys.time())), opts$curseed)
}

filename <- opts$filename  # evaluator reads this from .GlobalEnv

if (file.exists(filename)) stop(sprintf("Refusing to overwrite file '%s'.", filename))

source("load_objectives2.R")

makeEvaluator <- function(config) {

  curseed <- config$curseed


  seedstate <- .Random.seed

  if (config$objective == "all") {
    problem_ids = seq_len(nrow(tinst))
  } else {
    problem_ids = tinst[, which(cfg == config$objective)]
  }

  problem_count <- length(problem_ids)

  assertTRUE(problem_count >= 1)




  evaluate_metaconf <- function(metaconf) {
    tmpname <- paste0(filename, ".tmp")  # adapt this every call in case filename changed
    saveRDS(list(
        config = config,
        oi = oi,
        fun = fun
      ), tmpname)

    file.rename(tmpname, filename)

    curseed <<- curseed + problem_count

    if (config$mu != 0) metaconf$mu <- config$mu

    if (config$batchmethod != "any") metaconf$batch_method <- config$batchmethod

    callseed = seq(curseed, length.out = problem_count * config$reps)
    more.args = list(metaconf = metaconf, budgetfactor = config$budgetfactor)

    evalresults <- parallelMap(evaluate_miesmuschel, problem_ids, seed = callseed, more.args = more.args)

    # parallelMap with batchtools seems to reset this (?)
    lgr::get_logger("mlr3")$set_threshold("info")
    lgr::get_logger("bbotk")$set_threshold("info")


    c(list(yval = mean(unlist(evalresults)), curseed = curseed), structure(evalresults, names = tinst[problem_ids, sprintf("%s.%s", cfg, level)]))
  }

  objective <- bbotk::ObjectiveRFun$new(
    fun = function(xs) {
      evaluate_metaconf(xs)
    },
    domain = suggested_meta_domain,
    codomain = ps(yval = p_dbl(tags = "maximize"))
  )

  space <- get_searchspace(
    include.mu = config$mu == 0, include.batchmethod = config$batchmethod == "any",
    infill = config$infillsearch, include.siman = config$siman,
    include.mo = FALSE, numeric.only = config$searchspace.numeric
  )

  oi <- bbotk::OptimInstanceSingleCrit$new(objective, search_space = space, terminator = bbotk::trm("none"))

  # need 'fun' as a variable in this environment.
  fun <- switch(config$algo,
    intermbo = function() {
      designlength <- oi$search_space$length  # design would be 4x param length
      assertTRUE(designlength > 0)
      while ((evald <- nrow(oi$archive$data)) < designlength) {
        .Random.seed <<- seedstate
        design <- generate_design_random(space, designlength)$data
        if (evald) {
          design <- data.table::last(design, -evald)
        }
        bbotk::opt("design_points", design = design)$optimize(oi)
      }
      mboopter <- bbotk::opt("intermbo", infill.opt = "focussearch", infill.opt.focussearch.maxit = 20, initial.design.size = 0)
      repeat {
        .Random.seed <<- seedstate
        evald <- nrow(oi$archive$data)

        oi$terminator <- bbotk::trm("evals", n_evals = evald + 1)

        if (evald %% 3 == 0) {
          design <- generate_design_random(space, 1)$data
          bbotk::opt("design_points", design = design)$optimize(oi)
        } else {
          mboopter$optimize(oi)
        }

        seedstate <<- .Random.seed
      }
    },
    random_search = function() {
      repeat {
        .Random.seed <<- seedstate
        design <- generate_design_random(space, 1)$data
        bbotk::opt("design_points", design = design)$optimize(oi)
        seedstate <<- .Random.seed
      }
    },
    design_points = function() {
      designlength <- 10
      .Random.seed <<- seedstate

      design <- generate_design_random(space, designlength)$data
      repeat {
        evald <- nrow(oi$archive$data)
        drop <- evald %% designlength
        if (drop) {
          cat(sprintf("Dropping %s rows\n", drop))
          usedesign <- data.table::last(design, -drop)
        } else {
          usedesign <- design
        }
        bbotk::opt("design_points", design = usedesign)$optimize(oi)
      }
    }
  )
  list(
    config = config,
    oi = oi,
    fun = fun
  )
}

set.seed(opts$curseed)

evalfun <- makeEvaluator(opts)

saveRDS(evalfun, opts$filename)
cat(sprintf("File %s was created.\n", opts$filename))