R/core.EAControl.R

In jakobbossek/ecr3: Evolutionary Computation in R - Version 3

EAControl = R6Class("EAControl",
  public = list(
    # general fields
    fitness.fun = NULL,
    n.objectives = NULL,
    minimize = NULL,
    operators = NULL,
    genotype = NULL,

    # internal bookkeeping
    last.evals = NULL,

    initialize = function(fitness.fun, n.objectives = NULL, minimize = NULL, genotype = "custom") {
      checkmate::assertFunction(fitness.fun)

      if (smoof::isSmoofFunction(fitness.fun)) {
        BBmisc::catf("[ecr3] Passed smoof function. Ignoring remaing arguments 'n.objectives' and 'minimize.")
        n.objectives = smoof::getNumberOfObjectives(fitness.fun)
        minimize = smoof::shouldBeMinimized(fitness.fun)
      }

      self$fitness.fun = fitness.fun
      self$n.objectives = checkmate::assertCount(n.objectives, coerce = TRUE, positive = TRUE)
      self$minimize = checkmate::assertLogical(minimize, all.missing = FALSE, any.missing = FALSE, len = n.objectives)
      self$genotype = genotype
      self$last.evals = 0L
    },

    register = function(slot, what, ...) {
      if (is.null(self$operators[[slot]])) {
        self$operators[[slot]] = list()
      }
      checkmate::assertChoice(slot, choices = c("candidate", "generate", "mutate", "recombine", "selectForMating", "selectForSurvival"))
      self$operators[[slot]] = c(self$operators[[slot]], what)
      invisible(self)
    },

    evaluate = function(X, ...) {
      checkmate::assertList(X)
      # Workarround for future_lapply to be much slower than lapply/parallelMap
      # see: https://github.com/HenrikBengtsson/future.apply/issues/39
      # oopts = options(future.globals.maxSize = +Inf)
      # on.exit(options(oopts))

      # determine individuals with invalid fitness
      invalid = whichInvalidFitness(X)
      self$last.evals = length(invalid)

      lg$debug("Evaluating fitness of %i/%i individuals.", length(invalid), length(X))

      if (smoof::isSmoofFunction(self$fitness.fun)) {
        if (smoof::isVectorized(self$fitness.fun)) {
          FX = do.call(self$fitness.fun, c(list(do.call(cbind, X[invalid])), ...))
        } else {
          #FX = do.call(cbind, future.apply::future_lapply(X, self$fitness.fun, ...))
          FX = do.call(cbind, parallelMap::parallelLapply(X[invalid], self$fitness.fun, ...))
        }
        # fitness matrix is always an (n.obj x n.X) matrix
        if (!is.matrix(FX))
          FX = matrix(FX, nrow = 1L)

        # Now add stuff to X
        X[invalid] = assignFitness(X[invalid], FX)
        return(X)
      }

      #FIXME: slow as hell with future!
      #FX = future.apply::future_lapply(X, function(x) do.call(self$fitness.fun, c(list(x), list(...))))
      FX = parallelMap::parallelLapply(X[invalid], function(x) do.call(self$fitness.fun, c(list(x), list(...))))

      # force fitness to be stored in a matrix (be consistent for single and
      # multi-objective fitness funs)
      FX = do.call(cbind, FX)

      # Now add stuff to X
      X[invalid] = assignFitness(X[invalid], FX)

      return(X)
    },

    # FIXME: Should be private # not exported
    selectSurvivors = function(X, Y, size, strategy, n.elite) {
      if (strategy == "plus")
        return(self$selectPlus(X, Y, size))
      return(self$selectComma(X, Y, size, n.elite))
    },

    selectPlus = function(X, Y, size) {
      selector = self$getOperator("selectForSurvival")
      X = c(X, Y)
      FX = extractFX(X)
      do.survive = selector$run(FX, size = size)
      return(X[do.survive])
    },

    selectComma = function(X, Y, size, n.elite = 1L) {
      selector = self$getOperator("selectForSurvival")
      if (n.elite > 0L) {
        size = size - n.elite
        to.survive1 = EASelectorGreedy$new()$run(extractFX(X), size = n.elite)
        X = X[do.survive1]
      }
      to.survive2 = c()
      if (size > 0L)
        to.survive2 = selector$run(extractFX(Y), size = size)
      Y = Y[do.survive2]

      # catf("n.elite: %i, size: %i", n.elite, size)
      # print(to.survive2)
      # print(inds2)
      if (n.elite == 0L)
        return(Y)
      return(c(X, Y))
    },

    mutate = function(X, p, ...) {
      checkmate::assertList(X, types = "EAIndividual")
      n = length(X)
      checkmate::assertNumber(p, lower = 0, upper = 1L, null.ok = FALSE)

      mutator = self$getOperator("mutate")

      #FIXME: future
      to.touch = which(runif(n) <= p)

      # make older
      X = growOlder(X)

      if (length(to.touch)) {
        X[to.touch] = lapply(X[to.touch], function(x) {
          # Some operator may drop attributes ->reassign
          # BBmisc::catf("--- Passing down to mutator.")
          # print(x)
          x.attr = attributes(x)
          x = mutator$run(x, ...)
          attributes(x) = x.attr
          attr(x, "valid") = FALSE
          return(x)
        })
      }

      return(X)
    },

    recombine = function(pool, p, size = NULL, ...) {
      checkmate::assertList(pool, min.len = 1L, any.missing = FALSE, all.missing = FALSE)
      checkmate::assertNumber(p, lower = 0, upper = 1, null.ok = FALSE)
      checkmate::assertInt(size, lower = 1L, null.ok = TRUE)

      recombinator = self$getOperator("recombine")
      children = NULL
      multiple.children = (recombinator$getNumberOfChildren() >= 2L)

      # parents are children if no recombinator given
      if (is.null(recombinator)) {
        children = do.call(c, pool)
      } else {
        # wrapper fun is necessary since we want to
        wrapper.fun = if (multiple.children) identity else list
        # Otherwise apply recombination to part of pool and keep the rest
        n.pool = length(pool)
        to.touch = runif(n.pool) <= p
        #FIXME: future
        children = lapply(seq_len(n.pool), function(i) {
          parents = lapply(pool[[i]], dropAttributes)
          if (to.touch[i]) {
            return(wrapper.fun(recombinator$run(parents, ...)))
          }
          return(parents)
        })

        # unlist one layer if there were multiple children
        if (multiple.children)
          children = unlist(children, recursive = FALSE)

        # need to make individuals out of stuff again
        children = lapply(children, makeIndividual)

      } # recombination

      # finally we eventually need to drop some individuals
      # This happens, e.g. if we want lambda=5 children, but the recombinator produces 2 children out of two parents
      # per application. Hence, there are 3x2=6 children. Our strategy is to drop the overhead uniformly at random.
      if (!is.null(size))
        children = sample(children, size = size, replace = FALSE)

      return(children)
    },

    populate = function(size, initial = NULL, wrapper = makeIndividual) {
      size = checkmate::asInt(size, lower = 1L)
      checkmate::assertList(initial, min.len = 1L, null.ok = TRUE, all.missing = FALSE, any.missing = FALSE)
      checkmate::assertFunction(wrapper)

      population = list()
      n.initial = 0L

      # sample from given initial
      if (!is.null(initial)) {
        n.initial = length(initial)
      }

      # populate with initial candidate solutions
      if (n.initial > 0L) {
        lg$info("Adding %i provided solutions to initial population.")
        if (n.initial >= size) {
          lg$warn("Population of %i individuals to be build, but %i initial initial provided. Sampling!", size, n.initial)
          population = sample(initial, size = size, replace = FALSE)
        } else {
          population = initial
          size = size - n.initial
        }
      }

      # populate with generated instances if no or to few initial solutions provided
      if (size > 0L) {
        lg$info("Generating random individuals")
        generator = self$getOperator("generate")
        if (is.null(generator))
          BBmisc::stopf("EAControl$generate() requires slot 'generate' to be not null unless enough initial solutions are passed.")
        population2 = generator$run(n = size)
        population = c(population, population2)
      }

      population = lapply(population, wrapper)
      return(population)
    },

    generateOffspring = function(X, size, pr, pm) {
      #BBmisc::catf("X for POOL")
      #print(X)
      recombinator = self$getOperator("recombine")
      mutator = self$getOperator("mutate")
      if (is.null(recombinator) & is.null(mutator)) {
        BBmisc::stopf("[ecr3] EAControl$generateOffspring: Either a recombinator or a mutator must be available.")
      }
      pool = self$selectMates(X, size = size)
      #BBmisc::catf("POOL")
      #print(pool)
      offspring = pool
      if (!is.null(recombinator)) {
        offspring = self$recombine(offspring, p = pr, size = size)
      }
      if (!is.null(mutator)) {
        offspring = self$mutate(offspring, p = pm)
      }
      return(offspring)
    },

    adaptY = function(FX, select.direction) {
      # "vectorize" character indicating supported opt direction by selector
      select.direction = rep(select.direction, self$n.objectives)
      # "logicalize" selector opt direction
      select.direction = (select.direction == "minimize")

      fn.scale = ifelse(xor(self$minimize, select.direction), -1, 1)

      # build transformation matrix
      fn.scale = if (self$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)
      }

      # adapt fitness
      return(fn.scale %*% FX)
    },

    selectMates = function(X, size, slot = "recombine") {
      selector = self$getOperator("selectForMating")

      FX = extractFX(X)
      FX = self$adaptY(FX, selector$getDirection())
      recombinator = self$getOperator(slot)

      to.select = NULL
      if (slot == "recombine" && !is.null(recombinator)) {
        # prepare parents for recombination
        n.parents = recombinator$getNumberOfParentsNeededForMating()
        n.children = recombinator$getNumberOfChildren()
        n.mating = ceiling(size * n.parents / n.children)
        if (n.mating == 1L)
          n.mating = n.parents
        if (n.mating %% n.parents != 0L)
          n.mating = n.mating + (n.mating %% n.parents)
        to.select = matrix(selector$run(FX, size = n.mating), ncol = n.parents)

        # otherwise return list of lists of individuals
        return(lapply(1:nrow(to.select), function(i) {
          X[to.select[i, , drop = TRUE]]
        }))
      }

      # Otherwise just return list of selected individuals if no recombinator passed
      to.select = selector$run(FX, size = size)
      return(X[to.select])
    },

    getOperator = function(slot) {
      self$operators[[slot]][[1L]]
    },

    getLastEvaluationCount = function() {
      self$last.evals
    },

    shouldStop = function(log, terminators) {
      if (missing(terminators))
        terminators = self$terminators
      if (is.null(terminators))
        BBmisc::stopf("[ecr3] EAControl$shouldStop: No terminators provided!")

      stop = list()
      for (terminator in terminators) {
        if (terminator$shouldStop(log)) {
          stop$message  = terminator$getMessage()
          break
        }
      }
      return(stop)
    },

    # check compatibility of operators
    check = function() {
      # problem characteristics
      n.objectives = self$n.objectives
      any.issues = FALSE

      # go through selectors and check if they support the above
      selectors = c(self$operators[["selectForMating"]], self$operators[["selectForSurvival"]])

      for (selector in selectors) {
        if (!selector$hasSupportForObjectives(n.objectives)) {
          any.issues = TRUE
          BBmisc::warningf("Selector '%s' supports '%s' objectives, but fitness function is '%s'.",
           selector$getName(), selector$getSetting(), if (n.objectives == 1L) "single-objective" else "multi-objective")
        }
      }
      # go through variation operators and check if they fit to the genotype!
      operators = c(self$operators[["mutate"]], self$operators[["generate"]], self$operators[["recombine"]])

      for (operator in operators) {
        if (!(self$genotype %in% operator$getSupportedRepresentations())) {
          any.issues = TRUE
          BBmisc::warningf("Operator '%s' supports genotypes '%s', but control has genotype '%s'.",
            operator$getName(), collapse(operator$getSupportedRepresentations(), sep = ", "), self$genotype)
        }
      }
      return(invisible(any.issues))
    },

    print = function(...) {
      BBmisc::catf("[ecr3] Control object.")
      BBmisc::catf("Objectives: %i", self$n.objectives)
      BBmisc::catf("OptDir: (%s)", BBmisc::collapse(ifelse(self$minimize, "-> min", "-> max"), sep = ", "))
      for (opset in self$operators) {
        opset$print()
      }
    }
  ), # public
  private = list(
    # .fitness.fun = NULL,
    # .n.objectives = NULL,
    # .minimize = NULL,
    # .operators = NULL
  ) # private
) # EAControl