R/helper.R

In mlr3tuning: Hyperparameter Optimization for 'mlr3'

# calls a tuning specific stage only on the callbacks that define it
# plain bbotk callbacks are silently skipped since they only define the bbotk stages
call_back_tuning = function(stage, callbacks, context) {
  callbacks = keep(callbacks, function(callback) exists(stage, envir = callback, inherits = FALSE))
  call_back(stage, callbacks, context)
}

# only callbacks with resample stages have to be passed to resample() and benchmark()
resample_callbacks = function(callbacks) {
  keep(callbacks, function(callback) exists("on_resample_begin", envir = callback, inherits = FALSE))
}

measures_to_codomain = function(measures) {
  measures = as_measures(measures)
  domains = map(measures, function(s) {
    if (is.na(s$minimize)) {
      stopf("Measure %s has its `minimize` field set to NA, which is disallowed when tuning.", s$id)
    }
    p_dbl(tags = ifelse(s$minimize, "minimize", "maximize"))
  })
  names(domains) = ids(measures)
  Codomain$new(domains)
}

# errors if the learner's model is marshaled, so accessors do not silently return the untrained learner or NULL
assert_unmarshaled = function(learner) {
  if (is_marshaled_model(learner$model)) {
    # nolint next
    stopf("Cannot access the trained learner or tuning instance of '%s' while the model is marshaled. Unmarshal it first with `$unmarshal()`.", learner$id)
  }
}

extract_runtime = function(resample_result) {
  runtimes = map_dbl(
    get_private(resample_result)$.data$learner_states(get_private(resample_result)$.view),
    function(state) {
      state$train_time + state$predict_time
    }
  )
  sum(runtimes)
}

extract_inner_tuned_values = function(resample_result, internal_search_space) {
  internal_tuned_values = transpose_list(map(
    get_private(resample_result)$.data$learner_states(get_private(resample_result)$.view),
    "internal_tuned_values"
  ))
  set_class(internal_search_space$aggr_internal_tuned_values(internal_tuned_values), "internal_tuned_values")
}


split_internal_search_space = function(search_space) {
  internal_tune_ids = search_space$ids(any_tags = "internal_tuning")
  if (length(internal_tune_ids)) {
    internal_search_space = search_space$subset(internal_tune_ids)
    search_space = search_space$subset(setdiff(search_space$ids(), internal_tune_ids))
    return(list(search_space = search_space, internal_search_space = internal_search_space))
  }
  list(search_space = search_space, internal_search_space = NULL)
}

#' @export
format_list_item.internal_tuned_values = function(x, ...) {
  as_short_string(unclass(x))
}