R/core.EAStatistics.R

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

EAStatistics = R6Class("EAStatistics",
  public = list(
    stats = NA,

    initialize = function() {
      self$stats = list()
      invisible(self)
    },

    register = function(slot, group, funs, obj = NULL, extractor = NULL, ...) {
      checkmate::assertChoice(slot, choices = c("fitness", "inds"))
      #FIXME: add pattern to group check
      checkmate::assertString(group, min.chars = 1L)
      checkmate::assertCount(obj, positive = TRUE, null.ok = TRUE)
      checkmate::assertFunction(extractor, null.ok = TRUE)
      the.stats = list(
        slot = slot,
        group = group,
        funs = ensureNamedStats(funs),
        obj = obj, extractor = extractor,
        params = list(...))
      #FIXME: check if already present
      self$stats[[group]] = the.stats
      return(invisible(self))
    },

    calculate = function(X) {
      #print(self$stats)
      #print(names(self$stats))
      runner = function(x) {
        input = if (x$slot == "fitness") extractFX(X) else X
        input = if (!is.null(x$extractor)) x$extractor(input) else input
        if (x$slot == "fitness" && !is.null(x$obj))
          input = input[x$obj, , drop = FALSE]
        res = lapply(x$funs, function(statfun) {
          if (is.function(statfun)) {
            return(statfun(input))
          }
          return(do.call(statfun$fun, c(list(input), statfun$params)))
        })
        names(res) = paste(x$group, names(x$funs), sep = ".")
        as.data.frame(res)
      }
      #FIXME: be aware of 'unname' here
      res = do.call(cbind, unname(lapply(self$stats, runner)))
      #return(data.frame(y.min = 1.2, y.max = 1.3, y.sd = 0.0003))
      return(res)
    },

    getNames = function() {
      unname(unlist(lapply(self$stats, function(elem) paste(elem$group, names(elem$funs), sep = "."))))
    }

  ) # public
) # EAStatistics

# Helper function to ensure proper naming of the log.stats list passed
# to the logger.
ensureNamedStats = function(stats) {
  no.names = names(stats) == ""
  if (length(no.names) == 0L)
    no.names = rep(TRUE, length(stats))
  # which funs are no characters?
  no.char = !sapply(stats, is.character)
  # if both is true, i.e. unnamed and no char, we cannot determine a name
  if (all(no.char & no.names))
    stopf("log.stats needs to be a list of function names as strings or named lists.")
  # otherwise take chars as names ...
  names(stats)[no.names] = stats[no.names]
  # ... and convert names to functions
  stats[no.names] = sapply(stats[no.names], get)
  return(stats)
}