R/xegaDfReplicate.R

In xegaDfGene: Gene Operations for Real-Coded Genes

#
# (c) 2021 Andreas Geyer-Schulz
#          Simple Genetic Algorithm in R. V 0.1
#          Layer: Population-level functions.
#                 Independent of gene representation.
#                 The replication mechanism and its variants
#          Package: xegaPopulation.
#

#' Replicates a gene (differential evolution).
#'
#' @description \code{xegaDfReplicateGeneDE()} replicates a gene. Replication
#'              is the reproduction function which uses crossover and
#'              mutation. The control flow of differential evolution 
#'              is as follows:
#'              \itemize{
#'              \item A target gene is selected from the population.
#'              \item A mutant gene is generated by differential mutation.
#'              \item The gene and the mutant gene are crossed to get a 
#'                    new gene.
#'              \item The gene is accepted if it is at least as good 
#'                    as the target gene.
#'              }
#'
#' @details For \code{selection="UniformP"},
#'          for \code{crossover="UPCrossGene"} and
#'          for \code{accept="Best"}
#'          this is 
#'          the algorithm of Price, Storn and Lampinen (2005), page 41.
#'   
#'          targetGene is selected with \code{lF$SelectGene()},
#'          gene0, gene1, and gene2 are selected by \code{lF$SelectMate()}.
#'
#' @param pop    Population of real-coded genes.
#' @param fit    Fitness vector.
#' @param lF     Local configuration of the genetic algorithm.
#'
#' @return A list of one gene.
#'
#' @family Replication
#'
#' @references
#' Price, Kenneth V., Storn, Rainer M. and Lampinen, Jouni A. (2005)
#' The Differential Evolution Algorithm (Chapter 2), pp. 37-134.
#' In: Differential Evolution. A Practical Approach to Global Optimization.
#' Springer, Berlin.
#' <doi:10.1007/3-540-31306-0>
#'
#' @examples
#' pop10<-lapply(rep(0,10), function(x) xegaDfGene::xegaDfInitGene(lFxegaDfGene))
#' epop10<-lapply(pop10, lFxegaDfGene$EvalGene, lF=lFxegaDfGene)
#' fit10<-unlist(lapply(epop10, function(x) {x$fit}))
#' newgenes<-xegaDfReplicateGeneDE(pop10, fit10, lFxegaDfGene)
#' @importFrom xegaSelectGene parm
#' @export
xegaDfReplicateGeneDE<- function(pop, fit, lF)
{
targetGene<-pop[[lF$SelectGene(fit, lF)]]
gene0<-pop[[lF$SelectMate(fit, lF)]]
gene1<-pop[[lF$SelectMate(fit, lF)]]
gene2<-pop[[lF$SelectMate(fit, lF)]]
trialGene<-lF$CrossGene(targetGene,lF$MutateGene(gene0, gene1, gene2, lF))[[1]]
t1<-lF$EvalGene(trialGene, lF)
    lF$trialGene<-parm(t1)
    OperatorPipeline<-function(g, lF) {lF$trialGene()}   
    return(list(lF$Accept(OperatorPipeline, targetGene, lF)))
}

