R/mating.R

In gena: Genetic Algorithm and Particle Swarm Optimization

#' Mating
#' @description Mating (selection) method (algorithm) to be used in the
#' genetic algorithm.
#' @param population numeric matrix which rows are chromosomes i.e. vectors of 
#' parameters values.
#' @param fitness numeric vector which \code{i}-th element is the value of 
#' \code{fn} at point \code{population[i, ]}.
#' @param parents.n even positive integer representing the number of parents.
#' @param method mating method to be used for selection of parents.
#' @param par additional parameters to be passed depending on the \code{method}.
#' @param self logical; if \code{TRUE} then chromosome may mate itself. 
#' Otherwise mating is allowed only between different chromosomes.
#' @param iter iteration number of the genetic algorithm.
#' @details Denote \code{population} by \eqn{C} which \code{i}-th row 
#' \code{population[i, ]} is a chromosome \eqn{c_{i}} i.e. the vector of 
#' parameter values of the function being optimized \eqn{f(.)} that is
#' provided via \code{fn} argument of \code{\link[gena]{gena}}.
#' The elements of chromosome \eqn{c_{ij}} are genes representing parameters 
#' values. Argument \code{fitness} is a vector of function values at
#' corresponding chromosomes i.e. \code{fitness[i]} corresponds to
#' \eqn{f_{i}=f(c_{i})}. Total number of chromosomes in population
#' \eqn{n_{population}} equals to \code{nrow(population)}.
#' 
#' Mating algorithm determines selection of chromosomes that will become parents. 
#' During mating each iteration one of chromosomes become a parent until
#' there are \eqn{n_{parents}} (i.e. \code{parents.n}) parents selected.
#' Each chromosome may become a parent multiple times or not become a 
#' parent at all.
#' 
#' Denote by \eqn{c^{s}_{i}} the \eqn{i}-th of selected parents. Parents
#' \eqn{c^{s}_{i}} and \eqn{c^{s}_{i + 1}} form a pair that will further
#' produce a child (offspring), where \eqn{i} is odd.
#' If \code{self = FALSE} then for each pair of parents 
#' \eqn{(c_{i}^s, c_{i+1}^s)} it is insured that 
#' \eqn{c^{s}_{i} \ne c^{s}_{i + 1}} except the case when there are several 
#' identical chromosomes in population. However \code{self} is ignored 
#' if \code{method} is \code{"tournament"}, so in this case self-mating
#' is always possible.
#' 
#' Denote by \eqn{p_{i}} the probability of a chromosome to become a parent.
#' Remind that each chromosome may become a parent multiple times.
#' Probability \eqn{p_{i}\left(f_{i}\right)} is a function 
#' of fitness \eqn{f_{i}}. Usually this function is non-decreasing so 
#' more fitted chromosomes have higher probability of becoming a parent. 
#' There is also an intermediate value \eqn{w_{i}} called weight such that:
#' \deqn{p_{i}=\frac{w_{i}}{\sum\limits_{j=1}^{n_{population}}w_{j}}}
#' Therefore all weights \eqn{w_{i}} are proportional to corresponding 
#' probabilities \eqn{p_{i}} by the same factor (sum of weights).
#' 
#' Argument \code{method} determines particular mating algorithm to be applied.
#' Denote by \eqn{\tau} the vector of parameters used by the algorithm.
#' Note that \eqn{\tau} corresponds to \code{par}. The algorithm determines
#' a particular form of the \eqn{w_{i}\left(f_{i}\right)} function which 
#' in turn determines \eqn{p_{i}\left(f_{i}\right)}.
#' 
#' If \code{method = "constant"} then all weights and probabilities are equal:
#' \deqn{w_{i}=1 => p_{i}=\frac{1}{n_{population}}}
#' 
#' If \code{method = "rank"} then each chromosome receives a rank \eqn{r_{i}} 
#' based on the fitness \eqn{f_{i}} value. So if \code{j}-th chromosome is the
#' fittest one and \code{k}-th chromosome has the lowest fitness value then
#' \eqn{r_{j}=n_{population}} and  \eqn{r_{k}=1}. The relationship
#' between weight \eqn{w_{i}} and rank \eqn{r_{i}} is as follows:
#' \deqn{w_{i}=\left(\frac{r_{i}}{n_{population}}\right)^{\tau_{1}}}
#' The greater value of \eqn{\tau_{1}} the greater portion of probability will
#' be delivered to more fitted chromosomes. 
#' Default value is \eqn{\tau_{1} = 0.5} so \code{par = 0.5}.
#' 
#' If \code{method = "fitness"} then weights are calculated as follows:
#' \deqn{w_{i}=\left(f_{i} - 
#'                   \min\left(f_{1},...,f_{n_{population}}\right) + 
#'                   \tau_{1}\right)^{\tau_{2}}}
#' By default \eqn{\tau_{1}=10} and \eqn{\tau_{2}=0.5} i.e. 
#' \code{par = c(10, 0.5)}. There is a restriction \eqn{\tau_{1}\geq0}
#' insuring that expression in brackets is non-negative.
#' 
#' If \code{method = "tournament"} then  \eqn{\tau_{1}} (i.e. \code{par}) 
#' chromosomes will be randomly selected with equal probabilities and without 
#' replacement. Then the chromosome with the highest fitness 
#' (among these selected chromosomes) value will become a parent.
#' It is possible to provide representation of this algorithm via 
#' probabilities \eqn{p_{i}} but the formulas are numerically unstable.
#' By default \code{par = min(5, ceiling(parents.n * 0.1))}.
#' 
#' Validation and default values assignment for \code{par} is performed inside
#' \code{\link[gena]{gena}} function not in \code{\link[gena]{gena.mating}}.
#' It allows to perform validation a single time instead of repeating it
#' each iteration of genetic algorithm.
#' 
#' For more information on mating (selection) algorithms
#' please see Shukla et. al. (2015).
#' 
#' @return The function returns a list with the following elements:
#' \itemize{
#' \item \code{parents} - matrix which rows are parents. The number of
#' rows of this matrix equals to \code{parents.n} while the number of columns
#' is \code{ncol(population)}.
#' \item \code{fitness} - vector which i-th element is the fitness of the
#' i-th parent.
#' \item \code{ind} - vector which i-th element is the index of i-th
#' parent in population so \code{$parents[i, ]} equals to 
#' \code{population[ind[i], ]}.
#' }
#' @references A. Shukla, H. Pandey, D. Mehrotra (2015). 
#' Comparative review of selection techniques in genetic algorithm.
#' \emph{2015 International Conference on Futuristic Trends on Computational 
#' Analysis and Knowledge Management (ABLAZE)}, 515-519,
#' <doi:10.1109/ABLAZE.2015.7154916>.
#' @examples 
#' # Consider the following fitness function
#' fn <- function(x)
#' {
#'   val <- x[1] * x[2] - x[1] ^ 2 - x[2] ^ 2
#' }
#' 
#' # Randomly initialize the population
#' set.seed(123)
#' pop.nulation <- 10
#' population <- gena.population(pop.n = pop.nulation,
#'                               lower = c(-5, -5), 
#'                               upper = c(5, 5))
#'
#' # Calculate fitness of each chromosome
#' fitness <- rep(NA, pop.nulation)
#' for(i in 1:pop.nulation)
#' {
#'   fitness[i] <- fn(population[i, ])
#' }
#' 
#' # Perform mating to select parents
#' parents <- gena.mating(population = population,
#'                        fitness = fitness,
#'                        parents.n = pop.nulation,
#'                        method = "rank",
#'                        par = 0.8)
#' print(parents)
#' 
gena.mating <- function(population,                        # population of chromosomes
                        fitness,                           # fitness values of chromosomes
                        parents.n,                         # number of parents to select
                        method = "rank",                   # algorithm to assign probabilities 
                                                           # of being a parent
                        par = NULL,                        # additional parameters
                                                           # depending on "method"
                        self = FALSE,
                        iter = NULL)                       # genetic algorithm iteration              
{      
  # ---
  # The algorithm brief description:
  # 1. For each chromosome (solution) estimate the 
  #    probability of being selected to be a parent.
  # 2. Select the parents according to estimated
  #    probabilities or some other criteria.
  # 3. Return the parents along with their fitness.
  # ---
  
  # Prepare some values
  
  pop.n <- nrow(population)                                # the number of chromosomes
  ind_pop <- 1:pop.n                                       # chromosomes indexes
  
  # Estimate the probability of being a parent
  # for each chromosome
  
  probs <- rep(1 / pop.n, pop.n)                           # default probabilities vector
  
  if (method == "rank")                                    # rank based probabilities
  {
    fitness_rank <- rank(fitness)                          # rank by fitness
    fitness_weight <- (fitness_rank / pop.n) ^ par[1]      # weight according to rank
    probs <- fitness_weight / sum(fitness_weight)          # assign probabilities
                                                           # proportional to weights
  }
  
  if (method == "fitness")                                 # fitness based probabilities
  {
    fitness_weight <- (fitness - min(fitness) + par[1]) ^  # weight according 
                      par[2]                               # to the fitness
    probs <- fitness_weight / sum(fitness_weight)          # assign probabilities
  }                                                        # proportional to weights
  
  # Select the parents based on probabilities
  
  parents_ind <- rep(NA, parents.n)                        # vector to store
                                                           # parents indexes
  
  if (method %in% c("constant", "rank", "fitness"))
  {
    parents_ind <- sample(ind_pop,                         # indexes of parents
                          size = parents.n,            
                          replace = TRUE, 
                          prob = probs)
  }
  
  # Select parents following some other criteria
  
  if (method == "tournament")                              # select parents 
  {                                                        # via the tournament
    pop_ind <- 1:pop.n
    parents_ind <- mating_tournament(                      # Rcpp version for
      pop_ind = pop_ind, candidates_n = par[1],            # speed improvement
      fitness = fitness, parents_n = parents.n)                                 
    # for(i in 1:parents.n)
    # {
    #   candidates <- sample(pop_ind,                      # randomly pick
    #                        size = par[1],                # some candidates
    #                        replace = FALSE)
    #   parents_ind[i] <- candidates[                      # select the fittest
    #     which.max(fitness[candidates])]                  # of all candidates
    # }
  }
    # ---
    # Comment to tournament method:
    # It is possible to assign the probabilities
    # but it requires combinatorial formulas to be
    # used that may cause numeric instability
    # ---
  
  # Prevent self-mating
  
  odd_ind <- NULL
  
  if (!self)
  {
    odd_ind <- seq(from = 1, to = parents.n, by = 2)
    if (method %in% c("constant", "rank", "fitness"))
    {
      for (i in odd_ind)
      {
        if (parents_ind[i] == parents_ind[i + 1])
        {
          parents_ind[i] <- sample(ind_pop[-parents_ind[i]],
                                   size = 1,            
                                   replace = TRUE, 
                                   prob = probs[-parents_ind[i]] / 
                                          sum(probs[-parents_ind[i]]))
        }
      }
    }
  }
  
  # Save and return the results of selection
  
  parents <- population[parents_ind, , drop = FALSE]       # parents and
  parents_fitness <- fitness[parents_ind]                  # their fitness
  
  return_val <- list(parents = parents,                    # output in a form
                     fitness = parents_fitness,            # of a list
                     ind = parents_ind)            
  
  return(return_val)                                       # return the parents
                                                           # along with their 
                                                           # fitness
}

