damn! merge stuff by hand

NAMESPACE

@@ -60,6 +60,7 @@ export(makeOperator)
 export(makeOptimizationTask)
 export(makePMXRecombinator)
 export(makePermutationGenerator)
+export(makePopulation)
 export(makeRecombinator)
 export(makeRouletteWheelSelector)
 export(makeScrambleMutator)

R/computeFitness.R

@@ -9,9 +9,18 @@
 #'   Population.
 #' @param fitness.fun [\code{function}]\cr
 #'   Fitness function.
+#' @param control [\code{ecr_control}]\cr
+#'   Control object containing all operators and further parameters.
+#'   See \code{\link{setupECRControl}} and \code{\link{setupEvolutionaryOperators}}.
 #' @return [\code{matrix}].
-computeFitness = function(population, fitness.fun) {
-  fitness = lapply(population$individuals, fitness.fun)
+computeFitness = function(population, fitness.fun, control) {
+  if (getParamNr(control$par.set) == 1L) {
+    # one parameter
+    fitness = lapply(population$individuals, fitness.fun)
+  } else {
+    # many parameters, which are explicit defined in function
+    fitness = lapply(population$individuals, function(ind) do.call(fitness.fun, ind))
+  }
   # force fitness to be stored in a matrix (be consistent for single and
   # multi-objective fitness funs)
   fitness = do.call(cbind, fitness)

R/doTheEvolution.R

@@ -67,7 +67,7 @@ doTheEvolution = function(task, control, initial.population = NULL) {
 
   # generate intial population
   population = buildInitialPopulation(n.population, task, control, initial.population)
-  population$fitness = computeFitness(population, task$fitness.fun)
+  population$fitness = computeFitness(population, task$fitness.fun, control)
   n.evals = n.population
 
   # initialize storage object which contains all the stuff needed by the algorithms

R/emoa.spea2.R

@@ -0,0 +1,85 @@
+# @title
+#   Implementation of the SPEA2 EMOA algorithm.
+#
+# @description
+#   ...
+#
+# @note
+#   This is a pure R implementation of the SPEA2 algorithm. It hides the regular
+#   \pkg{ecr} interface and offers a more R like interface while still being quite
+#   adaptable.
+#
+# @keywords optimize
+#
+# @references
+#   ...
+#
+# @template arg_optimization_task
+# @param n.population [\code{integer(1)}]\cr
+#   Population size. Default is \code{100}.
+# @param n.archive [\code{integer(1)}]\cr
+#   Size of the pareto archive.
+# @template arg_parent_selector
+# @template arg_mutator
+# @template arg_recombinator
+# @template arg_max_iter
+# @template arg_max_evals
+# @template arg_max_time
+# @return [\code{ecr_ecr_multi_objective_result}]
+spea2 = function(
+  task,
+  n.population = 100L,
+  n.archive,
+  parent.selector = makeSimpleSelector(),
+  mutator = makeGaussMutator(),
+  recombinator = makeCrossoverRecombinator(),
+  max.iter = 100L,
+  max.evals = NULL,
+  max.time = NULL) {
+
+  if (isSmoofFunction(task)) {
+    task = makeOptimizationTask(task)
+  }
+  assertInt(n.archive, na.ok = FALSE, lower = 2L)
+
+  # Implementation of surival selection operator of the AS-EMOA algorithm.
+  spea2Selector = makeSelector(
+    selector = function(population, storage, task, n.select, control) {
+      fitness = population$fitness
+      population = population$individuals
+
+      return(makePopulation(...))
+    },
+    supported.objectives = "multi-objective",
+    name = "SPEA2 selector",
+    description = "Selection takes place on modified fitness function."
+  )
+
+  # SPEA2 control object
+  ctrl = setupECRControl(
+    n.population = n.population,
+    n.offspring = 1L,
+    representation = "float",
+    survival.strategy = "comma",
+    monitor = makeConsoleMonitor(),
+    stopping.conditions = list(
+      makeMaximumEvaluationsStoppingCondition(max.evals),
+      makeMaximumTimeStoppingCondition(max.time),
+      makeMaximumIterationsStoppingCondition(max.iter)
+    )
+  )
+
+  ctrl = setupEvolutionaryOperators(
+    ctrl,
+    parent.selector = parent.selector,
+    recombinator = recombinator,
+    generator = makeUniformGenerator,
+    mutator = mutator,
+    survival.selector = asemoaSelector
+  )
+
+  ctrl$n.archive = n.archive
+  ctrl$archive = list()
+
+  return(doTheEvolution(task, ctrl))
+}

R/generateOffspring.R

@@ -10,32 +10,32 @@
 #' @param objective.fun [\code{function}]\cr
 #'   Target fun.
 #' @param control [\code{ecr_control}]\cr
-#'   Control object containing alle the operators and further parameters.
+#'   Control object containing all operators and further parameters.
 #' @param opt.path [\code{OptPath}]\cr
 #'   Optimization path.
 #' @return [\code{setOfIndividuals}] Generated offspring.
 generateOffspring = function(matingPool, task, STORAGE, objective.fun, control, opt.path) {
   n.offspring = control$n.offspring
   offspring = vector(mode = "list", length = n.offspring)
 
-  i = 1L
-  while(i <= n.offspring) {
+  i.offspring = 1L
+  while(i.offspring <= n.offspring) {
     parents = getParents(matingPool, n.parents = getNumberOfParentsNeededForMating(control))
     children = recombine(control, parents, task)
     # eventually the recombinator returns multiple children
     if (hasAttributes(children, "multiple")) {
-      max.children = min(length(children), n.offspring - i + 1L)
+      max.children = min(length(children), n.offspring - i.offspring + 1L)
       for (j in seq(max.children)) {
-        offspring[[i]] = mutate(control, children[[j]], task)
-        i = i + 1L
+        offspring[[i.offspring]] = mutate(control, children[[j]], task)
+        i.offspring = i.offspring + 1L
       }
     } else {
-      offspring[[i]] = mutate(control, children, task)
-      i = i + 1L
+      offspring[[i.offspring]] = mutate(control, children, task)
+      i.offspring = i.offspring + 1L
     }
   }
 
-  offspring.fitness = computeFitness(makePopulation(offspring), objective.fun)
+  offspring.fitness = computeFitness(makePopulation(offspring), objective.fun, control)
 
   return(makePopulation(offspring, offspring.fitness))
 }

R/generator.random.binary.R

@@ -5,24 +5,34 @@
 #'   The generated operator samples uniformally distributed points in the design
 #'   space of the target function taking care not to violate bounds.
 #'
-#' @return [\code{ecr_operator}]
+#' @return [\code{ecr_generator}]
 #' @export
 makeBinaryGenerator = function() {
   generateBinaryPopulation = function(size, task, control) {
     par.set = control$par.set
-    n.params = sum(getParamLengths(par.set))
-    population = list()
-    for (i in seq(size)) {
-      population[[i]] = sample(c(0, 1), size = n.params, replace = TRUE)
+
+    if (getParamNr(par.set) == 1L) {
+      # one vector is an individual
+      createInd = function(param.length) {
+        sample(c(0, 1), size = param.length, replace = TRUE)
+      }
+    } else {
+      # a list of vectors is an individual
+      createInd = function(param.length) {
+        lapply(param.length, function(x) sample(c(0, 1), size = x, replace = TRUE))
+      }
     }
+
+    # create population list
+    population = lapply(seq(size), function(x) createInd(getParamLengths(par.set)))
     makePopulation(population)
   }
-  operator = makeOperator(
-    operator = generateBinaryPopulation,
+
+  generator = makeGenerator(
+    generator = generateBinaryPopulation,
     name = "Binary generator",
     description = "Samples uniformally distributed 0, 1 values.",
     supported = c("binary")
   )
-  operator = addClasses(operator, c("ecr_generator"))
-  return(operator)
+  return(generator)
 }

R/generator.random.permutation.R

@@ -9,19 +9,23 @@
 makePermutationGenerator = function() {
   generatePermutationPopulation = function(size, task, control) {
     par.set = control$par.set
+    if (getParamNr(par.set) > 1L) {
+      stopf("The Permutation Generator works only with one parameter(-vector).")
+    }
+
     n.params = sum(getParamLengths(par.set))
     population = list()
     for(i in seq(size)) {
       population[[i]] = sample(1:n.params)
     }
     makePopulation(population)
   }
-  operator = makeOperator(
-    operator = generatePermutationPopulation,
+
+  generator = makeGenerator(
+    generator = generatePermutationPopulation,
     name = "Permutation generator",
     description = "Generates random permutations.",
     supported = c("permutation")
   )
-  operator = addClasses(operator, c("ecr_generator"))
-  return(operator)
+  return(generator)
 }

R/generator.uniform.float.R

@@ -6,30 +6,55 @@
 #'   within the bounds specified by the paramter set of the \pkg{smoof} objective
 #'   function passed to the \code{\link{doTheEvolution}} function.
 #'
-#' @return [\code{ecr_opeator}]
+#' @return [\code{ecr_generator}]
 #' @export
 makeUniformGenerator = function() {
   generateUniformPopulation = function(size, task, control) {
     par.set = control$par.set
+    if (!isNumeric(par.set)) {
+      stopf("Uniform generator needs a numeric parameter set.")
+    }
+    if (!hasFiniteBoxConstraints(par.set)) {
+      stopf("Uniform generator needs box constraints.")
+    }
+
     lower = getLower(par.set)
     upper = getUpper(par.set)
-    n.params = sum(getParamLengths(par.set))
-    population = list()
-    for(i in seq(size)) {
-      ind = vector(mode = "numeric", length = n.params)
-      for (j in seq(n.params)) {
-        ind[j] = runif(1L, min = lower[j], max = upper[j])
+
+    # create one gene
+    createGene = function(constr) {
+      mapply(runif, n = 1L, min = constr$low, max = constr$up)
+    }
+    # is one gene an individual or is a set of genes an individual
+    n.params = getParamNr(par.set)
+    if (n.params == 1L) {
+      constraints = list(low = lower, up = upper)
+      createInd = createGene
+    } else {
+      ids = getParamIds(par.set)
+      constraints = vector("list", n.params)
+      names(constraints) = ids
+      for (i.param in seq(n.params)) {
+        constraints[[i.param]] = list(low = lower[names(lower) == ids[i.param]]
+                                      , up = upper[names(upper) == ids[i.param]]
+                                      )
+      }
+      # create individual from genes
+      createInd = function(constr) {
+        lapply(constr, createGene)
       }
-      population[[i]] = ind
     }
+
+    population = lapply(seq(size), function(x) createInd(constraints))
     makePopulation(population)
   }
-  operator = makeOperator(
-    operator = generateUniformPopulation,
+
+  generator = makeGenerator(
+    generator = generateUniformPopulation,
     name = "Uniform generator",
     description = "Samples uniformally distributed points in the design space.",
     supported = "float"
   )
-  operator = addClasses(operator, c("ecr_generator"))
-  return(operator)
+
+  return(generator)
 }

R/makeOperator.R

@@ -30,9 +30,9 @@ makeOperator = function(operator, name, description = NULL,
   defaults = list(),
   checker = function(operator.control) TRUE) {
   assertFunction(operator)
-  assertCharacter(name, len = 1L, any.missing = FALSE)
+  assertString(name)
   if (!is.null(description)) {
-    assertCharacter(description, len = 1L, any.missing = FALSE)
+    assertString(description)
   }
   assertSubset(supported, choices = getAvailableRepresentations(), empty.ok = FALSE)
   assertList(defaults, unique = TRUE, any.missing = FALSE)

R/makePopulation.R

@@ -2,11 +2,20 @@
 #'   Wrap individuals in a \code{setOfIndividuals}.
 #'
 #' @param individuals [\code{matrix}]\cr
-#'   Matrix of individuals.
+#'   List of individuals.
 #' @param fitness [\code{matrix}]\cr
-#'   Matrix of fitness values for the individuals.
+#'   Matrix with one row of fitness values for the individuals.
+#'   Default is \code{NULL}.
 #' @return [\code{setOfIndividuals}]
+#' @export
 makePopulation = function(individuals, fitness = NULL) {
+  assertList(individuals, any.missing = FALSE)
+  if (!testNull(fitness)) {
+    assert(checkMatrix(fitness, any.missing = FALSE, nrows = 1, ncols = length(individuals))
+           , checkNumber(fitness)
+           )
+  }
+
   makeS3Obj(
     individuals = individuals,
     fitness = fitness,

R/mutator.bitflip.R

@@ -12,7 +12,7 @@
 #' @export
 makeBitFlipMutator = function(p = 0.1) {
   mutatorCheck = function(operator.control) {
-    assertNumber(operator.control$p, lower = 0.000001, upper = 0.999999, na.ok = FALSE)
+    assertNumber(operator.control$p, lower = 0, upper = 1)
   }
 
   force(p)
@@ -23,6 +23,18 @@ makeBitFlipMutator = function(p = 0.1) {
     n.params = length(ind)
     do.mutate = runif(n.params) < args$p
     ind[do.mutate] = 1 - ind[do.mutate]
+    mutateGene = function(gene, prob) {
+      do.mutate = runif(length(gene)) < prob
+      gene[do.mutate] = 1 - gene[do.mutate]
+      gene
+    }
+
+    if (getParamNr(control$par.set) == 1L) {
+      ind = mutateGene(ind, args$p)
+    } else {
+      ind = lapply(ind, mutateGene, prob = args$p)
+    }
+
     return(ind)
   }