diff --git a/src/GA.hs b/src/GA.hs index 414d945..2dffb69 100644 --- a/src/GA.hs +++ b/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 :: diff --git a/src/IrisDataset.hs b/src/IrisDataset.hs index 697cac3..e4d4205 100644 --- a/src/IrisDataset.hs +++ b/src/IrisDataset.hs @@ -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 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) diff --git a/src/Main.hs b/src/Main.hs index b16c03e..9838db9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Seminar.hs b/src/Seminar.hs index ebc8adb..643c95a 100644 --- a/src/Seminar.hs +++ b/src/Seminar.hs @@ -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 -- |