# Assign default parameters for
# a mating algorithm depending
# on the "method"
gena.mating.validate <- function(method, par, parents.n)
{
  # Validate the "method"
  
  methods <- c("constant", "rank", "fitness",              # the list of all
               "tournament")                               # available methods
                                                           
  if (!(method %in% methods))
  {
    stop(paste0("Incorrect mating.method argument. ",      # if the user has provided
                "It should be one of: ",                   # incorrect argument
                paste(methods, collapse = ", "),
                "\n"))
  }
  
  # Assign default parameters
  
  if (method == "rank")
  {
    if (!is.null(par))
    {
      if ((length(par) != 1) | (!is.numeric(par)))
      {
        stop(paste0("Incorrect mating.par agrument. Please, insure that ",
                    "(length(mating.par) == 1) and is.numeric(mating.par)",
                    "\n"))
      }
    } else {
      par <- 0.5
    }
  }
  
  if (method == "fitness")
  {
    if (!is.null(par))
    {
      if ((length(par) != 2) | (par[1] < 0) | (!is.numeric(par)))
      {
        stop(paste0("Incorrect mating.par agrument. Please, insure that ",
                    "(length(mating.par) == 2), (mating.par[1] > 0) ",
                    "and is.numeric(mating.par)",
                    "\n"))
      }
    } else {
      par <- c(10, 0.5)
    }
  }
  
  if (method == "tournament")
  {
    if (!is.null(par))
    {
      if ((length(par) != 1) | (par < 1) | (par > parents.n) | 
         (!is.numeric(par)))
      {
        stop(paste0("Incorrect mating.par agrument. Please, insure that ",
                    "(length(mating.par) == 1), (mating.par >= 1)",
                    "(mating.par < (pop.n - n_elite)), and ",
                    "is.numeric(mating.par)",
                    "\n"))
      }
    } else {
      par <- min(5, ceiling(parents.n * 0.1))
    }
  }
  
  return(par)
}