R/core.EAResult.R

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

EAResult = R6Class("EAResult",
  public = list(
    xy = NULL,
    minimize = NULL,
    logbook = NULL,
    obj.names = NULL,
    algorithm = NULL,

    initialize = function(X, control, algo.name = NA_character_, log = NULL) {
      checkmate::assertList(X, types = "EAIndividual")
      checkmate::assertR6(control, classes = "EAControl")
      checkmate::assertString(algo.name, na.ok = TRUE)
      checkmate::assertR6(log, classes = "EALogger", null.ok = TRUE)
      self$minimize = control$minimize
      self$obj.names = paste0("y", seq_len(control$n.objectives))
      self$algorithm = algo.name

      #checkmate::assertList(X, len = ncol(FX), null.ok = TRUE)
      checkmate::assertString(algo.name)

      FX = extractFX(X)

      xy = dplyr::as_tibble(t(FX), row.names = FALSE)
      colnames(xy) = self$obj.names
      xy$algorithm = algo.name

      attributes(X) = NULL
      xy$x = X

      if (control$n.objectives > 1L) {
        xy = ecr3::filterDominated(xy)
        xy = ecr3::orderBy(xy, order.col = self$obj.names[1L])
      }

      self$xy = xy

      if (!is.null(log))
        self$logbook = log$getLogbook()

      return(invisible(self))
    },

    getLogbook = function(exclude.pattern = NULL) {
      if (is.null(self$logbook)) {
        return(NA)
      }
      ns = names(self$logbook)
      if (!is.null(exclude.pattern))
        return(self$logbook[, !grepl(exclude.pattern, colnames(self$logbook))])
      return(self$logbook)
    },

    getXY = function(include.x = TRUE) {
      checkmate::assertFlag(include.x)
      if (include.x)
        return(self$xy)
      return(self$xy[, !(colnames(self$xy) == "x"), drop = FALSE])
    }
  ) # public
) # EAresult

EAResultCollection = R6Class("EAResultCollection",
  public = list(
    raw.results = NULL,
    n.results = NULL,

    initialize = function(results = list(), ...) {
      results = BBmisc::insert(results, list(...))
      self$n.results = length(results)
      self$raw.results = results
    },

    getLogbook = function(exclude.pattern = NULL) {
      logbooks = lapply(1:self$n.results, function(i) {
        rr = self$raw.results[[i]]
        lb = rr$getLogbook(exclude.pattern)
        lb$algorithm = rr$algorithm
        lb$repl = i
        return(lb)
      })
      dplyr::as_tibble(do.call(rbind, logbooks))
    },

    getXY = function(include.x = TRUE) {
      xys = lapply(1:self$n.results, function(i) {
        rr = self$raw.results[[i]]
        xy = rr$getXY(include.x = include.x)
        xy$algorithm = rr$algorithm
        xy$repl = i
        return(xy)
      })
      dplyr::as_tibble(do.call(rbind, xys))
    }
  ) # public
) # EAResultCollection

#FIXME: first draft
plotLogbook = function(logbook, x = "gen", y, ...) {
  #FIXME: lookbook is modified in place! Make copy here
  if (is.null(logbook$algorithm)) {
    logbook$algorithm = "Some EA"
  }
  if (is.null(logbook$repl)) {
    logbook$repl = 1L
  }
  n.algorithms = length(unique(logbook$algorithm))
  n.repls = length(unique(logbook$repl))
  logbook$repl = as.factor(logbook$repl)

  pl = ggplot2::ggplot(data = logbook, ggplot2::aes_string(x = x, y = y))
  if (n.repls > 1L) {
    pl = pl + ggplot2::geom_step(ggplot2::aes_string(colour = "repl"))
    pl = pl + viridis::scale_colour_viridis(discrete = TRUE, end = 0.8, alpha = 0.8)
  } else {
    pl = pl + ggplot2::geom_step()
  }

  if (n.algorithms > 1L) {
    pl = pl + facet_wrap(. ~ algorithm, scales = "free")
  }
  return(pl)
}

unite = function(results, ...) {
  results = BBmisc::insert(results, list(...))
  #print(results)
  n.res = length(results)
  n.sols = sapply(results, nrow)
  res = do.call(rbind, results)
  res$repl = rep(seq_len(n.res), n.sols)
  return(res)
}

orderBy = function(x, order.col) {
  UseMethod("orderBy")
}

orderBy.data.frame = function(x, order.col) {
  x[order(x[[order.col]], decreasing = FALSE), , drop = FALSE]
}

filterDominated = function(x) {
  UseMethod("filterDominated")
}

filterDominated.data.frame = function(x, obj.cols = NULL) {
  if (is.null(obj.cols))
    obj.cols = getYColumns(x)
  x[nondominated(t(x[, obj.cols])), , drop = FALSE]
}

filterNondominated = function(x) {
  UseMethod("filterNondominated")
}

filterNondominated.data.frame = function(x, obj.cols = NULL) {
  if (is.null(obj.cols))
    obj.cols = getYColumns(x)
  x[dominated(t(x[, obj.cols])), , drop = FALSE]
}

#FIXME: works only for minimization of all objectives
#FIXME: works only for two dimensions!
which.onhull = function(x, obj.cols = NULL) {
  if (is.null(obj.cols))
    obj.cols = getYColumns(x)
  sort(grDevices::chull(x = as.matrix(x[, obj.cols, drop = FALSE])))
}

onhull = function(x, obj.cols = NULL) {
  (1:nrow(x)) %in% which.onhull(x, obj.cols)
}