Hans/haga
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

clean up, organize and document

Browse Source
This commit is contained in:
Johannes Merl
2024-04-22 14:33:40 +02:00
parent 5945016607
commit ea687a2fbb
25 changed files with 390 additions and 410 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
lambda/README.md Normal file
View File

@@ -0,0 +1,17 @@
# Why this split:
The Module(s) used when evaluating individuals has to be in an external library to make Hint work. so we split the lamda-calculus command program in a library we need to expose in the main library and the implementation.
Sadly, ghc / ghci / cabal can not properly make a public, internal library available to ghci (and, with that, Hint). Should this ever change:
```
library haga-lambda-lib
visibility: public
build-depends: base
, protolude
default-language: Haskell2010
ghc-options: -Wall -Wno-orphans -O2
hs-source-dirs: lambda/lib
other-modules: CommonDefinition
exposed-modules: LambdaDatasets.NurseryDefinition
```

9
lambda/lib/CommonDefinition.hs Normal file
View File

@@ -0,0 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-}
module CommonDefinition where
import Protolude
if' :: Bool -> a -> a -> a
if' True e _ = e
if' False _ e = e

38
lambda/lib/LambdaDatasets/GermanDefinition.hs Normal file
View File

@@ -0,0 +1,38 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.GermanDefinition
( module LambdaDatasets.GermanDefinition,
module CommonDefinition,
) where
import Protolude
import CommonDefinition
data GermanClass = Accept | Deny deriving (Eq, Generic, Show, Enum, Bounded)
data AccountStatus = AccountInDebt | NoAccount | LowAccountBalance | HighAccountBalanceOrRegular deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data CreditHistory = HistoryGood | HistoryGoodHere | HistoryGoodSoFar | DelaysInHistory | CreditsExist deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Purpose = OldCar | NewCar | FunitureOrEquipment | Tech | Appliances | Repairs | Education | Retraining | Business | Other deriving (Eq, Generic, Show, Enum, Bounded)
data Savings = UnknownOrNone | SmallSavings | NormalSavings | GoodSavings | GreatSavings deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data EmploymentStatus = NotEmployed | ShortTermEmployed | MediumTermEmployed | LongTermEmployed | VeteranEmployed deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data StatusAndSex = MaleAndSeperated | FemaleAndSeperatedOrMarried | MaleAndSingle | FemaleAndSingle | MaleAndWidowedOrMarried deriving (Eq, Generic, Show, Enum, Bounded)
data OtherDebtors = NoOtherDebtors | CoApplicant | Guarantor deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Property = UnknownOrNoProperty | RealEstate | Savings | CarOrOther deriving (Eq, Generic, Show, Enum, Bounded)
data OtherPlans = PlansAtBank | PlansAtStores | NoOtherPlans deriving (Eq, Generic, Show, Enum, Bounded)
data Housing = Renting | OwningRecidency | ResidingForFree deriving (Eq, Generic, Show, Enum, Bounded)
data Job = UnemployedOrUnskilledNonResident | UnskilledResident | Skilled | HighlySkilled deriving (Eq, Generic, Show, Enum, Bounded, Ord)

16
lambda/lib/LambdaDatasets/IrisDefinition.hs Normal file
View File

@@ -0,0 +1,16 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.IrisDefinition
( module LambdaDatasets.IrisDefinition,
module CommonDefinition,
) where
import Protolude
import CommonDefinition
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)

32
lambda/lib/LambdaDatasets/NurseryDefinition.hs Normal file
View File

