implement Iris dataset

This commit is contained in:
Johannes Merl 2024-03-04 11:36:31 +01:00
parent 57cf1452bf
commit 6435f4aca2
4 changed files with 464 additions and 24 deletions

View File

@ -35,6 +35,7 @@ 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
@ -214,13 +215,10 @@ run eval env selectionType nParents pElite nPop term = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
firstPop <- liftIO $ smpl $ (population env nPop)
_ <- liftIO $ putText $ pretty $ NE.head firstPop
firstPop <- liftIO $ smpl $ (population env nPop)
_ <- liftIO $ putText $ pretty $ NE.head firstPop
res <- runIter eval 0 firstPop smpl
return res
where
runIter eval count pop smpl =
runIter eval count pop smpl = (
if term pop count
then do
return pop
@ -232,7 +230,7 @@ run eval env selectionType nParents pElite nPop term = do
let fBest = fitness eval $ NE.head $ fst $ bests eval 1 resPop
Pipes.yield (count, fBest)
res <- runIter eval (count + 1) resPop smpl
return res
return res)
-- * Selection mechanisms

438
src/IrisDataset.hs Normal file
View File

@ -0,0 +1,438 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module IrisDataset
( module LambdaCalculus,
module IrisDataset,
module GA,
)
where
import qualified Data.ByteString.Lazy as B
import Data.Csv
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 qualified Debug.Trace as DB
import GA
import LambdaCalculus
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import qualified Type.Reflection as Ref
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
instance FromRecord IrisClass
instance ToRecord IrisClass
irisLE :: LambdaEnviroment
irisLE =
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'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["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 = 1,
variable = 2,
constant = 1
}
}
irisLEE :: LamdaExecutionEnv
irisLEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["IrisDataset"],
-- Path to a CSV file containing the training dataset
trainingDataset = "./iris.csv",
-- Path to a CSV file containing the dataset results
trainingDatasetRes = "./res.csv",
trainingData =
( [ (5.1, 3.5, 1.4, 0.2),
(4.9, 3.0, 1.4, 0.2),
(4.7, 3.2, 1.3, 0.2),
(4.6, 3.1, 1.5, 0.2),
(5.0, 3.6, 1.4, 0.2),
(5.4, 3.9, 1.7, 0.4),
(4.6, 3.4, 1.4, 0.3),
(5.0, 3.4, 1.5, 0.2),
(4.4, 2.9, 1.4, 0.2),
(4.9, 3.1, 1.5, 0.1),
(5.4, 3.7, 1.5, 0.2),
(4.8, 3.4, 1.6, 0.2),
(4.8, 3.0, 1.4, 0.1),
(4.3, 3.0, 1.1, 0.1),
(5.8, 4.0, 1.2, 0.2),
(5.7, 4.4, 1.5, 0.4),
(5.4, 3.9, 1.3, 0.4),
(5.1, 3.5, 1.4, 0.3),
(5.7, 3.8, 1.7, 0.3),
(5.1, 3.8, 1.5, 0.3),
(5.4, 3.4, 1.7, 0.2),
(5.1, 3.7, 1.5, 0.4),
(4.6, 3.6, 1.0, 0.2),
(5.1, 3.3, 1.7, 0.5),
(4.8, 3.4, 1.9, 0.2),
(5.0, 3.0, 1.6, 0.2),
(5.0, 3.4, 1.6, 0.4),
(5.2, 3.5, 1.5, 0.2),
(5.2, 3.4, 1.4, 0.2),
(4.7, 3.2, 1.6, 0.2),
(4.8, 3.1, 1.6, 0.2),
(5.4, 3.4, 1.5, 0.4),
(5.2, 4.1, 1.5, 0.1),
(5.5, 4.2, 1.4, 0.2),
(4.9, 3.1, 1.5, 0.1),
(5.0, 3.2, 1.2, 0.2),
(5.5, 3.5, 1.3, 0.2),
(4.9, 3.1, 1.5, 0.1),
(4.4, 3.0, 1.3, 0.2),
(5.1, 3.4, 1.5, 0.2),
(5.0, 3.5, 1.3, 0.3),
(4.5, 2.3, 1.3, 0.3),
(4.4, 3.2, 1.3, 0.2),
(5.0, 3.5, 1.6, 0.6),
(5.1, 3.8, 1.9, 0.4),
(4.8, 3.0, 1.4, 0.3),
(5.1, 3.8, 1.6, 0.2),
(4.6, 3.2, 1.4, 0.2),
(5.3, 3.7, 1.5, 0.2),
(5.0, 3.3, 1.4, 0.2),
(7.0, 3.2, 4.7, 1.4),
(6.4, 3.2, 4.5, 1.5),
(6.9, 3.1, 4.9, 1.5),
(5.5, 2.3, 4.0, 1.3),
(6.5, 2.8, 4.6, 1.5),
(5.7, 2.8, 4.5, 1.3),
(6.3, 3.3, 4.7, 1.6),
(4.9, 2.4, 3.3, 1.0),
(6.6, 2.9, 4.6, 1.3),
(5.2, 2.7, 3.9, 1.4),
(5.0, 2.0, 3.5, 1.0),
(5.9, 3.0, 4.2, 1.5),
(6.0, 2.2, 4.0, 1.0),
(6.1, 2.9, 4.7, 1.4),
(5.6, 2.9, 3.6, 1.3),
(6.7, 3.1, 4.4, 1.4),
(5.6, 3.0, 4.5, 1.5),
(5.8, 2.7, 4.1, 1.0),
(6.2, 2.2, 4.5, 1.5),
(5.6, 2.5, 3.9, 1.1),
(5.9, 3.2, 4.8, 1.8),
(6.1, 2.8, 4.0, 1.3),
(6.3, 2.5, 4.9, 1.5),
(6.1, 2.8, 4.7, 1.2),
(6.4, 2.9, 4.3, 1.3),
(6.6, 3.0, 4.4, 1.4),
(6.8, 2.8, 4.8, 1.4),
(6.7, 3.0, 5.0, 1.7),
(6.0, 2.9, 4.5, 1.5),
(5.7, 2.6, 3.5, 1.0),
(5.5, 2.4, 3.8, 1.1),
(5.5, 2.4, 3.7, 1.0),
(5.8, 2.7, 3.9, 1.2),
(6.0, 2.7, 5.1, 1.6),
(5.4, 3.0, 4.5, 1.5),
(6.0, 3.4, 4.5, 1.6),
(6.7, 3.1, 4.7, 1.5),
(6.3, 2.3, 4.4, 1.3),
(5.6, 3.0, 4.1, 1.3),
(5.5, 2.5, 4.0, 1.3),
(5.5, 2.6, 4.4, 1.2),
(6.1, 3.0, 4.6, 1.4),
(5.8, 2.6, 4.0, 1.2),
(5.0, 2.3, 3.3, 1.0),
(5.6, 2.7, 4.2, 1.3),
(5.7, 3.0, 4.2, 1.2),
(5.7, 2.9, 4.2, 1.3),
(6.2, 2.9, 4.3, 1.3),
(5.1, 2.5, 3.0, 1.1),
(5.7, 2.8, 4.1, 1.3),
(6.3, 3.3, 6.0, 2.5),
(5.8, 2.7, 5.1, 1.9),
(7.1, 3.0, 5.9, 2.1),
(6.3, 2.9, 5.6, 1.8),
(6.5, 3.0, 5.8, 2.2),
(7.6, 3.0, 6.6, 2.1),
(4.9, 2.5, 4.5, 1.7),
(7.3, 2.9, 6.3, 1.8),
(6.7, 2.5, 5.8, 1.8),
(7.2, 3.6, 6.1, 2.5),
(6.5, 3.2, 5.1, 2.0),
(6.4, 2.7, 5.3, 1.9),
(6.8, 3.0, 5.5, 2.1),
(5.7, 2.5, 5.0, 2.0),
(5.8, 2.8, 5.1, 2.4),
(6.4, 3.2, 5.3, 2.3),
(6.5, 3.0, 5.5, 1.8),
(7.7, 3.8, 6.7, 2.2),
(7.7, 2.6, 6.9, 2.3),
(6.0, 2.2, 5.0, 1.5),
(6.9, 3.2, 5.7, 2.3),
(5.6, 2.8, 4.9, 2.0),
(7.7, 2.8, 6.7, 2.0),
(6.3, 2.7, 4.9, 1.8),
(6.7, 3.3, 5.7, 2.1),
(7.2, 3.2, 6.0, 1.8),
(6.2, 2.8, 4.8, 1.8),
(6.1, 3.0, 4.9, 1.8),
(6.4, 2.8, 5.6, 2.1),
(7.2, 3.0, 5.8, 1.6),
(7.4, 2.8, 6.1, 1.9),
(7.9, 3.8, 6.4, 2.0),
(6.4, 2.8, 5.6, 2.2),
(6.3, 2.8, 5.1, 1.5),
(6.1, 2.6, 5.6, 1.4),
(7.7, 3.0, 6.1, 2.3),
(6.3, 3.4, 5.6, 2.4),
(6.4, 3.1, 5.5, 1.8),
(6.0, 3.0, 4.8, 1.8),
(6.9, 3.1, 5.4, 2.1),
(6.7, 3.1, 5.6, 2.4),
(6.9, 3.1, 5.1, 2.3),
(5.8, 2.7, 5.1, 1.9),
(6.8, 3.2, 5.9, 2.3),
(6.7, 3.3, 5.7, 2.5),
(6.7, 3.0, 5.2, 2.3),
(6.3, 2.5, 5.0, 1.9),
(6.5, 3.0, 5.2, 2.0),
(6.2, 3.4, 5.4, 2.3),
(5.9, 3.0, 5.1, 1.8)
],
[ Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Setosa,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Versicolor,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica,
Virginica
]
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-- todo: kindaHacky
results = Map.empty
}
data LamdaExecutionEnv = LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports :: [Text],
-- Path to a CSV file containing the training dataset
trainingDataset :: FilePath,
-- Path to a CSV file containing the dataset results
trainingDatasetRes :: FilePath,
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester R
}
instance Evaluator TypeRequester LamdaExecutionEnv where
fitness env tr = (results env) Map.! tr
calc env pop = do
let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
env <- loadTrainingData env
toInsert <- Hint.runInterpreter (evalResults env toAdd)
let insertPair (key, val) m = Map.insert key val m
let res = foldr insertPair (results env) (fromRight undefined toInsert)
return env {results = res}
loadTrainingData :: LamdaExecutionEnv -> IO LamdaExecutionEnv
loadTrainingData ex@LamdaExecutionEnv {trainingData = ([], [])} = do
csv <- B.readFile (trainingDataset ex)
let dat = (toList $ fromRight undefined $ decode NoHeader csv) :: [(Float, Float, Float, Float)]
csvRes <- B.readFile (trainingDatasetRes ex)
let decodedRes = decode NoHeader csvRes
let recsRes = (toList $ fromRight undefined decodedRes) :: [IrisClass]
return ex {trainingData = (dat, recsRes)}
loadTrainingData lee@LamdaExecutionEnv {trainingData = (_ : _, _ : _)} = return lee
loadTrainingData lee@LamdaExecutionEnv {trainingData = (_ : _, [])} = return undefined
loadTrainingData lee@LamdaExecutionEnv {trainingData = ([], _ : _)} = return undefined
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)]
evalResults ex trs = mapM (evalResult ex) trs
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R)
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)
if' :: Bool -> a -> a -> a
if' True e _ = e
if' False _ e = e

