haskell-ml (empty) → 0.4.0
raw patch · 10 files changed
+903/−0 lines, 10 filesdep +MonadRandomdep +attoparsecdep +basesetup-changed
Dependencies added: MonadRandom, attoparsec, base, binary, haskell-ml, hmatrix, random-shuffle, singletons, text, vector
Files
- .gitignore +20/−0
- LICENSE +29/−0
- README.md +6/−0
- Setup.hs +3/−0
- example/iris/iris.hs +120/−0
- haskell-ml.cabal +65/−0
- src/Haskell_ML/FCN.hs +403/−0
- src/Haskell_ML/Util.hs +222/−0
- stack.yaml +7/−0
- test/fcnTest1.hs +28/−0
+ .gitignore view
@@ -0,0 +1,20 @@+dist+dist-*+cabal-dev+*.o+*.hi+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+.stack-work/+cabal.project.local+.HTF/
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, David Banas+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,6 @@+# Haskell_ML++Various examples of machine learning, in Haskell.++To get started, or learn more, visit the [wiki page]( https://github.com/capn-freako/Haskell_ML/wiki).+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ example/iris/iris.hs view
@@ -0,0 +1,120 @@+-- Example use of `Haskell_ML.FCN` to categorize the Iris dataset.+--+-- Original author: David Banas <capn.freako@gmail.com>+-- Original date: January 22, 2018+--+-- Copyright (c) 2018 David Banas; all rights reserved World wide.++{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Arrow+import Control.Monad+import Data.List+import System.Random.Shuffle++import Haskell_ML.FCN+import Haskell_ML.Util++dataFileName :: String+dataFileName = "data/iris.csv"++main :: IO ()+main = do+ -- Read in the Iris data set. It contains an equal number of samples+ -- for all 3 classes of iris.+ putStrLn "Reading in data..."+ samps <- readIrisData dataFileName++ -- Make field values uniform over [0,1].+ let samps' = mkSmplsUniform samps++ -- Split according to class, so we can keep equal representation+ -- throughout.+ let samps1 = filter ((== Setosa) . snd) samps'+ samps2 = filter ((== Versicolor) . snd) samps'+ samps3 = filter ((== Virginica) . snd) samps'++ -- Replace attributes record w/ feature vector.+ samps1' = map (first attributeToVector) samps1+ samps2' = map (first attributeToVector) samps2+ samps3' = map (first attributeToVector) samps3++ -- Replace iris type w/ one-hot vector.+ samps1'' = map (second irisTypeToVector) samps1'+ samps2'' = map (second irisTypeToVector) samps2'+ samps3'' = map (second irisTypeToVector) samps3'++ -- Shuffle samples.+ shuffled1 <- shuffleM samps1''+ shuffled2 <- shuffleM samps2''+ shuffled3 <- shuffleM samps3''++ -- Split into training/testing groups.+ -- We calculate separate lengths, even though we expect all 3 to be+ -- the same, just for safety's sake.+ let len1 = length shuffled1+ len2 = length shuffled2+ len3 = length shuffled3++ numTrn1 = len1 * 80 `div` 100+ numTrn2 = len2 * 80 `div` 100+ numTrn3 = len3 * 80 `div` 100++ -- training data+ trn1 = take numTrn1 shuffled1+ trn2 = take numTrn2 shuffled2+ trn3 = take numTrn3 shuffled3++ -- test data+ tst1 = drop numTrn1 shuffled1+ tst2 = drop numTrn2 shuffled2+ tst3 = drop numTrn3 shuffled3++ -- Reassemble into single training/testing sets.+ trn = trn1 ++ trn2 ++ trn3+ tst = tst1 ++ tst2 ++ tst3++ -- Reshuffle.+ trnShuffled <- shuffleM trn+ tstShuffled <- shuffleM tst++ putStrLn "Done."++ -- Ask user for internal network structure.+ putStrLn "Please, enter a list of integers specifying the width"+ putStrLn "of each hidden layer you want in your network."+ putStrLn "For instance, entering '[2, 4]' will give you a network"+ putStrLn "with 2 hidden layers:"+ putStrLn " - one (closest to the input layer) with 2 output nodes, and"+ putStrLn " - one with 4 output nodes."+ hs <- readLn+ n <- randNet hs+ putStrLn "Great! Now, enter your desired learning rate."+ putStrLn "(Should be a decimal floating point value in (0,1)."+ rate <- readLn+ let (n', TrainEvo{..}) = trainNTimes 60 rate n trnShuffled+ res = runNet n' $ map fst tstShuffled+ ref = map snd tstShuffled+ putStrLn $ "Test accuracy: " ++ show (classificationAccuracy res ref)++ -- Plot the evolution of the training accuracy.+ putStrLn "Training accuracy:"+ putStrLn $ asciiPlot accs++ -- Plot the evolution of the weights and biases.+ let weights = zip [1::Int,2..] $ (transpose . map fst) diffs+ biases = zip [1::Int,2..] $ (transpose . map snd) diffs+ forM_ weights $ \ (i, ws) -> do+ putStrLn $ "Average variance in layer " ++ show i ++ " weights:"+ putStrLn $ asciiPlot $ map (calcMeanList . map (\x -> x*x)) ws+ forM_ biases $ \ (i, bs) -> do+ putStrLn $ "Average variance in layer " ++ show i ++ " biases:"+ putStrLn $ asciiPlot $ map (calcMeanList . map (\x -> x*x)) bs+
+ haskell-ml.cabal view
@@ -0,0 +1,65 @@+name: haskell-ml+version: 0.4.0+synopsis: Machine learning in Haskell+description: Machine learning in Haskell+license: BSD3+license-file: LICENSE+author: David Banas+maintainer: capn.freako@gmail.com+copyright: 2018 David Banas+category: Machine Learning+build-type: Simple+extra-source-files: README.md+ stack.yaml+ .gitignore+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/capn-freako/Haskell_ML.git++library+ hs-source-dirs: src+ exposed-modules: Haskell_ML.FCN+ , Haskell_ML.Util+ build-depends: base >= 4.7 && < 5+ , attoparsec+ , binary+ , hmatrix+ , MonadRandom+ , singletons+ , text+ , vector+ default-language: Haskell2010+ ghc-options: -O2+ -fexcess-precision+ -optc-ffast-math+ -optc-O3++executable iris+ hs-source-dirs: example/iris+ main-is: iris.hs+ build-depends: base >= 4.7 && < 5+ , haskell-ml+ , hmatrix+ , random-shuffle+ default-language: Haskell2010+ ghc-options: -O2+ -fexcess-precision+ -optc-ffast-math+ -optc-O3+ -- -rtsopts++test-suite fcnTest1+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: fcnTest1.hs+ build-depends: base >= 4.7 && < 5+ , haskell-ml+ , MonadRandom+ default-language: Haskell2010+ ghc-options: -O2+ -fexcess-precision+ -optc-ffast-math+ -optc-O3+
+ src/Haskell_ML/FCN.hs view
@@ -0,0 +1,403 @@+-- Building blocks for making fully connected neural networks (FCNs).+--+-- Original author: David Banas <capn.freako@gmail.com>+-- Original date: January 18, 2018+--+-- Copyright (c) 2018 David Banas; all rights reserved World wide.++{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+++{-|+Module : Haskell_ML.FCN+Description : Allows: creation, training, running, saving, and loading,+ of multi-layer, fully connected neural networks.+Copyright : (c) David Banas, 2018+License : BSD-3+Maintainer : capn.freako@gmail.com+Stability : experimental+Portability : ?+-}+module Haskell_ML.FCN+ ( FCNet(), TrainEvo(..)+ , randNet, runNet, netTest, hiddenStruct+ , getWeights, getBiases+ , trainNTimes+ ) where++import Control.Monad.Random+import Data.Binary+import Data.List+import Data.Singletons.Prelude+import Data.Singletons.TypeLits+import Data.Vector.Storable (toList)+import GHC.Generics (Generic)+import Numeric.LinearAlgebra.Static++import Haskell_ML.Util+++-- | A fully connected, multi-layer network with fixed input/output+-- widths, but variable (and existentially hidden!) internal structure.+data FCNet :: Nat -> Nat -> * where+ FCNet :: Network i hs o -> FCNet i o++-- | Returns a value of type `FCNet`, filled with random weights+-- ready for training, tucked inside the appropriate Monad, which must+-- be an instance of `MonadRandom` . (IO is such an instance.)+--+-- The input/output widths are determined by the compiler automatically,+-- via type inferencing.+--+-- The internal structure of the network is determined by the list of+-- integers passed in. Each integer in the list indicates the output+-- width of one hidden layer, with the first entry in the list+-- corresponding to the hidden layer nearest to the input layer.+randNet :: (KnownNat i, KnownNat o, MonadRandom m)+ => [Integer]+ -> m (FCNet i o)+randNet hs = withSomeSing hs (fmap FCNet . randNetwork')+++-- | Data type for holding training evolution data.+data TrainEvo = TrainEvo+ { accs :: [Double] -- ^ training accuracies+ , diffs :: [([[Double]],[[Double]])] -- ^ differences of weights/biases, by layer+ }+++-- | Train a network on several epochs of the training data, keeping+-- track of accuracy and weight/bias changes per layer, after each.+trainNTimes :: (KnownNat i, KnownNat o)+ => Int -- ^ Number of epochs+ -> Double -- ^ learning rate+ -> FCNet i o -- ^ the network to be trained+ -> [(R i, R o)] -- ^ the training pairs+ -> (FCNet i o, TrainEvo)+trainNTimes = trainNTimes' [] []++trainNTimes' :: (KnownNat i, KnownNat o)+ => [Double] -- accuracies+ -> [([[Double]], [[Double]])] -- weight/bias differences+ -> Int -> Double -> FCNet i o -> [(R i, R o)] -> (FCNet i o, TrainEvo)+trainNTimes' accs diffs 0 _ net _ = (net, TrainEvo accs diffs)+trainNTimes' accs diffs n rate net prs = trainNTimes' (accs ++ [acc]) (diffs ++ [diff]) (n-1) rate net' prs+ where net' = trainNet rate net prs+ acc = classificationAccuracy res ref+ res = runNet net' $ map fst prs+ ref = map snd prs+ diff = ( zipWith (zipWith (-)) (getWeights net') (getWeights net)+ , zipWith (zipWith (-)) (getBiases net') (getBiases net) )+++-- | Run a network on a list of inputs.+runNet :: (KnownNat i, KnownNat o)+ => FCNet i o -- ^ the network to run+ -> [R i] -- ^ the list of inputs+ -> [R o] -- ^ the list of outputs+runNet (FCNet n) = map (runNetwork n)+++-- | `Binary` instance definition for `FCNet`.+--+-- With this definition, the user of our library is able to use standard+-- `put` and `get` calls, to serialize his created/trained network for+-- future use. And we don't need to provide auxilliary `saveNet` and+-- `loadNet` functions in the API.+instance (KnownNat i, KnownNat o) => Binary (FCNet i o) where+ put = putFCNet+ get = getFCNet+++-- | Basic sanity test of our code, taken from Justin's repository.+--+-- Printed output should contain two offset solid circles.+netTest :: MonadRandom m => Double -> Int -> m String+netTest rate n = do+ inps <- replicateM n $ do+ s <- getRandom+ return $ randomVector s Uniform * 2 - 1+ let outs = flip map inps $ \v ->+ if v `inCircle` (fromRational 0.33, 0.33)+ || v `inCircle` (fromRational (-0.33), 0.33)+ then fromRational 1+ else fromRational 0+ net0 :: Network 2 '[16, 8] 1 <- randNetwork+ let trained = sgd rate (zip inps outs) net0++ outMat = [ [ render (norm_2 (runNetwork trained (vector [x / 25 - 1,y / 10 - 1])))+ | x <- [0..50] ]+ | y <- [0..20] ]++ render r | r <= 0.2 = ' '+ | r <= 0.4 = '.'+ | r <= 0.6 = '-'+ | r <= 0.8 = '='+ | otherwise = '#'++ return $ unlines outMat+ where+ inCircle :: KnownNat n => R n -> (R n, Double) -> Bool+ v `inCircle` (o, r) = norm_2 (v - o) <= r+++-- | Returns a list of integers corresponding to the widths of the hidden+-- layers of a `FCNet`.+hiddenStruct :: FCNet i o -> [Integer]+hiddenStruct (FCNet net) = hiddenStruct' net++hiddenStruct' :: Network i hs o -> [Integer]+hiddenStruct' = \case+ W _ -> []+ _ :&~ (n' :: Network h hs' o)+ -> natVal (Proxy @h)+ : hiddenStruct' n'+++-- | Returns a list of lists of Doubles, each containing the weights of+-- one layer of the network.+getWeights :: (KnownNat i, KnownNat o) => FCNet i o -> [[Double]]+getWeights (FCNet net) = getWeights' net++getWeights' :: (KnownNat i, KnownNat o) => Network i hs o -> [[Double]]+getWeights' (W Layer{..}) = [concatMap (toList . extract) (toRows nodes)]+getWeights' (Layer{..} :&~ net) = concatMap (toList . extract) (toRows nodes) : getWeights' net+++-- | Returns a list of lists of Doubles, each containing the biases of+-- one layer of the network.+getBiases :: (KnownNat i, KnownNat o) => FCNet i o -> [[Double]]+getBiases (FCNet net) = getBiases' net++getBiases' :: (KnownNat i, KnownNat o) => Network i hs o -> [[Double]]+getBiases' (W Layer{..}) = [toList $ extract biases]+getBiases' (Layer{..} :&~ net) = toList (extract biases) : getBiases' net+++-----------------------------------------------------------------------+-- All following functions are for internal library use only!+-- They are not exported through the API.+-----------------------------------------------------------------------+++-- A single network layer mapping an input of width `i` to an output of+-- width `o`, via simple matrix/vector mult.+data Layer i o = Layer { biases :: !(R o)+ , nodes :: !(L o i)+ }+ deriving (Show, Generic)++instance (KnownNat i, KnownNat o) => Binary (Layer i o)+++-- Generates a value of type `Layer i o`, filled with normally+-- distributed random values, tucked inside the appropriate Monad, which+-- must be an instance of `MonadRandom`.+randLayer :: forall m i o. (MonadRandom m, KnownNat i, KnownNat o)+ => m (Layer i o)+randLayer = do+ s1 :: Int <- getRandom+ s2 :: Int <- getRandom+ let m = eye+ b = randomVector s2 Gaussian+ n = gaussianSample s1 (takeDiag m) (sym m)+ return $ Layer b n+++-- This is the network structure that `FCNet i o` wraps, hiding its+-- internal structure existentially, outside of the library.+data Network :: Nat -> [Nat] -> Nat -> * where+ W :: !(Layer i o)+ -> Network i '[] o++ (:&~) :: KnownNat h+ => !(Layer i h)+ -> !(Network h hs o)+ -> Network i (h ': hs) o++infixr 5 :&~+++-- Generates a value of type `Network i hs o`+-- filled with random weights, ready to begin training.+--+-- Note: `hs` is determined explicitly, via the first argument, while+-- `i` and `o` are determined implicitly, via type inference.+randNetwork :: forall m i hs o. (MonadRandom m, KnownNat i, SingI hs, KnownNat o)+ => m (Network i hs o)+randNetwork = randNetwork' sing++randNetwork' :: forall m i hs o. (MonadRandom m, KnownNat i, KnownNat o)+ => Sing hs -> m (Network i hs o)+randNetwork' = \case+ SNil -> W <$> randLayer+ SNat `SCons` ss -> (:&~) <$> randLayer <*> randNetwork' ss+++-- Binary instance definition for `Network i hs o`.+putNet :: (KnownNat i, KnownNat o)+ => Network i hs o+ -> Put+putNet = \case+ W w -> put w+ w :&~ n -> put w *> putNet n++getNet :: forall i hs o. (KnownNat i, KnownNat o)+ => Sing hs+ -> Get (Network i hs o)+getNet = \case+ SNil -> W <$> get+ SNat `SCons` ss -> (:&~) <$> get <*> getNet ss++instance (KnownNat i, SingI hs, KnownNat o) => Binary (Network i hs o) where+ put = putNet+ get = getNet sing+++putFCNet :: (KnownNat i, KnownNat o)+ => FCNet i o+ -> Put+putFCNet (FCNet net) = do+ put (hiddenStruct' net)+ putNet net++getFCNet :: (KnownNat i, KnownNat o)+ => Get (FCNet i o)+getFCNet = do+ hs <- get+ withSomeSing hs (fmap FCNet . getNet)++runLayer :: (KnownNat i, KnownNat o)+ => Layer i o+ -> R i+ -> R o+runLayer (Layer b n) v = b + n #> v++runNetwork :: (KnownNat i, KnownNat o)+ => Network i hs o+ -> R i+ -> R o+runNetwork = \case+ W w -> \(!v) -> logistic (runLayer w v)+ (w :&~ n') -> \(!v) -> let v' = logistic (runLayer w v)+ in runNetwork n' v'++-- Trains a value of type `FCNet i o`, using the supplied list of+-- training pairs (i.e. - matched input/output vectors).+trainNet :: (KnownNat i, KnownNat o)+ => Double -- learning rate+ -> FCNet i o -- the network to be trained+ -> [(R i, R o)] -- the training pairs+ -> FCNet i o -- the trained network+trainNet rate (FCNet net) trn_prs = FCNet $ sgd rate trn_prs net+++-- Train a network of type `Network i hs o` using a list of training+-- pairs and the Stochastic Gradient Descent (SGD) approach.+sgd :: forall i hs o. (KnownNat i, KnownNat o)+ => Double -- learning rate+ -> [(R i, R o)] -- training pairs+ -> Network i hs o -- network to train+ -> Network i hs o -- trained network+sgd rate trn_prs net = foldl' (sgdStep rate) net trn_prs+++-- Train a network of type `Network i hs o` using a single training pair.+--+-- This code was taken directly from Justin Le's public GitHub archive:+-- https://github.com/mstksg/inCode/blob/43adae31b5689a95be83a72866600033fcf52b50/code-samples/dependent-haskell/NetworkTyped.hs#L77+-- and modified only slightly.+sgdStep :: forall i hs o. (KnownNat i, KnownNat o)+ => Double -- learning rate+ -> Network i hs o -- network to train+ -> (R i, R o) -- training pair+ -> Network i hs o -- trained network+sgdStep rate net trn_pr = fst $ go x0 net+ where+ x0 = fst trn_pr+ target = snd trn_pr+ go :: forall j js. KnownNat j+ => R j -- input vector+ -> Network j js o -- network to train+ -> (Network j js o, R j)+ go !x (W w@(Layer wB wN))+ = let y = runLayer w x+ o = logistic y+ -- the gradient (how much y affects the error)+ -- (logistic' is the derivative of logistic)+ dEdy = logistic' y * (o - target)+ -- new bias weights and node weights+ wB' = wB - konst rate * dEdy+ wN' = wN - konst rate * (dEdy `outer` x)+ w' = Layer wB' wN'+ -- bundle of derivatives for next step+ dWs = tr wN #> dEdy+ in (W w', dWs)+ -- handle the inner layers+ go !x (w@(Layer wB wN) :&~ n)+ = let y = runLayer w x+ o = logistic y+ -- get dWs', bundle of derivatives from rest of the net+ (n', dWs') = go o n+ -- the gradient (how much y affects the error)+ dEdy = logistic' y * dWs'+ -- new bias weights and node weights+ wB' = wB - konst rate * dEdy+ wN' = wN - konst rate * (dEdy `outer` x)+ w' = Layer wB' wN'+ -- bundle of derivatives for next step+ dWs = tr wN #> dEdy+ in (w' :&~ n', dWs)+++-- Doesn't work, because the "constructors of R are not in scope."+-- What am I to do, here?!+-- Orphan `Ord` instance, for R n.+-- deriving instance (KnownNat n) => Ord (R n)+++-- | Normalize a vector to a probability vector, via softmax.+-- softMax :: (KnownNat n)+-- => R n -- ^ vector to be normalized+-- -> R n+-- softMax v = exp v / norm_0 v+++-- Rectified Linear Unit+-- relu :: (KnownNat n)+-- => R n+-- -> R n+-- relu = max 0+++-- relu' :: (KnownNat n)+-- => R n+-- -> R n+-- relu' v = if v > 0 then 1+-- else 0+++-- Logistic non-linear activation function.+logistic :: Floating a => a -> a+logistic x = 1 / (1 + exp (-x))++logistic' :: Floating a => a -> a+logistic' x = logix * (1 - logix)+ where+ logix = logistic x+
+ src/Haskell_ML/Util.hs view
@@ -0,0 +1,222 @@+-- General utilities for working with neural networks.+--+-- Original author: David Banas <capn.freako@gmail.com>+-- Original date: January 22, 2018+--+-- Copyright (c) 2018 David Banas; all rights reserved World wide.++{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-|+Module : Haskell_ML.Util+Description : Provides certain general purpose utilities in the Haskell_ML package.+Copyright : (c) David Banas, 2018+License : BSD-3+Maintainer : capn.freako@gmail.com+Stability : experimental+Portability : ?+-}+module Haskell_ML.Util+ ( Iris(..), Attributes(..), Sample+ , readIrisData, attributeToVector, irisTypeToVector+ , classificationAccuracy, printVector, printVecPair, mkSmplsUniform+ , asciiPlot, calcMeanList+ , for+ ) where++import Control.Applicative+import Control.Arrow+import Data.List+import qualified Data.Text as T+import Data.Attoparsec.Text hiding (take)+import Data.Singletons.TypeLits+import Numeric.LinearAlgebra.Data (maxIndex, toList)+import Numeric.LinearAlgebra.Static+import Text.Printf+++-- | The 3 classes of iris are represented by the 3 constructors of this+-- type.+data Iris = Setosa+ | Versicolor+ | Virginica+ deriving (Show, Read, Eq, Ord, Enum)+++-- | Data type representing the set of attributes for a sample in the+-- Iris dataset.+data Attributes = Attributes+ { sepLen :: Double+ , sepWidth :: Double+ , pedLen :: Double+ , pedWidth :: Double+ } deriving (Show, Read, Eq, Ord)+++-- | A single sample in the dataset is a pair of a list of attributes+-- and a classification.+type Sample = (Attributes, Iris)+++-- | Read in an Iris dataset from the given file name.+readIrisData :: String -> IO [Sample]+readIrisData fname = do+ ls <- T.lines . T.pack <$> readFile fname+ return $ f <$> ls++ where+ f l = case parseOnly sampleParser l of+ Left msg -> error msg+ Right x -> x+++-- | Rescale all feature values, to fall in [0,1].+mkSmplsUniform :: [Sample] -> [Sample]+mkSmplsUniform samps = map (first $ scaleAtt . offsetAtt) samps+ where scaleAtt :: Attributes -> Attributes+ scaleAtt Attributes{..} = Attributes (sls * sepLen) (sws * sepWidth) (pls * pedLen) (pws * pedWidth)++ offsetAtt :: Attributes -> Attributes+ offsetAtt Attributes{..} = Attributes (sepLen - slo) (sepWidth - swo) (pedLen - plo) (pedWidth - pwo)++ slo = minFldVal sepLen samps+ swo = minFldVal sepWidth samps+ plo = minFldVal pedLen samps+ pwo = minFldVal pedWidth samps++ sls = 1.0 / (maxFldVal sepLen samps - slo)+ sws = 1.0 / (maxFldVal sepWidth samps - swo)+ pls = 1.0 / (maxFldVal pedLen samps - plo)+ pws = 1.0 / (maxFldVal pedWidth samps - pwo)+++-- | Finds the minimum value, for a particular `Attributes` field, in a+-- list of samples.+minFldVal :: (Attributes -> Double) -> [Sample] -> Double+minFldVal = overSamps minimum+++-- | Finds the maximum value, for a particular `Attributes` field, in a+-- list of samples.+maxFldVal :: (Attributes -> Double) -> [Sample] -> Double+maxFldVal = overSamps maximum+++-- | Applies a reduction to an `Attributes` field in a list of `Sample`s.+overSamps :: ([Double] -> Double) -> (Attributes -> Double) -> [Sample] -> Double+overSamps f fldAcc = f . fldFromSamps fldAcc+++-- | Extracts the values of a `Attributes` field from a list of `Sample`s.+fldFromSamps :: (Attributes -> Double) -> [Sample] -> [Double]+fldFromSamps fldAcc = map (fldAcc . fst)+++-- | Convert a value of type `Attributes` to a value of type `R` 4.+attributeToVector :: Attributes -> R 4+attributeToVector Attributes{..} = vector [sepLen, sepWidth, pedLen, pedWidth]+++-- | Convert a value of type `Iris` to a one-hot vector value of type `R` 3.+irisTypeToVector :: Iris -> R 3+irisTypeToVector = \case+ Setosa -> vector [1,0,0]+ Versicolor -> vector [0,1,0]+ Virginica -> vector [0,0,1]+++-- | Calculate the classification accuracy, given:+--+-- - a list of results vectors, and+-- - a list of reference vectors.+classificationAccuracy :: (KnownNat n) => [R n] -> [R n] -> Double+classificationAccuracy us vs = calcMeanList $ cmpr us vs++ where cmpr :: (KnownNat n) => [R n] -> [R n] -> [Double]+ cmpr xs ys = for (zipWith maxComp xs ys) $ \case+ True -> 1.0+ False -> 0.0++ maxComp :: (KnownNat n) => R n -> R n -> Bool+ maxComp u v = maxIndex (extract u) == maxIndex (extract v)+++-- | Calculate the mean value of a list.+calcMeanList :: (Fractional a) => [a] -> a+calcMeanList = uncurry (/) . foldr (\e (s,c) -> (e+s,c+1)) (0,0)+++-- | Pretty printer for values of type `R` n.+printVector :: (KnownNat n) => R n -> String+printVector v = foldl' (\ s x -> s ++ printf "%+6.4f " x) "[ " ((toList . extract) v) ++ " ]"+++-- | Pretty printer for values of type (`R` `m`, `R` `n`).+printVecPair :: (KnownNat m, KnownNat n) => (R m, R n) -> String+printVecPair (u, v) = "( " ++ printVector u ++ ", " ++ printVector v ++ " )"+++-- | Plot a list of Doubles to an ASCII terminal.+asciiPlot :: [Double] -> String+asciiPlot xs = unlines $+ zipWith (++)+ [ " "+ , printf " %6.4f " x_max+ , " "+ , " "+ , " "+ , " "+ , " "+ , " "+ , " "+ , " "+ , " "+ , printf " %6.4f " x_min+ , " "+ ] $+ (:) "^" $ transpose (+ (:) "|||||||||||" $+ for (take 60 xs) $ \x ->+ valToStr $ (x - x_min) * 10 / x_range+ ) ++ ["|" ++ replicate 60 '_' ++ ">"]++ where valToStr :: Double -> String+ valToStr x = let i = round (10 - x)+ in replicate i ' ' ++ "*" ++ replicate (10 - i) ' '+ x_min = minimum xs+ x_max = maximum xs+ x_range = x_max - x_min+++-----------------------------------------------------------------------+-- All following functions are for internal library use only!+-- They are not exported through the API.+-----------------------------------------------------------------------+++sampleParser :: Parser Sample+sampleParser = f <$> (double <* char ',')+ <*> (double <* char ',')+ <*> (double <* char ',')+ <*> (double <* char ',')+ <*> irisParser+ where++ f sl sw pl pw i = (Attributes sl sw pl pw, i)++ irisParser :: Parser Iris+ irisParser = string "Iris-setosa" *> return Setosa+ <|> string "Iris-versicolor" *> return Versicolor+ <|> string "Iris-virginica" *> return Virginica+++-- | Convenience function (= flip map).+for :: [a] -> (a -> b) -> [b]+for = flip map+
+ stack.yaml view
@@ -0,0 +1,7 @@+flags: {}+extra-package-dbs: []+packages:+- .+extra-deps: []+resolver: lts-9.20+
+ test/fcnTest1.hs view
@@ -0,0 +1,28 @@+-- Test of FCN module+--+-- Original author: David Banas <capn.freako@gmail.com>+-- Original date: January 20, 2018+--+-- Copyright (c) 2018 David Banas; all rights reserved World wide.++module Main where++import Control.Monad.Random+import Data.Maybe+import System.Environment+import Text.Read+import Haskell_ML.FCN++main :: IO ()+main = do+ args <- getArgs+ let n = readMaybe =<< (args !!? 0)+ rate = readMaybe =<< (args !!? 1)+ putStrLn "Training network..."+ putStrLn =<< evalRandIO (netTest (fromMaybe 0.25 rate)+ (fromMaybe 500000 n )+ )++(!!?) :: [a] -> Int -> Maybe a+xs !!? i = listToMaybe (drop i xs)+