finish German

haga.cabal

@@ -49,9 +49,9 @@ library
                      , Pretty
                      , Szenario191
                      , LambdaCalculus
-                     , IrisDataset
+                     , GermanDataset
-                     , IrisData
+                     , GermanData
-
+                     , Utils
 executable haga
   build-depends:       base
                      , bytestring
@@ -83,8 +83,9 @@ executable haga
                      , Pretty
                      , Szenario191
                      , LambdaCalculus
-                     , IrisDataset
+                     , GermanDataset
-                     , IrisData
+                     , GermanData
+                     , Utils
 
 executable haga-test
   build-depends:       base
@@ -118,5 +119,6 @@ executable haga-test
                      , Pretty
                      , Szenario191
                      , LambdaCalculus
-                     , IrisDataset
+                     , GermanDataset
-                     , IrisData
+                     , GermanData
+                     , Utils

src/IrisData.hs

@@ -136,12 +136,8 @@ irisTrainingData =
     ((5.7, 2.5, 5.0, 2.0), Virginica),
     ((6.8, 2.8, 4.8, 1.4), Versicolor),
     ((6.3, 2.9, 5.6, 1.8), Virginica),
-    ((6.0, 2.2, 4.0, 1.0), Versicolor)
+    ((6.0, 2.2, 4.0, 1.0), Versicolor),
-  ]
+    ((5.0, 3.5, 1.6, 0.6), Setosa),
-
-irisTestData :: [((Float, Float, Float, Float), IrisClass)]
-irisTestData =
-  [ ((5.0, 3.5, 1.6, 0.6), Setosa),
     ((4.6, 3.1, 1.5, 0.2), Setosa),
     ((4.8, 3.4, 1.6, 0.2), Setosa),
     ((4.8, 3.0, 1.4, 0.3), Setosa),
@@ -172,3 +168,4 @@ irisTestData =
     ((6.1, 2.6, 5.6, 1.4), Virginica),
     ((6.6, 2.9, 4.6, 1.3), Versicolor)
   ]
+

src/IrisDataset.hs

@@ -15,6 +15,7 @@ where
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Random
+import System.Random.MWC (createSystemRandom)
 import Data.Random.Distribution.Uniform
 import qualified Data.Text as T
 import Data.Tuple.Extra
@@ -24,6 +25,7 @@ import IrisData
 import qualified Language.Haskell.Interpreter as Hint
 import qualified Language.Haskell.Interpreter.Unsafe as Hint
 import Protolude
+import Utils
 import Protolude.Error
 import qualified Type.Reflection as Ref
 
@@ -64,15 +66,35 @@ irisLEE =
       imports = ["IrisDataset"],
       training = True,
       trainingData =
-        ( map fst irisTrainingData,
+        ( map fst (takeFraktion 0.8 irisTrainingData),
-          map snd irisTrainingData
+          map snd (takeFraktion 0.8 irisTrainingData)
         ),
       testData =
-        ( map fst irisTestData,
+        ( map fst (dropFraktion 0.8 irisTrainingData),
-          map snd irisTestData
+          map snd (dropFraktion 0.8 irisTrainingData)
+        ),
+      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
+      results = Map.empty
+    }
+
+shuffledIrisLEE :: IO LamdaExecutionEnv
+shuffledIrisLEE = do
+  mwc <- liftIO createSystemRandom
+  let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
+  itD <- smpl $ shuffle irisTrainingData
+  return  LamdaExecutionEnv
+    { -- For now these need to define all available functions and types. Generic functions can be used.
+      imports = ["IrisDataset"],
+      training = True,
+      trainingData =
+        ( map fst (takeFraktion 0.8 itD),
+          map snd (takeFraktion 0.8 itD)
+        ),
+      testData =
+        ( map fst (dropFraktion 0.8 itD),
+          map snd (dropFraktion 0.8 itD)
         ),
       exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      -- todo: kindaHacky
       results = Map.empty
     }
 
@@ -92,8 +114,9 @@ data FittnesRes = FittnesRes
     fitnessTotal :: R,
     fitnessGeoMean :: R,
     fitnessMean :: R,
-    accuracy :: Int,
+    accuracy :: R,
-    biasSize :: R
+    biasSize :: R,
+    totalSize :: N
   }
   deriving (Show)
 
@@ -104,10 +127,11 @@ 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
+    let relevantResults = Map.filterWithKey (\k _ -> contains pop k) (results env)
+    let toAdd = NE.filter (\k -> not (Map.member k relevantResults)) pop
     toInsert <- Hint.runInterpreter (evalResults env toAdd)
     let insertPair (key, val) m = Map.insert key val m
