Use R6 OptPath

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),

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)

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
+}

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

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,

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)

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