@@ -0,0 +1,32 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.NurseryDefinition
( module LambdaDatasets.NurseryDefinition,
module CommonDefinition,
) where
import Protolude
import CommonDefinition
data NurseryClass = NotRecommend | Recommend | VeryRecommend | Priority | SpecPriority deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Parents = Usual | Pretentious | GreatPret deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data HasNurs = ProperNurs | LessProperNurs | ImproperNurs | CriticalNurs | VeryCritNurs deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Form = CompleteFamilyForm | CompletedFamilyForm | IncompleteFamilyForm | FosterFamilyForm deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Children = OneChild | TwoChilds | ThreeChilds | MoreChilds deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Housing = ConvenientHousing | LessConvHousing | CriticalHousing deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Finance = ConvenientFinance | InconvFinance deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Social = NotProblematicSocial | SlightlyProblematicSocial | ProblematicSocial deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Health = NotRecommendHealth |RecommendedHealth | PriorityHealth deriving (Eq, Generic, Show, Enum, Bounded, Ord)

1014
lambda/src/LambdaDatasets/GermanData.hs Normal file
View File

File diff suppressed because it is too large Load Diff

208
lambda/src/LambdaDatasets/GermanDataset.hs Normal file
View File

@@ -0,0 +1,208 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.GermanDataset
( module LambdaCalculus,
module LambdaDatasets.GermanDataset,
module LambdaDatasets.GermanData,
module GA,
)
where
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
import GA
import LambdaDatasets.GermanData
import LambdaCalculus
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import Protolude.Error
import System.Random.MWC (createSystemRandom)
import qualified Type.Reflection as Ref
import Utils
lE :: LambdaEnviroment
lE =
LambdaEnviroment
{ functions =
Map.fromList
[ -- Math
((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)"]),
-- Logic
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-- Ordered Enums
((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> AccountStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory -> CreditHistory -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Savings -> Savings -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus -> EmploymentStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors -> OtherDebtors -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Job -> Job -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-- Eq Enum
((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass -> GermanClass -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Purpose -> Purpose -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex -> StatusAndSex -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Property -> Property -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherPlans -> OtherPlans -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(==)", "(/=)"]),
-- Any Type
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> GermanClass -> GermanClass -> GermanClass))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> AccountStatus -> AccountStatus -> AccountStatus))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> CreditHistory -> CreditHistory -> CreditHistory))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Purpose -> Purpose -> Purpose))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Savings -> Savings -> Savings))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> EmploymentStatus -> EmploymentStatus -> EmploymentStatus))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> StatusAndSex -> StatusAndSex -> StatusAndSex))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> OtherDebtors -> OtherDebtors -> OtherDebtors))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Property -> Property -> Property))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> OtherPlans -> OtherPlans -> OtherPlans))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Job -> Job -> Job))), ["if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Int))), [(fmap show (uniform 0 10 :: RVar Int))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass))), [(fmap show (enumUniform Accept Deny))]),
((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus))), [(fmap show (enumUniform AccountInDebt HighAccountBalanceOrRegular))]),
((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory))), [(fmap show (enumUniform HistoryGood CreditsExist ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Purpose))), [(fmap show (enumUniform OldCar Other ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Savings))), [(fmap show (enumUniform UnknownOrNone GreatSavings ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus))), [(fmap show (enumUniform NotEmployed VeteranEmployed ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex))), [(fmap show (enumUniform MaleAndSeperated MaleAndWidowedOrMarried ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors))), [(fmap show (enumUniform NoOtherDebtors Guarantor ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Property))), [(fmap show (enumUniform UnknownOrNoProperty CarOrOther ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherPlans))), [(fmap show (enumUniform PlansAtBank NoOtherPlans ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform Renting ResidingForFree ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Job))), [(fmap show (enumUniform UnemployedOrUnskilledNonResident HighlySkilled ))])
],
targetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
maxDepth = 8,
weights =
ExpressionWeights
{ lambdaSpucker = 1,
lambdaSchlucker = 2,
symbol = 30,
variable = 10,
constant = 5
}
}
lEE :: LamdaExecutionEnv
lEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.GermanDefinition"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 germanTrainingData),
map snd (takeFraktion 0.8 germanTrainingData)
),
testData =
( map fst (dropFraktion 0.8 germanTrainingData),
map snd (dropFraktion 0.8 germanTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
results = Map.empty
}
shuffledLEE :: IO LamdaExecutionEnv
shuffledLEE = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
itD <- smpl $ shuffle germanTrainingData
return
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.GermanDefinition"],
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 @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
results = Map.empty
}
data LamdaExecutionEnv = LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports :: [Text],
training :: Bool,
trainingData :: ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass]),
testData :: ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass]),
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester FittnesRes
}
data FittnesRes = FittnesRes
{ total :: R,
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: R,
biasSize :: R,
totalSize :: N
}
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 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 relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
return env {results = res}
dset :: LamdaExecutionEnv -> ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass])
dset lEE = if training lEE then trainingData lEE else testData lEE
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
evalResults ex trs = do
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
Hint.unsafeSetGhcOption "-O2"
let arrayOfFunctionText = map toLambdaExpressionS trs
let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]"
result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass])
return $ zipWith (evalResult ex) trs result
evalResult :: LamdaExecutionEnv -> TypeRequester -> (AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass) -> (TypeRequester, FittnesRes)
evalResult ex tr result = ( tr,
FittnesRes
{ total = score,
fitnessTotal = fitness',
fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc,
biasSize = biasSmall,
totalSize = countTrsR tr
}
)
where
res = map (\(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> result a b c d e f g h i j k l m n o p q r s t) (fst (dset ex))
resAndTarget = (zip (snd (dset ex)) res)
acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
fitness' = meanOfAccuricyPerClass resAndTarget
score = fitness' + (biasSmall - 1)

168
lambda/src/LambdaDatasets/IrisData.hs Normal file
View File

@@ -0,0 +1,168 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.IrisData
( module LambdaDatasets.IrisDefinition,
module LambdaDatasets.IrisData,
)
where
import LambdaDatasets.IrisDefinition
import Protolude
irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
irisTrainingData =
[ ((6.7, 3.1, 4.4, 1.4), Versicolor),
((5.4, 3.7, 1.5, 0.2), Setosa),
((5.4, 3.0, 4.5, 1.5), Versicolor),
((5.1, 3.8, 1.5, 0.3), Setosa),
((5.0, 2.3, 3.3, 1.0), Versicolor),
((6.0, 2.7, 5.1, 1.6), Versicolor),
((4.6, 3.2, 1.4, 0.2), Setosa),
((5.6, 2.7, 4.2, 1.3), Versicolor),
((6.7, 3.3, 5.7, 2.1), Virginica),
((6.9, 3.1, 5.1, 2.3), Virginica),
((7.7, 3.8, 6.7, 2.2), Virginica),
((6.1, 2.8, 4.7, 1.2), Versicolor),
((5.8, 2.7, 3.9, 1.2), Versicolor),
((6.7, 3.3, 5.7, 2.5), Virginica),
((5.0, 3.4, 1.5, 0.2), Setosa),
((4.7, 3.2, 1.6, 0.2), Setosa),
((6.8, 3.0, 5.5, 2.1), Virginica),
((6.2, 2.2, 4.5, 1.5), Versicolor),
((5.7, 3.8, 1.7, 0.3), Setosa),
((5.8, 4.0, 1.2, 0.2), Setosa),
((7.2, 3.2, 6.0, 1.8), Virginica),
((5.8, 2.7, 4.1, 1.0), Versicolor),
((6.5, 3.0, 5.8, 2.2), Virginica),
((6.9, 3.2, 5.7, 2.3), Virginica),
((5.8, 2.7, 5.1, 1.9), Virginica),
((5.2, 4.1, 1.5, 0.1), Setosa),
((4.6, 3.6, 1.0, 0.2), Setosa),
((4.7, 3.2, 1.3, 0.2), Setosa),
((6.9, 3.1, 5.4, 2.1), Virginica),
((6.1, 2.9, 4.7, 1.4), Versicolor),
((6.0, 3.4, 4.5, 1.6), Versicolor),
((5.6, 3.0, 4.5, 1.5), Versicolor),
((5.2, 3.4, 1.4, 0.2), Setosa),
((6.3, 3.3, 4.7, 1.6), Versicolor),
((7.2, 3.6, 6.1, 2.5), Virginica),
((6.5, 3.2, 5.1, 2.0), Virginica),
((6.3, 2.5, 4.9, 1.5), Versicolor),
((5.1, 3.8, 1.9, 0.4), Setosa),
((7.0, 3.2, 4.7, 1.4), Versicolor),
((4.9, 3.1, 1.5, 0.1), Setosa),
((4.9, 2.4, 3.3, 1.0), Versicolor),
((6.1, 3.0, 4.9, 1.8), Virginica),
((4.9, 3.1, 1.5, 0.1), Setosa),
((6.2, 2.9, 4.3, 1.3), Versicolor),
((5.7, 3.0, 4.2, 1.2), Versicolor),
((7.2, 3.0, 5.8, 1.6), Virginica),
((5.0, 2.0, 3.5, 1.0), Versicolor),
((4.3, 3.0, 1.1, 0.1), Setosa),
((6.7, 3.1, 4.7, 1.5), Versicolor),
((5.5, 2.4, 3.8, 1.1), Versicolor),
((5.7, 2.8, 4.5, 1.3), Versicolor),
((7.7, 2.8, 6.7, 2.0), Virginica),
((7.6, 3.0, 6.6, 2.1), Virginica),
((4.9, 2.5, 4.5, 1.7), Virginica),
((5.1, 2.5, 3.0, 1.1), Versicolor),
((6.4, 2.8, 5.6, 2.1), Virginica),
((6.4, 2.8, 5.6, 2.2), Virginica),
((5.9, 3.0, 5.1, 1.8), Virginica),
((4.4, 3.2, 1.3, 0.2), Setosa),
((6.3, 2.3, 4.4, 1.3), Versicolor),
((5.4, 3.4, 1.7, 0.2), Setosa),
((4.9, 3.0, 1.4, 0.2), Setosa),
((6.7, 3.0, 5.2, 2.3), Virginica),
((5.0, 3.5, 1.3, 0.3), Setosa),
((5.1, 3.3, 1.7, 0.5), Setosa),
((7.7, 2.6, 6.9, 2.3), Virginica),
((5.6, 2.9, 3.6, 1.3), Versicolor),
((7.3, 2.9, 6.3, 1.8), Virginica),
((6.7, 3.1, 5.6, 2.4), Virginica),
((6.3, 2.8, 5.1, 1.5), Virginica),
((5.6, 2.5, 3.9, 1.1), Versicolor),
((5.4, 3.9, 1.3, 0.4), Setosa),
((5.5, 2.3, 4.0, 1.3), Versicolor),
((6.4, 2.7, 5.3, 1.9), Virginica),
((5.1, 3.5, 1.4, 0.3), Setosa),
((5.5, 3.5, 1.3, 0.2), Setosa),
((5.0, 3.2, 1.2, 0.2), Setosa),
((5.1, 3.4, 1.5, 0.2), Setosa),
((5.4, 3.9, 1.7, 0.4), Setosa),
((4.5, 2.3, 1.3, 0.3), Setosa),
((6.7, 3.0, 5.0, 1.7), Versicolor),
((5.0, 3.3, 1.4, 0.2), Setosa),
((7.1, 3.0, 5.9, 2.1), Virginica),
((5.8, 2.6, 4.0, 1.2), Versicolor),
((6.3, 2.7, 4.9, 1.8), Virginica),
((6.8, 3.2, 5.9, 2.3), Virginica),
((6.6, 3.0, 4.4, 1.4), Versicolor),
((5.4, 3.4, 1.5, 0.4), Setosa),
((5.0, 3.6, 1.4, 0.2), Setosa),
((5.9, 3.2, 4.8, 1.8), Versicolor),
((6.3, 2.5, 5.0, 1.9), Virginica),
((6.0, 3.0, 4.8, 1.8), Virginica),
((7.9, 3.8, 6.4, 2.0), Virginica),
((5.9, 3.0, 4.2, 1.5), Versicolor),
((4.8, 3.0, 1.4, 0.1), Setosa),
((5.7, 2.8, 4.1, 1.3), Versicolor),
((6.7, 2.5, 5.8, 1.8), Virginica),
((5.7, 2.6, 3.5, 1.0), Versicolor),
((4.4, 3.0, 1.3, 0.2), Setosa),
((4.8, 3.4, 1.9, 0.2), Setosa),
((6.3, 3.4, 5.6, 2.4), Virginica),
((5.5, 4.2, 1.4, 0.2), Setosa),
((5.0, 3.0, 1.6, 0.2), Setosa),
((5.7, 2.9, 4.2, 1.3), Versicolor),
((6.2, 2.8, 4.8, 1.8), Virginica),
((6.2, 3.4, 5.4, 2.3), Virginica),
((6.5, 3.0, 5.2, 2.0), Virginica),
((4.9, 3.1, 1.5, 0.1), Setosa),
((5.8, 2.7, 5.1, 1.9), Virginica),
((5.1, 3.5, 1.4, 0.2), Setosa),
((5.6, 2.8, 4.9, 2.0), Virginica),
((5.5, 2.4, 3.7, 1.0), Versicolor),
((6.1, 2.8, 4.0, 1.3), Versicolor),
((5.7, 4.4, 1.5, 0.4), Setosa),
((6.9, 3.1, 4.9, 1.5), Versicolor),
((5.8, 2.8, 5.1, 2.4), Virginica),
((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),
((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),
((6.4, 2.9, 4.3, 1.3), Versicolor),
((5.5, 2.6, 4.4, 1.2), Versicolor),
((5.2, 2.7, 3.9, 1.4), Versicolor),
((6.0, 2.9, 4.5, 1.5), Versicolor),
((5.3, 3.7, 1.5, 0.2), Setosa),
((6.4, 3.2, 5.3, 2.3), Virginica),
((6.4, 3.1, 5.5, 1.8), Virginica),
((5.1, 3.8, 1.6, 0.2), Setosa),
((5.1, 3.7, 1.5, 0.4), Setosa),
((4.6, 3.4, 1.4, 0.3), Setosa),
((5.6, 3.0, 4.1, 1.3), Versicolor),
((6.1, 3.0, 4.6, 1.4), Versicolor),
((5.2, 3.5, 1.5, 0.2), Setosa),
((7.4, 2.8, 6.1, 1.9), Virginica),
((6.5, 2.8, 4.6, 1.5), Versicolor),
((6.3, 3.3, 6.0, 2.5), Virginica),
((4.8, 3.1, 1.6, 0.2), Setosa),
((7.7, 3.0, 6.1, 2.3), Virginica),
((6.0, 2.2, 5.0, 1.5), Virginica),
((5.5, 2.5, 4.0, 1.3), Versicolor),
((6.5, 3.0, 5.5, 1.8), Virginica),
((4.4, 2.9, 1.4, 0.2), Setosa),
((6.4, 3.2, 4.5, 1.5), Versicolor),
((5.0, 3.4, 1.6, 0.4), Setosa),
((6.1, 2.6, 5.6, 1.4), Virginica),
((6.6, 2.9, 4.6, 1.3), Versicolor)
]

168
lambda/src/LambdaDatasets/IrisDataset.hs Normal file
View File

@@ -0,0 +1,168 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.IrisDataset
( module LambdaCalculus,
module LambdaDatasets.IrisDataset,
module LambdaDatasets.IrisData,
module GA,
)
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
import GA
import LambdaCalculus
import LambdaDatasets.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
lE :: LambdaEnviroment
lE =
LambdaEnviroment
{ functions =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'","if'","if'","if'","if'","if'","if'","if'","if'","if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float))), [(fmap show (uniform 0 10 :: RVar Float))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
],
targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
maxDepth = 10,
weights =
ExpressionWeights
{ lambdaSpucker = 1,
lambdaSchlucker = 1,
symbol = 30,
variable = 100,
constant = 5
}
}
lEE :: LamdaExecutionEnv
lEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.IrisDataset"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 irisTrainingData),
map snd (takeFraktion 0.8 irisTrainingData)
),
testData =
( map fst (dropFraktion 0.8 irisTrainingData),
map snd (dropFraktion 0.8 irisTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
results = Map.empty
}
shuffledLEE :: IO LamdaExecutionEnv
shuffledLEE = 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 = ["LambdaDatasets.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))),
results = Map.empty
}
data LamdaExecutionEnv = LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports :: [Text],
training :: Bool,
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
testData :: ([(Float, Float, Float, Float)], [IrisClass]),
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester FittnesRes
}
data FittnesRes = FittnesRes
{ total :: R,
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: R,
biasSize :: R,
totalSize :: N
}
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 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 relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
return env {results = res}
dset :: LamdaExecutionEnv -> ([(Float, Float, Float, Float)], [IrisClass])
dset lEE = if training lEE then trainingData lEE else testData lEE
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
evalResults ex trs = do
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
Hint.unsafeSetGhcOption "-O2"
let arrayOfFunctionText = map toLambdaExpressionS trs
let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]"
result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [Float -> Float -> Float -> Float -> IrisClass])
return $ zipWith (evalResult ex) trs result
evalResult :: LamdaExecutionEnv -> TypeRequester -> (Float -> Float -> Float -> Float -> IrisClass) -> (TypeRequester, FittnesRes)
evalResult ex tr result = ( tr,
FittnesRes
{ total = score,
fitnessTotal = fitness',
fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc,
biasSize = biasSmall,
totalSize = countTrsR tr
}
)
where
res = map (\(a, b, c, d) -> result a b c d) (fst (dset ex))
resAndTarget = (zip (snd (dset ex)) res)
acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
fitness' = meanOfAccuricyPerClass resAndTarget
score = fitness' + (biasSmall - 1)