-    let res = foldr insertPair (results env) (fromRight (error ("To insert is " <> show toInsert)) toInsert)
+    let res = foldr insertPair relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
     return env {results = res}
 
 dset :: LamdaExecutionEnv -> ([(Float, Float, Float, Float)], [IrisClass])
@@ -123,7 +147,7 @@ evalResult ex tr = do
   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 (dset ex))
   let resAndTarget = (zip (snd (dset ex)) res)
-  let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: Int
+  let acc =  (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
   let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
   let fitness' = meanOfAccuricyPerClass resAndTarget
   let score = fitness' + (biasSmall - 1)
@@ -135,7 +159,8 @@ evalResult ex tr = do
           fitnessMean = meanOfAccuricyPerClass resAndTarget,
           fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
           accuracy = acc,
-          biasSize = biasSmall
+          biasSize = biasSmall,
+          totalSize = countTrsR tr
         }
     )
 

src/LambdaCalculus.hs

@@ -9,7 +9,7 @@
 
 module LambdaCalculus where
 
-import Data.List (foldr1, last, nub, intersect, (!!), (\\))
+import Data.List (foldr1, intersect, last, nub, (!!), (\\))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -17,14 +17,15 @@ import Data.Random
 import qualified Data.Text as T
 import Data.Tuple.Extra
 import Data.Typeable
+import Debug.Trace as DB
 import GA
 import Pretty
 import Protolude
 import Protolude.Error
-import Debug.Trace as DB
 import Test.QuickCheck hiding (sample, shuffle)
 import Test.QuickCheck.Monadic (assert, monadicIO)
 import qualified Type.Reflection as Ref
+import Utils
 
 data ExpressionWeights = ExpressionWeights
   { lambdaSpucker :: Int,
@@ -73,7 +74,6 @@ exampleLE =
 
 type BoundVars = [TypeRep]
 
-
 -- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it...
 type ConVal = Text
 
@@ -96,7 +96,6 @@ toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr"
 
 -- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
 
-
 eToLambdaExpressionS :: LambdaExpression -> Text
 eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
 eToLambdaExpressionS (LambdaSchlucker typeRequester boundVars) = "\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester
@@ -179,7 +178,7 @@ genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthL
   let args = typeRepArgs target
   let lambaType = fromJust (head args)
   let toFind = last args
-  typeRequester <- genTypeRequester env depthLeft toFind (boundVar ++ [lambaType])
+  typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
   return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
 
 genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
@@ -234,100 +233,119 @@ instance Environment TypeRequester LambdaEnviroment where
     return tr
 
   mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
-    let trCount = countTrsR (tr)
+    selfCrossover <- uniform True False
-    selectedTR <- uniform 1 trCount
+    co <- crossover1 env tr tr
-    let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
+    if selfCrossover && isJust co
-    res <- genTypeRequester env depthAt trep bound
+      then do
-    return $ replaceAtR selectedTR tr res
+        let (tr1, tr2) = fromJust co
+        return $ minimumBy (compare `on` countTrsR) [tr1, tr2]
+      else do
+        let trCount = countTrsR (tr)
+        selectedTR <- uniform 1 trCount
+        let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
+        res <- genTypeRequester env depthAt trep bound
+        return $ replaceAtR selectedTR tr res
 
   nX _ = 3 -- todo!
 
   crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
     let trCount = countTrsR tr1
     selectedIndex1 <- uniform 1 trCount
-    let (depthAt, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
+    let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
-    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1) 0
+    let depthLeftNeeded = depthOfTR selectedTr1
-    if length indexes == 0 then return Nothing else (do
+    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1 (maxDepth - depthAt1) depthLeftNeeded) 0 0
-      (selectedTr2@(TR _ _ bound2),selectedIndex2) <- randomElement indexes
+    if length indexes == 0
-      selectedTr2 <- adaptBoundVars selectedTr2 bound1
+      then return Nothing
-      selectedTr1 <- adaptBoundVars selectedTr1 bound2
+      else
-      let child1 = replaceAtR selectedIndex1 tr1 selectedTr2
+        ( do
-      let child2 = replaceAtR selectedIndex2 tr2 selectedTr1
+            (selectedTr2@(TR _ _ bound2), selectedIndex2) <- randomElement indexes
-      return $ Just (child1, child2)
+            selectedTr2 <- adaptBoundVars selectedTr2 bound1
-      )
+            selectedTr1 <- adaptBoundVars selectedTr1 bound2
-
+            let child1 = replaceAtR selectedIndex1 tr1 selectedTr2
+            let child2 = replaceAtR selectedIndex2 tr2 selectedTr1
+            return $ Just (child1, child2)
+        )
 
 -- helper
