Selection.hs

{- |

Selection operators for genetic algorithms.

-}

module Moo.GeneticAlgorithm.Selection
  (
    rouletteSelect
  , stochasticUniversalSampling
  , tournamentSelect
  -- ** Scaling and niching
  , withPopulationTransform
  , withScale
  , rankScale
  , withFitnessSharing
  -- ** Sorting
  , bestFirst
  ) where


import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Niching (fitnessSharing)


import Control.Monad (liftM, replicateM)
import Control.Arrow (second)
import Data.List (sortBy)
import Data.Function (on)
import qualified Data.Vector as V



-- | Apply given scaling or other transform to population before selection.
withPopulationTransform :: (Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform transform select = \pop -> select (transform pop)


-- | Transform objective function values before seletion.
withScale :: (Objective -> Objective) -> SelectionOp a -> SelectionOp a
withScale f select =
    let scale = map (second f)
    in  withPopulationTransform scale select

-- | Replace objective function values in the population with their
-- ranks.  For a population of size @n@, a genome with the best value
-- of objective function has rank @n' <= n@, and a genome with the
-- worst value of objective function gets rank @1@.
--
-- 'rankScale' may be useful to avoid domination of few super-genomes
-- in 'rouletteSelect' or to apply 'rouletteSelect' when an objective
-- function is not necessarily positive.
rankScale :: ProblemType -> Population a -> Population a
rankScale problem pop =
    let sorted = bestFirst (opposite problem) pop  -- worst first
        worst = takeObjectiveValue . head $ sorted
    in  ranks 1 worst sorted
    where
      ranks _ _ [] = []
      ranks rank worst ((genome,objective):rest)
          | worst == objective  = (genome,rank)   : ranks rank worst rest
          | otherwise           = (genome,rank+1) : ranks (rank+1) objective rest
      opposite Minimizing = Maximizing
      opposite Maximizing = Minimizing


-- | A popular niching method proposed by D. Goldberg and
-- J. Richardson in 1987. The shared fitness of the individual is inversely
-- protoptional to its niche count.
-- The method expects the objective function to be non-negative.
--
-- An extension for minimization problems is implemented by
-- making the fitnes proportional to its niche count (rather than
-- inversely proportional).
--
-- Reference: Chen, J. H., Goldberg, D. E., Ho, S. Y., & Sastry,
-- K. (2002, July). Fitness inheritance in multiobjective
-- optimization. In Proceedings of the Genetic and Evolutionary
-- Computation Conference (pp. 319-326). Morgan Kaufmann Publishers
-- Inc..
withFitnessSharing ::
    (Phenotype a -> Phenotype a -> Double)  -- ^ distance function
    -> Double  -- ^ niche radius
    -> Double  -- ^ niche compression exponent @alpha@ (usually 1)
    -> ProblemType   -- ^ type of the optimization problem
    -> (SelectionOp a -> SelectionOp a)
withFitnessSharing dist r alpha ptype =
    withPopulationTransform (fitnessSharing dist r alpha ptype)


-- |Objective-proportionate (roulette wheel) selection: select @n@
-- random items with each item's chance of being selected is
-- proportional to its objective function (fitness).
-- Objective function should be non-negative.
rouletteSelect :: Int -> SelectionOp a
rouletteSelect n xs = replicateM n roulette1
  where
  fs = map takeObjectiveValue xs
  xs' = zip xs (scanl1 (+) fs)
  sumScores = (snd . last) xs'
  roulette1 = do
    rand <- (sumScores*) `liftM` getDouble
    return $ (fst . head . dropWhile ((rand >) . snd)) xs'

-- |Performs tournament selection among @size@ individuals and
-- returns the winner. Repeat @n@ times.
tournamentSelect :: ProblemType  -- ^ type of the optimization problem
                 -> Int -- ^ size of the tournament group
                 -> Int -- ^ how many tournaments to run
                 -> SelectionOp a
tournamentSelect problem size n xs = do
    let popvec = V.fromList xs
    let popsize = V.length popvec
    groups <- replicateM n $ randomSampleIndices size popsize
    return $ map (tournament1 problem popvec) groups
  where
    tournament1 problem popvec group =
      let contestants = map (popvec V.!) group
          best = head $ bestFirst problem contestants
      in  best

-- | Stochastic universal sampling (SUS) is a selection technique
-- similar to roulette wheel selection. It gives weaker members a fair
-- chance to be selected, which is proportinal to their
-- fitness. Objective function should be non-negative.
stochasticUniversalSampling :: Int  -- ^ how many genomes to select
                            -> SelectionOp a
stochasticUniversalSampling n phenotypes = do
    let total = sum . map takeObjectiveValue $ phenotypes
    let step = total / (fromIntegral n)
    start <- getRandomR (0, step)
    let stops = [start + (fromIntegral i)*step | i <- [0..(n-1)]]
    let cumsums = scanl1 (+) (map takeObjectiveValue phenotypes)
    let ranges = zip (0:cumsums) cumsums
    -- for every stop select a phenotype with left cumsum <= stop < right cumsum
    return $ selectAtStops [] phenotypes stops ranges
  where
    selectAtStops selected _ [] _ = selected  -- no more stop points
    selectAtStops selected [] _ _ = selected  -- no more phenotypes
    selectAtStops selected phenotypes@(x:xs) stops@(s:ss) ranges@((l,r):lrs)
       | (l <= s && s < r) = selectAtStops (x:selected) phenotypes ss ranges  -- select a phenotype
       | s >= r = selectAtStops selected xs stops lrs  -- skip a phenotype AND the range
       | s < l  = error "stochasticUniformSampling: stop < leftSum"  -- should never happen
    selectAtStops _ _ _ _ = error "stochasticUniversalSampling: unbalanced ranges?"  -- should never happen

-- | Sort population by decreasing objective function (also known as
-- fitness for maximization problems). The genomes with the highest
-- fitness are put in the head of the list.
sortByFitnessDesc :: Population a -> Population a
sortByFitnessDesc = sortBy (flip compare `on` snd)

-- | Sort population by increasing objective function (also known as
-- cost for minimization problems). The genomes with the smallest
-- cost are put in the head of the list.
sortByCostAsc :: Population a -> Population a
sortByCostAsc = sortBy (compare `on` snd)

-- | Reorders a list of individual solutions,
-- by putting the best in the head of the list.
bestFirst :: ProblemType -> Population a -> Population a
bestFirst Maximizing = sortByFitnessDesc
bestFirst Minimizing = sortByCostAsc