12978
lambda/src/LambdaDatasets/NurseryData.hs Normal file
View File

File diff suppressed because it is too large Load Diff

199
lambda/src/LambdaDatasets/NurseryDataset.hs Normal file
View File

@@ -0,0 +1,199 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.NurseryDataset
( module LambdaCalculus,
module LambdaDatasets.NurseryDataset,
module LambdaDatasets.NurseryData,
module GA,
)
where
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
import GA
import LambdaDatasets.NurseryData
import LambdaCalculus
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import Protolude.Error
import System.Random.MWC (createSystemRandom)
import qualified Type.Reflection as Ref
import Utils
lE :: LambdaEnviroment
lE =
LambdaEnviroment
{ functions =
Map.fromList
[ -- Math
-- Logic
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-- Ordered Enums
((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Parents -> Parents -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs -> HasNurs -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Form -> Form -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Children -> Children -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Finance -> Finance -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Social -> Social -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Health -> Health -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-- Eq Enum
-- Any Type
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> NurseryClass -> NurseryClass -> NurseryClass))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Parents -> Parents -> Parents))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> HasNurs -> HasNurs -> HasNurs))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Form -> Form -> Form))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Children -> Children -> Children))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Finance -> Finance -> Finance))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Social -> Social -> Social))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Health -> Health -> Health))), ["if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass))), [(fmap show (enumUniform NotRecommend SpecPriority))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Parents))), [(fmap show (enumUniform Usual GreatPret))]),
((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs))), [(fmap show (enumUniform ProperNurs VeryCritNurs ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Form))), [(fmap show (enumUniform CompleteFamilyForm FosterFamilyForm ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Children))), [(fmap show (enumUniform OneChild MoreChilds ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform ConvenientHousing CriticalHousing ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Finance))), [(fmap show (enumUniform ConvenientFinance InconvFinance ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Social))), [(fmap show (enumUniform NotProblematicSocial ProblematicSocial ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Health))), [(fmap show (enumUniform NotRecommendHealth PriorityHealth ))])
],
targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
maxDepth = 8,
weights =
ExpressionWeights
{ lambdaSpucker = 1,
lambdaSchlucker = 2,
symbol = 30,
variable = 20,
constant = 5
}
}
trainingFraction :: R
trainingFraction = (2/3)
lEE :: LamdaExecutionEnv
lEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.NurseryDefinition"],
training = True,
trainingData =
( map fst (takeFraktion trainingFraction nurseryTrainingData),
map snd (takeFraktion trainingFraction nurseryTrainingData)
),
testData =
( map fst (dropFraktion trainingFraction nurseryTrainingData),
map snd (dropFraktion trainingFraction nurseryTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
results = Map.empty
}
shuffledLEE :: IO LamdaExecutionEnv
shuffledLEE = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
itD <- smpl $ shuffle nurseryTrainingData
return
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.NurseryDefinition"],
training = True,
trainingData =
( map fst (takeFraktion trainingFraction itD),
map snd (takeFraktion trainingFraction itD)
),
testData =
( map fst (dropFraktion trainingFraction itD),
map snd (dropFraktion trainingFraction itD)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
results = Map.empty
}
data LamdaExecutionEnv = LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports :: [Text],
training :: Bool,
trainingData :: ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass]),
testData :: ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass]),
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester FittnesRes
}
data FittnesRes = FittnesRes
{ total :: R,
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: R,
biasSize :: R,
totalSize :: N
}
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 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 relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
return env {results = res}
dset :: LamdaExecutionEnv -> ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass])
dset lEE = if training lEE then trainingData lEE else testData lEE
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
evalResults ex trs = do
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
Hint.unsafeSetGhcOption "-O2"
let arrayOfFunctionText = map toLambdaExpressionS trs
let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]"
result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass])
return $ zipWith (evalResult ex) trs result
evalResult :: LamdaExecutionEnv -> TypeRequester -> (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass) -> (TypeRequester, FittnesRes)
evalResult ex tr result = ( tr,
FittnesRes
{ total = acc * 100 + (biasSmall - 1),
fitnessTotal = fitness',
fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc,
biasSize = biasSmall,
totalSize = countTrsR tr
}
)
where
res = map (\(a, b, c, d, e, f, g, h) -> result a b c d e f g h) (fst (dset ex))
resAndTarget = (zip (snd (dset ex)) res)
acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
fitness' = meanOfAccuricyPerClass resAndTarget
score = fitness' + (biasSmall - 1)

