diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -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/ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/example/iris/iris.hs b/example/iris/iris.hs new file mode 100644 --- /dev/null +++ b/example/iris/iris.hs @@ -0,0 +1,120 @@ +-- Example use of `Haskell_ML.FCN` to categorize the Iris dataset. +-- +-- Original author: David Banas +-- 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 + diff --git a/haskell-ml.cabal b/haskell-ml.cabal new file mode 100644 --- /dev/null +++ b/haskell-ml.cabal @@ -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 + diff --git a/src/Haskell_ML/FCN.hs b/src/Haskell_ML/FCN.hs new file mode 100644 --- /dev/null +++ b/src/Haskell_ML/FCN.hs @@ -0,0 +1,403 @@ +-- Building blocks for making fully connected neural networks (FCNs). +-- +-- Original author: David Banas +-- 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 + diff --git a/src/Haskell_ML/Util.hs b/src/Haskell_ML/Util.hs new file mode 100644 --- /dev/null +++ b/src/Haskell_ML/Util.hs @@ -0,0 +1,222 @@ +-- General utilities for working with neural networks. +-- +-- Original author: David Banas +-- 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 + diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,7 @@ +flags: {} +extra-package-dbs: [] +packages: +- . +extra-deps: [] +resolver: lts-9.20 + diff --git a/test/fcnTest1.hs b/test/fcnTest1.hs new file mode 100644 --- /dev/null +++ b/test/fcnTest1.hs @@ -0,0 +1,28 @@ +-- Test of FCN module +-- +-- Original author: David Banas +-- 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) +