-adaptBoundVars:: TypeRequester -> BoundVars -> RVar TypeRequester
+depthOfTR :: TypeRequester -> Int
+depthOfTR (TR _ (Just le@(LambdaSchlucker _ _)) _) = maximum (0:(map depthOfTR (asList le)))
+depthOfTR (TR _ (Just le) _) = maximum (0:(map depthOfTR (asList le))) + 1
+depthOfTR _ = error "le Not Just (depthOfTR)"
+
+adaptBoundVars :: TypeRequester -> BoundVars -> RVar TypeRequester
 adaptBoundVars tr@(TR _ _ bvOld) bvNew = do
   newIndexMap <- generateConversionIndexMap bvOld bvNew
   return $ convertTr tr bvOld bvNew newIndexMap
 
-convertTr:: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> TypeRequester
+convertTr :: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> TypeRequester
 convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld))
 convertTr _ _ _ _ = error "le Not Just (convertTr)"
 
-
 -- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
-convertLe:: LambdaExpression -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> LambdaExpression
+convertLe :: LambdaExpression -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> LambdaExpression
 convertLe (LambdaSpucker tr1 tr2 bvCurr) bvOld bvNew mapper = LambdaSpucker (convertTrf tr1) (convertTrf tr2) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
 convertLe (LambdaSchlucker tr bvCurr) bvOld bvNew mapper = LambdaSchlucker (convertTrf tr) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
 convertLe (Symbol cv trs bvCurr) bvOld bvNew mapper = Symbol cv (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
 convertLe (Var varType varNumber trs bvCurr) bvOld bvNew mapper = Var varType ((fromMaybe identity (Map.lookup varType mapper)) varNumber) (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
 convertLe le@(Constan _) _ _ _ = le
 
-
+generateConversionIndexMap :: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
-generateConversionIndexMap:: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
 generateConversionIndexMap bvOld bvNew = do
   funcs <- mapM (\bT -> genMapper (count bvOld bT - 1) (count bvNew bT - 1)) (nub bvOld)
   return $ Map.fromList $ zip (nub bvOld) funcs
 
-genMapper:: Int -> Int -> RVar (Int -> Int)
+genMapper :: Int -> Int -> RVar (Int -> Int)
-genMapper i j | i == j = return identity
+genMapper i j
-              | i < j = return $ \int -> if int <= i then int else int + (j-i)
+  | i == j = return identity
-              | i > j = do
+  | i < j = return $ \int -> if int <= i then int else int + (j - i)
-                  permutationForUnbound <- genPermutation i j
+  | i > j = do
-                  return $ genMapperRandomAssment i j permutationForUnbound
+      permutationForUnbound <- genPermutation i j
-              | otherwise = error "impossible case in genMapper"
+      return $ genMapperRandomAssment i j permutationForUnbound
+  | otherwise = error "impossible case in genMapper"
 
-genMapperRandomAssment:: Int -> Int -> [Int] -> Int -> Int
+genMapperRandomAssment :: Int -> Int -> [Int] -> Int -> Int
-genMapperRandomAssment i j permutationForUnbound int | int <= j = int
+genMapperRandomAssment i j permutationForUnbound int
-                                                     | int > i = int - (i-j)
+  | int <= j = int
-                                                     | otherwise = permutationForUnbound !! (int - j - 1)
+  | int > i = int - (i - j)
+  | otherwise = permutationForUnbound !! (int - j - 1)
 
-genPermutation:: Int -> Int -> RVar [Int]
+genPermutation :: Int -> Int -> RVar [Int]
 genPermutation i j = replicateM (i - j) (uniform 0 j)
 
-isCompatibleTr:: TypeRequester -> TypeRequester -> Bool
+isCompatibleTr :: TypeRequester -> Int -> Int -> TypeRequester -> Int -> Bool
-isCompatibleTr tr1@(TR trep1 _ bound1) tr2@(TR trep2 _ bound2) | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1
+isCompatibleTr tr1@(TR trep1 _ bound1) maxDepthOfTR2 maxDepthOfNode tr2@(TR trep2 _ bound2) depthOfNode
-                                                       | otherwise = False
+  | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1 && maxDepthOfTR2 >= (depthOfTR tr2) && maxDepthOfNode >= depthOfNode
+  | otherwise = False
+
 allUsedBound :: BoundVars -> BoundVars -> Bool
 allUsedBound used available = all (\x -> any (== x) available) used
 
-
 usedVars :: BoundVars -> TypeRequester -> BoundVars
 usedVars boundOld tr@(TR trep1 (Just (Var trp ind trs _)) _) = if any (== trp) boundOld && count boundOld trp > ind then trp : concatMap (usedVars boundOld) trs else concatMap (usedVars boundOld) trs
-usedVars boundOld tr@(TR trep1 (Just le) _) =  concatMap (usedVars boundOld) (asList le)
+usedVars boundOld tr@(TR trep1 (Just le) _) = concatMap (usedVars boundOld) (asList le)
 usedVars _ _ = error "Nothing in usedVars"
 
+boundsConvertable :: BoundVars -> BoundVars -> Bool
+boundsConvertable bv1 bv2 = length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
 
-boundsConvertable:: BoundVars -> BoundVars -> Bool
+findIndicesWhere :: TypeRequester -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
-boundsConvertable bv1 bv2 =  length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
+findIndicesWhere tr@(TR _ (Just le@(LambdaSchlucker _ _)) _) filte indx currDepth = if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth))
+findIndicesWhere tr@(TR _ lE _) filte indx currDepth = case lE of
+  Just le -> if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1))
+  Nothing -> error "Nothing in findIndicesWhere"
 
