diff --git a/hmatrix-tests.cabal b/hmatrix-tests.cabal --- a/hmatrix-tests.cabal +++ b/hmatrix-tests.cabal @@ -1,5 +1,5 @@ Name: hmatrix-tests -Version: 0.5.0.0 +Version: 0.6.0.0 License: BSD3 License-file: LICENSE Author: Alberto Ruiz @@ -28,9 +28,10 @@ Build-Depends: base >= 4 && < 5, deepseq, QuickCheck >= 2, HUnit, random, - hmatrix >= 0.17 + hmatrix >= 0.18 + , binary if flag(gsl) - Build-Depends: hmatrix-gsl >= 0.17 + Build-Depends: hmatrix-gsl >= 0.18 hs-source-dirs: src diff --git a/src/Numeric/LinearAlgebra/Tests.hs b/src/Numeric/LinearAlgebra/Tests.hs --- a/src/Numeric/LinearAlgebra/Tests.hs +++ b/src/Numeric/LinearAlgebra/Tests.hs @@ -26,6 +26,7 @@ utest, runTests, runBenchmarks + , binaryTests -- , findNaN --, runBigTests ) where @@ -132,15 +133,17 @@ --------------------------------------------------------------------- -randomTestGaussian = c :~1~: snd (meanCov dat) where +randomTestGaussian = (unSym c) :~3~: unSym (snd (meanCov dat)) + where a = (3><3) [1,2,3, 2,4,0, -2,2,1] m = 3 |> [1,2,3] - c = a <> tr a + c = mTm a dat = gaussianSample 7 (10^6) m c -randomTestUniform = c :~1~: snd (meanCov dat) where +randomTestUniform = c :~2~: unSym (snd (meanCov dat)) + where c = diag $ 3 |> map ((/12).(^2)) [1,2,3] dat = uniformSample 7 (10^6) [(0,1),(1,3),(3,6)] @@ -741,6 +744,15 @@ | otherwise = v where n = sqrt (v `dot` v) +binaryTests :: IO () +binaryTests = do + let test :: forall t . T.Testable t => t -> IO () + test = qCheck 100 + test vectorBinaryRoundtripProp + test staticVectorBinaryRoundtripProp + qCheck 30 matrixBinaryRoundtripProp + qCheck 30 staticMatrixBinaryRoundtripProp + -- -- | Some additional tests on big matrices. They take a few minutes. -- runBigTests :: IO () -- runBigTests = undefined @@ -944,5 +956,3 @@ luBenchN_2 luSolve' luPacked' 500 (5::R) "luSolve'.luPacked' Double " luBenchN_2 luSolve' luPacked' 500 (5::Mod 9973 I) "luSolve'.luPacked' I mod 9973" luBenchN_2 luSolve' luPacked' 500 (5::Mod 9973 Z) "luSolve'.luPacked' Z mod 9973" - - diff --git a/src/Numeric/LinearAlgebra/Tests/Instances.hs b/src/Numeric/LinearAlgebra/Tests/Instances.hs --- a/src/Numeric/LinearAlgebra/Tests/Instances.hs +++ b/src/Numeric/LinearAlgebra/Tests/Instances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, UndecidableInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-} ----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Tests.Instances @@ -29,7 +29,11 @@ import Control.Monad(replicateM) import Test.QuickCheck(Arbitrary,arbitrary,choose,vector,sized,shrink) +import GHC.TypeLits +import Data.Proxy (Proxy(..)) +import qualified Numeric.LinearAlgebra.Static as Static + shrinkListElementwise :: (Arbitrary a) => [a] -> [[a]] shrinkListElementwise [] = [] shrinkListElementwise (x:xs) = [ y:xs | y <- shrink x ] @@ -40,15 +44,26 @@ chooseDim = sized $ \m -> choose (1,max 1 m) -instance (Field a, Arbitrary a) => Arbitrary (Vector a) where +instance (Field a, Arbitrary a) => Arbitrary (Vector a) where arbitrary = do m <- chooseDim l <- vector m return $ fromList l -- shrink any one of the components shrink = map fromList . shrinkListElementwise . toList -instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where +instance KnownNat n => Arbitrary (Static.R n) where arbitrary = do + l <- vector n + return (Static.fromList l) + + where + n :: Int + n = fromIntegral (natVal (Proxy :: Proxy n)) + + shrink v = [] + +instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where + arbitrary = do m <- chooseDim n <- chooseDim l <- vector (m*n) @@ -57,9 +72,23 @@ -- shrink any one of the components shrink a = map (rows a >< cols a) . shrinkListElementwise - . concat . toLists + . concat . toLists $ a +instance (KnownNat n, KnownNat m) => Arbitrary (Static.L m n) where + arbitrary = do + l <- vector (m * n) + return (Static.fromList l) + + where + m :: Int + m = fromIntegral (natVal (Proxy :: Proxy m)) + + n :: Int + n = fromIntegral (natVal (Proxy :: Proxy n)) + + shrink mat = [] + -- a square matrix newtype (Sq a) = Sq (Matrix a) deriving Show instance (Element a, Arbitrary a) => Arbitrary (Sq a) where @@ -121,7 +150,7 @@ -- a positive definite square matrix (the eigenvalues are between 0 and 100) newtype (PosDef a) = PosDef (Matrix a) deriving Show -instance (Numeric a, ArbitraryField a, Num (Vector a)) +instance (Numeric a, ArbitraryField a, Num (Vector a)) => Arbitrary (PosDef a) where arbitrary = do m <- arbitrary diff --git a/src/Numeric/LinearAlgebra/Tests/Properties.hs b/src/Numeric/LinearAlgebra/Tests/Properties.hs --- a/src/Numeric/LinearAlgebra/Tests/Properties.hs +++ b/src/Numeric/LinearAlgebra/Tests/Properties.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- {- | @@ -39,12 +40,25 @@ expmDiagProp, multProp1, multProp2, subProp, - linearSolveProp, linearSolvePropH, linearSolveProp2 + linearSolveProp, linearSolvePropH, linearSolveProp2, + + -- Binary properties + vectorBinaryRoundtripProp + , staticVectorBinaryRoundtripProp + , matrixBinaryRoundtripProp + , staticMatrixBinaryRoundtripProp + , staticVectorBinaryFailProp ) where import Numeric.LinearAlgebra.HMatrix hiding (Testable,unitary) +import qualified Numeric.LinearAlgebra.Static as Static import Test.QuickCheck +import Data.Binary +import Data.Binary.Get (runGet) +import Data.Either (isLeft) +import Debug.Trace (traceShowId) + (~=) :: Double -> Double -> Bool a ~= b = abs (a - b) < 1e-10 @@ -275,3 +289,31 @@ subProp m = m == (conj . tr . fromColumns . toRows) m +------------------------------------------------------------------ + +vectorBinaryRoundtripProp :: Vector Double -> Bool +vectorBinaryRoundtripProp vec = decode (encode vec) == vec + +staticVectorBinaryRoundtripProp :: Static.R 5 -> Bool +staticVectorBinaryRoundtripProp vec = + let + decoded = decode (encode vec) :: Static.R 500 + in + Static.extract decoded == Static.extract vec + +matrixBinaryRoundtripProp :: Matrix Double -> Bool +matrixBinaryRoundtripProp mat = decode (encode mat) == mat + +staticMatrixBinaryRoundtripProp :: Static.L 100 200 -> Bool +staticMatrixBinaryRoundtripProp mat = + let + decoded = decode (encode mat) :: Static.L 100 200 + in + (Static.extract decoded) == (Static.extract mat) + +staticVectorBinaryFailProp :: Static.R 20 -> Bool +staticVectorBinaryFailProp vec = + let + decoded = runGet get (encode vec) :: Either String (Static.R 50) + in + isLeft decoded