module RunCrossVal where
import qualified Numeric.LinearAlgebra as LA
import qualified Data.Vector as V
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.Ord
import Data.Maybe
import Control.Monad
import Control.Monad.State
import Data.Bifunctor
import System.Random
import System.Random.Shuffle
import Data.ConfigFile
import Data.Either.Utils
import IT
import IT.Shape
import ITEA.Config
import ITEA.Report
import IT.ITEA
import IT.FI2POP
import IT.Regression
import IT.Algorithms
import IT.Metrics
import RunConfig (Alg(..),getSetting,getWithDefault)
createMutCfg :: (Int, Int) -> Int -> [Transformation] -> MutationCfg
createMutCfg :: (Int, Int) -> Int -> [Transformation] -> MutationCfg
createMutCfg (Int
e1,Int
e2) Int
tmax [Transformation]
tfuncs = MutationCfg
cfg
where cfg :: MutationCfg
cfg = UncheckedMutationCfg -> MutationCfg
forall a b. Valid a b => a -> b
validateConfig
(UncheckedMutationCfg -> MutationCfg)
-> UncheckedMutationCfg -> MutationCfg
forall a b. (a -> b) -> a -> b
$ Int -> Int -> UncheckedMutationCfg
exponents Int
e1 Int
e2
UncheckedMutationCfg
-> UncheckedMutationCfg -> UncheckedMutationCfg
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> UncheckedMutationCfg
termLimit Int
2 Int
tmax
UncheckedMutationCfg
-> UncheckedMutationCfg -> UncheckedMutationCfg
forall a. Semigroup a => a -> a -> a
<> Int -> UncheckedMutationCfg
nonzeroExps Int
1
UncheckedMutationCfg
-> UncheckedMutationCfg -> UncheckedMutationCfg
forall a. Semigroup a => a -> a -> a
<> [Transformation] -> UncheckedMutationCfg
transFunctions [Transformation]
tfuncs
UncheckedMutationCfg
-> UncheckedMutationCfg -> UncheckedMutationCfg
forall a. Semigroup a => a -> a -> a
<> [String] -> UncheckedMutationCfg
measures [String
"NMSE"]
validateArgs :: [String] -> (String, Int)
validateArgs :: [String] -> (String, Int)
validateArgs (String
x:String
y:[String]
_) = (String
x, String -> Int
forall a. Read a => String -> a
read String
y)
validateArgs [String]
_ = String -> (String, Int)
forall a. HasCallStack => String -> a
error String
"Usage: crossval dataname fold"
runITEARegCV :: Fitness
-> (Solution -> Maybe [Double])
-> Int
-> MutationCfg
-> Int
-> Int
-> IO Double
runITEARegCV :: Fitness
-> (Solution -> Maybe [Double])
-> Int
-> MutationCfg
-> Int
-> Int
-> IO Double
runITEARegCV Fitness
fitTrain Solution -> Maybe [Double]
fitTest Int
dim MutationCfg
mcfg Int
nPop Int
nGens = do
StdGen
g <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
let (Mutation
mutFun, Rnd Term
rndTerm) = MutationCfg -> Int -> (Mutation, Rnd Term)
withMutation MutationCfg
mcfg Int
dim
p0 :: Rnd Population
p0 = Int -> Int -> Rnd Term -> Fitness -> Rnd Population
initialPop Int
4 Int
nPop Rnd Term
rndTerm Fitness
fitTrain
gens :: [Population]
gens = (Rnd Population
p0 Rnd Population
-> (Population -> StateT StdGen Identity [Population])
-> StateT StdGen Identity [Population]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Mutation
-> Fitness -> Population -> StateT StdGen Identity [Population]
itea Mutation
mutFun Fitness
fitTrain) StateT StdGen Identity [Population] -> StdGen -> [Population]
forall s a. State s a -> s -> a
`evalState` StdGen
g
best :: Solution
best = Int -> [Population] -> Solution
getBest Int
nGens [Population]
gens
result :: [Double]
result = [Double] -> Maybe [Double] -> [Double]
forall a. a -> Maybe a -> a
fromMaybe [Double
1e+10] (Maybe [Double] -> [Double]) -> Maybe [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ Solution -> Maybe [Double]
fitTest Solution
best
(Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return(Double -> IO Double)
-> ([Double] -> Double) -> [Double] -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Double] -> Double
forall a. [a] -> a
head) [Double]
result
runFI2POPRegCV :: Fitness
-> (Solution -> Maybe [Double])
-> Int
-> MutationCfg
-> Int
-> Int
-> IO Double
runFI2POPRegCV :: Fitness
-> (Solution -> Maybe [Double])
-> Int
-> MutationCfg
-> Int
-> Int
-> IO Double
runFI2POPRegCV Fitness
fitTrain Solution -> Maybe [Double]
fitTest Int
dim MutationCfg
mcfg Int
nPop Int
nGens = do
StdGen
g <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
let (Mutation
mutFun, Rnd Term
rndTerm) = MutationCfg -> Int -> (Mutation, Rnd Term)
withMutation MutationCfg
mcfg Int
dim
p0 :: StateT StdGen Identity (Population, Population)
p0 = Population -> (Population, Population)
splitPop (Population -> (Population, Population))
-> Rnd Population
-> StateT StdGen Identity (Population, Population)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Rnd Term -> Fitness -> Rnd Population
initialPop Int
4 Int
nPop Rnd Term
rndTerm Fitness
fitTrain
gens :: [Population]
gens = ((Population, Population) -> Population)
-> [(Population, Population)] -> [Population]
forall a b. (a -> b) -> [a] -> [b]
map (Population, Population) -> Population
forall a b. (a, b) -> a
fst ([(Population, Population)] -> [Population])
-> [(Population, Population)] -> [Population]
forall a b. (a -> b) -> a -> b
$ (StateT StdGen Identity (Population, Population)
p0 StateT StdGen Identity (Population, Population)
-> ((Population, Population)
-> StateT StdGen Identity [(Population, Population)])
-> StateT StdGen Identity [(Population, Population)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Mutation
-> Fitness
-> (Population, Population)
-> StateT StdGen Identity [(Population, Population)]
fi2pop Mutation
mutFun Fitness
fitTrain) StateT StdGen Identity [(Population, Population)]
-> StdGen -> [(Population, Population)]
forall s a. State s a -> s -> a
`evalState` StdGen
g
mBest :: Maybe Solution
mBest = Int -> [Population] -> Maybe Solution
getBestMaybe Int
nGens [Population]
gens
result :: [Double]
result = case Maybe Solution
mBest of
Maybe Solution
Nothing -> [Double
1e+10]
Just Solution
best -> [Double] -> Maybe [Double] -> [Double]
forall a. a -> Maybe a -> a
fromMaybe [Double
1e+10] (Maybe [Double] -> [Double]) -> Maybe [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ Solution -> Maybe [Double]
fitTest Solution
best
(Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return(Double -> IO Double)
-> ([Double] -> Double) -> [Double] -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Double] -> Double
forall a. [a] -> a
head) [Double]
result
runCfg :: FilePath -> Int -> MutationCfg -> IO Double
runCfg :: String -> Int -> MutationCfg -> IO Double
runCfg String
fname Int
fold MutationCfg
mutCfg = do
ConfigParser
cp <- Either CPError ConfigParser -> ConfigParser
forall e a. Show e => Either e a -> a
forceEither (Either CPError ConfigParser -> ConfigParser)
-> IO (Either CPError ConfigParser) -> IO ConfigParser
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigParser -> String -> IO (Either CPError ConfigParser)
forall (m :: * -> *).
MonadError CPError m =>
ConfigParser -> String -> IO (m ConfigParser)
readfile ConfigParser
emptyCP String
fname
let
trainname :: String
trainname = ConfigParser -> String -> String -> String
forall a. Get_C a => ConfigParser -> String -> String -> a
getSetting ConfigParser
cp String
"IO" String
"train"
alg :: Alg
alg = ConfigParser -> String -> String -> Alg
forall a. Get_C a => ConfigParser -> String -> String -> a
getSetting ConfigParser
cp String
"Algorithm" String
"algorithm"
shapes :: [Shape]
shapes = [Shape] -> ConfigParser -> String -> String -> [Shape]
forall a. Get_C a => a -> ConfigParser -> String -> String -> a
getWithDefault [] ConfigParser
cp String
"Constraints" String
"shapes"
domains :: Maybe [(Double, Double)]
domains = Maybe [(Double, Double)]
-> ConfigParser -> String -> String -> Maybe [(Double, Double)]
forall a. Get_C a => a -> ConfigParser -> String -> String -> a
getWithDefault Maybe [(Double, Double)]
forall a. Maybe a
Nothing ConfigParser
cp String
"Constraints" String
"domains"
(Matrix Double
trainX, Vector
trainY) <- (Matrix Double -> Matrix Double)
-> (Matrix Double, Vector) -> (Matrix Double, Vector)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Matrix Double
1.0 Matrix Double -> Matrix Double -> Matrix Double
forall t. Element t => Matrix t -> Matrix t -> Matrix t
LA.|||) ((Matrix Double, Vector) -> (Matrix Double, Vector))
-> (String -> (Matrix Double, Vector))
-> String
-> (Matrix Double, Vector)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Matrix Double, Vector)
parseFile (String -> (Matrix Double, Vector))
-> IO String -> IO (Matrix Double, Vector)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
trainname
StdGen
g <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
let nRows :: Int
nRows = Matrix Double -> Int
forall t. Matrix t -> Int
LA.rows Matrix Double
trainX
dim :: Int
dim = Matrix Double -> Int
forall t. Matrix t -> Int
LA.cols Matrix Double
trainX Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
cycle' :: [a] -> [a]
cycle' [] = []
cycle' (a
x:[a]
xs) = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]
rndix :: [Int]
rndix = [Int] -> Int -> StdGen -> [Int]
forall gen a. RandomGen gen => [a] -> Int -> gen -> [a]
shuffle' [Int
0 .. (Int
nRowsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] Int
nRows StdGen
g
nRows' :: Int
nRows' = Int
nRows Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
fold
idxs :: [[Int]]
idxs = [Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
nRows' ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nRows') [Int]
rndix | Int
i <- [Int
0 .. Int
foldInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
folds :: [([Int], [Int])]
folds = Int -> [([Int], [Int])] -> [([Int], [Int])]
forall a. Int -> [a] -> [a]
take Int
fold ([([Int], [Int])] -> [([Int], [Int])])
-> [([Int], [Int])] -> [([Int], [Int])]
forall a b. (a -> b) -> a -> b
$ ([[Int]] -> ([Int], [Int])) -> [[[Int]]] -> [([Int], [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (\([Int]
x:[[Int]]
xs) -> ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
xs,[Int]
x)) ([[[Int]]] -> [([Int], [Int])]) -> [[[Int]]] -> [([Int], [Int])]
forall a b. (a -> b) -> a -> b
$ ([[Int]] -> [[Int]]) -> [[Int]] -> [[[Int]]]
forall a. (a -> a) -> a -> [a]
iterate [[Int]] -> [[Int]]
forall a. [a] -> [a]
cycle' [[Int]]
idxs
getY :: [Int] -> Vector
getY [Int]
is = Matrix Double -> Vector
forall t. Element t => Matrix t -> Vector t
LA.flatten (Matrix Double -> Vector) -> Matrix Double -> Vector
forall a b. (a -> b) -> a -> b
$ Vector -> Matrix Double
forall a. Storable a => Vector a -> Matrix a
LA.asColumn Vector
trainY Matrix Double -> (Extractor, Extractor) -> Matrix Double
forall t.
Element t =>
Matrix t -> (Extractor, Extractor) -> Matrix t
LA.?? (Vector I -> Extractor
LA.Pos ([Int] -> Vector I
LA.idxs [Int]
is), Extractor
LA.All)
getX :: [Int] -> Matrix Double
getX [Int]
is = Matrix Double
trainX Matrix Double -> (Extractor, Extractor) -> Matrix Double
forall t.
Element t =>
Matrix t -> (Extractor, Extractor) -> Matrix t
LA.?? (Vector I -> Extractor
LA.Pos ([Int] -> Vector I
LA.idxs [Int]
is), Extractor
LA.All)
trYs :: [Vector]
trYs = (([Int], [Int]) -> Vector) -> [([Int], [Int])] -> [Vector]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Vector
getY([Int] -> Vector)
-> (([Int], [Int]) -> [Int]) -> ([Int], [Int]) -> Vector
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst) [([Int], [Int])]
folds
tvYs :: [Vector]
tvYs = (([Int], [Int]) -> Vector) -> [([Int], [Int])] -> [Vector]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Vector
getY([Int] -> Vector)
-> (([Int], [Int]) -> [Int]) -> ([Int], [Int]) -> Vector
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd) [([Int], [Int])]
folds
trXs :: [Matrix Double]
trXs = (([Int], [Int]) -> Matrix Double)
-> [([Int], [Int])] -> [Matrix Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Matrix Double
getX([Int] -> Matrix Double)
-> (([Int], [Int]) -> [Int]) -> ([Int], [Int]) -> Matrix Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst) [([Int], [Int])]
folds
tvXs :: [Matrix Double]
tvXs = (([Int], [Int]) -> Matrix Double)
-> [([Int], [Int])] -> [Matrix Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Matrix Double
getX([Int] -> Matrix Double)
-> (([Int], [Int]) -> [Int]) -> ([Int], [Int]) -> Matrix Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd) [([Int], [Int])]
folds
toRegMtx :: Matrix Double -> Vector Vector
toRegMtx = [Vector] -> Vector Vector
forall a. [a] -> Vector a
V.fromList ([Vector] -> Vector Vector)
-> (Matrix Double -> [Vector]) -> Matrix Double -> Vector Vector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix Double -> [Vector]
forall t. Element t => Matrix t -> [Vector t]
LA.toColumns
criteria :: NonEmpty Measure
criteria = [Measure] -> NonEmpty Measure
forall a. [a] -> NonEmpty a
NE.fromList [Measure
_nmse]
fitTrains :: [Fitness]
fitTrains = (Matrix Double -> Vector -> Fitness)
-> [Matrix Double] -> [Vector] -> [Fitness]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Matrix Double
x Vector
y -> Task
-> NonEmpty Measure
-> Constraint
-> Penalty
-> Vector Vector
-> Vector
-> Vector Vector
-> Vector
-> Fitness
evalTrain Task
Regression NonEmpty Measure
criteria ([Shape] -> Maybe [(Double, Double)] -> Constraint
fromShapes [Shape]
shapes Maybe [(Double, Double)]
domains) Penalty
NoPenalty (Matrix Double -> Vector Vector
toRegMtx Matrix Double
x) Vector
y (Matrix Double -> Vector Vector
toRegMtx Matrix Double
x) Vector
y) [Matrix Double]
trXs [Vector]
trYs
fitTests :: [Solution -> Maybe [Double]]
fitTests = (Matrix Double -> Vector -> Solution -> Maybe [Double])
-> [Matrix Double] -> [Vector] -> [Solution -> Maybe [Double]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Matrix Double
x Vector
y -> Task
-> NonEmpty Measure
-> Vector Vector
-> Vector
-> Solution
-> Maybe [Double]
evalTest Task
Regression NonEmpty Measure
criteria (Matrix Double -> Vector Vector
toRegMtx Matrix Double
x) Vector
y) [Matrix Double]
tvXs [Vector]
tvYs
average :: t a -> a
average t a
xs = t a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum t a
xs a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs)
run :: Fitness -> (Solution -> Maybe [Double]) -> IO Double
run Fitness
fitTr Solution -> Maybe [Double]
fitTe =
case Alg
alg of
Alg
ITEA -> Fitness
-> (Solution -> Maybe [Double])
-> Int
-> MutationCfg
-> Int
-> Int
-> IO Double
runITEARegCV Fitness
fitTr Solution -> Maybe [Double]
fitTe Int
dim MutationCfg
mutCfg Int
100 Int
100
Alg
FI2POP -> Fitness
-> (Solution -> Maybe [Double])
-> Int
-> MutationCfg
-> Int
-> Int
-> IO Double
runFI2POPRegCV Fitness
fitTr Solution -> Maybe [Double]
fitTe Int
dim MutationCfg
mutCfg Int
100 Int
100
[Double]
rmses <- (Fitness -> (Solution -> Maybe [Double]) -> IO Double)
-> [Fitness] -> [Solution -> Maybe [Double]] -> IO [Double]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Fitness -> (Solution -> Maybe [Double]) -> IO Double
run [Fitness]
fitTrains [Solution -> Maybe [Double]]
fitTests
Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ [Double] -> Double
forall a (t :: * -> *). (Fractional a, Foldable t) => t a -> a
average [Double]
rmses
runCrossVal :: [String] -> IO ()
runCrossVal :: [String] -> IO ()
runCrossVal [String]
args = do
let
allCfgs :: [MutationCfg]
allCfgs = [(Int, Int) -> Int -> [Transformation] -> MutationCfg
createMutCfg]
[(Int, Int) -> Int -> [Transformation] -> MutationCfg]
-> [(Int, Int)] -> [Int -> [Transformation] -> MutationCfg]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(-Int
1,Int
1),(-Int
3,Int
3),(-Int
5,Int
5),(Int
0,Int
1),(Int
0,Int
3),(Int
0,Int
5)]
[Int -> [Transformation] -> MutationCfg]
-> [Int] -> [[Transformation] -> MutationCfg]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Int
2,Int
5,Int
10]
[[Transformation] -> MutationCfg]
-> [[Transformation]] -> [MutationCfg]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Transformation
Id],[Transformation
Id, Transformation
SqrtAbs, Transformation
Log, Transformation
Exp], [Transformation
Id, Transformation
SqrtAbs, Transformation
Log, Transformation
Exp, Transformation
Sin, Transformation
Tanh]]
(String
dname, Int
nfold) = [String] -> (String, Int)
validateArgs [String]
args
[Double]
tests <- (MutationCfg -> IO Double) -> [MutationCfg] -> IO [Double]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Int -> MutationCfg -> IO Double
runCfg String
dname Int
nfold) [MutationCfg]
allCfgs
let (MutationCfg
bestCfg, Double
bestRMSE) = ((MutationCfg, Double) -> (MutationCfg, Double) -> Ordering)
-> [(MutationCfg, Double)] -> (MutationCfg, Double)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((MutationCfg, Double) -> Double)
-> (MutationCfg, Double) -> (MutationCfg, Double) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (MutationCfg, Double) -> Double
forall a b. (a, b) -> b
snd) ([MutationCfg] -> [Double] -> [(MutationCfg, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MutationCfg]
allCfgs [Double]
tests)
String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nfold String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ MutationCfg -> String
forall a. Show a => a -> String
show MutationCfg
bestCfg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
bestRMSE