Fix #201: focussearch now handles discrete vector parameters (cont.)

R/infillOptFocus.R

@@ -8,11 +8,40 @@
 # See infillOptCMAES.R for interface explanation.
 infillOptFocus = function(infill.crit, models, control, par.set, opt.path, design, iter, ...) {
   global.y = Inf
+
+  discrete.vector.pars = filterParams(par.set, type = c("discretevector", "logicalvector"))
+
+  all.requirements = extractSubList(par.set$pars, "requires", simplify = FALSE)
+  all.requirement.vars = unique(unlist(lapply(all.requirements, all.vars)))
+  if (any(all.requirement.vars %in% getParamIds(discrete.vector.pars))) {
+    stop("Cannot do focus search when some variables have requirements that depend on discrete or logical vector parameters.")
+  }
+
 
-  # restart the whole crap some times
+  # perform multiple starts
   for (restart.iter in seq_len(control$infill.opt.restarts)) {
     # copy parset so we can shrink it
     ps.local = par.set
+
+    # Handle discrete vectors (and logical vectors):
+    # The problem is that for discrete vectors, we can't adjust the range dimension-wise.
+    # Instead we store the range of each discrete vectorparameter dimension in the list of named characters
+    # `discrete.vector.mapping`. In each iteration a random value (that does not contain
+    # the optimum) is dropped from each vector on this list. The $values of the parameters in the parameterset also
+    # need to be modified to reflect the reduced range: from them, always the last value is dropped.
+    # Then `discrete.vector.mapping` is a mapping that maps, for each discrete vector param dimension
+    # with originally n values, from the sampled value (levels 1 to n - #(dropped levels)) to the acutal levels with
+    # random dropouts.
+    #
+    # Since the requirements of the param set are queried while generating the design, this breaks if
+    # there are requirements depending on discrete vector parameters.
+    discrete.vector.mapping = lapply(discrete.vector.pars$pars,
+        function(param) rep(list(setNames(names(param$values), names(param$values))), param$len))
+    discrete.vector.mapping = unlist(discrete.vector.mapping, recursive=FALSE)
+    if (!isEmpty(discrete.vector.pars)) {
+      names(discrete.vector.mapping) = getParamIds(discrete.vector.pars, with.nr = TRUE, repeated = TRUE)
+    }
+
 
     # do iterations where we focus the region-of-interest around the current best point
     for (local.iter in seq_len(control$infill.opt.focussearch.maxit)) {
@@ -21,13 +50,20 @@ infillOptFocus = function(infill.crit, models, control, par.set, opt.path, desig
 
       # convert to param encoding our model was trained on and can use
       newdesign = convertDataFrameCols(newdesign, ints.as.num = TRUE, logicals.as.factor = TRUE)
-      y = infill.crit(newdesign, models, control, ps.local, design, iter, ...)
+
+      # handle discrete vectors
+      for (dfindex in names(discrete.vector.mapping)) {
+        mapping = discrete.vector.mapping[[dfindex]]
+        levels(newdesign[[dfindex]]) = mapping[levels(newdesign[[dfindex]])]
+      }
+
+      y = infill.crit(newdesign, models, control, par.set, design, iter, ...)
 
       # get current best value
       local.index = getMinIndex(y, ties.method = "random")
       local.y = y[local.index]
       local.x.df = newdesign[local.index, , drop = FALSE]
-      local.x.list = dfRowToList(recodeTypes(local.x.df, ps.local), ps.local, 1)
+      local.x.list = dfRowToList(recodeTypes(local.x.df, par.set), par.set, 1)
 
       # if we found a new best value, store it
       if (local.y < global.y) {
@@ -39,24 +75,46 @@ infillOptFocus = function(infill.crit, models, control, par.set, opt.path, desig
        ps.local$pars = lapply(ps.local$pars, function(par) {
          # only shrink when there is a value
          val = local.x.list[[par$id]]
-         if (!isScalarNA(val)) {
-           if (isNumeric(par)) {
-             # shrink to range / 2, centered at val
-             range = par$upper - par$lower
-             par$lower = pmax(par$lower, val - (range / 4))
-             par$upper = pmin(par$upper, val + (range / 4))
-             if (isInteger(par)) {
-               par$lower = floor(par$lower)
-               par$upper = ceiling(par$upper)
+         if (isScalarNA(val)) {
+           return(par)
+         }
+         if (isNumeric(par)) {
+           # shrink to range / 2, centered at val
+           range = par$upper - par$lower
+           par$lower = pmax(par$lower, val - (range / 4))
+           par$upper = pmin(par$upper, val + (range / 4))
+           if (isInteger(par)) {
+             par$lower = floor(par$lower)
+             par$upper = ceiling(par$upper)
+           }
+         } else if (isDiscrete(par)) {
+           # randomly drop a level, which is not val
+           if (length(par$values) <= 1L) {
+             return(par)
+           }
+           # need to do some magic to handle discrete vectors
+           if (par$type %nin% c("discretevector", "logicalvector")) {
+             val.names = names(par$values)
+             # remove current val from delete options, should work also for NA
+             val.names = val.names[!sapply(par$values, identical, y=val)]  # remember, 'val' can be any type
+             to.del = sample(val.names, 1)
+             par$values[[to.del]] = NULL
+           } else {
+             # we remove the last element of par$values and a random element for
+             # each dimension in discrete.vector.mapping.
+             par$values = par$values[-length(par$values)]
+             if (par$type != "logicalvector") {
+               # for discretevectorparam val would be a list; convert to character vector
+               val = names(val)
              }
-           } else if (isDiscrete(par)) {
-             # randomly drop a level, which is not val
-             if (length(par$values) > 1L) {
-               val.names = names(par$values)
-               # remove current val from delete options, should work also for NA
-               val.names = setdiff(val.names, val)
-               to.del = sample(seq_along(val.names), 1)
-               par$values = par$values[-to.del]
+             for (dimnum in seq_len(par$len)) {
+               dfindex = paste0(par$id, dimnum)
+               newmap = val.names = discrete.vector.mapping[[dfindex]]
+               val.names = val.names[val.names != val[dimnum]]
+               to.del = sample(val.names, 1)
+               newmap = newmap[newmap != to.del]
+               names(newmap) = names(par$values)
+               discrete.vector.mapping[[dfindex]] <<- newmap
              }
            }
          }

tests/testthat/test_infill_opt_focus.R

@@ -68,13 +68,18 @@ test_that("complex param space, dependencies, focusing, restarts", {
       if(x$disc2 == 'a') tmp3 = log(x$realA) + x$intA^4 + ifelse(x$discA == 'm', 5, 0)
       if(x$disc2 == 'b') tmp3 = exp(x$realB) + ifelse(x$discB == 'R', sin(x$realBR), sin(x$realBNR))
       if(x$disc2 == "c") tmp3 = 500
+      assert(is.list(x$discVec))
+      assert(x$discVec[[1]] %in% c("a", "b", "c"))
+      assert(x$discScal %in% c("x", "y", "z"))
       tmp1 + tmp2 + tmp3
     },
     par.set = makeParamSet(
       makeNumericParam("real1", lower = 0, upper = 1000),
       makeIntegerParam("int1", lower = -100, upper = 100),
       makeNumericVectorParam("realVec", len = 10, lower = -50, upper = 50),
       makeIntegerVectorParam("intVec", len = 3, lower = 0, upper = 100),
+      makeDiscreteVectorParam("discVec", len = 3, c(x = "a", y = "b", z = "c")),
+      makeDiscreteParam("discScal", c(a = "x", b = "y", c = "z")),
       makeNumericParam("real2", lower = -1, upper = 1),
       makeDiscreteParam("disc1", values = c("foo", "bar"), requires = quote(real2 < 0)),
       makeNumericParam("real3", lower = -100, upper = 100, requires = quote(real2 > 0)),