add support for maximization

R/doTheEvolution.R

@@ -1,8 +1,8 @@
 #' @title
-#'   Working horse of the ecr package.
+#' Working horse of the ecr package.
 #'
 #' @description
-#'   Takes a function and searches for a global optimum with an evolutionary approach.
+#' Takes a function and searches for a global optimum with an evolutionary approach.
 #'
 #' @keywords optimize
 #'
@@ -153,7 +153,7 @@ print.ecr_result = function(x, ...) {
 }
 
 # @title
-#   Generate 'extras' argument for opt.path.
+# Generate 'extras' argument for opt.path.
 #
 # @param iter [integer(1)]
 #   Current iteration/generation.
@@ -189,7 +189,7 @@ getListOfExtras = function(iter, n.evals, population, start.time, control) {
 }
 
 # @title
-#   Helper function to build initial population.
+# Helper function to build initial population.
 #
 # @param n.population [integer(1)]
 #   Size of the population.
@@ -221,19 +221,25 @@ buildInitialPopulation = function(n.population, task, control, initial.populatio
   return(generated.population)
 }
 
+# @title
+# Check selectors for compatibility with objectives.
+#
+# @param n.objectives [integer(1)]
+#   Number of objectives of the optimization task.
+# @param task [ecr_optimization_task]
+#   Optimization task.
+# @param control [ecr_control]
+#   Control object.
+# @param ... [any]
+#   List of ecr_selector objects.
+# @return Nothing
 checkSelectorCompatibility = function(n.objectives, task, control, ...) {
   selectors = list(...)
   desired.obj = if (n.objectives == 1L) "single-objective" else "multi-objective"
-  # FIXME: case where we have mixed stuff not supported!
-  desired.opt = if (all(task$minimize)) "minimize" else "maximize"
   lapply(selectors, function(selector) {
     if (desired.obj %nin% attr(selector, "supported.objectives")) {
       stopf("Selector '%s' cannot be applied to problem with %i objectives.",
         getOperatorName(selector), n.objectives)
     }
-    if (desired.opt %nin% attr(selector, "supported.opt.directions")) {
-      stopf("Selector '%s' cannot be applied to %s a task.",
-        getOperatorName(selector), desired.opt)
-    }
   })
 }

R/makeOptimizationTask.R