69
lambda/src/Main.hs Normal file
View File

@@ -0,0 +1,69 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Options.Applicative
import Pipes
import Pretty
import Protolude hiding (for)
import System.IO
-- import LambdaDatasets.IrisDataset
-- import LambdaDatasets.NurseryDataset
import LambdaDatasets.GermanDataset
import Debug.Trace as DB
import qualified Data.Map.Strict as Map
data Options = Options
{ iterations :: !N,
populationSize :: !N
}
options :: Parser Options
options =
Options
<$> option
auto
( long "iterations"
<> short 'i'
<> metavar "N"
<> value 1500
<> help "Number of iterations"
)
<*> option
auto
( long "population-size"
<> short 'p'
<> metavar "N"
<> value 400
<> help "Population size"
)
optionsWithHelp :: ParserInfo Options
optionsWithHelp =
info
(helper <*> options)
( fullDesc
<> progDesc "Run a GA"
<> header "haga - Haskell implementations of EAs"
)
main :: IO ()
main =
execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering
lEE <- shuffledLEE
let env = lE
let selType = Tournament 3
let run' = run lEE env selType 120 (5 / 100) (populationSize opts) (steps (iterations opts))
pop' <- runEffect (for run' logCsv)
lEE' <- calc lEE pop'
let (res, _) = bests lEE' 5 pop'
let lEE' = lEE {training = False}
lEE' <- calc lEE' res
mapM_ (format lEE') res
where
format l s = do
let f = fitness' l s
putErrText $ show f <> "\n" <> pretty s
logCsv = putText . csv
csv (t, f) = show t <> " " <> show f