From a17bd53598ee5266fc3a1c45f8f4bb4798dc495e Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Fri, 21 Feb 2025 13:35:26 +0100 Subject: Working tests and benchmarks against 'ad' --- bench/Main.hs | 17 +++++++++++++++-- examples/Numeric/ADDual/Examples.hs | 37 +++++++++++++++++++------------------ src/Numeric/ADDual/Internal.hs | 6 +++--- test/Main.hs | 36 ++++++++++++++++++++++++++---------- 4 files changed, 63 insertions(+), 33 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index a11f4e8..99c3f1d 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,11 +4,24 @@ module Main where import Criterion import Criterion.Main +import qualified Numeric.AD as AD + import qualified Numeric.ADDual as ADD import Numeric.ADDual.Examples main :: IO () main = defaultMain - [env (pure makeNeuralInput) $ \input -> - bench "neural" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input] + [env (pure (makeNeuralInput 100)) $ \input -> + bgroup "neural-100" + [bench "dual" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input + ,bench "ad" $ nf (\inp -> AD.grad fneural inp) input] + ,env (pure (makeNeuralInput 500)) $ \input -> + bgroup "neural-500" + [bench "dual" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input + ,bench "ad" $ nf (\inp -> AD.grad fneural inp) input] + ,env (pure (makeNeuralInput 2000)) $ \input -> + bgroup "neural-2000" + [bench "dual" $ nf (\inp -> ADD.gradient' @Double fneural inp 1.0) input + ,bench "ad" $ nf (\inp -> AD.grad fneural inp) input] + ] diff --git a/examples/Numeric/ADDual/Examples.hs b/examples/Numeric/ADDual/Examples.hs index d6aa6d2..819aec4 100644 --- a/examples/Numeric/ADDual/Examples.hs +++ b/examples/Numeric/ADDual/Examples.hs @@ -5,17 +5,21 @@ module Numeric.ADDual.Examples where import Control.DeepSeq import Control.Monad (replicateM) +import Data.Maybe (catMaybes) import qualified Data.Vector as V import GHC.Generics (Generic) -import Hedgehog (Gen) +import Hedgehog (Gen, Size) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import qualified Hedgehog.Internal.Gen as HI.Gen +import qualified Hedgehog.Internal.Seed as HI.Seed +import qualified Hedgehog.Internal.Tree as HI.Tree type Matrix s = V.Vector s data FNeural a = FNeural [(Matrix a, V.Vector a)] (V.Vector a) - deriving (Show, Functor, Foldable, Traversable, Generic) + deriving (Show, Eq, Functor, Foldable, Traversable, Generic) instance NFData a => NFData (FNeural a) @@ -39,27 +43,24 @@ fneural (FNeural layers input) = in forward lys x' in V.sum $ forward layers input -makeNeuralInput :: FNeural Double -makeNeuralInput = - let genMatrix nin nout = - V.fromListN (nin*nout) [sin (fromIntegral @Int (i+j)) - | i <- [0..nout-1], j <- [0..nin-1]] - genVector nout = V.fromListN nout [sin (0.41 * fromIntegral @Int i) | i <- [0..nout-1]] - -- 50 inputs; 2 hidden layers (100; 50); final softmax, then sum the outputs. - nIn = 50; n1 = 100; n2 = 50 - in FNeural [(genMatrix nIn n1, genVector n1) - ,(genMatrix n1 n2, genVector n2)] - (genVector nIn) +makeNeuralInput :: Int -> FNeural Double +makeNeuralInput scale = sampleGenPure 100 (genNeuralInput scale) -genNeuralInput :: Gen (FNeural Double) -genNeuralInput = do +genNeuralInput :: Int -> Gen (FNeural Double) +genNeuralInput scale = do let genScalar = Gen.double (Range.linearFracFrom 0 (-1) 1) genMatrix nin nout = V.fromListN (nin*nout) <$> replicateM (nin*nout) genScalar genVector nout = V.fromListN nout <$> replicateM nout genScalar - nIn <- Gen.integral (Range.linear 1 80) - n1 <- Gen.integral (Range.linear 1 100) - n2 <- Gen.integral (Range.linear 1 80) + nIn <- Gen.integral (Range.linear 1 scale) + n1 <- Gen.integral (Range.linear 1 scale) + n2 <- Gen.integral (Range.linear 1 scale) m1 <- genMatrix nIn n1; v1 <- genVector n1 m2 <- genMatrix n1 n2; v2 <- genVector n2 inp <- genVector nIn pure $ FNeural [(m1, v1), (m2, v2)] inp + + +sampleGenPure :: Size -> Gen a -> a +sampleGenPure size gen = + HI.Tree.treeValue $ head $ catMaybes + [HI.Gen.evalGen size (HI.Seed.from n) gen | n <- [42..]] diff --git a/src/Numeric/ADDual/Internal.hs b/src/Numeric/ADDual/Internal.hs index 5955fae..1ea3132 100644 --- a/src/Numeric/ADDual/Internal.hs +++ b/src/Numeric/ADDual/Internal.hs @@ -159,9 +159,9 @@ instance (Fractional a, Storable a, Taping s a) => Fractional (Dual s a) where instance (Floating a, Storable a, Taping s a) => Floating (Dual s a) where pi = Dual pi (-1) - exp (Dual x i1) = mkDual (exp x) i1 (exp x) (-1) 0 - log (Dual x i1) = mkDual (log x) i1 (recip x) (-1) 0 - sqrt (Dual x i1) = mkDual (sqrt x) i1 (recip (2*sqrt x)) (-1) 0 + exp (Dual x i1) = mkDual (exp x) i1 (exp x) (-1) 0 + log (Dual x i1) = mkDual (log x) i1 (recip x) (-1) 0 + sqrt (Dual x i1) = mkDual (sqrt x) i1 (recip (2*sqrt x)) (-1) 0 -- d/dx (x ^ y) = d/dx (e ^ (y ln x)) = e ^ (y ln x) * d/dx (y ln x) = e ^ (y ln x) * y/x -- d/dy (x ^ y) = d/dy (e ^ (y ln x)) = e ^ (y ln x) * d/dy (y ln x) = e ^ (y ln x) * ln x Dual x i1 ** Dual y i2 = diff --git a/test/Main.hs b/test/Main.hs index 04a8923..a04533f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,26 +1,42 @@ {-# LANGUAGE TypeApplications #-} module Main where -import qualified Data.Vector as V +import Data.Foldable (toList) import Hedgehog import Test.Tasty import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import qualified Numeric.AD as AD + import Numeric.ADDual import Numeric.ADDual.Examples +(~==) :: (Foldable t, Fractional a, Ord a, Show (t a)) => t a -> t a -> PropertyT IO () +a ~== b + | length (toList a) == length (toList b) + , and (zipWith close (toList a) (toList b)) + = return () + | otherwise + = diff a (\_ _ -> False) b + where + close x y = abs (x - y) < 1e-5 || + (let m = max (abs x) (abs y) in m > 1e-5 && abs (x - y) / m < 1e-5) + + main :: IO () main = defaultMain $ testGroup "Tests" [testCase "product [1..5]" $ gradient' @Double product [1..5] 1 @?= (120, [120, 60, 40, 30, 24]) - ,testCase "neural one" $ - let problem = FNeural - [(V.replicate 6 0.0, V.replicate 6 0.0), (V.replicate 24 0.0, V.replicate 4 0.0)] - (V.replicate 1 0.0) - in fst (gradient' @Double fneural problem 1) @?= fneural problem - ,testProperty "neural run" $ property $ do - input <- forAll genNeuralInput - let (res, _grad) = gradient' fneural input 1 - res === fneural input] + ,testProperty "neural 80" $ property $ do + input <- forAll (genNeuralInput 80) + let (res, grad) = gradient' fneural input 1 + res === fneural input + grad ~== AD.grad fneural input + ,testProperty "neural 150" $ property $ do + input <- forAll (genNeuralInput 150) + let (res, grad) = gradient' fneural input 1 + res === fneural input + grad ~== AD.grad fneural input + ] -- cgit v1.2.3-70-g09d2