-
+findIndicesWhere' :: [TypeRequester] -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
-findIndicesWhere:: TypeRequester -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)]
+findIndicesWhere' [] _ _ _ = []
-findIndicesWhere tr@(TR t lE _) filte indx = case lE of
+findIndicesWhere' [tr] f indx currDepth = (findIndicesWhere tr f indx currDepth)
-                           Just le -> if filte tr then (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) else (findIndicesWhere' (asList le) filte (indx+1))
+findIndicesWhere' (tr : trs) f indx currDepth = (findIndicesWhere tr f indx currDepth) ++ (findIndicesWhere' trs f (indx + countTrsR tr) currDepth)
-                           Nothing -> error "Nothing in findIndicesWhere"
-
-findIndicesWhere':: [TypeRequester] -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)]
-findIndicesWhere' [] _ _ = []
-findIndicesWhere' [tr] f indx = (findIndicesWhere tr f indx)
-findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
 
 replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
 replaceAtR 1 _ with = with
@@ -351,6 +369,7 @@ depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt
 depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
 
 depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
+depthLeftAndTypeAt le@(LambdaSchlucker tr bv) indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft (depthLeft + 1)
 depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
 
 depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
@@ -365,17 +384,6 @@ countTrsR tr@(TR t lE _) = case lE of
 countTrs :: LambdaExpression -> Int
 countTrs le = sum (map countTrsR (asList le))
 
-repeatedly :: (a -> Maybe a) -> a -> [a]
-repeatedly f x = case f x of
-  Nothing -> []
-  Just y -> y : repeatedly f y
-
-count :: (Eq a) => [a] -> a -> Int
-count [] find = 0
-count ys find = length xs
-  where
-    xs = [xs | xs <- ys, xs == find]
-
 -- Test Stuff
 
 testConstInt :: TypeRequester
@@ -535,34 +543,3 @@ eToLambdaExpressionShort (Constan (valS)) = valS
 
 res :: Int -> ResClass
 res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))
-
-
-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

@@ -9,7 +9,7 @@ import Protolude hiding (for)
 import System.IO
 -- import Szenario212Pun
 -- import Szenario191
-import IrisDataset
+import GermanDataset
 import Debug.Trace as DB
 import qualified Data.Map.Strict as Map
 
@@ -26,7 +26,7 @@ options =
       ( long "iterations"
           <> short 'i'
           <> metavar "N"
-          <> value 500
+          <> value 1000
           <> help "Number of iterations"
       )
     <*> option
@@ -51,18 +51,19 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    let env = irisLE
+    germanLEE <- shuffledGermanLEE
+    let env = germanLE
     let selType = Tournament 3
-    let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
+    let run' = run germanLEE env selType 80 (5 / 100) (populationSize opts) (steps (iterations opts))
     pop' <- runEffect (for run' logCsv)
-    irisLEE' <- calc irisLEE  pop'
+    germanLEE' <- calc germanLEE  pop'
-    let (res, _) = bests irisLEE' 5 pop'
+    let (res, _) = bests germanLEE' 5 pop'
-    let irisLEE' = irisLEE {training = False}
+    let germanLEE' = germanLEE {training = False}
-    irisLEE' <- calc irisLEE' res
+    germanLEE' <- calc germanLEE' res
-    mapM_ (format irisLEE') res
+    mapM_ (format germanLEE') res
   where
-    format irisL s = do
+    format germanL s = do
-      let f = fitness' irisL s
+      let f = fitness' germanL s
       putErrText $ show f <> "\n" <> pretty s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f