#' Generates a function closure with a gene pipeline for differential evolution.
#'
#' @description \code{xegaDfReplicateGeneDEPipeline()} embeds  
#'              a gene pipeline for differential evolution and the 
#'              genes necessary to evaluate it into 
#'              a function closure.  
#'              Replication
#'              is the reproduction function which uses crossover and
#'              mutation. The control flow of differential evolution 
#'              is as follows:
#'              \itemize{
#'              \item A target gene is selected from the population.
#'              \item A mutant gene is generated by differential mutation.
#'              \item The gene and the mutant gene are crossed to get a 
#'                    new gene.
#'              \item The gene is accepted if it is at least as good 
#'                    as the target gene.
#'              }
#'              The execution is shifted to the evaluation phase.
#'
#' @details For \code{selection="UniformP"},
#'          for \code{crossover="UPCrossGene"} and
#'          for \code{accept="Best"}
#'          this is 
#'          the algorithm of Price, Storn and Lampinen (2005), page 41.
#'
#'          \code{xegaDfReplicateGeneDEPipeline()} is a genetic operator
#'          constructor which generates a function closure which embeds
#'          differential mutation, crossover and the acceptance rule.
#'
#' @param pop    Population of real-coded genes.
#' @param fit    Fitness vector.
#' @param lF     Local configuration of the genetic algorithm.
#'
#' @return A list of differential evolution pipelines.
#'
#' @family Replication
#'
#' @references
#' Price, Kenneth V., Storn, Rainer M. and Lampinen, Jouni A. (2005)
#' The Differential Evolution Algorithm (Chapter 2), pp. 37-134.
#' In: Differential Evolution. A Practical Approach to Global Optimization.
#' Springer, Berlin.
#' <doi:10.1007/3-540-31306-0>
#'
#' @examples
#' pop10<-lapply(rep(0,10), function(x) xegaDfGene::xegaDfInitGene(lFxegaDfGene))
#' epop10<-lapply(pop10, lFxegaDfGene$EvalGene, lF=lFxegaDfGene)
#' fit10<-unlist(lapply(epop10, function(x) {x$fit}))
#' ng<-xegaDfReplicateGeneDEPipeline(pop10, fit10, lFxegaDfGene)
#' @importFrom rlang env_unbind
#' @importFrom xegaSelectGene parm
#' @export
xegaDfReplicateGeneDEPipeline<- function(pop, fit, lF)
{
targetGene<-pop[[lF$SelectGene(fit, lF)]]
gene0<-pop[[lF$SelectMate(fit, lF)]]
gene1<-pop[[lF$SelectMate(fit, lF)]]
gene2<-pop[[lF$SelectMate(fit, lF)]]
# force
a<-targetGene
a<-gene0
a<-gene1
a<-gene2
# end of force
Pipeline<-function(lF)
{
trialGene<-lF$CrossGene(targetGene,lF$MutateGene(gene0, gene1, gene2, lF), lF)[[1]]
t1<-lF$EvalGene(trialGene, lF)
    lF$trialGene<-parm(t1)
    OperatorPipeline<-function(g, lF) {lF$trialGene()}   
    t2<-lF$Accept(OperatorPipeline, targetGene, lF)
    if (any(is.nan(t2$gene))) 
    { cat("NaN discovered:\n")
    cat("trialGene:\n"); print(trialGene); 
    cat("targetGene:\n"); print(targetGene) 
    cat("gene0:\n"); print(gene0); 
    cat("gene1:\n"); print(gene1); 
    cat("gene2:\n"); print(gene2); 
    cat("t2:\n"); print(t2) 
    }
    return(t2)
    #return(lF$Accept(OperatorPipeline, targetGene, lF))
}
  rlang::env_unbind(environment(Pipeline), c("lF", "a", "pop", "fit"))
return(Pipeline)
}

#' Configure the replication function of a genetic algorithm.
#'
#' @description \code{xegaDfReplicationFactory()} implements the selection
#'              of a replication method. 
#'
#'              Current support:
#'
#'              \enumerate{
#'              \item "DE" returns \code{xegaDfReplicateGeneDE()}.
#'              }
#'
#' @param method A string specifying the replication function.
#'
#' @return A replication function for genes.
#'
#' @family Configuration
#'
#' @examples
#' pop10<-lapply(rep(0,10), function(x) xegaDfInitGene(lFxegaDfGene))
#' epop10<-lapply(pop10, lFxegaDfGene$EvalGene, lF=lFxegaDfGene)
#' fit10<-unlist(lapply(epop10, function(x) {x$fit}))
#' Replicate<-xegaDfReplicationFactory("DE")
#' newgenes2<-Replicate(pop10, fit10, lFxegaDfGene)
#' @export
xegaDfReplicationFactory<-function(method="DE") {
if (method=="DE") {f<- xegaDfReplicateGeneDE}
if (method=="DEPipeline") {f<- xegaDfReplicateGeneDEPipeline}
if (!exists("f", inherits=FALSE))
        {stop("sgde Replication label ", method, " does not exist")}
return(f)
}