R/core.EAIndividual.R

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

makeIndividual = function(x, ...) {
  attr(x, "fitness") = NULL
  attr(x, "age") = 1L
  attr(x, "valid") = FALSE
  attr(x, "more.stuff") = list(...)
  BBmisc::addClasses(x, "EAIndividual")
}

print.EAIndividual = function(x, ...) {
  BBmisc::catf("<EAIndividual>")
  BBmisc::catf("x    : (%s, ...)", collapse(head(x, n = 5L), sep = ", "))
  BBmisc::catf("f(x) : %s (%s)", if(!is.null(attr(x, "fitness"))) collapse(attr(x, "fitness"), sep = ", ") else "NA", if (attr(x, "valid")) "valid" else "invalid")
  BBmisc::catf("Age  : %i", attr(x, "age"))
  BBmisc::catf("Stuff: (%s)", collapse(unname(unlist(attr(x, "more.stuff"))), sep = ", "))
}

whichInvalidFitness = function(X) {
  which(!sapply(X, function(x) attr(x, "valid")))
}

getCurrentBest = function(X, minimize = TRUE) {
  FX = as.numeric(extractFX(X))
  which.fun = if (minimize) which.min else which.max
  idx.best = which.fun(FX)
  list(x = X[[idx.best]], fx = FX[idx.best])
}

extractFX = function(xs) {
  #do.call(cbind, lapply(xs, function(x) attr(x, "fitness")))
  fastCBind(lapply(xs, function(x) attr(x, "fitness")))
}

assignFitness = function(X, FX) {
  lapply(1:ncol(FX), function(i) {
    attr(X[[i]], "fitness") = FX[, i, drop = TRUE]
    attr(X[[i]], "valid") = TRUE
    attr(X[[i]], "age") = 1L
    return(X[[i]])
  })
}

growOlder = function(X) {
  lapply(X, function(x) {
    attr(x, "age") = attr(x, "age") + 1L
    x
  })
}