R/core.EALogger.R

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

# FIXME: log populations at specific generations
# FIXME: getPopulationsAt(generations = c(1L, 10L, 100L), generations = c(0.1, 0.45, 1.9), as.df = TRUE)
EALogger = R6Class("EALogger",
  public = list(
    # information regarding statistics
    stat.names = c(),
    stat.types = c(),
    n.stats = 0L,

    # information regarding extras
    extras.names = c(),
    extras.types = c(),
    n.extras = 0L,

    # internal variables
    logbook = NULL,
    curline = NULL,
    size = NULL,
    grow.fun = NULL,

    # keep track of progress
    last.record = NULL,
    stat.stagnation = NULL,

    # single-objective optimization,
    minimize = NULL,
    incumbant.x = NULL,
    incumbant.fx = NULL,
    log.incumbant = NULL,

    # global interest
    time.started = NULL,
    evals = NULL,
    gen = NULL,

    initialize = function(control, size = 1000L, stats = NULL, log.pop = FALSE, extras = NULL, grow.fun = function(x) x + 1000L) {
      checkmate::assertR6(control, classes = "EAControl")
      checkmate::assertR6(stats, classes = "EAStatistics", null.ok = TRUE)
      size = checkmate::asInt(size, lower = 1L)
      checkmate::assertFlag(log.pop)
      checkmate::assertList(extras, names = "unique", any.missing = FALSE, all.missing = FALSE, null.ok = TRUE)
      checkmate::assertFunction(grow.fun)

      if (!is.null(stats)) {
        self$stat.names = stats$getNames()
        self$n.stats = length(self$stat.names)
        self$stat.types = rep("numeric", self$n.stats)
        self$stat.stagnation = rep(0L, self$n.stats)
      }

      if (!is.null(extras)) {
        self$extras.names = names(extras)
        self$n.extras = length(self$extras.names)
        self$extras.types = unname(unlist(extras))
      }

      self$logbook = self$initLogbook(size)
      self$size = size
      self$curline = 1L
      self$grow.fun = grow.fun

      self$gen = 0L
      self$evals = 0L
      self$time.started = proc.time()[3L]

      self$minimize = control$minimize[1L]
      self$incumbant.x = NULL
      self$log.incumbant = (control$n.objectives == 1L)
      self$incumbant.fx = if (control$minimize[1L]) Inf else -Inf

      return(invisible(self))
    },

    update = function(gen, evals, stats.record = list(), extras.record = list(), X = NULL) {
      # update globals
      time.passed = as.numeric(proc.time()[3L] - self$time.started)
      self$gen = gen
      self$evals = self$evals + evals

      # update incumbant
      if (!is.null(X) && self$log.incumbant) {
        cur.best = getCurrentBest(X, minimize = self$minimize)
        if ((self$minimize && cur.best$fx <= self$incumbant.fx) ||
            (!self$minimize && cur.best$fx >= self$incumbant.fx)) {
          self$incumbant.x = cur.best$x
          self$incumbant.fx = cur.best$fx
        }
      }

      # handle missing extras
      if (length(extras.record) != self$n.extras) {
        #FIXME: save extras.missing?
        extras.missing = BBmisc::namedList(names = self$extras.names, init = NA)
        extras.record = BBmisc::insert(extras.missing, extras.record)
      }

      # do we  need to resize
      if (self$overflowIncoming()) {
        self$resizeLogbook()
      }

      record = c(list(gen = gen, evaluations = evals, time.passed = time.passed), stats.record, extras.record)
      self$logbook[self$curline, ] = record
      self$curline = self$curline + 1L

      # update stagnation bookkeeping
      #FIXME: this is damn slow! In particular the update of self§last.record. Why!?
      # if (!is.null(self$last.record)) {
      #   did.change = (self$last.record != stats.record)
      #   self$stat.stagnation = ifelse(did.change, 0, self$stat.stagnation + 1L)
      # }
      #self$last.record = stats.record

      return(invisible(self))
    },

    initLogbook = function(size) {
      BBmisc::makeDataFrame(nrow = size, ncol = 3L + self$n.stats + self$n.extras,
        col.types = c("integer", "integer", "numeric", self$stat.types, self$extras.types),
        col.names = c("gen", "evaluations", "time.passed", self$stat.names, self$extras.names))
    },

    overflowIncoming = function() {
      self$curline > self$size
    },

    resizeLogbook = function() {
      newsize = self$grow.fun(self$size)
      logbook2 = self$initLogbook(newsize - self$size)
      self$logbook = rbind(self$logbook, logbook2)
      lg$debug("logger: resizing logbook (%i to %i).", self$size, newsize)
      self$size = newsize
    },

    getLogbook = function() {
      return(dplyr::as_tibble(self$logbook[seq_len(self$curline - 1L), , drop = FALSE]))
    },

    getIncumbant = function() {
      if (!self$log.incumbant) {
        BBmisc::warningf("EALogger$getIncumbant(): incumbant not logged in multi-objective setting.")
        return(NA)
      }
      return(list(x = self$incumbant.x, fx = self$incumbant.fx))
    }
  ) # public
) # EALogger