feat(crossEntropy): crossEntropy cost function

This commit is contained in:
Mahdi Dibaiee 2016-07-24 10:48:04 +04:30
parent 49606406d1
commit 493a20eb0a
5 changed files with 88 additions and 21 deletions

BIN
app/Main

Binary file not shown.

Binary file not shown.

View File

@ -7,20 +7,27 @@ module Main where
main = do
let learning_rate = 0.5
(iterations, epochs) = (2, 1000)
rnetwork = randomNetwork 0 2 [8] 1 -- two inputs, 8 nodes in a single hidden layer, 1 output
a = (logistic, logistic')
rnetwork = randomNetwork 0 2 [(8, a)] (1, a) -- two inputs, 8 nodes in a single hidden layer, 1 output
inputs = [vector [0, 1], vector [1, 0], vector [1, 1], vector [0, 0]]
labels = [vector [1], vector [1], vector [0], vector [0]]
initial_cost = zipWith crossEntropy (map (`forward` rnetwork) inputs) labels
network = session inputs rnetwork labels learning_rate (iterations, epochs)
results = map (`forward` network) inputs
rounded = map (map round . toList) results
cost = zipWith crossEntropy (map (`forward` network) inputs) labels
putStrLn "parameters: "
putStrLn $ "- inputs: " ++ show inputs
putStrLn $ "- labels: " ++ show labels
putStrLn $ "- learning rate: " ++ show learning_rate
putStrLn $ "- iterations/epochs: " ++ show (iterations, epochs)
putStrLn $ "- initial cost (cross-entropy): " ++ show initial_cost
putStrLn "results: "
putStrLn $ "- actual result: " ++ show results
putStrLn $ "- rounded result: " ++ show rounded
putStrLn $ "- cost (cross-entropy): " ++ show cost

View File

@ -19,6 +19,7 @@ library
build-depends: base >= 4.7 && < 5
, hmatrix
, random
, deepseq
default-language: Haskell2010
executable sibe-exe

View File

@ -8,49 +8,84 @@ module Sibe
Layer,
Input,
Output,
Activation,
forward,
randomLayer,
randomNetwork,
saveNetwork,
loadNetwork,
train,
session,
shuffle,
logistic,
logistic',
crossEntropy,
genSeed,
replaceVector
) where
import Numeric.LinearAlgebra
import System.Random
import Debug.Trace
import Data.List (foldl', sortBy)
import System.IO
import Control.DeepSeq
type LearningRate = Double
type Input = Vector Double
type Output = Vector Double
type Activation = (Vector Double -> Vector Double, Vector Double -> Vector Double)
data Layer = L { biases :: !(Vector Double)
, nodes :: !(Matrix Double)
} deriving (Show)
data Layer = L { biases :: !(Vector Double)
, nodes :: !(Matrix Double)
, activation :: Activation
}
instance Show Layer where
show (L biases nodes _) = "(" ++ show biases ++ "," ++ show nodes ++ ")"
data Network = O Layer
| Layer :- Network
deriving (Show)
infixr 5 :-
saveNetwork :: Network -> String -> IO ()
saveNetwork network file =
writeFile file ((show . reverse) (gen network []))
where
gen (O (L biases nodes _)) list = (biases, nodes) : list
gen (L biases nodes _ :- n) list = gen n $ (biases, nodes) : list
loadNetwork :: [Activation] -> String -> IO Network
loadNetwork activations file = do
handle <- openFile file ReadMode
content <- hGetContents handle
let list = read content :: [(Vector Double, Matrix Double)]
network = gen list activations
content `deepseq` hClose handle
return network
where
gen [(biases, nodes)] [a] = O (L biases nodes a)
gen ((biases, nodes):hs) (a:as) = L biases nodes a :- gen hs as
runLayer :: Input -> Layer -> Output
runLayer input (L !biases !weights) = input <# weights + biases
runLayer input (L !biases !weights _) = input <# weights + biases
forward :: Input -> Network -> Output
forward input (O l) = logistic $ runLayer input l
forward input (l :- n) = forward (logistic $ runLayer input l) n
forward input (O l@(L _ _ (fn, _))) = fn $ runLayer input l
forward input (l@(L _ _ (fn, _)) :- n) = forward ((fst . activation $ l) $ runLayer input l) n
randomLayer :: Seed -> (Int, Int) -> Layer
randomLayer :: Seed -> (Int, Int) -> Activation -> Layer
randomLayer seed (wr, wc) =
let weights = uniformSample seed wr $ replicate wc (-1, 1)
biases = randomVector seed Uniform wc * 2 - 1
in L biases weights
randomNetwork :: Seed -> Int -> [Int] -> Int -> Network
randomNetwork seed input [] output =
O $ randomLayer seed (input, output)
randomNetwork seed input (h:hs) output =
randomLayer seed (input, h) :-
randomNetwork :: Seed -> Int -> [(Int, Activation)] -> (Int, Activation) -> Network
randomNetwork seed input [] (output, a) =
O $ randomLayer seed (input, output) a
randomNetwork seed input ((h, a):hs) output =
randomLayer seed (input, h) a :-
randomNetwork (seed + 1) h hs output
logistic :: Vector Double -> Vector Double
@ -59,6 +94,14 @@ module Sibe
logistic' :: Vector Double -> Vector Double
logistic' x = logistic x * (1 - logistic x)
crossEntropy :: Output -> Output -> Double
crossEntropy output target =
let pairs = zip (toList output) (toList target)
n = fromIntegral (length pairs)
in (-1 / n) * sum (map f pairs)
where
f (a, y) = y * log a + (1 - y) * log (1 - a)
train :: Input
-> Network
-> Output -- target
@ -67,30 +110,31 @@ module Sibe
train input network target alpha = fst $ run input network
where
run :: Input -> Network -> (Network, Vector Double)
run input (O l@(L biases weights)) =
run input (O l@(L biases weights (fn, fn'))) =
let y = runLayer input l
o = logistic y
o = fn y
delta = o - target
de = delta * logistic' y
-- de = delta * fn' y -- quadratic cost
de = delta -- cross entropy cost
biases' = biases - scale alpha de
weights' = weights - scale alpha (input `outer` de) -- small inputs learn slowly
layer = L biases' weights' -- updated layer
layer = L biases' weights' (fn, fn') -- updated layer
pass = weights #> de
-- pass = weights #> de
in (O layer, pass)
run input (l@(L biases weights) :- n) =
run input (l@(L biases weights (fn, fn')) :- n) =
let y = runLayer input l
o = logistic y
o = fn y
(n', delta) = run o n
de = delta * logistic' y
de = delta * fn' y -- quadratic cost
biases' = biases - scale alpha de
weights' = weights - scale alpha (input `outer` de)
layer = L biases' weights'
layer = L biases' weights' (fn, fn')
pass = weights #> de
-- pass = weights #> de
@ -115,3 +159,18 @@ module Sibe
in map snd $ sortBy (\x y -> fst x) (zip ords list)
where ord x | x == 0 = LT
| x == 1 = GT
genSeed :: IO Seed
genSeed = do
(seed, _) <- random <$> newStdGen :: IO (Int, StdGen)
return seed
replaceVector :: Vector Double -> Int -> Double -> Vector Double
replaceVector vec index value =
let list = toList vec
in fromList $ rrow index list
where
rrow index [] = []
rrow index (x:xs)
| index == index = value:xs
| otherwise = x : rrow (index + 1) xs