@@ -40,19 +40,23 @@ makeOptimizationTask = function(fun, n.objectives = NULL, minimize = NULL) {
   !is.null(minimize) && assertLogical(minimize, any.missing = FALSE)
 
   if (is.null(minimize)) {
-    minimize = rep(TRUE, n.objectives)
+    if (isSmoofFunction(fun)) {
+      minimize = shouldBeMinimized(fun)
+    } else {
+      minimize = rep(TRUE, n.objectives)
+    }
   }
 
   if (n.objectives != length(minimize)) {
     stopf("Number of objectives does not correspond to the length of the minimize argument.")
   }
 
-  if (n.objectives >= 2L && any(!minimize)) {
-    stopf("At the moment in many-objective optimization ecr needs all objectives to be minimized,
-      but %i objectives shall be maximized. Consider a transformation of you objective function.",
-      sum(!minimize)
-    )
-  }
+  # if (n.objectives >= 2L && any(!minimize)) {
+  #   stopf("At the moment in many-objective optimization ecr needs all objectives to be minimized,
+  #     but %i objectives shall be maximized. Consider a transformation of you objective function.",
+  #     sum(!minimize)
+  #   )
+  # }
 
   task = makeS3Obj(
     fitness.fun = fun,

R/makeSelector.R

@@ -15,10 +15,10 @@
 #'   'permutation', 'float', 'binary'.
 #' @param supported.objectives [\code{character}]\cr
 #'   At least one of \dQuote{single-objective} or \dQuote{multi-objective}.
-#' @param supported.opt.directions [\code{character(1-2)}]\cr
+#' @param supported.opt.direction [\code{character(1-2)}]\cr
 #'   Does the selector work for maximization tasks xor minimization tasks or both?
-#'   Default is \code{c("maximze", "minimize")}, which means both optimization
-#'   \dQuote{directions} are supported.
+#'   Default is \dQuote{\code{minimize}}, which means that the selector selects
+#'   in favour of low fitness values.
 #' @return [\code{ecr_selector}]
 #'   Selector object.
 #' @export
@@ -27,13 +27,13 @@ makeSelector = function(
   name, description,
   supported = getAvailableRepresentations(),
   supported.objectives,
-  supported.opt.directions = c("minimize", "maximze")) {
+  supported.opt.direction = "minimize") {
   assertFunction(selector, args = c("fitness", "n.select", "task", "control", "storage"), ordered = TRUE)
   assertSubset(supported.objectives, c("single-objective", "multi-objective"))
-  assertSubset(supported.opt.directions, c("maximze", "minimize"))
+  assertChoice(supported.opt.direction, choices = c("maximize", "minimize"))
   selector = makeOperator(selector, name, description, supported)
   selector = setAttribute(selector, "supported.objectives", supported.objectives)
-  selector = setAttribute(selector, "supported.opt.directions", supported.opt.directions)
+  selector = setAttribute(selector, "supported.opt.direction", supported.opt.direction)
   selector = addClasses(selector, c("ecr_selector"))
   return(selector)
 }

R/selector.roulettewheel.R

@@ -39,7 +39,7 @@ makeRouletteWheelSelector = function(offset = 0.1) {
       fitness = fitness + abs(min(fitness)) + offset
     }
     #FIXME: this selector supports maximization only at the moment
-    fitness = 1 / fitness
+    #fitness = 1 / fitness
     prob = fitness / sum(fitness)
     idx = sample(seq_along(fitness), size = n.select, replace = TRUE, prob = prob)
     return(idx)
@@ -48,6 +48,7 @@ makeRouletteWheelSelector = function(offset = 0.1) {
     selector = selector,
     name = "Roulette-Wheel selector",
     description = "Selects individuals in a fitness-proportional fashion.",
-    supported.objectives = c("single-objective")
+    supported.objectives = c("single-objective"),
+    supported.opt.direction = "maximize"
   )
 }

R/setupECRControl.R

@@ -1,4 +1,5 @@
-#' @title Generates control object.
+#' @title
+#' Generates control object.
 #'
 #' @description
 #' The ecr package offers a framework for evolutionary computing and therefore offers
@@ -179,9 +180,53 @@ mutate = function(parent, task, control) {
 }
 
 selectForMating = function(fitness, n.select, task, control, storage) {
-  control$parent.selector(fitness, n.select, task, control, storage)
+  fitness2 = transformFitness(fitness, task, control$parent.selector)
+  control$parent.selector(fitness2, n.select, task, control, storage)
 }
 
 selectForSurvival = function(fitness, n.select, task, control, storage) {
-  control$survival.selector(fitness, n.select, task, control, storage)
+  fitness2 = transformFitness(fitness, task, control$survival.selector)
+  control$survival.selector(fitness2, n.select, task, control, storage)
+}
+
+# @title
+# Fitness transformation / scaling.
+#
+# @description
+# Some selectors support maximization only, e.g., roulette wheel selector, or
+# minimization (most others). This function computes a factor from {-1, 1} for
+# each objective to match supported selector optimization directions and
+# the actual objectives of the task.
+#
+# @param fitness [matrix]
+#   Matrix of fitness values with the fitness vector of individual i in the i-th
+#   column.
+# @param task [ecr_optimization_task]
+#   Optimization task.
+# @param control [ecr_control]
+#   Control object.
+# @return [matrix] Transformed / scaled fitness matrix.
+transformFitness = function(fitness, task, selector) {
+  # logical vector of opt directions
+  task.dir = task$minimize
+  # "vectorize" character indicating supported opt direction by selector
+  sup.dir = rep(attr(selector, "supported.opt.direction"), task$n.objectives)
+  # "logicalize" selector opt direction
+  sup.dir = (sup.dir == "minimize")
+
+  fn.scale = ifelse(xor(task.dir, sup.dir), -1, 1)
+
+  # build transformation matrix
+  fn.scale = if (task$n.objectives == 1L) {
+    #FIXME: R BUG?!?!
+    # diag(ifelse(xor(task.dir, sup.dir), -1, 1)) breaks with message
+    # Fehler in diag(ifelse(xor(task.dir, sup.dir), -1, 1)) : ung"ultiger 'nrow' Wert (< 0)
+    # if n.objectives is 1! -.-
+    # Weird R bug??? diag(1) works!
+    as.matrix(fn.scale)
+  } else {
+    diag(fn.scale)
+  }
+  # transform fitness
+  return(fn.scale %*% fitness)
 }

tests/testthat/test_ecr.R

@@ -52,6 +52,25 @@ test_that("ecr works with simple soo function", {
   }
 })
 
+test_that("ecr works for maximization", {
+  obj.fun = makeSingleObjectiveFunction(
+    name = "maximize me",
+    fn = function(x) -sum(x^2),
+    par.set = makeNumericParamSet("x", len = 1L, lower = -10, upper = 10),
+    minimize = FALSE # we want to maximize here
+  )
+  control = setupECRControl(
+    n.population = 10L,
+    n.offspring = 10L,
+    survival.strategy = "plus",
+    stopping.conditions = list(makeMaximumIterationsStoppingCondition(max.iter = 50L)),
+    monitor = makeNullMonitor(),
+    representation = "float"
+  )
+  res = doTheEvolution(obj.fun, control = control)
+  expect_true(abs(res$best.value - 0) < 0.05)
+})
+
 test_that("ecr works on binary representations", {
   n.params = 10L
   max.iter = 150L

tests/testthat/test_makeOptimizationTask.R

@@ -19,11 +19,6 @@ test_that("optimization tasks are properly generated", {
   # wrong length of minimize parameter
   expect_error(makeOptimizationTask(fn, minimize = c(TRUE, FALSE, TRUE)))
 
-  fn = makeZDT3Function(3L)
-  # ecr for now in multi-objective optimization needs all objectives to be minimized
-  expect_error(makeOptimizationTask(fn, minimize = c(TRUE, FALSE)), "all objectives to be minimized",
-    ignore.case = TRUE)
-
   # check if warning is printed if function with requires/forbidden is passed
   fn = makeSingleObjectiveFunction(
     "FUN",