cleanup

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 ::

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
+data FittnesRes = FittnesRes
-  fitness env tr = (results env) Map.! tr
+  { 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 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)
+  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)))
+  let biasSmall = exp (-(fromIntegral (countTrsR tr))) -- 0 (schlecht) bis 1 (gut)
-  let score = acc + (biasWellDistributed/5.1) + (biasSmall)
+  let fitness' = mean [meanOfAccuricyPerClass resAndTarget, geomeanOfDistributionAccuracy resAndTarget]
-  return (tr, score)
+  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)

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

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
+instance Evaluator Assignment Priorities R where
-  fitness prio assment =
+  fitness' prio assment =
     negate . sum $ fromIntegral . uncurry (prioOf' prio) <$> assment
 
 -- |