Merge pull request #211 from Shimuuar/tests-failures

Fix few sporadic test failures

tests/Tests/Correlation.hs

@@ -102,11 +102,11 @@ testSpearmanNonlinear sample0
         , not (isNaN c3)
         , not (isNaN c4)
         ]
-  ==> ( counterexample (show sample0)
-      $ counterexample (show sample1)
-      $ counterexample (show sample2)
-      $ counterexample (show sample3)
-      $ counterexample (show sample4)
+  ==> ( counterexample ("S0 = " ++ show sample0)
+      $ counterexample ("S1 = " ++ show sample1)
+      $ counterexample ("S2 = " ++ show sample2)
+      $ counterexample ("S3 = " ++ show sample3)
+      $ counterexample ("S4 = " ++ show sample4)
       $ counterexample (show (c1,c2,c3,c4))
       $ and [ c1 == c2
             , c1 == c3
@@ -117,8 +117,8 @@ testSpearmanNonlinear sample0
     -- We need to stretch sample into [-10 .. 10] range to avoid
     -- problems with under/overflows etc.
     stretch xs
-      | a == b = xs
-      | otherwise = [ (x - a - 10) * 20 / (a - b) | x <- xs ]
+      | a == b    = xs
+      | otherwise = [ ((x - a)/(b - a) - 0.5) * 20 | x <- xs ]
       where
         a = minimum xs
         b = maximum xs

tests/Tests/ExactDistribution.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE BangPatterns,
-             FlexibleInstances,
-             FlexibleContexts,
-             ScopedTypeVariables
-  #-}
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
 -- |
 -- Module    : Tests.ExactDistribution
 -- Copyright : (c) 2022 Lorenz Minder
@@ -64,8 +65,6 @@ module Tests.ExactDistribution (
     , ExactHypergeomDistr(..)
 
     -- * Linking to production distributions
-    , ProductionProbFuncs(..)
-    , productionProbFuncs
     , ProductionLinkage
 
     -- * Individual test routines
@@ -88,6 +87,7 @@ import Test.Tasty                       (TestTree, testGroup)
 import Test.Tasty.QuickCheck            (testProperty)
 import Test.QuickCheck as QC
 import Numeric.MathFunctions.Comparison (relativeError)
+import Numeric.MathFunctions.Constants  (m_tiny)
 
 import Statistics.Distribution
 import Statistics.Distribution.Binomial
@@ -295,102 +295,93 @@ instance QC.Arbitrary (TestCase ExactHypergeomDistr) where
 --
 ----------------------------------------------------------------
 
--- | Distribution evaluation functions.
---
--- This is used to store a
-data ProductionProbFuncs = ProductionProbFuncs {
-        prodProb            :: Int -> Double
-    ,   prodCumulative      :: Double -> Double
-    ,   prodComplCumulative :: Double -> Double
-    }
-
-productionProbFuncs :: (DiscreteDistr a) => a -> ProductionProbFuncs
-productionProbFuncs d = ProductionProbFuncs {
-        prodProb = probability d
-    ,   prodCumulative = cumulative d
-    ,   prodComplCumulative = complCumulative d
-    }
-
-class (ExactDiscreteDistr a) => ProductionLinkage a where
-    productionLinkage :: a -> ProductionProbFuncs
+class (ExactDiscreteDistr a, DiscreteDistr (ProdDistrib a)
+      ) => ProductionLinkage a where
+  type ProdDistrib a
+  toProd :: a -> ProdDistrib a
 
 instance ProductionLinkage ExactBinomialDistr where
-    productionLinkage (ExactBD n p) =
-        let d = binomial (fromIntegral n) (fromRational p)
-        in  productionProbFuncs d
+  type ProdDistrib ExactBinomialDistr = BinomialDistribution
+  toProd (ExactBD n p) = binomial (fromIntegral n) (fromRational p)
 
 instance ProductionLinkage ExactDiscreteUniformDistr where
-    productionLinkage (ExactDU lower upper) =
-        let d = discreteUniformAB (fromIntegral lower) (fromIntegral upper)
-        in  productionProbFuncs d
+  type ProdDistrib ExactDiscreteUniformDistr = DiscreteUniform
+  toProd (ExactDU lower upper) = discreteUniformAB (fromIntegral lower) (fromIntegral upper)
 
 instance ProductionLinkage ExactGeometricDistr where
-    productionLinkage (ExactGeom p) =
-        let d = geometric $ fromRational p
-        in  productionProbFuncs d
+  type ProdDistrib ExactGeometricDistr = GeometricDistribution
+  toProd (ExactGeom p) = geometric $ fromRational p
 
 instance ProductionLinkage ExactHypergeomDistr where
-    productionLinkage (ExactHG nK nN n) =
-        let d = hypergeometric (fromIntegral nK) (fromIntegral nN) (fromIntegral n)
-        in  productionProbFuncs d
+  type ProdDistrib ExactHypergeomDistr = HypergeometricDistribution
+  toProd (ExactHG nK nN n) =
+    hypergeometric (fromIntegral nK) (fromIntegral nN) (fromIntegral n)
+
 
 ----------------------------------------------------------------
 -- Tests
 ----------------------------------------------------------------
 
+-- Compare that probabilities agree. If they are denormalized just
+-- return True. You can't say much about precision
+probabilityAgree :: Double -> Double -> Double -> Bool
+probabilityAgree tol pe pa
+  | pa < 0      = False
+  | pe < 0      = False
+  | pe < m_tiny = True
+  | otherwise   = relativeError pe pa < tol
+
 -- Check production probability mass function accuracy.
 --
 -- Inputs: tolerance (max relative error) and test case
-pmfMatch :: (Show a, ProductionLinkage a) => Double -> TestCase a -> Bool
-pmfMatch tol (TestCase dExact k) =
-    let dProd = productionLinkage dExact
-        pe = fromRational $ exactProb dExact k
-        pa = prodProb dProd k'
-        k' = fromIntegral k
-    in  relativeError pe pa < tol
+pmfMatch :: (Show a, ProductionLinkage a) => Double -> TestCase a -> Property
+pmfMatch tol (TestCase dExact k)
+  = counterexample ("Exact  = " ++ show pe)
+  $ counterexample ("Approx = " ++ show pa)
+  $ probabilityAgree tol pe pa
+  where
+    pe = fromRational $ exactProb dExact k
+    pa = probability (toProd dExact) (fromIntegral k)
 
 -- Check production cumulative probability function accuracy.
 --
 -- Inputs:  tolerance (max relative error) and test case.
 cdfMatch :: (Show a, ProductionLinkage a) => Double -> TestCase a -> Bool
-cdfMatch tol (TestCase dExact k) =
-    let dProd = productionLinkage dExact
-        pe = fromRational $ exactCumulative dExact k
-        pa = prodCumulative dProd k'
-        k' = fromIntegral k
-    in  relativeError pe pa < tol
+cdfMatch tol (TestCase dExact k)
+  = probabilityAgree tol pe pa
+  where
+    pe = fromRational $ exactCumulative dExact k
+    pa = cumulative (toProd dExact) (fromIntegral k)
 
 -- Check production complement cumulative function accuracy.
 --
 -- Inputs:  tolerance (max relative error) and test case.
 complCdfMatch :: (Show a, ProductionLinkage a) => Double -> TestCase a -> Bool
-complCdfMatch tol (TestCase dExact k) =
-    let dProd = productionLinkage dExact
-        pe = fromRational $ 1 - exactCumulative dExact k
-        pa = prodComplCumulative dProd k'
-        k' = fromIntegral k
-    in  relativeError pe pa < tol
+complCdfMatch tol (TestCase dExact k)
+  = probabilityAgree tol pe pa
+  where
+    pe = fromRational $ 1 - exactCumulative dExact k
+    pa = complCumulative (toProd dExact) (fromIntegral k)
 
 -- Phantom type to encode an exact distribution.
 data Tag a = Tag
 
-distTests :: (Show a, ProductionLinkage a, Arbitrary (TestCase a)) =>
+distTests :: forall a. (Show a, ProductionLinkage a, Arbitrary (TestCase a)) =>
     Tag a -> String -> Double -> TestTree
 distTests (Tag :: Tag a) name tol =
-    testGroup ("Exact tests for " ++ name) [
-        testProperty "PMF match" $ ((pmfMatch tol) :: TestCase a -> Bool)
-    ,   testProperty "CDF match" $ ((cdfMatch tol) :: TestCase a -> Bool)
-    ,   testProperty "1 - CDF match" $ ((complCdfMatch tol) :: TestCase a -> Bool)
+  testGroup ("Exact tests for " ++ name)
+    [ testProperty "PMF match"     $ pmfMatch      @a tol
+    , testProperty "CDF match"     $ cdfMatch      @a tol
+    , testProperty "1 - CDF match" $ complCdfMatch @a tol
     ]
 
 
 -- Test driver -------------------------------------------------
 
 exactDistributionTests :: TestTree
 exactDistributionTests = testGroup "Test distributions against exact"
-  [
-    distTests (Tag :: Tag ExactBinomialDistr)       "Binomial"          1.0e-12
-  , distTests (Tag :: Tag ExactDiscreteUniformDistr) "DiscreteUniform"  1.0e-12
-  , distTests (Tag :: Tag ExactGeometricDistr)      "Geometric"         1.0e-13
-  , distTests (Tag :: Tag ExactHypergeomDistr)      "Hypergeometric"    1.0e-12
+  [ distTests (Tag @ExactBinomialDistr)        "Binomial"         1.0e-12
+  , distTests (Tag @ExactDiscreteUniformDistr) "DiscreteUniform"  1.0e-12
+  , distTests (Tag @ExactGeometricDistr)       "Geometric"        1.0e-13
+  , distTests (Tag @ExactHypergeomDistr)       "Hypergeometric"   1.0e-12
   ]