Merge 4d9328d into 4ee008d

R/PA.EMOA.computeDominanceRanking.R

@@ -1,10 +1,10 @@
 #' @title Ranking of approximation sets.
 #'
 #' @description Ranking is performed by merging all approximation sets over all
-#' algorithms and runs per instance. Next, each approximation \eqn{C} set is assigned a
-#' rank which is 1 plus the number of approximation sets, which are better than
-#' \eqn{C} (a set \eqn{D} is better than \eqn{C}, if for each point \eqn{x \in C} there
-#' exists a point in \eqn{y \in D} which weakly dominates \eqn{x}).
+#' algorithms and runs per instance. Next, each approximation set \eqn{C} is assigned a
+#' rank which is 1 plus the number of approximation sets that are better than
+#' \eqn{C}. A set \eqn{D} is better than \eqn{C}, if for each point \eqn{x \in C}{x in C} there
+#' exists a point in \eqn{y \in D}{y in D} which weakly dominates \eqn{x}.
 #' Thus, each approximation set is reduced to a number -- its rank. This rank distribution
 #' may act for first comparrison of multi-objecitve stochastic optimizers.
 #' See [1] for more details.

R/dominates.R

@@ -56,7 +56,7 @@ isDominated = function(x, y) {
 #' @rdname dominated
 #' @export
 dominated = function(x) {
-  assertMatrix(x, min.rows = 2L, min.cols = 2L, any.missing = FALSE, all.missing = FALSE)
+  assertMatrix(x, min.rows = 2L, min.cols = 1L, any.missing = FALSE, all.missing = FALSE)
   return(.Call("dominatedC", x))
 }
 

R/logger.default.R

@@ -224,7 +224,7 @@ updateLogger = function(log, population, fitness = NULL, n.evals, extras = NULL,
 
   # grow memory
   if (n.log < log$env$cur.line) {
-    #catf("increasing log size! Doubling size: %i -> %i", n.log, 2 * n.log)
+    catf("increasing log size! Doubling size: %i -> %i", n.log, 2 * n.log)
     log$env$stats = rbind(log$env$stats,
       makeDataFrame(ncol = ncol(log$env$stats),
       nrow = n.log * 2,
@@ -319,7 +319,7 @@ getStatistics = function(log, trim = TRUE) {
   assertClass(log, "ecr_logger")
   assertFlag(trim)
   stats = log$env$stats
-  if (trim & (log$env$cur.line < nrow(stats))) {
+  if (trim & (log$env$cur.line - 1 < nrow(stats))) {
     stats = stats[seq.int(log$env$cur.line - 1L), , drop = FALSE]
   }
   return(stats)
@@ -351,7 +351,7 @@ getPopulations = function(log, trim = TRUE) {
   if (is.null(pops))
     stopf("This should not happen. Populations should be saved, but not found.")
 
-  if (trim & (log$env$cur.line < length(pops))) {
+  if (trim & (log$env$cur.line - 1 < length(pops))) {
     pops = pops[seq.int(log$env$cur.line - 1L)]
   }
   return(pops)
@@ -382,7 +382,7 @@ getPopulationFitness = function(log, trim = TRUE) {
   if (is.null(pops))
     stopf("This should not happen. Populations should be saved, but not found.")
 
-  if (trim & (log$env$cur.line < length(pops))) {
+  if (trim & (log$env$cur.line - 1 < length(pops))) {
     pops = pops[seq.int(log$env$cur.line - 1L)]
   }
 

R/operator.mutator.bitflip.R

@@ -6,6 +6,10 @@
 #' with a given probability \eqn{p \in (0, 1)}. Usually it is recommended to
 #' set \eqn{p = \frac{1}{n}} where \eqn{n} is the number of bits in the
 #' representation.
+#' 
+#' @references
+#' [1] Eiben, A. E. & Smith, James E. (2015). Introduction to Evolutionary
+#' Computing (2nd ed.). Springer Publishing Company, Incorporated. 52.
 #'
 #' @param ind [\code{binary}]\cr
 #'   Binary vector, i.e., vector with elements 0 and 1 only.

R/operator.mutator.gauss.R

@@ -7,6 +7,14 @@
 #' an individual \eqn{\mathbf{x} \in R^l} this mutator adds a Gaussian
 #' distributed random value to each component of \eqn{\mathbf{x}}, i.~e.,
 #' \eqn{\tilde{\mathbf{x}}_i = \mathbf{x}_i + \sigma \mathcal{N}(0, 1)}.
+#' 
+#' @references 
+#' [1] Beyer, Hans-Georg & Schwefel, Hans-Paul (2002). Evolution strategies. 
+#' Kluwer Academic Publishers.
+#' 
+#' [2] Mateo, P. M. & Alberto, I. (2011). A mutation operator based
+#' on a Pareto ranking for multi-objective evolutionary algorithms. 
+#' Springer Science+Business Meda. 57.
 #'
 #' @param ind [\code{numeric}]\cr
 #'   Numeric vector / individual to mutate.

R/operator.mutator.polynomial.R

@@ -15,7 +15,8 @@
 #' @param ind [\code{numeric}]\cr
 #'   Numeric vector / individual to mutate.
 #' @param p [\code{numeric(1)}]\cr
-#'   Probability of mutation of each gene.
+#'   Probability of mutation for each gene of an offspring. In other words, 
+#'   the probability that the value (allele) of a given gene will change.
 #'   Default is 0.2
 #' @param eta [\code{numeric(1)}\cr
 #'   Distance parameter to control the shape of the mutation distribution. 

R/replace.R

@@ -58,6 +58,7 @@ replaceMuPlusLambda = function(control, population, offspring, fitness = NULL, f
 replaceMuCommaLambda = function(control, population, offspring, fitness = NULL, fitness.offspring = NULL, n.elite = base::max(ceiling(length(population) * 0.1), 1L)) {
   assertList(population)
   assertList(offspring)
+
   mu = length(population)
 
   if (is.null(fitness))
@@ -69,10 +70,13 @@ replaceMuCommaLambda = function(control, population, offspring, fitness = NULL,
   assertMatrix(fitness.offspring, ncols = length(offspring))
   n.elite = asInt(n.elite, lower = 0)
   # get elite individuals from current population
-  #FIXME: only if we are not multi-objective
+  # works only if we are not multi-objective
   surv = vector("list", mu)
   surv.fit = fitness
   if (n.elite > 0) {
+    if (control$task$n.objectives > 1L) stopf(paste("Incomparable solutions - no total order can be established among the individuals with respect to their fitness.\n",
+                                                    "Elitism via 'n.elite' is only supported for single-objective optimization tasks.\n"))
+
     elite.idx = order(as.numeric(fitness), decreasing = !control$task$minimize)[1:n.elite]
     surv[1:n.elite] = population[elite.idx]
     surv.fit[, 1:n.elite] = fitness[, elite.idx, drop = FALSE]

ecr2.Rproj

@@ -0,0 +1,17 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX
+
+BuildType: Package
+PackageUseDevtools: Yes
+PackageInstallArgs: --no-multiarch --with-keep.source

inst/examples/ea.weasel.R

@@ -1,6 +1,5 @@
 library(BBmisc)
 library(devtools)
-library(rpn)
 
 load_all(".")
 

inst/examples/simple_emoa.R

@@ -28,7 +28,7 @@ control = registerECROperator(control, "selectForMating", selSimple)
 # setup initial population
 population = genReal(mu, n.dim = getNumberOfParameters(fun),
   lower = getLowerBoxConstraints(fun), upper = getUpperBoxConstraints(fun))
-fitness = evaluateFitness(population, control)
+fitness = evaluateFitness(control, population)
 
 # initialize Pareto archive
 truncateByHVContr = function(inds, fitness, max.size, ...) {
@@ -46,7 +46,7 @@ for (iter in seq_len(max.iter)) {
   fitness.archive = getFront(archive)
   inds.archive = getIndividuals(archive)
   population = generateOffspring(control, inds.archive, fitness.archive, lambda = mu, p.recomb = 0, p.mut = 0.6)
-  fitness = evaluateFitness(population, control)
+  fitness = evaluateFitness(control, population)
 }
 
 pareto.front = getFront(archive)

man-roxygen/arg_p_mut.R

@@ -1,3 +1,5 @@
 #' @param p.mut [\code{numeric(1)}]\cr
-#'   Probability to apply mutation to a child.
+#'   The probability that the mutation operator will be applied to a child. 
+#'   Refers only to the application of the mutation operator, not to the 
+#'   probability of mutating individual genes of the respective child.
 #'   Default is 0.1.

src/dominance.c

@@ -50,7 +50,7 @@ static int getDominance(double *points, R_len_t col1, R_len_t col2, R_len_t dim)
 SEXP dominatedC(SEXP r_points) {
   // first unpack R structures
   EXTRACT_NUMERIC_MATRIX(r_points, c_points, dim, n_points);
-
+  
   // allocate memory for result vector
   // I.e., logical vector: component i is TRUE, if i is dominated by at least
   // one j != i
@@ -61,25 +61,28 @@ SEXP dominatedC(SEXP r_points) {
   for (int i = 0; i < n_points; ++i) {
     dominated[i] = FALSE;
   }
-
-  // now actually check for dominance
-  for (int i = 0; i < n_points; ++i) {
-    if (dominated[i]) {
-      continue;
-    }
-    for (int j = (i + 1); j < n_points; ++j) {
-      if (dominated[j]) {
+
+  // single-column matrices always return FALSE
+  if(n_points > 1){
+    // now actually check for dominance
+    for (int i = 0; i < n_points; ++i) {
+      if (dominated[i]) {
         continue;
       }
-      // check if i dominates j or vice verca
-      int dominance = getDominance(c_points, i, j, dim);
-      if (dominance > 0) {
-        dominated[j] = TRUE;
-      } else if (dominance < 0) {
-        dominated[i] = TRUE;
+      for (int j = (i + 1); j < n_points; ++j) {
+        if (dominated[j]) {
+          continue;
+        }
+        // check if i dominates j or vice verca
+        int dominance = getDominance(c_points, i, j, dim);
+        if (dominance > 0) {
+          dominated[j] = TRUE;
+        } else if (dominance < 0) {
+          dominated[i] = TRUE;
+        }
       }
     }
-  }
+  } 
 
   UNPROTECT(1);
   return(r_res);

tests/testthat/test_dominates.R

@@ -50,3 +50,8 @@ test_that("setDominates works as expected", {
   y = cbind(y, matrix(c(0.5, 0.5), ncol = 1L))
   expect_false(setDominates(x, y))
 })
+
+test_that("dominated returns FALSE for single-columned matrices", {
+  x = matrix(c(1,2,3), ncol = 1L)
+  expect_false(dominated(x))
+})

tests/testthat/test_logger.R

@@ -19,11 +19,13 @@ test_that("logger keeps track the right way in single-objective case", {
     population = genBin(10L, evals.per.iter)
     #population = replicate(sample(c(0, 1), 10L, replace = TRUE), n = evals.per.iter, simplify = FALSE)
     fitness = matrix(sapply(population, sum), nrow = 1L)
-    for (i in seq_along(population)) {
-      attr(population[[i]], "fitness") = fitness[, i]
+    cat(i)
+    for (j in seq_along(population)) {
+      attr(population[[j]], "fitness") = fitness[, j]
     }
     extras = list(double = runif(1), number = sample(1:10, 1L), mutator = c("mut1", "mut2")[sample(1:2, 1L)])
     updateLogger(log, population, n.evals = evals.per.iter, extras = extras)
+    expect_true(nrow(getStatistics(log)) == i)
   }
 
   # now check that stuff
@@ -58,3 +60,4 @@ test_that("logger keeps track the right way in single-objective case", {
   expect_length(pops, n.iters)
   expect_true(!all(sapply(pops, is.null)))
 })
+