View File

@ -62,21 +62,22 @@ exampleLE =
weights =
ExpressionWeights
{ lambdaSpucker = 1,
lambdaSchlucker = 1,
symbol = 1,
variable = 1,
constant = 1
lambdaSchlucker = 2,
symbol = 2,
variable = 10,
constant = 2
}
}
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
-- LambdaSpucker - adds TypeRequester#1 as bound var and returns the result of TypeRequester#2
data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord)
data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
asList :: LambdaExpression -> [TypeRequester]
asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2]
@ -85,7 +86,7 @@ asList (Symbol _ trs _) = trs
asList (Var _ _ trs _) = trs
asList (Constan _) = []
data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord)
data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord, Show)
toLambdaExpressionS :: TypeRequester -> Text
toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
@ -163,7 +164,7 @@ doTypesMatch toGen available = elem toGen (available : (repeatedly (lastMay . ty
genLambdaSpucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
genLambdaSpucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
lamdaTypeLength <- uniform 1 3
lamdaTypeLength <- uniform 1 4
lambaTypes <- replicateM lamdaTypeLength (randomElement (Map.keys constants))
let lambaType = foldr1 mkFunTy lambaTypes
lamdaVarTypeRequester <- genTypeRequester env depthLeft lambaType boundVar
@ -260,7 +261,7 @@ instance Environment TypeRequester LambdaEnviroment where
-- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
replaceAtR 0 _ with = with
replaceAtR 1 _ with = with
replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
replaceAtR _ (TR _ Nothing _) _ = undefined
@ -276,7 +277,7 @@ replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLe
replaceInSubtreeWithIndex _ [] _ = undefined
depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
depthLeftAndTypeAtR t 0 depthLeft = ((depthLeft - 1), t)
depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t)
depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined
@ -458,7 +459,7 @@ toLambdaExpressionShort (TR _ (Nothing) _) = "Invalid Lambda Epr"
eToLambdaExpressionShort :: LambdaExpression -> Text
eToLambdaExpressionShort (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester2 <> ") " <> toLambdaExpressionShort typeRequester1
eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "()\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")"
eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")"
eToLambdaExpressionShort (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
eToLambdaExpressionShort (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
eToLambdaExpressionShort (Constan (valS)) = valS

View File

@ -8,7 +8,8 @@ import Pretty
import Protolude hiding (for)
import System.IO
-- import Szenario212Pun
import Szenario191
-- import Szenario191
import IrisDataset
data Options = Options
{ iterations :: !N,
@ -48,16 +49,18 @@ main :: IO ()
main =
execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering
let env = AssignmentEnviroment (students prios, topics prios)
let selType = Tournament 20
let run' = run prios env selType 20 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
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)
pop' <-
runEffect (for run' logCsv)
let (res, _) = bests prios 5 pop'
mapM_ format res
irisLE <- calc irisLEE pop'
let (res, _) = bests irisLE 5 pop'
mapM_ (format irisLE) res
where
format s = do
let f = fitness prios s
format irisL s = do
let f = fitness irisL s
putErrText $ show f <> "\n" <> pretty s
logCsv = putText . csv
csv (t, f) = show t <> " " <> show f