diff --git a/src/HushGP/GP/PushArgs.hs b/src/HushGP/GP/PushArgs.hs index 892c7ea..d80e4bc 100644 --- a/src/HushGP/GP/PushArgs.hs +++ b/src/HushGP/GP/PushArgs.hs @@ -3,7 +3,6 @@ module HushGP.GP.PushArgs where import HushGP.State import HushGP.Instructions import HushGP.GP.PushData -import HushGP.GP.Individual import Data.Map qualified as Map -- | The structure holding the arguments for the various aspects @@ -62,7 +61,7 @@ data PushArgs = PushArgs maxInitialPlushySize :: Int, -- | Maximum amount of generations allowed in an evolutionary run. maxGenerations :: Int, - -- | Type of parent selection to use. Think "lexicase" and "tournament" for now. + -- | Type of parent selection to use. Options are: "tournament","lexicase","epsilonLexicase". parentSelectionAlgo :: String, -- |Size of the population in the evolutionary run. populationSize :: Int, diff --git a/src/HushGP/GP/Selection.hs b/src/HushGP/GP/Selection.hs index 99fc5de..692a750 100644 --- a/src/HushGP/GP/Selection.hs +++ b/src/HushGP/GP/Selection.hs @@ -1,6 +1,8 @@ module HushGP.GP.Selection where +import Numeric.Statistics.Median (medianFast) import Data.List +import Data.Maybe import System.Random import System.Random.Shuffle import HushGP.GP.PushArgs @@ -31,11 +33,73 @@ lexicaseSelection PushArgs{initialCases = iCases} pop = do Just (x, _) -> x _ -> error "Error: Population in lexicaseSelection cannot be empty!" +-- |The internals of lexicaseSelection selection. Loops for each of the survivors each lexicase loop. lexicaseSelection' :: [Individual] -> [Int] -> [Int] -> IO Individual lexicaseSelection' survivors cases initialCases = if null cases || null (drop 1 survivors) then (\ind -> ind{selectionCases = Just initialCases}) <$> randElem survivors - else lexicaseSelection' () + else lexicaseSelection' + (filter (\ind -> (extractFitnessCases ind !! case uncons cases of Just (x, _) -> x; _ -> error "Error: cases list is empty!") == minErrorForCase) survivors) + (drop 1 cases) + initialCases where minErrorForCase :: Double minErrorForCase = minimum $ map ((\x -> x !! case uncons cases of Just (y, _) -> y; _ -> error "Error: cases is empty!") . extractFitnessCases) survivors + +-- |Calculates the median absolute deviation for a list of fractional numbers. +medianAbsoluteDeviation :: forall a. (Fractional a, Ord a) => [a] -> a +medianAbsoluteDeviation xs = medianFast $ map (\x -> abs (x - medianVal)) xs + where + medianVal :: a + medianVal = medianFast xs + +-- | Calculates the epsilon list of a given population. Used in epsilon lexicase selection. +epsilonList :: [Individual] -> [Double] +epsilonList pop = epsilonList' [] 0 errorList errorLength + where + errorList :: [[Double]] + errorList = map extractFitnessCases pop + errorLength :: Int + errorLength = length $ extractFitnessCases (case uncons pop of Just (x, _) -> x; _ -> error "Error: pop is empty in epsilonList!") + +-- | Internals for the epsilonList function. +epsilonList' :: [Double] -> Int -> [[Double]] -> Int -> [Double] +epsilonList' epsilons index errorList errorLength = + if index == errorLength + then epsilons + else epsilonList' (medianAbsoluteDeviation (map (!! index) errorList) : epsilons) (succ index) errorList errorLength + +-- |Selects an individual from the population using epsilon-lexicase selection. +-- Epsilon lexicase selection follows the same process as lexicase selection except, +-- for a test case, only individuals with an error outside of a predefined epsilon are filtered. +epsilonLexicaseSelection :: PushArgs -> [Individual] -> IO Individual +epsilonLexicaseSelection PushArgs{epsilons = eps} pop = do + startCases <- shuffle' [0..lehp] lehp <$> initStdGen + epsilonLexicaseSelection' (fromMaybe (error "Error: epsilons list is empty!") eps) pop startCases + where + lehp :: Int -- length of the extracted fitness cases of the head of the passed population. + lehp = length $ extractFitnessCases $ + case uncons pop of + Just (x, _) -> x + _ -> error "Error: Population in epsilonLexicaseSelection cannot be empty!" + +-- |Internals for epsilon lexicase selection. +epsilonLexicaseSelection' :: [Double] -> [Individual] -> [Int] -> IO Individual +epsilonLexicaseSelection' eps survivors cases = + if null cases || null (drop 1 survivors) + then randElem survivors + else epsilonLexicaseSelection' eps (filter (\x -> (abs (extractFitnessCases x !! headCases cases) - minErrorForCase) <= epsilon) survivors) (drop 1 cases) + where + minErrorForCase :: Double + minErrorForCase = minimum $ map ((\x -> x !! headCases cases) . extractFitnessCases) survivors + epsilon :: Double + epsilon = eps !! headCases cases + +-- |Select the selection method the user specified in the passed PushArgs. +selectParent :: PushArgs -> [Individual] -> IO Individual +selectParent pushArgs@PushArgs{parentSelectionAlgo = selAlgo} pop = + case selAlgo of + "tournament" -> tournamentSelection pushArgs pop + "lexicase" -> lexicaseSelection pushArgs pop + "epsilonLexicase" -> epsilonLexicaseSelection pushArgs pop + _ -> error "Error: selection strategy not found!" diff --git a/src/HushGP/Utility.hs b/src/HushGP/Utility.hs index edc265c..51270f8 100644 --- a/src/HushGP/Utility.hs +++ b/src/HushGP/Utility.hs @@ -1,8 +1,9 @@ module HushGP.Utility where +import Data.List import Control.Monad -import HushGP.State import System.Random +import HushGP.State -- | Generates a single random instruction from a list of instructions. randomInstruction :: [Gene] -> IO Gene @@ -27,3 +28,6 @@ mapIndexed' count f (x : xs) = f count x : mapIndexed' (count + 1) f xs -- | Returns a random element from a passed list. No generator required. randElem :: [a] -> IO a randElem xs = (xs !!) . fst . uniformR (0, length xs - 1) <$> initStdGen + +headCases :: [Int] -> Int +headCases xs = case uncons xs of Just (y, _) -> y; _ -> error "Error: cases is empty!"