diff --git a/DESCRIPTION b/DESCRIPTION index 5e4af79e8..9cb8b8b92 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,7 +32,8 @@ Imports: checkmate (>= 1.8.2), data.table, lhs, - parallelMap (>= 1.3) + parallelMap (>= 1.3), + R6 Suggests: akima, cmaesr (>= 1.0.3), diff --git a/NAMESPACE b/NAMESPACE index 4461e59bd..621f26d12 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,17 @@ # Generated by roxygen2: do not edit by hand +S3method(addOptPathEl,OptPathNg) +S3method(as.data.frame,OptPathNg) +S3method(getOptPathCol,OptPathNg) +S3method(getOptPathCols,OptPathNg) +S3method(getOptPathDOB,OptPathNg) +S3method(getOptPathEOL,OptPathNg) +S3method(getOptPathEl,OptPathNg) +S3method(getOptPathErrorMessages,OptPathNg) +S3method(getOptPathExecTimes,OptPathNg) +S3method(getOptPathLength,OptPathNg) +S3method(getOptPathX,OptPathNg) +S3method(getOptPathY,OptPathNg) S3method(initCrit,InfillCritCB) S3method(initCrit,default) S3method(plot,MBOMultiObjResult) @@ -58,12 +70,14 @@ export(trafoSqrt) import(BBmisc) import(ParamHelpers) import(checkmate) +import(data.table) import(grDevices) import(mlr) import(parallelMap) import(smoof) import(stats) import(utils) +importFrom(R6,R6Class) importFrom(lhs,randomLHS) useDynLib(mlrMBO,c_eps_indicator) useDynLib(mlrMBO,c_sms_indicator) diff --git a/R/OptPathNg.R b/R/OptPathNg.R new file mode 100644 index 000000000..2a4ca7911 --- /dev/null +++ b/R/OptPathNg.R @@ -0,0 +1,228 @@ +## mlr-org/mlrng/attic/OptPath.R - 18.09.2017 + +#' @importFrom R6 R6Class +#' @import data.table +OptPathNg = R6Class(c("OptPathNg", "OptPath"), + public = list( + initialize = function(par.set, y.names = "y", minimize = TRUE) { + x.names = getParamIds(par.set, repeated = TRUE, with.nr = TRUE) + self$data = data.table( + dob = integer(0L), + eol = integer(0L), + msg = character(0L), + exec.time = double(0L), + extra = list()) + Map(function(id, type) { + set(self$data, j = id, value = get(type, mode = "function")()) + }, + id = x.names, + type = getParamTypes(par.set, df.cols = TRUE) + ) + for (y.name in y.names) { + set(self$data, j = y.name, value = numeric(0L)) + } + names(minimize) = y.names + self$x.names = x.names + self$y.names = y.names + self$par.set = par.set + self$minimize = minimize + }, + + add = function(x, y, dob = NULL, eol = NA_integer_, msg = NA_character_, exec.time = NA_real_, extra = NULL) { + if (!is.list(y)) { + y = setNames(as.list(y), self$y.names) + } + assert_list(x, names = "strict") + assert_list(y, names = "strict") + self$data = rbindlist( + list(self$data, c(list(dob = dob %??% (nrow(self$data) + 1), eol = eol, msg = msg, exec.time = exec.time, extra = list(extra)), x, y)) + ) + }, + x.names = NULL, + y.names = NULL, + par.set = NULL, + minimize = NULL, + data = NULL + ), + + active = list( + env = function() { + self$data + } + ) +) + +## overwrite creation + +makeOptPathDF = function(par.set, y.names, minimize, add.transformed.x = FALSE, include.error.message = FALSE, include.exec.time = FALSE, include.extra = FALSE) { + if (add.transformed.x == TRUE) { + stop("add.transformed.x == TRUE not supported by OptPathNg") + } + if (include.error.message == FALSE) { + stop("include.error.message == FALSE not supported by OptPathNg") + } + if (include.exec.time == FALSE) { + stop("include.exec.time == FALSE not supported by OptPathNg") + } + if (include.extra == FALSE) { + stop("include.extra == FALSE not supported by OptPathNg") + } + op = OptPathNg$new(par.set, y.names = y.names, minimize = minimize) + return(op) +} + +#' @export +addOptPathEl.OptPathNg = function(op, x, y, dob = getOptPathLength(op)+1L, eol = NA_integer_, error.message = NA_character_, exec.time = NA_real_, extra = NULL, check.feasible = FALSE) { + if (isTRUE(check.feasible)) { + warning("check.feasible is ignored for OptPathNg") + } + if (any(extractSubList(op$par.set$pars, "len") > 1)) { + x = lapply(x, as.list) + x = unlist(x, recursive = FALSE, use.names = FALSE) + x = setNames(x, getParamIds(op$par.set, repeated = TRUE, with.nr = TRUE)) + } + op$add(x = x, y = y, dob = dob, exec.time = exec.time, eol = eol, msg = error.message, extra = extra) + invisible(op) +} +## overwrite getters of ParamHelpers:: + +#' @export +getOptPathLength.OptPathNg = function(op) { + nrow(op$data) +} + +#' @export +getOptPathExecTimes.OptPathNg = function(op, dob, eol) { + if (!missing(dob) || !missing(eol)) { + stop("dob and eol not supported for OptPathNg") + } + op$data$exec.time +} + +#' @export +getOptPathX.OptPathNg = function(op, dob, eol) { + if (!missing(dob) || !missing(eol)) { + stop("dob and eol not supported for OptPathNg") + } + op$data[,op$x.names, with = FALSE] +} + +#' @export +getOptPathY.OptPathNg = function(op, names, dob, eol, drop = TRUE) { + if (!missing(dob) || !missing(eol)) { + stop("dob, eol and drop not supported for OptPathNg") + } + names = names %??% op$y.names + res = op$data[, names, with = FALSE] + if (drop && ncol(res) == 1) { + res[[1]] + } else { + as.matrix(res) + } +} + +#' @export +getOptPathDOB.OptPathNg = function(op, dob = NULL, eol = NULL) { + dobeol.sub = getOptPathDobAndEolIndex(op, dob, eol) + op$data$dob[dobeol.sub] +} + +#' @export +getOptPathErrorMessages.OptPathNg = function(op, dob, eol) { + if (!missing(dob) || !missing(eol)) { + stop("dob and eol not supported for OptPathNg") + } + op$data$msg +} + +#' @export +getOptPathEl.OptPathNg = function(op, index) { + x = dfRowToList(df = getOptPathX(op), par.set = op$par.set, i = index) + y = getOptPathY(op) + if (is.matrix(y)) { + y = y[index,] + } else { + y = y[index] + } + res = list(x = x, y = y, dob = op$data$dob[index], eol = op$data$eol[index], error.message = op$data$msg[index], exec.time = op$data$exec.time[index], extra = op$data$extra[[index]]) +} + +#not supported warnings + +#' @export +getOptPathCol.OptPathNg = function(op, name, dob = op$env$dob, eol = op$env$eol) { + stop("Not supported for OptPathNg!") +} + +#' @export +getOptPathCols.OptPathNg = function(op, names, dob = op$env$dob, eol = op$env$eol, row.names = NULL) { + stop("Not supported for OptPathNg!") +} + +#' @export +getOptPathEOL.OptPathNg = function(op, dob = op$env$dob, eol = op$env$eol) { + stop("Not supported for OptPathNg!") +} + +# data.frame conversion + +#' @export +as.data.frame.OptPathNg = function(x, row.names = NULL, optional, include.x = TRUE, include.y = TRUE, include.rest = TRUE, dob = NULL, eol = NULL, ...) { + + if (!missing(optional)) { + stop("optional is not supported for OptPathNg") + } + + dt = data.table::copy(x$data) + + dobeol.sub = getOptPathDobAndEolIndex(x, dob, eol) + dt = dt[dobeol.sub, ] + + if (include.rest == FALSE) { + dt[, c("dob", "eol", "msg", "exec.time", "extra"):=NULL] + } else { + extra = rbindlist(dt$extra, fill = TRUE) + dt[, "extra" := NULL] + dt = cbind(dt, extra) + } + if (include.x == FALSE) { + dt[, x$x.names := NULL] + } + if (include.y == FALSE) { + dt[, x$y.names := NULL] + } + + + as.data.frame(dt, ...) +} + +# helpers +getOptPathDobAndEolIndex = function(op, dob = NULL, eol = NULL) { + if (!is.null(dob)) { + dob.sub = op$data$dob %in% dob + } else { + dob.sub = rep(TRUE, times = nrow(op$data)) + } + + if (!is.null(eol)) { + eol.sub = op$data$eol %in% eol + } else { + eol.sub = rep(TRUE, times = nrow(op$data)) + } + dob.sub & eol.sub +} + + + +# WARNING: Obviously subsetting an OptPath can result in objects that do not resemble what we expect from an OptPath +`[.OptPathNg` = function(x, ...) { + z = x$clone() + z$data = '['(z$data, ...) + z +} + +`[[.OptPathNg` = function(x, ...) { + z = x$clone() + z$data = '[['(z$data, ...) + z +} diff --git a/R/OptState.R b/R/OptState.R index bbf52ddb8..2de09f198 100644 --- a/R/OptState.R +++ b/R/OptState.R @@ -59,9 +59,9 @@ makeOptState = function(opt.problem, loop = 0L, tasks = NULL, models = NULL, opt.state$models.loop = -1L #the loop the models where generated opt.state$tasks.loop = -1L #the loop the tasks where generated opt.state$time.model = time.model - opt.state$opt.result = coalesce(opt.result, makeOptResult()) + opt.state$opt.result = opt.result %??% makeOptResult() opt.state$state = state #possible states: init, iter, iter.exceeded, time.exceeded, exec.time.exceeded - opt.state$opt.path = coalesce(opt.path, makeMBOOptPath(opt.problem)) + opt.state$opt.path = opt.path %??% makeMBOOptPath(opt.problem) opt.state$time.last.saved = time.last.saved opt.state$loop.starttime = loop.starttime opt.state$time.used = time.used diff --git a/R/evalFinalPoint.R b/R/evalFinalPoint.R index 0cccd6488..5e17cecfe 100644 --- a/R/evalFinalPoint.R +++ b/R/evalFinalPoint.R @@ -8,7 +8,7 @@ evalFinalPoint = function(opt.state, x.df) { # do some final evaluations and compute mean of target fun values # FIXME: Do we really want the resampling of the last point be part of the opt.path and thus be part of a new model fit if we restart the problem? showInfo(getOptProblemShowInfo(opt.problem), "Performing %i final evals", n) - x.df[seq_len(n), ] = x.df + x.df = x.df[rep(1, times = n), ] prop = makeProposal( control = control, prop.points = x.df, diff --git a/R/filterProposedPoints.R b/R/filterProposedPoints.R index e2456ebb4..4791ce304 100644 --- a/R/filterProposedPoints.R +++ b/R/filterProposedPoints.R @@ -28,7 +28,7 @@ filterProposedPoints = function(prop, opt.state) { # look at min distance from i-point to current set (design + accepted) for (i in seq_len(n)) { - pp = prop$prop.points[i, ] + pp = prop$prop.points[i, , drop = FALSE] min.dist = min(apply(design, 1L, calcMaxMetric, y = pp)) # if too close, mark i-point, otherwise add it to set if (min.dist < control$filter.proposed.points.tol) diff --git a/R/proposePointsHelpers.R b/R/proposePointsHelpers.R index 87ef5462b..6d00568b3 100644 --- a/R/proposePointsHelpers.R +++ b/R/proposePointsHelpers.R @@ -53,6 +53,15 @@ createSinglePointControls = function(control, crit, crit.pars = NULL) { # so we can store (temporary) stuff in it, without changing the real opt.path # needed in CL and DIB multipoint deepCopyOptPath = function(op) { + UseMethod("deepCopyOptPath") +} + +deepCopyOptPath.OptPathNg = function(op) { + op$clone() +} + + +deepCopyOptPath.OptPath = function(op) { op2 = op op2$env = new.env() op2$env$path = op$env$path