cleanup
This commit is contained in:
Johannes Merl
parent
6435f4aca2
commit
f79355e4c1
34
src/GA.hs
34
src/GA.hs
|
|
@ -20,7 +20,7 @@
|
|||
-- In order to use it for a certain problem, basically, you have to make your
|
||||
-- solution type an instance of 'Individual' and then simply call the 'run'
|
||||
-- function.
|
||||
module GA (Environment, new, population, mutate, crossover1, crossover, nX, Evaluator, fitness, calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
|
||||
module GA (Environment, new, population, mutate, crossover1, crossover, nX, Fitness, getR, Evaluator, fitness,fitness', calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
|
||||
|
||||
import Control.Arrow hiding (first, second)
|
||||
import Data.List.NonEmpty ((<|))
|
||||
|
|
@ -35,7 +35,6 @@ import System.Random.MWC (create, createSystemRandom)
|
|||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Instances ()
|
||||
import Test.QuickCheck.Monadic
|
||||
import Debug.Trace as DB
|
||||
|
||||
-- TODO there should be a few 'shuffle's here
|
||||
|
||||
|
|
@ -84,13 +83,16 @@ class (Pretty e, Individual i) => Environment i e | e -> i where
|
|||
-- |
|
||||
-- An Evaluator that Individuals of type i can be evaluated by
|
||||
-- It stores all information required to evaluate an individuals fitness
|
||||
class (Individual i) => Evaluator i e where
|
||||
class (Individual i, Fitness r) => Evaluator i e r | i -> e r where
|
||||
-- |
|
||||
-- An individual's fitness. Higher values are considered “better”.
|
||||
--
|
||||
-- We explicitely allow fitness values to be have any sign (see, for example,
|
||||
-- 'proportionate1').
|
||||
fitness :: e -> i -> R
|
||||
fitness env i = getR ( fitness' env i)
|
||||
|
||||
fitness' :: e -> i -> r
|
||||
|
||||
-- TODO kinda hacky?!?
|
||||
calc :: e -> Population i -> IO e
|
||||
|
|
@ -99,6 +101,12 @@ class (Individual i) => Evaluator i e where
|
|||
|
||||
class (Pretty i, Ord i) => Individual i
|
||||
|
||||
class (Show i) => Fitness i where
|
||||
getR :: i -> R
|
||||
|
||||
instance Fitness Double where
|
||||
getR d = d
|
||||
|
||||
-- |
|
||||
-- Populations are just basic non-empty lists.
|
||||
type Population i = NonEmpty i
|
||||
|
|
@ -150,18 +158,18 @@ bestsBy' k f pop
|
|||
|
||||
-- |
|
||||
-- The @k@ worst individuals in the population (and the rest of the population).
|
||||
worst :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
|
||||
worst :: (Individual i, Evaluator i e r) => e -> N -> Population i -> (NonEmpty i, [i])
|
||||
worst e k = bestsBy k (negate . fitness e)
|
||||
|
||||
-- |
|
||||
-- The @k@ best individuals in the population (and the rest of the population).
|
||||
bests :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
|
||||
bests :: (Individual i, Evaluator i e r) => e -> N -> Population i -> (NonEmpty i, [i])
|
||||
bests e k = bestsBy k (fitness e)
|
||||
|
||||
-- TODO add top x percent parent selection (select n guys, sort by fitness first)
|
||||
|
||||
reproduce ::
|
||||
(Individual i, Environment i env, Evaluator i eval, SelectionType s) =>
|
||||
(Individual i, Environment i env, Evaluator i eval r, SelectionType s) =>
|
||||
eval ->
|
||||
env ->
|
||||
-- | Mechanism for selecting parents
|
||||
|
|
@ -177,7 +185,7 @@ reproduce eval env selectT nParents pop = do
|
|||
return pop'
|
||||
|
||||
selectBest ::
|
||||
(Individual i, Evaluator i eval) =>
|
||||
(Individual i, Evaluator i eval r) =>
|
||||
eval ->
|
||||
-- | Elitism ratio @pElite@
|
||||
R ->
|
||||
|
|
@ -198,7 +206,7 @@ selectBest eval pElite pop nPop = do
|
|||
else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
|
||||
|
||||
run ::
|
||||
(Individual i, Evaluator i eval, Environment i env, SelectionType s) =>
|
||||
(Individual i, Evaluator i eval r, Environment i env, SelectionType s) =>
|
||||
eval ->
|
||||
env ->
|
||||
-- | Mechanism for selecting parents
|
||||
|
|
@ -210,7 +218,7 @@ run ::
|
|||
-- | Population size
|
||||
N ->
|
||||
Termination i ->
|
||||
Producer (Int, R) IO (Population i)
|
||||
Producer (Int, r) IO (Population i)
|
||||
run eval env selectionType nParents pElite nPop term = do
|
||||
mwc <- liftIO createSystemRandom
|
||||
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
|
||||
|
|
@ -227,7 +235,7 @@ run eval env selectionType nParents pElite nPop term = do
|
|||
withKids <- liftIO $ smpl $ reproduce eval env selectionType nParents pop
|
||||
eval <- liftIO $ calc eval withKids
|
||||
resPop <- liftIO $ smpl $ selectBest eval pElite withKids nPop
|
||||
let fBest = fitness eval $ NE.head $ fst $ bests eval 1 resPop
|
||||
let fBest = fitness' eval $ NE.head $ fst $ bests eval 1 resPop
|
||||
Pipes.yield (count, fBest)
|
||||
res <- runIter eval (count + 1) resPop smpl
|
||||
return res)
|
||||
|
|
@ -240,7 +248,7 @@ run eval env selectionType nParents pElite nPop term = do
|
|||
data Tournament = Tournament N
|
||||
|
||||
class SelectionType t where
|
||||
select :: (Individual i, Evaluator i e) => t -> N -> Population i -> e -> RVar (NonEmpty i)
|
||||
select :: (Individual i, Evaluator i e r) => t -> N -> Population i -> e -> RVar (NonEmpty i)
|
||||
|
||||
-- type Selection m i = N -> Population i -> m (NonEmpty i)
|
||||
|
||||
|
|
@ -250,7 +258,7 @@ instance SelectionType Tournament where
|
|||
-- |
|
||||
-- Selects one individual from the population using tournament selection.
|
||||
tournament1 ::
|
||||
(Individual i, Evaluator i e) =>
|
||||
(Individual i, Evaluator i e r) =>
|
||||
e ->
|
||||
-- | Tournament size
|
||||
N ->
|
||||
|
|
@ -321,7 +329,7 @@ instance Environment Integer IntTestEnviroment where
|
|||
|
||||
data NoData = NoData deriving (Eq)
|
||||
|
||||
instance Evaluator Integer NoData where
|
||||
instance Evaluator Integer NoData Double where
|
||||
fitness _ = fromIntegral . negate
|
||||
|
||||
prop_children_asManyAsParents ::
|
||||
|
|
|
|||
|
|
@ -391,11 +391,25 @@ data LamdaExecutionEnv = LamdaExecutionEnv
|
|||
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
|
||||
exTargetType :: TypeRep,
|
||||
-- todo: kindaHacky
|
||||
results :: Map TypeRequester R
|
||||
results :: Map TypeRequester FittnesRes
|
||||
}
|
||||
|
||||
instance Evaluator TypeRequester LamdaExecutionEnv where
|
||||
fitness env tr = (results env) Map.! tr
|
||||
data FittnesRes = FittnesRes
|
||||
{ total :: R,
|
||||
fitnessTotal :: R,
|
||||
fitnessGeoMean :: R,
|
||||
fitnessMean :: R,
|
||||
accuracy :: Int,
|
||||
biasDist :: R,
|
||||
biasSize :: R
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Fitness FittnesRes where
|
||||
getR = total
|
||||
|
||||
instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
|
||||
fitness' env tr = (results env) Map.! tr
|
||||
|
||||
calc env pop = do
|
||||
let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
|
||||
|
|
@ -417,22 +431,64 @@ loadTrainingData lee@LamdaExecutionEnv {trainingData = (_ : _, _ : _)} = return
|
|||
loadTrainingData lee@LamdaExecutionEnv {trainingData = (_ : _, [])} = return undefined
|
||||
loadTrainingData lee@LamdaExecutionEnv {trainingData = ([], _ : _)} = return undefined
|
||||
|
||||
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)]
|
||||
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
|
||||
evalResults ex trs = mapM (evalResult ex) trs
|
||||
|
||||
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R)
|
||||
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes)
|
||||
evalResult ex tr = do
|
||||
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
|
||||
Hint.unsafeSetGhcOption "-O2"
|
||||
result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Float -> Float -> Float -> Float -> IrisClass)
|
||||
let res = map (\(a, b, c, d) -> result a b c d) (fst (trainingData ex))
|
||||
let resAndTarget = (zip (snd (trainingData ex)) res)
|
||||
let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: R
|
||||
let biasWellDistributed = (foldr (*) 1 (map (\ty -> (foldr (\ts s -> if ((snd ts) == ty) then s + 1 else s) 1 resAndTarget)) ([minBound..maxBound] :: [IrisClass]):: [R])) ** (1/3)
|
||||
let biasSmall = exp ( - (fromIntegral (countTrsR tr)))
|
||||
let score = acc + (biasWellDistributed/5.1) + (biasSmall)
|
||||
return (tr, score)
|
||||
let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: Int
|
||||
let biasWellDistributed = (foldr (*) 1 (map (\ty -> (foldr (\ts s -> if ((snd ts) == ty) then s + 1 else s) 1 resAndTarget)) ([minBound .. maxBound] :: [IrisClass]) :: [R])) ** (1 / 3) -- 1 (schlecht) bis 51 (gut)
|
||||
let biasSmall = exp (-(fromIntegral (countTrsR tr))) -- 0 (schlecht) bis 1 (gut)
|
||||
let fitness' = mean [meanOfAccuricyPerClass resAndTarget, geomeanOfDistributionAccuracy resAndTarget]
|
||||
let score = fitness' + (biasSmall - 1)
|
||||
return
|
||||
( tr,
|
||||
FittnesRes
|
||||
{ total = score,
|
||||
fitnessTotal = fitness',
|
||||
fitnessMean = meanOfAccuricyPerClass resAndTarget,
|
||||
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
|
||||
accuracy = acc,
|
||||
biasDist = biasWellDistributed,
|
||||
biasSize = biasSmall
|
||||
}
|
||||
)
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
||||
|
||||
meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
|
||||
meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
|
||||
|
||||
geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
|
||||
geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
|
||||
|
||||
geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
|
||||
geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
|
||||
|
||||
distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R
|
||||
distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100
|
||||
|
||||
mean :: (Show f, Floating f) => [f] -> f
|
||||
mean values = (sum values) * (1 / (fromIntegral (length values)))
|
||||
|
||||
geomean :: (Show f, Floating f) => [f] -> f
|
||||
geomean values = (product values) ** (1 / (fromIntegral (length values)))
|
||||
|
||||
accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
|
||||
accuracyInClass results clas = ((accuracy'(inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
|
||||
|
||||
inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
|
||||
inClass results clas = (filter ((clas ==) . fst) results)
|
||||
|
||||
inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
|
||||
inResClass results clas = (filter ((clas ==) . snd) results)
|
||||
|
||||
accuracy' :: (Eq r) => [(r, r)] -> R
|
||||
accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ main =
|
|||
hSetBuffering stdout NoBuffering
|
||||
let env = irisLE
|
||||
let selType = Tournament 3
|
||||
let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population TypeRequester)
|
||||
let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
|
||||
pop' <-
|
||||
runEffect (for run' logCsv)
|
||||
|
||||
|
|
@ -60,7 +60,7 @@ main =
|
|||
mapM_ (format irisLE) res
|
||||
where
|
||||
format irisL s = do
|
||||
let f = fitness irisL s
|
||||
let f = fitness' irisL s
|
||||
putErrText $ show f <> "\n" <> pretty s
|
||||
logCsv = putText . csv
|
||||
csv (t, f) = show t <> " " <> show f
|
||||
|
|
|
|||
|
|
@ -159,8 +159,8 @@ prioOf' p (Just _) Nothing = lowestPriority p + 2
|
|||
prioOf' p Nothing (Just _) = lowestPriority p + 2
|
||||
prioOf' p (Just s) (Just t) = prioOf p s t
|
||||
|
||||
instance Evaluator Assignment Priorities where
|
||||
fitness prio assment =
|
||||
instance Evaluator Assignment Priorities R where
|
||||
fitness' prio assment =
|
||||
negate . sum $ fromIntegral . uncurry (prioOf' prio) <$> assment
|
||||
|
||||
-- |
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user