diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -18,18 +18,11 @@ # Get involved! Please report bugs via the -[github issue tracker](https://github.com/bos/statistics/issues). - -Master [git mirror](https://github.com/bos/statistics): - -* `git clone git://github.com/bos/statistics.git` - -There's also a [Mercurial mirror](https://bitbucket.org/bos/statistics): - -* `hg clone https://bitbucket.org/bos/statistics` +[github issue tracker](https://github.com/haskell/statistics/issues). -(You can create and contribute changes using either Mercurial or git.) +Master [git mirror](https://github.com/haskell/statistics): +* `git clone git://github.com/haskell/statistics.git` # Authors diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/Statistics/ConfidenceInt.hs b/Statistics/ConfidenceInt.hs new file mode 100644 --- /dev/null +++ b/Statistics/ConfidenceInt.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ViewPatterns #-} +-- | Calculation of confidence intervals +module Statistics.ConfidenceInt ( + poissonCI + , poissonNormalCI + , binomialCI + , naiveBinomialCI + -- * References + -- $references + ) where + +import Statistics.Distribution +import Statistics.Distribution.ChiSquared +import Statistics.Distribution.Beta +import Statistics.Types + + + +-- | Calculate confidence intervals for Poisson-distributed value +-- using normal approximation +poissonNormalCI :: Int -> Estimate NormalErr Double +poissonNormalCI n + | n < 0 = error "Statistics.ConfidenceInt.poissonNormalCI negative number of trials" + | otherwise = estimateNormErr n' (sqrt n') + where + n' = fromIntegral n + +-- | Calculate confidence intervals for Poisson-distributed value for +-- single measurement. These are exact confidence intervals +poissonCI :: CL Double -> Int -> Estimate ConfInt Double +poissonCI cl@(significanceLevel -> p) n + | n < 0 = error "Statistics.ConfidenceInt.poissonCI: negative number of trials" + | n == 0 = estimateFromInterval m (0 ,m2) cl + | otherwise = estimateFromInterval m (m1,m2) cl + where + m = fromIntegral n + m1 = 0.5 * quantile (chiSquared (2*n )) (p/2) + m2 = 0.5 * complQuantile (chiSquared (2*n+2)) (p/2) + +-- | Calculate confidence interval using normal approximation. Note +-- that this approximation breaks down when /p/ is either close to 0 +-- or to 1. In particular if @np < 5@ or @1 - np < 5@ this +-- approximation shouldn't be used. +naiveBinomialCI :: Int -- ^ Number of trials + -> Int -- ^ Number of successes + -> Estimate NormalErr Double +naiveBinomialCI n k + | n <= 0 || k < 0 = error "Statistics.ConfidenceInt.naiveBinomialCI: negative number of events" + | k > n = error "Statistics.ConfidenceInt.naiveBinomialCI: more successes than trials" + | otherwise = estimateNormErr p σ + where + p = fromIntegral k / fromIntegral n + σ = sqrt $ p * (1 - p) / fromIntegral n + + +-- | Clopper-Pearson confidence interval also known as exact +-- confidence intervals. +binomialCI :: CL Double + -> Int -- ^ Number of trials + -> Int -- ^ Number of successes + -> Estimate ConfInt Double +binomialCI cl@(significanceLevel -> p) ni ki + | ni <= 0 || ki < 0 = error "Statistics.ConfidenceInt.binomialCI: negative number of events" + | ki > ni = error "Statistics.ConfidenceInt.binomialCI: more successes than trials" + | ki == 0 = estimateFromInterval eff (0, ub) cl + | ni == ki = estimateFromInterval eff (lb,0 ) cl + | otherwise = estimateFromInterval eff (lb,ub) cl + where + k = fromIntegral ki + n = fromIntegral ni + eff = k / n + lb = quantile (betaDistr k (n - k + 1)) (p/2) + ub = complQuantile (betaDistr (k + 1) (n - k) ) (p/2) + + +-- $references +-- +-- * Clopper, C.; Pearson, E. S. (1934). "The use of confidence or +-- fiducial limits illustrated in the case of the +-- binomial". Biometrika 26: 404–413. doi:10.1093/biomet/26.4.404 +-- +-- * Brown, Lawrence D.; Cai, T. Tony; DasGupta, Anirban +-- (2001). "Interval Estimation for a Binomial Proportion". Statistical +-- Science 16 (2): 101–133. doi:10.1214/ss/1009213286. MR 1861069. +-- Zbl 02068924. diff --git a/Statistics/Constants.hs b/Statistics/Constants.hs deleted file mode 100644 --- a/Statistics/Constants.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | --- Module : Statistics.Constants --- Copyright : (c) 2009, 2011 Bryan O'Sullivan --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : portable --- --- Constant values common to much statistics code. --- --- DEPRECATED: use module 'Numeric.MathFunctions.Constants' from --- math-functions. - -module Statistics.Constants -{-# DEPRECATED "use module Numeric.MathFunctions.Constants from math-functions" #-} - ( module Numeric.MathFunctions.Constants - ) where - -import Numeric.MathFunctions.Constants diff --git a/Statistics/Correlation.hs b/Statistics/Correlation.hs --- a/Statistics/Correlation.hs +++ b/Statistics/Correlation.hs @@ -6,9 +6,11 @@ module Statistics.Correlation ( -- * Pearson correlation pearson + , pearson2 , pearsonMatByRow -- * Spearman correlation , spearman + , spearman2 , spearmanMatByRow ) where @@ -23,13 +25,21 @@ -- Pearson ---------------------------------------------------------------- --- | Pearson correlation for sample of pairs. -pearson :: (G.Vector v (Double, Double), G.Vector v Double) +-- | Pearson correlation for sample of pairs. Exactly same as +-- 'Statistics.Sample.correlation' +pearson :: (G.Vector v (Double, Double)) => v (Double, Double) -> Double pearson = correlation {-# INLINE pearson #-} --- | Compute pairwise pearson correlation between rows of a matrix +-- | Pearson correlation for sample of pairs. Exactly same as +-- 'Statistics.Sample.correlation' +pearson2 :: (G.Vector v Double) + => v Double -> v Double -> Double +pearson2 = correlation2 +{-# INLINE pearson2 #-} + +-- | Compute pairwise Pearson correlation between rows of a matrix pearsonMatByRow :: Matrix -> Matrix pearsonMatByRow m = generateSym (rows m) @@ -42,15 +52,13 @@ -- Spearman ---------------------------------------------------------------- --- | compute spearman correlation between two samples +-- | Compute Spearman correlation between two samples spearman :: ( Ord a , Ord b , G.Vector v a , G.Vector v b , G.Vector v (a, b) , G.Vector v Int - , G.Vector v Double - , G.Vector v (Double, Double) , G.Vector v (Int, a) , G.Vector v (Int, b) ) @@ -63,7 +71,28 @@ (x, y) = G.unzip xy {-# INLINE spearman #-} --- | compute pairwise spearman correlation between rows of a matrix +-- | Compute Spearman correlation between two samples. Samples must +-- have same length. +spearman2 :: ( Ord a + , Ord b + , G.Vector v a + , G.Vector v b + , G.Vector v Int + , G.Vector v (Int, a) + , G.Vector v (Int, b) + ) + => v a + -> v b + -> Double +spearman2 xs ys + | nx /= ny = error "Statistics.Correlation.spearman2: samples must have same length" + | otherwise = pearson $ G.zip (rankUnsorted xs) (rankUnsorted ys) + where + nx = G.length xs + ny = G.length ys +{-# INLINE spearman2 #-} + +-- | compute pairwise Spearman correlation between rows of a matrix spearmanMatByRow :: Matrix -> Matrix spearmanMatByRow = pearsonMatByRow . fromRows . fmap rankUnsorted . toRows diff --git a/Statistics/Correlation/Kendall.hs b/Statistics/Correlation/Kendall.hs --- a/Statistics/Correlation/Kendall.hs +++ b/Statistics/Correlation/Kendall.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns, CPP, FlexibleContexts #-} +{-# LANGUAGE BangPatterns, FlexibleContexts #-} -- | -- Module : Statistics.Correlation.Kendall -- -- Fast O(NlogN) implementation of -- . -- --- This module implementes Kendall's tau form b which allows ties in the data. +-- This module implements Kendall's tau form b which allows ties in the data. -- This is the same formula used by other statistical packages, e.g., R, matlab. -- -- > \tau = \frac{n_c - n_d}{\sqrt{(n_0 - n_1)(n_0 - n_2)}} @@ -130,11 +130,6 @@ _ -> do GM.unsafeWrite src iIns eLow wroteLow low (iLow+1) high iHigh eHigh (iIns+1) {-# INLINE merge #-} - -#if !MIN_VERSION_base(4,6,0) -modifySTRef' :: STRef s a -> (a -> a) -> ST s () -modifySTRef' = modifySTRef -#endif -- $references -- diff --git a/Statistics/Distribution.hs b/Statistics/Distribution.hs --- a/Statistics/Distribution.hs +++ b/Statistics/Distribution.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -- | -- Module : Statistics.Distribution @@ -23,37 +24,37 @@ , Variance(..) , MaybeEntropy(..) , Entropy(..) + , FromSample(..) -- ** Random number generation , ContGen(..) , DiscreteGen(..) - , genContinous + , genContinuous -- * Helper functions , findRoot , sumProbabilities ) where -import Control.Applicative ((<$>), Applicative(..)) -import Control.Monad.Primitive (PrimMonad,PrimState) import Prelude hiding (sum) -import Statistics.Function (square) +import Statistics.Function (square) import Statistics.Sample.Internal (sum) -import System.Random.MWC (Gen, uniform) +import System.Random.Stateful (StatefulGen, uniformDouble01M) import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Generic as G -- | Type class common to all distributions. Only c.d.f. could be --- defined for both discrete and continous distributions. +-- defined for both discrete and continuous distributions. class Distribution d where -- | Cumulative distribution function. The probability that a -- random variable /X/ is less or equal than /x/, - -- i.e. P(/X/≤/x/). Cumulative should be defined for + -- i.e. P(/X/≤/x/). Cumulative should be defined for -- infinities as well: -- -- > cumulative d +∞ = 1 -- > cumulative d -∞ = 0 cumulative :: d -> Double -> Double - - -- | One's complement of cumulative distibution: + cumulative d x = 1 - complCumulative d x + -- | One's complement of cumulative distribution: -- -- > complCumulative d x = 1 - cumulative d x -- @@ -63,45 +64,50 @@ -- encouraged to provide more precise implementation. complCumulative :: d -> Double -> Double complCumulative d x = 1 - cumulative d x + {-# MINIMAL (cumulative | complCumulative) #-} + -- | Discrete probability distribution. class Distribution d => DiscreteDistr d where -- | Probability of n-th outcome. probability :: d -> Int -> Double probability d = exp . logProbability d - -- | Logarithm of probability of n-th outcome logProbability :: d -> Int -> Double logProbability d = log . probability d - + {-# MINIMAL (probability | logProbability) #-} --- | Continuous probability distributuion. +-- | Continuous probability distribution. -- -- Minimal complete definition is 'quantile' and either 'density' or -- 'logDensity'. class Distribution d => ContDistr d where -- | Probability density function. Probability that random -- variable /X/ lies in the infinitesimal interval - -- [/x/,/x+/δ/x/) equal to /density(x)/⋅δ/x/ + -- [/x/,/x+/δ/x/) equal to /density(x)/⋅δ/x/ density :: d -> Double -> Double density d = exp . logDensity d - - -- | Inverse of the cumulative distribution function. The value - -- /x/ for which P(/X/≤/x/) = /p/. If probability is outside - -- of [0,1] range function should call 'error' - quantile :: d -> Double -> Double - -- | Natural logarithm of density. logDensity :: d -> Double -> Double logDensity d = log . density d - + -- | Inverse of the cumulative distribution function. The value + -- /x/ for which P(/X/≤/x/) = /p/. If probability is outside + -- of [0,1] range function should call 'error' + quantile :: d -> Double -> Double + quantile d x = complQuantile d (1 - x) + -- | 1-complement of @quantile@: + -- + -- > complQuantile x ≡ quantile (1 - x) + complQuantile :: d -> Double -> Double + complQuantile d x = quantile d (1 - x) + {-# MINIMAL (density | logDensity), (quantile | complQuantile) #-} -- | Type class for distributions with mean. 'maybeMean' should return -- 'Nothing' if it's undefined for current value of data class Distribution d => MaybeMean d where maybeMean :: d -> Maybe Double --- | Type class for distributions with mean. If distribution have +-- | Type class for distributions with mean. If a distribution has -- finite mean for all valid values of parameters it should be -- instance of this type class. class MaybeMean d => Mean d where @@ -116,11 +122,12 @@ -- Minimal complete definition is 'maybeVariance' or 'maybeStdDev' class MaybeMean d => MaybeVariance d where maybeVariance :: d -> Maybe Double - maybeVariance d = (*) <$> x <*> x where x = maybeStdDev d + maybeVariance = fmap square . maybeStdDev maybeStdDev :: d -> Maybe Double - maybeStdDev = fmap sqrt . maybeVariance + maybeStdDev = fmap sqrt . maybeVariance + {-# MINIMAL (maybeVariance | maybeStdDev) #-} --- | Type class for distributions with variance. If distibution have +-- | Type class for distributions with variance. If distribution have -- finite variance for all valid parameter values it should be -- instance of this type class. -- @@ -130,7 +137,9 @@ variance d = square (stdDev d) stdDev :: d -> Double stdDev = sqrt . variance + {-# MINIMAL (variance | stdDev) #-} + -- | Type class for distributions with entropy, meaning Shannon entropy -- in the case of a discrete distribution, or differential entropy in the -- case of a continuous one. 'maybeEntropy' should return 'Nothing' if @@ -151,19 +160,29 @@ -- | Generate discrete random variates which have given -- distribution. class Distribution d => ContGen d where - genContVar :: PrimMonad m => d -> Gen (PrimState m) -> m Double + genContVar :: (StatefulGen g m) => d -> g -> m Double -- | Generate discrete random variates which have given -- distribution. 'ContGen' is superclass because it's always possible -- to generate real-valued variates from integer values class (DiscreteDistr d, ContGen d) => DiscreteGen d where - genDiscreteVar :: PrimMonad m => d -> Gen (PrimState m) -> m Int + genDiscreteVar :: (StatefulGen g m) => d -> g -> m Int --- | Generate variates from continous distribution using inverse +-- | Estimate distribution from sample. First parameter in sample is +-- distribution type and second is element type. +class FromSample d a where + -- | Estimate distribution from sample. Returns 'Nothing' if there is + -- not enough data, or if no usable fit results from the method + -- used, e.g., the estimated distribution parameters would be + -- invalid or inaccurate. + fromSample :: G.Vector v a => v a -> Maybe d + + +-- | Generate variates from continuous distribution using inverse -- transform rule. -genContinous :: (ContDistr d, PrimMonad m) => d -> Gen (PrimState m) -> m Double -genContinous d gen = do - x <- uniform gen +genContinuous :: (ContDistr d, StatefulGen g m) => d -> g -> m Double +genContinuous d gen = do + x <- uniformDouble01M gen return $! quantile d x data P = P {-# UNPACK #-} !Double {-# UNPACK #-} !Double @@ -203,6 +222,6 @@ -- | Sum probabilities in inclusive interval. sumProbabilities :: DiscreteDistr d => d -> Int -> Int -> Double sumProbabilities d low hi = - -- Return value is forced to be less than 1 to guard againist roundoff errors. + -- Return value is forced to be less than 1 to guard against roundoff errors. -- ATTENTION! this check should be removed for testing or it could mask bugs. min 1 . sum . U.map (probability d) $ U.enumFromTo low hi diff --git a/Statistics/Distribution/Beta.hs b/Statistics/Distribution/Beta.hs --- a/Statistics/Distribution/Beta.hs +++ b/Statistics/Distribution/Beta.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | @@ -14,62 +15,118 @@ ( BetaDistribution -- * Constructor , betaDistr + , betaDistrE , improperBetaDistr + , improperBetaDistrE -- * Accessors , bdAlpha , bdBeta ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) import Numeric.SpecFunctions ( - incompleteBeta, invIncompleteBeta, logBeta, digamma) -import Numeric.MathFunctions.Constants (m_NaN) + incompleteBeta, invIncompleteBeta, logBeta, digamma, log1p) +import Numeric.MathFunctions.Constants (m_NaN,m_neg_inf) import qualified Statistics.Distribution as D -import Data.Binary (put, get) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal + -- | The beta distribution data BetaDistribution = BD { bdAlpha :: {-# UNPACK #-} !Double -- ^ Alpha shape parameter , bdBeta :: {-# UNPACK #-} !Double -- ^ Beta shape parameter - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON BetaDistribution +instance Show BetaDistribution where + showsPrec n (BD a b) = defaultShow2 "improperBetaDistr" a b n +instance Read BetaDistribution where + readPrec = defaultReadPrecM2 "improperBetaDistr" improperBetaDistrE + instance ToJSON BetaDistribution +instance FromJSON BetaDistribution where + parseJSON (Object v) = do + a <- v .: "bdAlpha" + b <- v .: "bdBeta" + maybe (fail $ errMsgI a b) return $ improperBetaDistrE a b + parseJSON _ = empty instance Binary BetaDistribution where - put (BD x y) = put x >> put y - get = BD <$> get <*> get + put (BD a b) = put a >> put b + get = do + a <- get + b <- get + maybe (fail $ errMsgI a b) return $ improperBetaDistrE a b + -- | Create beta distribution. Both shape parameters must be positive. betaDistr :: Double -- ^ Shape parameter alpha -> Double -- ^ Shape parameter beta -> BetaDistribution -betaDistr a b - | a > 0 && b > 0 = improperBetaDistr a b - | otherwise = - error $ "Statistics.Distribution.Beta.betaDistr: " - ++ "shape parameters must be positive. Got a = " - ++ show a - ++ " b = " - ++ show b +betaDistr a b = maybe (error $ errMsg a b) id $ betaDistrE a b --- | Create beta distribution. This construtor doesn't check parameters. +-- | Create beta distribution. Both shape parameters must be positive. +betaDistrE :: Double -- ^ Shape parameter alpha + -> Double -- ^ Shape parameter beta + -> Maybe BetaDistribution +betaDistrE a b + | a > 0 && b > 0 = Just (BD a b) + | otherwise = Nothing + +errMsg :: Double -> Double -> String +errMsg a b = "Statistics.Distribution.Beta.betaDistr: " + ++ "shape parameters must be positive. Got a = " + ++ show a + ++ " b = " + ++ show b + + +-- | Create beta distribution. Both shape parameters must be +-- non-negative. So it allows to construct improper beta distribution +-- which could be used as improper prior. improperBetaDistr :: Double -- ^ Shape parameter alpha -> Double -- ^ Shape parameter beta -> BetaDistribution -improperBetaDistr = BD +improperBetaDistr a b + = maybe (error $ errMsgI a b) id $ improperBetaDistrE a b +-- | Create beta distribution. Both shape parameters must be +-- non-negative. So it allows to construct improper beta distribution +-- which could be used as improper prior. +improperBetaDistrE :: Double -- ^ Shape parameter alpha + -> Double -- ^ Shape parameter beta + -> Maybe BetaDistribution +improperBetaDistrE a b + | a >= 0 && b >= 0 = Just (BD a b) + | otherwise = Nothing + +errMsgI :: Double -> Double -> String +errMsgI a b + = "Statistics.Distribution.Beta.betaDistr: " + ++ "shape parameters must be non-negative. Got a = " ++ show a + ++ " b = " ++ show b + + + instance D.Distribution BetaDistribution where cumulative (BD a b) x | x <= 0 = 0 | x >= 1 = 1 | otherwise = incompleteBeta a b x + complCumulative (BD a b) x + | x <= 0 = 1 + | x >= 1 = 0 + -- For small x we use direct computation to avoid precision loss + -- when computing (1-x) + | x < 0.5 = 1 - incompleteBeta a b x + -- Otherwise we use property of incomplete beta: + -- > I(x,a,b) = 1 - I(1-x,b,a) + | otherwise = incompleteBeta b a (1-x) instance D.Mean BetaDistribution where mean (BD a b) = a / (a + b) @@ -96,10 +153,15 @@ instance D.ContDistr BetaDistribution where density (BD a b) x - | a <= 0 || b <= 0 = m_NaN - | x <= 0 = 0 - | x >= 1 = 0 - | otherwise = exp $ (a-1)*log x + (b-1)*log (1-x) - logBeta a b + | a <= 0 || b <= 0 = m_NaN + | x <= 0 = 0 + | x >= 1 = 0 + | otherwise = exp $ (a-1)*log x + (b-1) * log1p (-x) - logBeta a b + logDensity (BD a b) x + | a <= 0 || b <= 0 = m_NaN + | x <= 0 = m_neg_inf + | x >= 1 = m_neg_inf + | otherwise = (a-1)*log x + (b-1)*log1p (-x) - logBeta a b quantile (BD a b) p | p == 0 = 0 @@ -109,4 +171,4 @@ error $ "Statistics.Distribution.Gamma.quantile: p must be in [0,1] range. Got: "++show p instance D.ContGen BetaDistribution where - genContVar = D.genContinous + genContVar = D.genContinuous diff --git a/Statistics/Distribution/Binomial.hs b/Statistics/Distribution/Binomial.hs --- a/Statistics/Distribution/Binomial.hs +++ b/Statistics/Distribution/Binomial.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Binomial @@ -18,21 +20,23 @@ BinomialDistribution -- * Constructors , binomial + , binomialE -- * Accessors , bdTrials , bdProbability ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.SpecFunctions (choose,logChoose,incompleteBeta,log1p) +import Numeric.MathFunctions.Constants (m_epsilon,m_tiny) + import qualified Statistics.Distribution as D import qualified Statistics.Distribution.Poisson.Internal as I -import Numeric.SpecFunctions (choose,incompleteBeta) -import Numeric.MathFunctions.Constants (m_epsilon) -import Data.Binary (put, get) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal -- | The binomial distribution. @@ -41,20 +45,37 @@ -- ^ Number of trials. , bdProbability :: {-# UNPACK #-} !Double -- ^ Probability. - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON BinomialDistribution +instance Show BinomialDistribution where + showsPrec i (BD n p) = defaultShow2 "binomial" n p i +instance Read BinomialDistribution where + readPrec = defaultReadPrecM2 "binomial" binomialE + instance ToJSON BinomialDistribution +instance FromJSON BinomialDistribution where + parseJSON (Object v) = do + n <- v .: "bdTrials" + p <- v .: "bdProbability" + maybe (fail $ errMsg n p) return $ binomialE n p + parseJSON _ = empty instance Binary BinomialDistribution where - put (BD x y) = put x >> put y - get = BD <$> get <*> get + put (BD x y) = put x >> put y + get = do + n <- get + p <- get + maybe (fail $ errMsg n p) return $ binomialE n p + + instance D.Distribution BinomialDistribution where cumulative = cumulative + complCumulative = complCumulative instance D.DiscreteDistr BinomialDistribution where - probability = probability + probability = probability + logProbability = logProbability instance D.Mean BinomialDistribution where mean = mean @@ -83,9 +104,30 @@ probability (BD n p) k | k < 0 || k > n = 0 | n == 0 = 1 - | otherwise = choose n k * p^k * (1-p)^(n-k) + -- choose could overflow Double for n >= 1030 so we switch to + -- log-domain to calculate probability + -- + -- We also want to avoid underflow when computing p^k & + -- (1-p)^(n-k). + | n < 1000 + , pK >= m_tiny + , pNK >= m_tiny = choose n k * pK * pNK + | otherwise = exp $ logChoose n k + log p * k' + log1p (-p) * nk' + where + pK = p^k + pNK = (1-p)^(n-k) + k' = fromIntegral k + nk' = fromIntegral $ n - k --- Summation from different sides required to reduce roundoff errors +logProbability :: BinomialDistribution -> Int -> Double +logProbability (BD n p) k + | k < 0 || k > n = (-1)/0 + | n == 0 = 0 + | otherwise = logChoose n k + log p * k' + log1p (-p) * nk' + where + k' = fromIntegral k + nk' = fromIntegral $ n - k + cumulative :: BinomialDistribution -> Double -> Double cumulative (BD n p) x | isNaN x = error "Statistics.Distribution.Binomial.cumulative: NaN input" @@ -96,6 +138,16 @@ where k = floor x +complCumulative :: BinomialDistribution -> Double -> Double +complCumulative (BD n p) x + | isNaN x = error "Statistics.Distribution.Binomial.complCumulative: NaN input" + | isInfinite x = if x > 0 then 0 else 1 + | k < 0 = 1 + | k >= n = 0 + | otherwise = incompleteBeta (fromIntegral (k+1)) (fromIntegral (n-k)) p + where + k = floor x + mean :: BinomialDistribution -> Double mean (BD n p) = fromIntegral n * p @@ -114,10 +166,19 @@ binomial :: Int -- ^ Number of trials. -> Double -- ^ Probability. -> BinomialDistribution -binomial n p - | n < 0 = - error $ msg ++ "number of trials must be non-negative. Got " ++ show n - | p < 0 || p > 1 = - error $ msg++"probability must be in [0,1] range. Got " ++ show p - | otherwise = BD n p - where msg = "Statistics.Distribution.Binomial.binomial: " +binomial n p = maybe (error $ errMsg n p) id $ binomialE n p + +-- | Construct binomial distribution. Number of trials must be +-- non-negative and probability must be in [0,1] range +binomialE :: Int -- ^ Number of trials. + -> Double -- ^ Probability. + -> Maybe BinomialDistribution +binomialE n p + | n < 0 = Nothing + | p >= 0 && p <= 1 = Just (BD n p) + | otherwise = Nothing + +errMsg :: Int -> Double -> String +errMsg n p + = "Statistics.Distribution.Binomial.binomial: n=" ++ show n + ++ " p=" ++ show p ++ "but n>=0 and p in [0,1]" diff --git a/Statistics/Distribution/CauchyLorentz.hs b/Statistics/Distribution/CauchyLorentz.hs --- a/Statistics/Distribution/CauchyLorentz.hs +++ b/Statistics/Distribution/CauchyLorentz.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.CauchyLorentz @@ -18,16 +19,18 @@ , cauchyDistribScale -- * Constructors , cauchyDistribution + , cauchyDistributionE , standardCauchy ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Maybe (fromMaybe) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) import qualified Statistics.Distribution as D -import Data.Binary (put, get) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal -- | Cauchy-Lorentz distribution. data CauchyDistribution = CD { @@ -40,43 +43,97 @@ -- maximum (HWHM). , cauchyDistribScale :: {-# UNPACK #-} !Double } - deriving (Eq, Show, Read, Typeable, Data, Generic) + deriving (Eq, Typeable, Data, Generic) -instance FromJSON CauchyDistribution -instance ToJSON CauchyDistribution +instance Show CauchyDistribution where + showsPrec i (CD m s) = defaultShow2 "cauchyDistribution" m s i +instance Read CauchyDistribution where + readPrec = defaultReadPrecM2 "cauchyDistribution" cauchyDistributionE +instance ToJSON CauchyDistribution +instance FromJSON CauchyDistribution where + parseJSON (Object v) = do + m <- v .: "cauchyDistribMedian" + s <- v .: "cauchyDistribScale" + maybe (fail $ errMsg m s) return $ cauchyDistributionE m s + parseJSON _ = empty + instance Binary CauchyDistribution where - put (CD x y) = put x >> put y - get = CD <$> get <*> get + put (CD m s) = put m >> put s + get = do + m <- get + s <- get + maybe (error $ errMsg m s) return $ cauchyDistributionE m s + -- | Cauchy distribution cauchyDistribution :: Double -- ^ Central point -> Double -- ^ Scale parameter (FWHM) -> CauchyDistribution cauchyDistribution m s - | s > 0 = CD m s - | otherwise = - error $ "Statistics.Distribution.CauchyLorentz.cauchyDistribution: FWHM must be positive. Got " ++ show s + = fromMaybe (error $ errMsg m s) + $ cauchyDistributionE m s + +-- | Cauchy distribution +cauchyDistributionE :: Double -- ^ Central point + -> Double -- ^ Scale parameter (FWHM) + -> Maybe CauchyDistribution +cauchyDistributionE m s + | s > 0 = Just (CD m s) + | otherwise = Nothing + +errMsg :: Double -> Double -> String +errMsg _ s + = "Statistics.Distribution.CauchyLorentz.cauchyDistribution: FWHM must be positive. Got " + ++ show s + +-- | Standard Cauchy distribution. It's centered at 0 and have 1 FWHM standardCauchy :: CauchyDistribution standardCauchy = CD 0 1 instance D.Distribution CauchyDistribution where - cumulative (CD m s) x = 0.5 + atan( (x - m) / s ) / pi + cumulative (CD m s) x + | y < -1 = atan (-1/y) / pi + | otherwise = 0.5 + atan y / pi + where + y = (x - m) / s + complCumulative (CD m s) x + | y > 1 = atan (1/y) / pi + | otherwise = 0.5 - atan y / pi + where + y = (x - m) / s instance D.ContDistr CauchyDistribution where density (CD m s) x = (1 / pi) / (s * (1 + y*y)) where y = (x - m) / s quantile (CD m s) p - | p > 0 && p < 1 = m + s * tan( pi * (p - 0.5) ) - | p == 0 = -1 / 0 - | p == 1 = 1 / 0 - | otherwise = - error $ "Statistics.Distribution.CauchyLorentz..quantile: p must be in [0,1] range. Got: "++show p + | p == 0 = -1 / 0 + | p == 1 = 1 / 0 + | p == 0.5 = m + | p < 0 = err + | p < 0.5 = m - s / tan( pi * p ) + | p < 1 = m + s / tan( pi * (1 - p) ) + | otherwise = err + where + err = error + $ "Statistics.Distribution.CauchyLorentz.quantile: p must be in [0,1] range. Got: "++show p + complQuantile (CD m s) p + | p == 0 = 1 / 0 + | p == 1 = -1 / 0 + | p == 0.5 = m + | p < 0 = err + | p < 0.5 = m + s / tan( pi * p ) + | p < 1 = m - s / tan( pi * (1 - p) ) + | otherwise = err + where + err = error + $ "Statistics.Distribution.CauchyLorentz.quantile: p must be in [0,1] range. Got: "++show p + instance D.ContGen CauchyDistribution where - genContVar = D.genContinous + genContVar = D.genContinuous instance D.Entropy CauchyDistribution where entropy (CD _ s) = log s + log (4*pi) diff --git a/Statistics/Distribution/ChiSquared.hs b/Statistics/Distribution/ChiSquared.hs --- a/Statistics/Distribution/ChiSquared.hs +++ b/Statistics/Distribution/ChiSquared.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.ChiSquared @@ -13,51 +14,86 @@ -- distributions. It's commonly used in statistical tests module Statistics.Distribution.ChiSquared ( ChiSquared - -- Constructors - , chiSquared , chiSquaredNDF + -- * Constructors + , chiSquared + , chiSquaredE ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) -import Numeric.SpecFunctions ( - incompleteGamma,invIncompleteGamma,logGamma,digamma) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.SpecFunctions ( incompleteGamma,invIncompleteGamma,logGamma,digamma) +import Numeric.MathFunctions.Constants (m_neg_inf) +import qualified System.Random.MWC.Distributions as MWC import qualified Statistics.Distribution as D -import qualified System.Random.MWC.Distributions as MWC -import Data.Binary (put, get) +import Statistics.Internal + -- | Chi-squared distribution -newtype ChiSquared = ChiSquared Int - deriving (Eq, Read, Show, Typeable, Data, Generic) +newtype ChiSquared = ChiSquared + { chiSquaredNDF :: Int + -- ^ Get number of degrees of freedom + } + deriving (Eq, Typeable, Data, Generic) -instance FromJSON ChiSquared +instance Show ChiSquared where + showsPrec i (ChiSquared n) = defaultShow1 "chiSquared" n i +instance Read ChiSquared where + readPrec = defaultReadPrecM1 "chiSquared" chiSquaredE + instance ToJSON ChiSquared +instance FromJSON ChiSquared where + parseJSON (Object v) = do + n <- v .: "chiSquaredNDF" + maybe (fail $ errMsg n) return $ chiSquaredE n + parseJSON _ = empty instance Binary ChiSquared where - get = fmap ChiSquared get - put (ChiSquared x) = put x + put (ChiSquared x) = put x + get = do n <- get + maybe (fail $ errMsg n) return $ chiSquaredE n --- | Get number of degrees of freedom -chiSquaredNDF :: ChiSquared -> Int -chiSquaredNDF (ChiSquared ndf) = ndf -- | Construct chi-squared distribution. Number of degrees of freedom -- must be positive. chiSquared :: Int -> ChiSquared -chiSquared n - | n <= 0 = error $ - "Statistics.Distribution.ChiSquared.chiSquared: N.D.F. must be positive. Got " ++ show n - | otherwise = ChiSquared n +chiSquared n = maybe (error $ errMsg n) id $ chiSquaredE n +-- | Construct chi-squared distribution. Number of degrees of freedom +-- must be positive. +chiSquaredE :: Int -> Maybe ChiSquared +chiSquaredE n + | n <= 0 = Nothing + | otherwise = Just (ChiSquared n) + +errMsg :: Int -> String +errMsg n = "Statistics.Distribution.ChiSquared.chiSquared: N.D.F. must be positive. Got " ++ show n + instance D.Distribution ChiSquared where cumulative = cumulative instance D.ContDistr ChiSquared where - density = density + density chi x + | x <= 0 = 0 + | otherwise = exp $ log x * (ndf2 - 1) - x2 - logGamma ndf2 - log 2 * ndf2 + where + ndf = fromIntegral $ chiSquaredNDF chi + ndf2 = ndf/2 + x2 = x/2 + + logDensity chi x + | x <= 0 = m_neg_inf + | otherwise = log x * (ndf2 - 1) - x2 - logGamma ndf2 - log 2 * ndf2 + where + ndf = fromIntegral $ chiSquaredNDF chi + ndf2 = ndf/2 + x2 = x/2 + quantile = quantile instance D.Mean ChiSquared where @@ -94,15 +130,6 @@ | otherwise = incompleteGamma (ndf/2) (x/2) where ndf = fromIntegral $ chiSquaredNDF chi - -density :: ChiSquared -> Double -> Double -density chi x - | x <= 0 = 0 - | otherwise = exp $ log x * (ndf2 - 1) - x2 - logGamma ndf2 - log 2 * ndf2 - where - ndf = fromIntegral $ chiSquaredNDF chi - ndf2 = ndf/2 - x2 = x/2 quantile :: ChiSquared -> Double -> Double quantile (ChiSquared ndf) p diff --git a/Statistics/Distribution/DiscreteUniform.hs b/Statistics/Distribution/DiscreteUniform.hs new file mode 100644 --- /dev/null +++ b/Statistics/Distribution/DiscreteUniform.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings #-} +-- | +-- Module : Statistics.Distribution.DiscreteUniform +-- Copyright : (c) 2016 André Szabolcs Szelp +-- License : BSD3 +-- +-- Maintainer : a.sz.szelp@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The discrete uniform distribution. There are two parametrizations of +-- this distribution. First is the probability distribution on an +-- inclusive interval {1, ..., n}. This is parametrized with n only, +-- where p_1, ..., p_n = 1/n. ('discreteUniform'). +-- +-- The second parametrization is the uniform distribution on {a, ..., b} with +-- probabilities p_a, ..., p_b = 1/(a-b+1). This is parametrized with +-- /a/ and /b/. ('discreteUniformAB') + +module Statistics.Distribution.DiscreteUniform + ( + DiscreteUniform + -- * Constructors + , discreteUniform + , discreteUniformAB + -- * Accessors + , rangeFrom + , rangeTo + ) where + +import Control.Applicative (empty) +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import System.Random.Stateful (uniformRM) +import GHC.Generics (Generic) + +import qualified Statistics.Distribution as D +import Statistics.Internal + + + +-- | The discrete uniform distribution. +data DiscreteUniform = U { + rangeFrom :: {-# UNPACK #-} !Int + -- ^ /a/, the lower bound of the support {a, ..., b} + , rangeTo :: {-# UNPACK #-} !Int + -- ^ /b/, the upper bound of the support {a, ..., b} + } deriving (Eq, Typeable, Data, Generic) + +instance Show DiscreteUniform where + showsPrec i (U a b) = defaultShow2 "discreteUniformAB" a b i +instance Read DiscreteUniform where + readPrec = defaultReadPrecM2 "discreteUniformAB" (\a b -> Just (discreteUniformAB a b)) + +instance ToJSON DiscreteUniform +instance FromJSON DiscreteUniform where + parseJSON (Object v) = do + a <- v .: "uniformA" + b <- v .: "uniformB" + return $ discreteUniformAB a b + parseJSON _ = empty + +instance Binary DiscreteUniform where + put (U a b) = put a >> put b + get = discreteUniformAB <$> get <*> get + +instance D.Distribution DiscreteUniform where + cumulative (U a b) x + | x < fromIntegral a = 0 + | x > fromIntegral b = 1 + | otherwise = fromIntegral (floor x - a + 1) / fromIntegral (b - a + 1) + +instance D.DiscreteDistr DiscreteUniform where + probability (U a b) k + | k >= a && k <= b = 1 / fromIntegral (b - a + 1) + | otherwise = 0 + +instance D.Mean DiscreteUniform where + mean (U a b) = fromIntegral (a+b)/2 + +instance D.Variance DiscreteUniform where + variance (U a b) = (fromIntegral (b - a + 1)^(2::Int) - 1) / 12 + +instance D.MaybeMean DiscreteUniform where + maybeMean = Just . D.mean + +instance D.MaybeVariance DiscreteUniform where + maybeStdDev = Just . D.stdDev + maybeVariance = Just . D.variance + +instance D.Entropy DiscreteUniform where + entropy (U a b) = log $ fromIntegral $ b - a + 1 + +instance D.MaybeEntropy DiscreteUniform where + maybeEntropy = Just . D.entropy + +instance D.ContGen DiscreteUniform where + genContVar d = fmap fromIntegral . D.genDiscreteVar d + +instance D.DiscreteGen DiscreteUniform where + genDiscreteVar (U a b) = uniformRM (a,b) + +-- | Construct discrete uniform distribution on support {1, ..., n}. +-- Range /n/ must be >0. +discreteUniform :: Int -- ^ Range + -> DiscreteUniform +discreteUniform n + | n < 1 = error $ msg ++ "range must be > 0. Got " ++ show n + | otherwise = U 1 n + where msg = "Statistics.Distribution.DiscreteUniform.discreteUniform: " + +-- | Construct discrete uniform distribution on support {a, ..., b}. +discreteUniformAB :: Int -- ^ Lower boundary (inclusive) + -> Int -- ^ Upper boundary (inclusive) + -> DiscreteUniform +discreteUniformAB a b + | b < a = U b a + | otherwise = U a b diff --git a/Statistics/Distribution/Exponential.hs b/Statistics/Distribution/Exponential.hs --- a/Statistics/Distribution/Exponential.hs +++ b/Statistics/Distribution/Exponential.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Exponential @@ -8,8 +10,8 @@ -- Stability : experimental -- Portability : portable -- --- The exponential distribution. This is the continunous probability --- distribution of the times between events in a poisson process, in +-- The exponential distribution. This is the continuous probability +-- distribution of the times between events in a Poisson process, in -- which events occur continuously and independently at a constant -- average rate. @@ -18,33 +20,47 @@ ExponentialDistribution -- * Constructors , exponential - , exponentialFromSample + , exponentialE -- * Accessors , edLambda ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..),ToJSON,Value(..),(.:)) +import Data.Binary (Binary, put, get) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.SpecFunctions (log1p,expm1) import Numeric.MathFunctions.Constants (m_neg_inf) +import qualified System.Random.MWC.Distributions as MWC + import qualified Statistics.Distribution as D import qualified Statistics.Sample as S -import qualified System.Random.MWC.Distributions as MWC -import Statistics.Types (Sample) -import Data.Binary (put, get) +import Statistics.Internal + newtype ExponentialDistribution = ED { edLambda :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON ExponentialDistribution +instance Show ExponentialDistribution where + showsPrec n (ED l) = defaultShow1 "exponential" l n +instance Read ExponentialDistribution where + readPrec = defaultReadPrecM1 "exponential" exponentialE + instance ToJSON ExponentialDistribution +instance FromJSON ExponentialDistribution where + parseJSON (Object v) = do + l <- v .: "edLambda" + maybe (fail $ errMsg l) return $ exponentialE l + parseJSON _ = empty instance Binary ExponentialDistribution where - put = put . edLambda - get = fmap ED get + put = put . edLambda + get = do + l <- get + maybe (fail $ errMsg l) return $ exponentialE l instance D.Distribution ExponentialDistribution where cumulative = cumulative @@ -57,7 +73,8 @@ logDensity (ED l) x | x < 0 = m_neg_inf | otherwise = log l + (-l * x) - quantile = quantile + quantile = quantile + complQuantile = complQuantile instance D.Mean ExponentialDistribution where mean (ED l) = 1 / l @@ -83,7 +100,7 @@ cumulative :: ExponentialDistribution -> Double -> Double cumulative (ED l) x | x <= 0 = 0 - | otherwise = 1 - exp (-l * x) + | otherwise = - expm1 (-l * x) complCumulative :: ExponentialDistribution -> Double -> Double complCumulative (ED l) x | x <= 0 = 1 @@ -92,20 +109,35 @@ quantile :: ExponentialDistribution -> Double -> Double quantile (ED l) p - | p == 1 = 1 / 0 - | p >= 0 && p < 1 = -log (1 - p) / l + | p >= 0 && p <= 1 = - log1p(-p) / l + | otherwise = + error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p + +complQuantile :: ExponentialDistribution -> Double -> Double +complQuantile (ED l) p + | p == 0 = 0 + | p >= 0 && p < 1 = -log p / l | otherwise = error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p -- | Create an exponential distribution. exponential :: Double -- ^ Rate parameter. -> ExponentialDistribution -exponential l - | l <= 0 = - error $ "Statistics.Distribution.Exponential.exponential: scale parameter must be positive. Got " ++ show l - | otherwise = ED l +exponential l = maybe (error $ errMsg l) id $ exponentialE l --- | Create exponential distribution from sample. No tests are made to --- check whether it truly is exponential. -exponentialFromSample :: Sample -> ExponentialDistribution -exponentialFromSample = ED . S.mean +-- | Create an exponential distribution. +exponentialE :: Double -- ^ Rate parameter. + -> Maybe ExponentialDistribution +exponentialE l + | l > 0 = Just (ED l) + | otherwise = Nothing + +errMsg :: Double -> String +errMsg l = "Statistics.Distribution.Exponential.exponential: scale parameter must be positive. Got " ++ show l + +-- | Create exponential distribution from sample. Estimates the rate +-- with the maximum likelihood estimator, which is biased. Returns +-- @Nothing@ if the sample mean does not exist or is not positive. +instance D.FromSample ExponentialDistribution Double where + fromSample xs = let m = S.mean xs + in if m > 0 then Just (ED (1/m)) else Nothing diff --git a/Statistics/Distribution/FDistribution.hs b/Statistics/Distribution/FDistribution.hs --- a/Statistics/Distribution/FDistribution.hs +++ b/Statistics/Distribution/FDistribution.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.FDistribution @@ -11,49 +12,90 @@ -- Fisher F distribution module Statistics.Distribution.FDistribution ( FDistribution + -- * Constructors , fDistribution + , fDistributionE + , fDistributionReal + , fDistributionRealE + -- * Accessors , fDistributionNDF1 , fDistributionNDF2 ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.SpecFunctions ( + logBeta, incompleteBeta, invIncompleteBeta, digamma) import Numeric.MathFunctions.Constants (m_neg_inf) -import GHC.Generics (Generic) + import qualified Statistics.Distribution as D import Statistics.Function (square) -import Numeric.SpecFunctions ( - logBeta, incompleteBeta, invIncompleteBeta, digamma) -import Data.Binary (put, get) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal + -- | F distribution data FDistribution = F { fDistributionNDF1 :: {-# UNPACK #-} !Double , fDistributionNDF2 :: {-# UNPACK #-} !Double , _pdfFactor :: {-# UNPACK #-} !Double } - deriving (Eq, Show, Read, Typeable, Data, Generic) + deriving (Eq, Typeable, Data, Generic) -instance FromJSON FDistribution +instance Show FDistribution where + showsPrec i (F n m _) = defaultShow2 "fDistributionReal" n m i +instance Read FDistribution where + readPrec = defaultReadPrecM2 "fDistributionReal" fDistributionRealE + instance ToJSON FDistribution +instance FromJSON FDistribution where + parseJSON (Object v) = do + n <- v .: "fDistributionNDF1" + m <- v .: "fDistributionNDF2" + maybe (fail $ errMsgR n m) return $ fDistributionRealE n m + parseJSON _ = empty instance Binary FDistribution where - get = F <$> get <*> get <*> get - put (F x y z) = put x >> put y >> put z + put (F n m _) = put n >> put m + get = do + n <- get + m <- get + maybe (fail $ errMsgR n m) return $ fDistributionRealE n m fDistribution :: Int -> Int -> FDistribution -fDistribution n m +fDistribution n m = maybe (error $ errMsg n m) id $ fDistributionE n m + +fDistributionReal :: Double -> Double -> FDistribution +fDistributionReal n m = maybe (error $ errMsgR n m) id $ fDistributionRealE n m + +fDistributionE :: Int -> Int -> Maybe FDistribution +fDistributionE n m | n > 0 && m > 0 = let n' = fromIntegral n m' = fromIntegral m f' = 0.5 * (log m' * m' + log n' * n') - logBeta (0.5*n') (0.5*m') - in F n' m' f' - | otherwise = - error "Statistics.Distribution.FDistribution.fDistribution: non-positive number of degrees of freedom" + in Just $ F n' m' f' + | otherwise = Nothing +fDistributionRealE :: Double -> Double -> Maybe FDistribution +fDistributionRealE n m + | n > 0 && m > 0 = + let f' = 0.5 * (log m * m + log n * n) - logBeta (0.5*n) (0.5*m) + in Just $ F n m f' + | otherwise = Nothing + +errMsg :: Int -> Int -> String +errMsg _ _ = "Statistics.Distribution.FDistribution.fDistribution: non-positive number of degrees of freedom" + +errMsgR :: Double -> Double -> String +errMsgR _ _ = "Statistics.Distribution.FDistribution.fDistribution: non-positive number of degrees of freedom" + + + instance D.Distribution FDistribution where - cumulative = cumulative + cumulative = cumulative + complCumulative = complCumulative instance D.ContDistr FDistribution where density d x @@ -67,9 +109,37 @@ cumulative :: FDistribution -> Double -> Double cumulative (F n m _) x | x <= 0 = 0 - | isInfinite x = 1 -- Only matches +∞ - | otherwise = let y = n*x in incompleteBeta (0.5 * n) (0.5 * m) (y / (m + y)) + -- Only matches +∞ + | isInfinite x = 1 + -- NOTE: Here we rely on implementation detail of incompleteBeta. It + -- computes using series expansion for sufficiently small x + -- and uses following identity otherwise: + -- + -- I(x; a, b) = 1 - I(1-x; b, a) + -- + -- Point is we can compute 1-x as m/(m+y) without loss of + -- precision for large x. Sadly this switchover point is + -- implementation detail. + | n >= (n+m)*bx = incompleteBeta (0.5 * n) (0.5 * m) bx + | otherwise = 1 - incompleteBeta (0.5 * m) (0.5 * n) bx1 + where + y = n * x + bx = y / (m + y) + bx1 = m / (m + y) +complCumulative :: FDistribution -> Double -> Double +complCumulative (F n m _) x + | x <= 0 = 1 + -- Only matches +∞ + | isInfinite x = 0 + -- See NOTE at cumulative + | m >= (n+m)*bx = incompleteBeta (0.5 * m) (0.5 * n) bx + | otherwise = 1 - incompleteBeta (0.5 * n) (0.5 * m) bx1 + where + y = n*x + bx = m / (m + y) + bx1 = y / (m + y) + logDensity :: FDistribution -> Double -> Double logDensity (F n m fac) x = fac + log x * (0.5 * n - 1) - log(m + n*x) * 0.5 * (n + m) @@ -106,4 +176,4 @@ maybeEntropy = Just . D.entropy instance D.ContGen FDistribution where - genContVar = D.genContinous + genContVar = D.genContinuous diff --git a/Statistics/Distribution/Gamma.hs b/Statistics/Distribution/Gamma.hs --- a/Statistics/Distribution/Gamma.hs +++ b/Statistics/Distribution/Gamma.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Gamma @@ -19,55 +20,106 @@ GammaDistribution -- * Constructors , gammaDistr + , gammaDistrE , improperGammaDistr + , improperGammaDistrE -- * Accessors , gdShape , gdScale ) where -import Data.Aeson (FromJSON, ToJSON) -import Control.Applicative ((<$>), (<*>)) -import Data.Binary (Binary) -import Data.Binary (put, get) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) import Numeric.MathFunctions.Constants (m_pos_inf, m_NaN, m_neg_inf) import Numeric.SpecFunctions (incompleteGamma, invIncompleteGamma, logGamma, digamma) +import qualified System.Random.MWC.Distributions as MWC +import qualified Numeric.Sum as Sum + import Statistics.Distribution.Poisson.Internal as Poisson import qualified Statistics.Distribution as D -import qualified System.Random.MWC.Distributions as MWC +import Statistics.Internal + -- | The gamma distribution. data GammaDistribution = GD { gdShape :: {-# UNPACK #-} !Double -- ^ Shape parameter, /k/. , gdScale :: {-# UNPACK #-} !Double -- ^ Scale parameter, ϑ. - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON GammaDistribution +instance Show GammaDistribution where + showsPrec i (GD k theta) = defaultShow2 "improperGammaDistr" k theta i +instance Read GammaDistribution where + readPrec = defaultReadPrecM2 "improperGammaDistr" improperGammaDistrE + + instance ToJSON GammaDistribution +instance FromJSON GammaDistribution where + parseJSON (Object v) = do + k <- v .: "gdShape" + theta <- v .: "gdScale" + maybe (fail $ errMsgI k theta) return $ improperGammaDistrE k theta + parseJSON _ = empty instance Binary GammaDistribution where - put (GD x y) = put x >> put y - get = GD <$> get <*> get + put (GD x y) = put x >> put y + get = do + k <- get + theta <- get + maybe (fail $ errMsgI k theta) return $ improperGammaDistrE k theta + -- | Create gamma distribution. Both shape and scale parameters must -- be positive. gammaDistr :: Double -- ^ Shape parameter. /k/ -> Double -- ^ Scale parameter, ϑ. -> GammaDistribution gammaDistr k theta - | k <= 0 = error $ msg ++ "shape must be positive. Got " ++ show k - | theta <= 0 = error $ msg ++ "scale must be positive. Got " ++ show theta - | otherwise = improperGammaDistr k theta - where msg = "Statistics.Distribution.Gamma.gammaDistr: " + = maybe (error $ errMsg k theta) id $ gammaDistrE k theta --- | Create gamma distribution. This constructor do not check whether --- parameters are valid +errMsg :: Double -> Double -> String +errMsg k theta + = "Statistics.Distribution.Gamma.gammaDistr: " + ++ "k=" ++ show k + ++ "theta=" ++ show theta + ++ " but must be positive" + +-- | Create gamma distribution. Both shape and scale parameters must +-- be positive. +gammaDistrE :: Double -- ^ Shape parameter. /k/ + -> Double -- ^ Scale parameter, ϑ. + -> Maybe GammaDistribution +gammaDistrE k theta + | k > 0 && theta > 0 = Just (GD k theta) + | otherwise = Nothing + + +-- | Create gamma distribution. Both shape and scale parameters must +-- be non-negative. improperGammaDistr :: Double -- ^ Shape parameter. /k/ -> Double -- ^ Scale parameter, ϑ. -> GammaDistribution -improperGammaDistr = GD +improperGammaDistr k theta + = maybe (error $ errMsgI k theta) id $ improperGammaDistrE k theta +errMsgI :: Double -> Double -> String +errMsgI k theta + = "Statistics.Distribution.Gamma.gammaDistr: " + ++ "k=" ++ show k + ++ "theta=" ++ show theta + ++ " but must be non-negative" + +-- | Create gamma distribution. Both shape and scale parameters must +-- be non-negative. +improperGammaDistrE :: Double -- ^ Shape parameter. /k/ + -> Double -- ^ Scale parameter, ϑ. + -> Maybe GammaDistribution +improperGammaDistrE k theta + | k >= 0 && theta >= 0 = Just (GD k theta) + | otherwise = Nothing + instance D.Distribution GammaDistribution where cumulative = cumulative @@ -75,7 +127,11 @@ density = density logDensity (GD k theta) x | x <= 0 = m_neg_inf - | otherwise = log x * (k - 1) - (x / theta) - logGamma k - log theta * k + | otherwise = Sum.sum Sum.kbn [ log x * (k - 1) + , - (x / theta) + , - logGamma k + , - log theta * k + ] quantile = quantile instance D.Variance GammaDistribution where diff --git a/Statistics/Distribution/Geometric.hs b/Statistics/Distribution/Geometric.hs --- a/Statistics/Distribution/Geometric.hs +++ b/Statistics/Distribution/Geometric.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Geometric @@ -24,47 +25,67 @@ , GeometricDistribution0 -- * Constructors , geometric + , geometricE , geometric0 + , geometric0E -- ** Accessors , gdSuccess , gdSuccess0 ) where -import Data.Aeson (FromJSON, ToJSON) -import Control.Applicative ((<$>)) -import Control.Monad (liftM) -import Data.Binary (Binary) -import Data.Binary (put, get) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) -import Numeric.MathFunctions.Constants (m_pos_inf, m_neg_inf) -import qualified Statistics.Distribution as D +import Control.Applicative +import Control.Monad (liftM) +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.MathFunctions.Constants (m_neg_inf) +import Numeric.SpecFunctions (log1p,expm1) import qualified System.Random.MWC.Distributions as MWC +import qualified Statistics.Distribution as D +import Statistics.Internal + + + ---------------------------------------------------------------- --- Distribution over [1..] +-- | Distribution over [1..] newtype GeometricDistribution = GD { gdSuccess :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON GeometricDistribution +instance Show GeometricDistribution where + showsPrec i (GD x) = defaultShow1 "geometric" x i +instance Read GeometricDistribution where + readPrec = defaultReadPrecM1 "geometric" geometricE + instance ToJSON GeometricDistribution +instance FromJSON GeometricDistribution where + parseJSON (Object v) = do + x <- v .: "gdSuccess" + maybe (fail $ errMsg x) return $ geometricE x + parseJSON _ = empty instance Binary GeometricDistribution where - get = GD <$> get - put (GD x) = put x + put (GD x) = put x + get = do + x <- get + maybe (fail $ errMsg x) return $ geometricE x + instance D.Distribution GeometricDistribution where - cumulative = cumulative + cumulative = cumulative + complCumulative = complCumulative instance D.DiscreteDistr GeometricDistribution where probability (GD s) n | n < 1 = 0 - | otherwise = s * (1-s) ** (fromIntegral n - 1) + | s >= 0.5 = s * (1 - s)^(n - 1) + | otherwise = s * (exp $ log1p (-s) * (fromIntegral n - 1)) logProbability (GD s) n | n < 1 = m_neg_inf - | otherwise = log s + log (1-s) * (fromIntegral n - 1) + | otherwise = log s + log1p (-s) * (fromIntegral n - 1) instance D.Mean GeometricDistribution where @@ -82,9 +103,8 @@ instance D.Entropy GeometricDistribution where entropy (GD s) - | s == 0 = m_pos_inf | s == 1 = 0 - | otherwise = negate $ (s * log s + (1-s) * log (1-s)) / s + | otherwise = -(s * log s + (1-s) * log1p (-s)) / s instance D.MaybeEntropy GeometricDistribution where maybeEntropy = Just . D.entropy @@ -95,38 +115,70 @@ instance D.ContGen GeometricDistribution where genContVar d g = fromIntegral `liftM` D.genDiscreteVar d g --- | Create geometric distribution. -geometric :: Double -- ^ Success rate - -> GeometricDistribution -geometric x - | x >= 0 && x <= 1 = GD x - | otherwise = - error $ "Statistics.Distribution.Geometric.geometric: probability must be in [0,1] range. Got " ++ show x - cumulative :: GeometricDistribution -> Double -> Double cumulative (GD s) x | x < 1 = 0 | isInfinite x = 1 | isNaN x = error "Statistics.Distribution.Geometric.cumulative: NaN input" - | otherwise = 1 - (1-s) ^ (floor x :: Int) + | s >= 0.5 = 1 - (1 - s)^k + | otherwise = negate $ expm1 $ fromIntegral k * log1p (-s) + where k = floor x :: Int +complCumulative :: GeometricDistribution -> Double -> Double +complCumulative (GD s) x + | x < 1 = 1 + | isInfinite x = 0 + | isNaN x = error "Statistics.Distribution.Geometric.complCumulative: NaN input" + | s >= 0.5 = (1 - s)^k + | otherwise = exp $ fromIntegral k * log1p (-s) + where k = floor x :: Int + +-- | Create geometric distribution. +geometric :: Double -- ^ Success rate + -> GeometricDistribution +geometric x = maybe (error $ errMsg x) id $ geometricE x + +-- | Create geometric distribution. +geometricE :: Double -- ^ Success rate + -> Maybe GeometricDistribution +geometricE x + | x > 0 && x <= 1 = Just (GD x) + | otherwise = Nothing + +errMsg :: Double -> String +errMsg x = "Statistics.Distribution.Geometric.geometric: probability must be in (0,1] range. Got " ++ show x + + ---------------------------------------------------------------- --- Distribution over [0..] +-- | Distribution over [0..] newtype GeometricDistribution0 = GD0 { gdSuccess0 :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON GeometricDistribution0 +instance Show GeometricDistribution0 where + showsPrec i (GD0 x) = defaultShow1 "geometric0" x i +instance Read GeometricDistribution0 where + readPrec = defaultReadPrecM1 "geometric0" geometric0E + instance ToJSON GeometricDistribution0 +instance FromJSON GeometricDistribution0 where + parseJSON (Object v) = do + x <- v .: "gdSuccess0" + maybe (fail $ errMsg x) return $ geometric0E x + parseJSON _ = empty instance Binary GeometricDistribution0 where - get = GD0 <$> get - put (GD0 x) = put x + put (GD0 x) = put x + get = do + x <- get + maybe (fail $ errMsg x) return $ geometric0E x + instance D.Distribution GeometricDistribution0 where - cumulative (GD0 s) x = cumulative (GD s) (x + 1) + cumulative (GD0 s) x = cumulative (GD s) (x + 1) + complCumulative (GD0 s) x = complCumulative (GD s) (x + 1) instance D.DiscreteDistr GeometricDistribution0 where probability (GD0 s) n = D.probability (GD s) (n + 1) @@ -157,10 +209,18 @@ instance D.ContGen GeometricDistribution0 where genContVar d g = fromIntegral `liftM` D.genDiscreteVar d g + -- | Create geometric distribution. geometric0 :: Double -- ^ Success rate -> GeometricDistribution0 -geometric0 x - | x >= 0 && x <= 1 = GD0 x - | otherwise = - error $ "Statistics.Distribution.Geometric.geometric: probability must be in [0,1] range. Got " ++ show x +geometric0 x = maybe (error $ errMsg0 x) id $ geometric0E x + +-- | Create geometric distribution. +geometric0E :: Double -- ^ Success rate + -> Maybe GeometricDistribution0 +geometric0E x + | x > 0 && x <= 1 = Just (GD0 x) + | otherwise = Nothing + +errMsg0 :: Double -> String +errMsg0 x = "Statistics.Distribution.Geometric.geometric0: probability must be in (0,1] range. Got " ++ show x diff --git a/Statistics/Distribution/Hypergeometric.hs b/Statistics/Distribution/Hypergeometric.hs --- a/Statistics/Distribution/Hypergeometric.hs +++ b/Statistics/Distribution/Hypergeometric.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Hypergeometric @@ -21,40 +22,60 @@ HypergeometricDistribution -- * Constructors , hypergeometric + , hypergeometricE -- ** Accessors , hdM , hdL , hdK ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) -import Numeric.MathFunctions.Constants (m_epsilon) -import Numeric.SpecFunctions (choose) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.MathFunctions.Constants (m_epsilon,m_neg_inf) +import Numeric.SpecFunctions (choose,logChoose) + import qualified Statistics.Distribution as D -import Data.Binary (put, get) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal + data HypergeometricDistribution = HD { hdM :: {-# UNPACK #-} !Int , hdL :: {-# UNPACK #-} !Int , hdK :: {-# UNPACK #-} !Int - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON HypergeometricDistribution +instance Show HypergeometricDistribution where + showsPrec i (HD m l k) = defaultShow3 "hypergeometric" m l k i +instance Read HypergeometricDistribution where + readPrec = defaultReadPrecM3 "hypergeometric" hypergeometricE + instance ToJSON HypergeometricDistribution +instance FromJSON HypergeometricDistribution where + parseJSON (Object v) = do + m <- v .: "hdM" + l <- v .: "hdL" + k <- v .: "hdK" + maybe (fail $ errMsg m l k) return $ hypergeometricE m l k + parseJSON _ = empty instance Binary HypergeometricDistribution where - get = HD <$> get <*> get <*> get - put (HD x y z) = put x >> put y >> put z + put (HD m l k) = put m >> put l >> put k + get = do + m <- get + l <- get + k <- get + maybe (fail $ errMsg m l k) return $ hypergeometricE m l k instance D.Distribution HypergeometricDistribution where cumulative = cumulative + complCumulative = complCumulative instance D.DiscreteDistr HypergeometricDistribution where - probability = probability + probability = probability + logProbability = logProbability instance D.Mean HypergeometricDistribution where mean = mean @@ -86,11 +107,11 @@ mean (HD m l k) = fromIntegral k * fromIntegral m / fromIntegral l directEntropy :: HypergeometricDistribution -> Double -directEntropy d@(HD m _ _) = - negate . sum $ - takeWhile (< negate m_epsilon) $ - dropWhile (not . (< negate m_epsilon)) $ - [ let x = probability d n in x * log x | n <- [0..m]] +directEntropy d@(HD m _ _) + = negate . sum + $ takeWhile (< negate m_epsilon) + $ dropWhile (not . (< negate m_epsilon)) + [ let x = probability d n in x * log x | n <- [0..m]] hypergeometric :: Int -- ^ /m/ @@ -98,20 +119,45 @@ -> Int -- ^ /k/ -> HypergeometricDistribution hypergeometric m l k - | not (l > 0) = error $ msg ++ "l must be positive" - | not (m >= 0 && m <= l) = error $ msg ++ "m must lie in [0,l] range" - | not (k > 0 && k <= l) = error $ msg ++ "k must lie in (0,l] range" - | otherwise = HD m l k - where - msg = "Statistics.Distribution.Hypergeometric.hypergeometric: " + = maybe (error $ errMsg m l k) id $ hypergeometricE m l k +hypergeometricE :: Int -- ^ /m/ + -> Int -- ^ /l/ + -> Int -- ^ /k/ + -> Maybe HypergeometricDistribution +hypergeometricE m l k + | not (l > 0) = Nothing + | not (m >= 0 && m <= l) = Nothing + | not (k > 0 && k <= l) = Nothing + | otherwise = Just (HD m l k) + + +errMsg :: Int -> Int -> Int -> String +errMsg m l k + = "Statistics.Distribution.Hypergeometric.hypergeometric:" + ++ " m=" ++ show m + ++ " l=" ++ show l + ++ " k=" ++ show k + ++ " should hold: l>0 & m in [0,l] & k in (0,l]" + -- Naive implementation probability :: HypergeometricDistribution -> Int -> Double probability (HD mi li ki) n | n < max 0 (mi+ki-li) || n > min mi ki = 0 - | otherwise = - choose mi n * choose (li - mi) (ki - n) / choose li ki + -- No overflow + | li < 1000 = choose mi n * choose (li - mi) (ki - n) + / choose li ki + | otherwise = exp $ logChoose mi n + + logChoose (li - mi) (ki - n) + - logChoose li ki +logProbability :: HypergeometricDistribution -> Int -> Double +logProbability (HD mi li ki) n + | n < max 0 (mi+ki-li) || n > min mi ki = m_neg_inf + | otherwise = logChoose mi n + + logChoose (li - mi) (ki - n) + - logChoose li ki + cumulative :: HypergeometricDistribution -> Double -> Double cumulative d@(HD mi li ki) x | isNaN x = error "Statistics.Distribution.Hypergeometric.cumulative: NaN argument" @@ -119,6 +165,18 @@ | n < minN = 0 | n >= maxN = 1 | otherwise = D.sumProbabilities d minN n + where + n = floor x + minN = max 0 (mi+ki-li) + maxN = min mi ki + +complCumulative :: HypergeometricDistribution -> Double -> Double +complCumulative d@(HD mi li ki) x + | isNaN x = error "Statistics.Distribution.Hypergeometric.complCumulative: NaN argument" + | isInfinite x = if x > 0 then 0 else 1 + | n < minN = 1 + | n >= maxN = 0 + | otherwise = D.sumProbabilities d (n + 1) maxN where n = floor x minN = max 0 (mi+ki-li) diff --git a/Statistics/Distribution/Laplace.hs b/Statistics/Distribution/Laplace.hs --- a/Statistics/Distribution/Laplace.hs +++ b/Statistics/Distribution/Laplace.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Laplace @@ -15,28 +17,27 @@ -- recognition and least absolute deviations method (Laplace's first -- law of errors, giving a robust regression method) -- - module Statistics.Distribution.Laplace ( LaplaceDistribution -- * Constructors , laplace - , laplaceFromSample + , laplaceE -- * Accessors , ldLocation , ldScale ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary(..)) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) import qualified Data.Vector.Generic as G import qualified Statistics.Distribution as D import qualified Statistics.Quantile as Q import qualified Statistics.Sample as S -import Statistics.Types (Sample) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal data LaplaceDistribution = LD { @@ -44,14 +45,27 @@ -- ^ Location. , ldScale :: {-# UNPACK #-} !Double -- ^ Scale. - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON LaplaceDistribution +instance Show LaplaceDistribution where + showsPrec i (LD l s) = defaultShow2 "laplace" l s i +instance Read LaplaceDistribution where + readPrec = defaultReadPrecM2 "laplace" laplaceE + instance ToJSON LaplaceDistribution +instance FromJSON LaplaceDistribution where + parseJSON (Object v) = do + l <- v .: "ldLocation" + s <- v .: "ldScale" + maybe (fail $ errMsg l s) return $ laplaceE l s + parseJSON _ = empty instance Binary LaplaceDistribution where - put (LD l s) = put l >> put s - get = LD <$> get <*> get + put (LD l s) = put l >> put s + get = do + l <- get + s <- get + maybe (fail $ errMsg l s) return $ laplaceE l s instance D.Distribution LaplaceDistribution where cumulative = cumulative @@ -60,7 +74,8 @@ instance D.ContDistr LaplaceDistribution where density (LD l s) x = exp (- abs (x - l) / s) / (2 * s) logDensity (LD l s) x = - abs (x - l) / s - log 2 - log s - quantile = quantile + quantile = quantile + complQuantile = complQuantile instance D.Mean LaplaceDistribution where mean (LD l _) = l @@ -82,7 +97,7 @@ maybeEntropy = Just . D.entropy instance D.ContGen LaplaceDistribution where - genContVar = D.genContinous + genContVar = D.genContinuous cumulative :: LaplaceDistribution -> Double -> Double cumulative (LD l s) x @@ -106,20 +121,43 @@ where inf = 1 / 0 +complQuantile :: LaplaceDistribution -> Double -> Double +complQuantile (LD l s) p + | p == 0 = inf + | p == 1 = -inf + | p == 0.5 = l + | p > 0 && p < 0.5 = l - s * log (2 * p) + | p > 0.5 && p < 1 = l + s * log (2 - 2 * p) + | otherwise = + error $ "Statistics.Distribution.Laplace.quantile: p must be in [0,1] range. Got: "++show p + where + inf = 1 / 0 + -- | Create an Laplace distribution. laplace :: Double -- ^ Location -> Double -- ^ Scale -> LaplaceDistribution -laplace l s - | s <= 0 = - error $ "Statistics.Distribution.Laplace.laplace: scale parameter must be positive. Got " ++ show s - | otherwise = LD l s +laplace l s = maybe (error $ errMsg l s) id $ laplaceE l s --- | Create Laplace distribution from sample. No tests are made to --- check whether it truly is Laplace. Location of distribution --- estimated as median of sample. -laplaceFromSample :: Sample -> LaplaceDistribution -laplaceFromSample xs = LD s l - where - s = Q.continuousBy Q.medianUnbiased 1 2 xs - l = S.mean $ G.map (\x -> abs $ x - s) xs +-- | Create an Laplace distribution. +laplaceE :: Double -- ^ Location + -> Double -- ^ Scale + -> Maybe LaplaceDistribution +laplaceE l s + | s >= 0 = Just (LD l s) + | otherwise = Nothing + +errMsg :: Double -> Double -> String +errMsg _ s = "Statistics.Distribution.Laplace.laplace: scale parameter must be positive. Got " ++ show s + + +-- | Create Laplace distribution from sample. The location is estimated +-- as the median of the sample, and the scale as the mean absolute +-- deviation of the median. +instance D.FromSample LaplaceDistribution Double where + fromSample xs + | G.null xs = Nothing + | otherwise = Just $! LD s l + where + s = Q.median Q.medianUnbiased xs + l = S.mean $ G.map (\x -> abs $ x - s) xs diff --git a/Statistics/Distribution/Lognormal.hs b/Statistics/Distribution/Lognormal.hs new file mode 100644 --- /dev/null +++ b/Statistics/Distribution/Lognormal.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +-- | +-- Module : Statistics.Distribution.Lognormal +-- Copyright : (c) 2020 Ximin Luo +-- License : BSD3 +-- +-- Maintainer : infinity0@pwned.gg +-- Stability : experimental +-- Portability : portable +-- +-- The log normal distribution. This is a continuous probability +-- distribution that describes data whose log is clustered around a +-- mean. For example, the multiplicative product of many independent +-- positive random variables. + +module Statistics.Distribution.Lognormal + ( + LognormalDistribution + -- * Constructors + , lognormalDistr + , lognormalDistrErr + , lognormalDistrMeanStddevErr + , lognormalStandard + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Binary (Binary (..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.MathFunctions.Constants (m_huge, m_sqrt_2_pi) +import Numeric.SpecFunctions (expm1, log1p) +import qualified Data.Vector.Generic as G + +import qualified Statistics.Distribution as D +import qualified Statistics.Distribution.Normal as N +import Statistics.Internal + + +-- | The lognormal distribution. +newtype LognormalDistribution = LND N.NormalDistribution + deriving (Eq, Typeable, Data, Generic) + +instance Show LognormalDistribution where + showsPrec i (LND d) = defaultShow2 "lognormalDistr" m s i + where + m = D.mean d + s = D.stdDev d +instance Read LognormalDistribution where + readPrec = defaultReadPrecM2 "lognormalDistr" $ + (either (const Nothing) Just .) . lognormalDistrErr + +instance ToJSON LognormalDistribution +instance FromJSON LognormalDistribution + +instance Binary LognormalDistribution where + put (LND d) = put m >> put s + where + m = D.mean d + s = D.stdDev d + get = do + m <- get + sd <- get + either fail return $ lognormalDistrErr m sd + +instance D.Distribution LognormalDistribution where + cumulative = cumulative + complCumulative = complCumulative + +instance D.ContDistr LognormalDistribution where + logDensity = logDensity + quantile = quantile + complQuantile = complQuantile + +instance D.MaybeMean LognormalDistribution where + maybeMean = Just . D.mean + +instance D.Mean LognormalDistribution where + mean (LND d) = exp (m + v / 2) + where + m = D.mean d + v = D.variance d + +instance D.MaybeVariance LognormalDistribution where + maybeStdDev = Just . D.stdDev + maybeVariance = Just . D.variance + +instance D.Variance LognormalDistribution where + variance (LND d) = expm1 v * exp (2 * m + v) + where + m = D.mean d + v = D.variance d + +instance D.Entropy LognormalDistribution where + entropy (LND d) = logBase 2 (s * exp (m + 0.5) * m_sqrt_2_pi) + where + m = D.mean d + s = D.stdDev d + +instance D.MaybeEntropy LognormalDistribution where + maybeEntropy = Just . D.entropy + +instance D.ContGen LognormalDistribution where + genContVar d = D.genContinuous d + +-- | Standard log normal distribution with mu 0 and sigma 1. +-- +-- Mean is @sqrt e@ and variance is @(e - 1) * e@. +lognormalStandard :: LognormalDistribution +lognormalStandard = LND N.standard + +-- | Create log normal distribution from parameters. +lognormalDistr + :: Double -- ^ Mu + -> Double -- ^ Sigma + -> LognormalDistribution +lognormalDistr mu sig = either error id $ lognormalDistrErr mu sig + +-- | Create log normal distribution from parameters. +lognormalDistrErr + :: Double -- ^ Mu + -> Double -- ^ Sigma + -> Either String LognormalDistribution +lognormalDistrErr mu sig + | sig >= sqrt (log m_huge - 2 * mu) = Left $ errMsg mu sig + | otherwise = LND <$> N.normalDistrErr mu sig + +errMsg :: Double -> Double -> String +errMsg mu sig = + "Statistics.Distribution.Lognormal.lognormalDistr: sigma must be > 0 && < " + ++ show lim ++ ". Got " ++ show sig + where lim = sqrt (log m_huge - 2 * mu) + +-- | Create log normal distribution from mean and standard deviation. +lognormalDistrMeanStddevErr + :: Double -- ^ Mu + -> Double -- ^ Sigma + -> Either String LognormalDistribution +lognormalDistrMeanStddevErr m sd = LND <$> N.normalDistrErr mu sig + where r = sd / m + sig2 = log1p (r * r) + sig = sqrt sig2 + mu = log m - sig2 / 2 + +-- | Variance is estimated using maximum likelihood method +-- (biased estimation) over the log of the data. +-- +-- Returns @Nothing@ if sample contains less than one element or +-- variance is zero (all elements are equal) +instance D.FromSample LognormalDistribution Double where + fromSample = fmap LND . D.fromSample . G.map log + +logDensity :: LognormalDistribution -> Double -> Double +logDensity (LND d) x + | x > 0 = let lx = log x in D.logDensity d lx - lx + | otherwise = 0 + +cumulative :: LognormalDistribution -> Double -> Double +cumulative (LND d) x + | x > 0 = D.cumulative d $ log x + | otherwise = 0 + +complCumulative :: LognormalDistribution -> Double -> Double +complCumulative (LND d) x + | x > 0 = D.complCumulative d $ log x + | otherwise = 1 + +quantile :: LognormalDistribution -> Double -> Double +quantile (LND d) = exp . D.quantile d + +complQuantile :: LognormalDistribution -> Double -> Double +complQuantile (LND d) = exp . D.complQuantile d diff --git a/Statistics/Distribution/NegativeBinomial.hs b/Statistics/Distribution/NegativeBinomial.hs new file mode 100644 --- /dev/null +++ b/Statistics/Distribution/NegativeBinomial.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings, PatternGuards, + DeriveDataTypeable, DeriveGeneric #-} +-- | +-- Module : Statistics.Distribution.NegativeBinomial +-- Copyright : (c) 2022 Lorenz Minder +-- License : BSD3 +-- +-- Maintainer : lminder@gmx.net +-- Stability : experimental +-- Portability : portable +-- +-- The negative binomial distribution. This is the discrete probability +-- distribution of the number of failures in a sequence of independent +-- yes\/no experiments before a specified number of successes /r/. Each +-- Bernoulli trial has success probability /p/ in the range (0, 1]. The +-- parameter /r/ must be positive, but does not have to be integer. + +module Statistics.Distribution.NegativeBinomial ( + NegativeBinomialDistribution + -- * Constructors + , negativeBinomial + , negativeBinomialE + -- * Accessors + , nbdSuccesses + , nbdProbability +) where + +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import Data.Foldable (foldl') +import GHC.Generics (Generic) +import Numeric.SpecFunctions (incompleteBeta, log1p) +import Numeric.SpecFunctions.Extra (logChooseFast) +import Numeric.MathFunctions.Constants (m_epsilon, m_tiny) + +import qualified Statistics.Distribution as D +import Statistics.Internal + +-- Math helper functions + +-- | Generalized binomial coefficients. +-- +-- These computes binomial coefficients with the small generalization +-- that the /n/ need not be integer, but can be real. +gChoose :: Double -> Int -> Double +gChoose n k + | k < 0 = 0 + | k' >= 50 = exp $ logChooseFast n k' + | otherwise = foldl' (*) 1 factors + where factors = [ (n - k' + j) / j | j <- [1..k'] ] + k' = fromIntegral k + + +-- Implementation of Negative Binomial + +-- | The negative binomial distribution. +data NegativeBinomialDistribution = NBD { + nbdSuccesses :: {-# UNPACK #-} !Double + -- ^ Number of successes until stop + , nbdProbability :: {-# UNPACK #-} !Double + -- ^ Success probability. + } deriving (Eq, Typeable, Data, Generic) + +instance Show NegativeBinomialDistribution where + showsPrec i (NBD r p) = defaultShow2 "negativeBinomial" r p i +instance Read NegativeBinomialDistribution where + readPrec = defaultReadPrecM2 "negativeBinomial" negativeBinomialE + +instance ToJSON NegativeBinomialDistribution +instance FromJSON NegativeBinomialDistribution where + parseJSON (Object v) = do + r <- v .: "nbdSuccesses" + p <- v .: "nbdProbability" + maybe (fail $ errMsg r p) return $ negativeBinomialE r p + parseJSON _ = empty + +instance Binary NegativeBinomialDistribution where + put (NBD r p) = put r >> put p + get = do + r <- get + p <- get + maybe (fail $ errMsg r p) return $ negativeBinomialE r p + +instance D.Distribution NegativeBinomialDistribution where + cumulative = cumulative + complCumulative = complCumulative + +instance D.DiscreteDistr NegativeBinomialDistribution where + probability = probability + logProbability = logProbability + +instance D.Mean NegativeBinomialDistribution where + mean = mean + +instance D.Variance NegativeBinomialDistribution where + variance = variance + +instance D.MaybeMean NegativeBinomialDistribution where + maybeMean = Just . D.mean + +instance D.MaybeVariance NegativeBinomialDistribution where + maybeStdDev = Just . D.stdDev + maybeVariance = Just . D.variance + +instance D.Entropy NegativeBinomialDistribution where + entropy = directEntropy + +instance D.MaybeEntropy NegativeBinomialDistribution where + maybeEntropy = Just . D.entropy + +-- This could be slow for big n +probability :: NegativeBinomialDistribution -> Int -> Double +probability d@(NBD r p) k + | k < 0 = 0 + -- Switch to log domain for large k + r to avoid overflows. + -- + -- We also want to avoid underflow when computing (1-p)^k & + -- p^r. + | k' + r < 1000 + , pK >= m_tiny + , pR >= m_tiny = gChoose (k' + r - 1) k * pK * pR + | otherwise = exp $ logProbability d k + where + pK = exp $ log1p (-p) * k' + pR = p**r + k' = fromIntegral k + +logProbability :: NegativeBinomialDistribution -> Int -> Double +logProbability (NBD r p) k + | k < 0 = (-1)/0 + | otherwise = logChooseFast (k' + r - 1) k' + + log1p (-p) * k' + + log p * r + where k' = fromIntegral k + +cumulative :: NegativeBinomialDistribution -> Double -> Double +cumulative (NBD r p) x + | isNaN x = error "Statistics.Distribution.NegativeBinomial.cumulative: NaN input" + | isInfinite x = if x > 0 then 1 else 0 + | k < 0 = 0 + | otherwise = incompleteBeta r (fromIntegral (k+1)) p + where + k = floor x :: Integer + +complCumulative :: NegativeBinomialDistribution -> Double -> Double +complCumulative (NBD r p) x + | isNaN x = error "Statistics.Distribution.NegativeBinomial.complCumulative: NaN input" + | isInfinite x = if x > 0 then 0 else 1 + | k < 0 = 1 + | otherwise = incompleteBeta (fromIntegral (k+1)) r (1 - p) + where + k = floor x :: Integer + +mean :: NegativeBinomialDistribution -> Double +mean (NBD r p) = r * (1 - p)/p + +variance :: NegativeBinomialDistribution -> Double +variance (NBD r p) = r * (1 - p)/(p * p) + +directEntropy :: NegativeBinomialDistribution -> Double +directEntropy d = + negate . sum $ + takeWhile (< -m_epsilon) $ + dropWhile (>= -m_epsilon) $ + [ let x = probability d k in x * log x | k <- [0..]] + +-- | Construct negative binomial distribution. Number of successes /r/ +-- must be positive and probability must be in (0,1] range +negativeBinomial :: Double -- ^ Number of successes. + -> Double -- ^ Success probability. + -> NegativeBinomialDistribution +negativeBinomial r p = maybe (error $ errMsg r p) id $ negativeBinomialE r p + +-- | Construct negative binomial distribution. Number of successes /r/ +-- must be positive and probability must be in (0,1] range +negativeBinomialE :: Double -- ^ Number of successes. + -> Double -- ^ Success probability. + -> Maybe NegativeBinomialDistribution +negativeBinomialE r p + | r > 0 && 0 < p && p <= 1 = Just (NBD r p) + | otherwise = Nothing + +errMsg :: Double -> Double -> String +errMsg r p + = "Statistics.Distribution.NegativeBinomial.negativeBinomial: r=" ++ show r + ++ " p=" ++ show p ++ ", but need r>0 and p in (0,1]" diff --git a/Statistics/Distribution/Normal.hs b/Statistics/Distribution/Normal.hs --- a/Statistics/Distribution/Normal.hs +++ b/Statistics/Distribution/Normal.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Normal -- Copyright : (c) 2009 Bryan O'Sullivan @@ -16,44 +18,62 @@ NormalDistribution -- * Constructors , normalDistr - , normalFromSample + , normalDistrE + , normalDistrErr , standard ) where -import Data.Aeson (FromJSON, ToJSON) -import Control.Applicative ((<$>), (<*>)) -import Data.Binary (Binary) -import Data.Binary (put, get) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) import Numeric.MathFunctions.Constants (m_sqrt_2, m_sqrt_2_pi) import Numeric.SpecFunctions (erfc, invErfc) +import qualified System.Random.MWC.Distributions as MWC +import qualified Data.Vector.Generic as G + import qualified Statistics.Distribution as D import qualified Statistics.Sample as S -import qualified System.Random.MWC.Distributions as MWC +import Statistics.Internal + -- | The normal distribution. data NormalDistribution = ND { mean :: {-# UNPACK #-} !Double , stdDev :: {-# UNPACK #-} !Double , ndPdfDenom :: {-# UNPACK #-} !Double , ndCdfDenom :: {-# UNPACK #-} !Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON NormalDistribution +instance Show NormalDistribution where + showsPrec i (ND m s _ _) = defaultShow2 "normalDistr" m s i +instance Read NormalDistribution where + readPrec = defaultReadPrecM2 "normalDistr" normalDistrE + instance ToJSON NormalDistribution +instance FromJSON NormalDistribution where + parseJSON (Object v) = do + m <- v .: "mean" + sd <- v .: "stdDev" + either fail return $ normalDistrErr m sd + parseJSON _ = empty instance Binary NormalDistribution where - put (ND w x y z) = put w >> put x >> put y >> put z - get = ND <$> get <*> get <*> get <*> get + put (ND m sd _ _) = put m >> put sd + get = do + m <- get + sd <- get + either fail return $ normalDistrErr m sd instance D.Distribution NormalDistribution where cumulative = cumulative complCumulative = complCumulative instance D.ContDistr NormalDistribution where - logDensity = logDensity - quantile = quantile + logDensity = logDensity + quantile = quantile + complQuantile = complQuantile instance D.MaybeMean NormalDistribution where maybeMean = Just . D.mean @@ -92,23 +112,45 @@ normalDistr :: Double -- ^ Mean of distribution -> Double -- ^ Standard deviation of distribution -> NormalDistribution -normalDistr m sd - | sd > 0 = ND { mean = m - , stdDev = sd - , ndPdfDenom = log $ m_sqrt_2_pi * sd - , ndCdfDenom = m_sqrt_2 * sd - } - | otherwise = - error $ "Statistics.Distribution.Normal.normalDistr: standard deviation must be positive. Got " ++ show sd +normalDistr m sd = either error id $ normalDistrErr m sd --- | Create distribution using parameters estimated from --- sample. Variance is estimated using maximum likelihood method +-- | Create normal distribution from parameters. +-- +-- IMPORTANT: prior to 0.10 release second parameter was variance not +-- standard deviation. +normalDistrE :: Double -- ^ Mean of distribution + -> Double -- ^ Standard deviation of distribution + -> Maybe NormalDistribution +normalDistrE m sd = either (const Nothing) Just $ normalDistrErr m sd + +-- | Create normal distribution from parameters. +-- +normalDistrErr :: Double -- ^ Mean of distribution + -> Double -- ^ Standard deviation of distribution + -> Either String NormalDistribution +normalDistrErr m sd + | sd > 0 = Right $ ND { mean = m + , stdDev = sd + , ndPdfDenom = log $ m_sqrt_2_pi * sd + , ndCdfDenom = m_sqrt_2 * sd + } + | otherwise = Left $ errMsg m sd + +errMsg :: Double -> Double -> String +errMsg _ sd = "Statistics.Distribution.Normal.normalDistr: standard deviation must be positive. Got " ++ show sd + +-- | Variance is estimated using maximum likelihood method -- (biased estimation). -normalFromSample :: S.Sample -> NormalDistribution -normalFromSample xs - = normalDistr m (sqrt v) - where - (m,v) = S.meanVariance xs +-- +-- Returns @Nothing@ if sample contains less than one element or +-- variance is zero (all elements are equal) +instance D.FromSample NormalDistribution Double where + fromSample xs + | G.length xs <= 1 = Nothing + | v == 0 = Nothing + | otherwise = Just $! normalDistr m (sqrt v) + where + (m,v) = S.meanVariance xs logDensity :: NormalDistribution -> Double -> Double logDensity d x = (-xm * xm / (2 * sd * sd)) - ndPdfDenom d @@ -130,4 +172,15 @@ | otherwise = error $ "Statistics.Distribution.Normal.quantile: p must be in [0,1] range. Got: "++show p where x = - invErfc (2 * p) + inf = 1/0 + +complQuantile :: NormalDistribution -> Double -> Double +complQuantile d p + | p == 0 = inf + | p == 1 = -inf + | p == 0.5 = mean d + | p > 0 && p < 1 = x * ndCdfDenom d + mean d + | otherwise = + error $ "Statistics.Distribution.Normal.complQuantile: p must be in [0,1] range. Got: "++show p + where x = invErfc (2 * p) inf = 1/0 diff --git a/Statistics/Distribution/Poisson.hs b/Statistics/Distribution/Poisson.hs --- a/Statistics/Distribution/Poisson.hs +++ b/Statistics/Distribution/Poisson.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Poisson @@ -18,33 +19,51 @@ PoissonDistribution -- * Constructors , poisson + , poissonE -- * Accessors , poissonLambda -- * References -- $references ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) -import qualified Statistics.Distribution as D -import qualified Statistics.Distribution.Poisson.Internal as I +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) + +import qualified System.Random.MWC.Distributions as MWC + import Numeric.SpecFunctions (incompleteGamma,logFactorial) import Numeric.MathFunctions.Constants (m_neg_inf) -import Data.Binary (put, get) +import qualified Statistics.Distribution as D +import qualified Statistics.Distribution.Poisson.Internal as I +import Statistics.Internal + + newtype PoissonDistribution = PD { poissonLambda :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON PoissonDistribution +instance Show PoissonDistribution where + showsPrec i (PD l) = defaultShow1 "poisson" l i +instance Read PoissonDistribution where + readPrec = defaultReadPrecM1 "poisson" poissonE + instance ToJSON PoissonDistribution +instance FromJSON PoissonDistribution where + parseJSON (Object v) = do + l <- v .: "poissonLambda" + maybe (fail $ errMsg l) return $ poissonE l + parseJSON _ = empty instance Binary PoissonDistribution where - get = fmap PD get - put = put . poissonLambda + put = put . poissonLambda + get = do + l <- get + maybe (fail $ errMsg l) return $ poissonE l instance D.Distribution PoissonDistribution where cumulative (PD lambda) x @@ -77,13 +96,28 @@ instance D.MaybeEntropy PoissonDistribution where maybeEntropy = Just . D.entropy +-- | @since 0.16.5.0 +instance D.DiscreteGen PoissonDistribution where + genDiscreteVar (PD lambda) = MWC.poisson lambda + +-- | @since 0.16.5.0 +instance D.ContGen PoissonDistribution where + genContVar (PD lambda) gen = fromIntegral <$> MWC.poisson lambda gen + -- | Create Poisson distribution. poisson :: Double -> PoissonDistribution -poisson l - | l >= 0 = PD l - | otherwise = error $ - "Statistics.Distribution.Poisson.poisson: lambda must be non-negative. Got " - ++ show l +poisson l = maybe (error $ errMsg l) id $ poissonE l + +-- | Create Poisson distribution. +poissonE :: Double -> Maybe PoissonDistribution +poissonE l + | l >= 0 = Just (PD l) + | otherwise = Nothing + +errMsg :: Double -> String +errMsg l = "Statistics.Distribution.Poisson.poisson: lambda must be non-negative. Got " + ++ show l + -- $references -- diff --git a/Statistics/Distribution/Poisson/Internal.hs b/Statistics/Distribution/Poisson/Internal.hs --- a/Statistics/Distribution/Poisson/Internal.hs +++ b/Statistics/Distribution/Poisson/Internal.hs @@ -16,7 +16,7 @@ import Data.List (unfoldr) import Numeric.MathFunctions.Constants (m_sqrt_2_pi, m_tiny, m_epsilon) -import Numeric.SpecFunctions (logGamma, stirlingError, choose, logFactorial) +import Numeric.SpecFunctions (logGamma, stirlingError {-, choose, logFactorial -}) import Numeric.SpecFunctions.Extra (bd0) -- | An unchecked, non-integer-valued version of Loader's saddle point @@ -32,23 +32,23 @@ | otherwise = exp (-(stirlingError x) - bd0 x lambda) / (m_sqrt_2_pi * sqrt x) --- | Compute entropy using Theorem 1 from "Sharp Bounds on the Entropy --- of the Poisson Law". This function is unused because 'directEntorpy' --- is just as accurate and is faster by about a factor of 4. -alyThm1 :: Double -> Double -alyThm1 lambda = - sum (takeWhile (\x -> abs x >= m_epsilon * lll) alySeries) + lll - where lll = lambda * (1 - log lambda) - alySeries = - [ alyc k * exp (fromIntegral k * log lambda - logFactorial k) - | k <- [2..] ] +-- -- | Compute entropy using Theorem 1 from "Sharp Bounds on the Entropy +-- -- of the Poisson Law". This function is unused because 'directEntropy' +-- -- is just as accurate and is faster by about a factor of 4. +-- alyThm1 :: Double -> Double +-- alyThm1 lambda = +-- sum (takeWhile (\x -> abs x >= m_epsilon * lll) alySeries) + lll +-- where lll = lambda * (1 - log lambda) +-- alySeries = +-- [ alyc k * exp (fromIntegral k * log lambda - logFactorial k) +-- | k <- [2..] ] -alyc :: Int -> Double -alyc k = - sum [ parity j * choose (k-1) j * log (fromIntegral j+1) | j <- [0..k-1] ] - where parity j - | even (k-j) = -1 - | otherwise = 1 +-- alyc :: Int -> Double +-- alyc k = +-- sum [ parity j * choose (k-1) j * log (fromIntegral j+1) | j <- [0..k-1] ] +-- where parity j +-- | even (k-j) = -1 +-- | otherwise = 1 -- | Returns [x, x^2, x^3, x^4, ...] powers :: Double -> [Double] @@ -61,7 +61,7 @@ 1.4189385332046727 + 0.5 * log lambda + zipCoefficients lambda coefficients --- | Returns the average of the upper and lower bounds accounding to +-- | Returns the average of the upper and lower bounds according to -- theorem 2. alyThm2 :: Double -> [Double] -> [Double] -> Double alyThm2 lambda upper lower = @@ -164,7 +164,7 @@ dropWhile (not . (< negate m_epsilon * lambda)) $ [ let x = probability lambda k in x * log x | k <- [0..]] --- | Compute the entropy of a poisson distribution using the best available +-- | Compute the entropy of a Poisson distribution using the best available -- method. poissonEntropy :: Double -> Double poissonEntropy lambda diff --git a/Statistics/Distribution/StudentT.hs b/Statistics/Distribution/StudentT.hs --- a/Statistics/Distribution/StudentT.hs +++ b/Statistics/Distribution/StudentT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.StudentT @@ -11,40 +12,66 @@ -- Student-T distribution module Statistics.Distribution.StudentT ( StudentT + -- * Constructors , studentT - , studentTndf + , studentTE , studentTUnstandardized + -- * Accessors + , studentTndf ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.SpecFunctions ( + logBeta, incompleteBeta, invIncompleteBeta, digamma, log1p) + import qualified Statistics.Distribution as D import Statistics.Distribution.Transform (LinearTransform (..)) -import Numeric.SpecFunctions ( - logBeta, incompleteBeta, invIncompleteBeta, digamma) -import Data.Binary (put, get) +import Statistics.Internal + -- | Student-T distribution newtype StudentT = StudentT { studentTndf :: Double } - deriving (Eq, Show, Read, Typeable, Data, Generic) + deriving (Eq, Typeable, Data, Generic) -instance FromJSON StudentT +instance Show StudentT where + showsPrec i (StudentT ndf) = defaultShow1 "studentT" ndf i +instance Read StudentT where + readPrec = defaultReadPrecM1 "studentT" studentTE + instance ToJSON StudentT +instance FromJSON StudentT where + parseJSON (Object v) = do + ndf <- v .: "studentTndf" + maybe (fail $ errMsg ndf) return $ studentTE ndf + parseJSON _ = empty instance Binary StudentT where - put = put . studentTndf - get = fmap StudentT get + put = put . studentTndf + get = do + ndf <- get + maybe (fail $ errMsg ndf) return $ studentTE ndf -- | Create Student-T distribution. Number of parameters must be positive. studentT :: Double -> StudentT -studentT ndf - | ndf > 0 = StudentT ndf - | otherwise = modErr "studentT" "non-positive number of degrees of freedom" +studentT ndf = maybe (error $ errMsg ndf) id $ studentTE ndf +-- | Create Student-T distribution. Number of parameters must be positive. +studentTE :: Double -> Maybe StudentT +studentTE ndf + | ndf > 0 = Just (StudentT ndf) + | otherwise = Nothing + +errMsg :: Double -> String +errMsg _ = modErr "studentT" "non-positive number of degrees of freedom" + + instance D.Distribution StudentT where - cumulative = cumulative + cumulative = cumulative + complCumulative = complCumulative instance D.ContDistr StudentT where density d@(StudentT ndf) x = exp (logDensityUnscaled d x) / sqrt ndf @@ -58,9 +85,18 @@ where ibeta = incompleteBeta (0.5 * ndf) 0.5 (ndf / (ndf + x*x)) +complCumulative :: StudentT -> Double -> Double +complCumulative (StudentT ndf) x + | x > 0 = 0.5 * ibeta + | otherwise = 1 - 0.5 * ibeta + where + ibeta = incompleteBeta (0.5 * ndf) 0.5 (ndf / (ndf + x*x)) + + logDensityUnscaled :: StudentT -> Double -> Double -logDensityUnscaled (StudentT ndf) x = - log (ndf / (ndf + x*x)) * (0.5 * (1 + ndf)) - logBeta 0.5 (0.5 * ndf) +logDensityUnscaled (StudentT ndf) x + = log1p (x*x/ndf) * (-(0.5 * (1 + ndf))) + - logBeta 0.5 (0.5 * ndf) quantile :: StudentT -> Double -> Double quantile (StudentT ndf) p @@ -90,7 +126,7 @@ maybeEntropy = Just . D.entropy instance D.ContGen StudentT where - genContVar = D.genContinous + genContVar = D.genContinuous -- | Create an unstandardized Student-t distribution. studentTUnstandardized :: Double -- ^ Number of degrees of freedom diff --git a/Statistics/Distribution/Transform.hs b/Statistics/Distribution/Transform.hs --- a/Statistics/Distribution/Transform.hs +++ b/Statistics/Distribution/Transform.hs @@ -18,11 +18,9 @@ ) where import Data.Aeson (FromJSON, ToJSON) -import Control.Applicative ((<*>)) import Data.Binary (Binary) import Data.Binary (put, get) import Data.Data (Data, Typeable) -import Data.Functor ((<$>)) import GHC.Generics (Generic) import qualified Statistics.Distribution as D @@ -66,7 +64,8 @@ instance D.ContDistr d => D.ContDistr (LinearTransform d) where density (LinearTransform loc sc dist) x = D.density dist ((x-loc) / sc) / sc logDensity (LinearTransform loc sc dist) x = D.logDensity dist ((x-loc) / sc) - log sc - quantile (LinearTransform loc sc dist) p = loc + sc * D.quantile dist p + quantile (LinearTransform loc sc dist) p = loc + sc * D.quantile dist p + complQuantile (LinearTransform loc sc dist) p = loc + sc * D.complQuantile dist p instance D.MaybeMean d => D.MaybeMean (LinearTransform d) where maybeMean (LinearTransform loc _ dist) = (+loc) <$> D.maybeMean dist @@ -82,12 +81,10 @@ variance (LinearTransform _ sc dist) = sc * sc * D.variance dist stdDev (LinearTransform _ sc dist) = sc * D.stdDev dist -instance (D.MaybeEntropy d, D.DiscreteDistr d) - => D.MaybeEntropy (LinearTransform d) where +instance (D.MaybeEntropy d) => D.MaybeEntropy (LinearTransform d) where maybeEntropy (LinearTransform _ _ dist) = D.maybeEntropy dist -instance (D.Entropy d, D.DiscreteDistr d) - => D.Entropy (LinearTransform d) where +instance (D.Entropy d) => D.Entropy (LinearTransform d) where entropy (LinearTransform _ _ dist) = D.entropy dist instance D.ContGen d => D.ContGen (LinearTransform d) where diff --git a/Statistics/Distribution/Uniform.hs b/Statistics/Distribution/Uniform.hs --- a/Statistics/Distribution/Uniform.hs +++ b/Statistics/Distribution/Uniform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Distribution.Uniform @@ -14,42 +15,66 @@ UniformDistribution -- * Constructors , uniformDistr + , uniformDistrE -- ** Accessors , uniformA , uniformB ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import System.Random.Stateful (uniformRM) +import GHC.Generics (Generic) + import qualified Statistics.Distribution as D -import qualified System.Random.MWC as MWC -import Data.Binary (put, get) -import Control.Applicative ((<$>), (<*>)) +import Statistics.Internal + -- | Uniform distribution from A to B data UniformDistribution = UniformDistribution { uniformA :: {-# UNPACK #-} !Double -- ^ Low boundary of distribution , uniformB :: {-# UNPACK #-} !Double -- ^ Upper boundary of distribution - } deriving (Eq, Read, Show, Typeable, Data, Generic) + } deriving (Eq, Typeable, Data, Generic) -instance FromJSON UniformDistribution +instance Show UniformDistribution where + showsPrec i (UniformDistribution a b) = defaultShow2 "uniformDistr" a b i +instance Read UniformDistribution where + readPrec = defaultReadPrecM2 "uniformDistr" uniformDistrE + instance ToJSON UniformDistribution +instance FromJSON UniformDistribution where + parseJSON (Object v) = do + a <- v .: "uniformA" + b <- v .: "uniformB" + maybe (fail errMsg) return $ uniformDistrE a b + parseJSON _ = empty instance Binary UniformDistribution where - put (UniformDistribution x y) = put x >> put y - get = UniformDistribution <$> get <*> get + put (UniformDistribution x y) = put x >> put y + get = do + a <- get + b <- get + maybe (fail errMsg) return $ uniformDistrE a b -- | Create uniform distribution. uniformDistr :: Double -> Double -> UniformDistribution -uniformDistr a b - | b < a = uniformDistr b a - | a < b = UniformDistribution a b - | otherwise = error "Statistics.Distribution.Uniform.uniform: wrong parameters" --- NOTE: failure is in default branch to guard againist NaNs. +uniformDistr a b = maybe (error errMsg) id $ uniformDistrE a b +-- | Create uniform distribution. +uniformDistrE :: Double -> Double -> Maybe UniformDistribution +uniformDistrE a b + | b < a = Just $ UniformDistribution b a + | a < b = Just $ UniformDistribution a b + | otherwise = Nothing +-- NOTE: failure is in default branch to guard against NaNs. + +errMsg :: String +errMsg = "Statistics.Distribution.Uniform.uniform: wrong parameters" + + instance D.Distribution UniformDistribution where cumulative (UniformDistribution a b) x | x < a = 0 @@ -65,6 +90,10 @@ | p >= 0 && p <= 1 = a + (b - a) * p | otherwise = error $ "Statistics.Distribution.Uniform.quantile: p must be in [0,1] range. Got: "++show p + complQuantile (UniformDistribution a b) p + | p >= 0 && p <= 1 = b + (a - b) * p + | otherwise = + error $ "Statistics.Distribution.Uniform.complQuantile: p must be in [0,1] range. Got: "++show p instance D.Mean UniformDistribution where mean (UniformDistribution a b) = 0.5 * (a + b) @@ -88,4 +117,4 @@ maybeEntropy = Just . D.entropy instance D.ContGen UniformDistribution where - genContVar (UniformDistribution a b) gen = MWC.uniformR (a,b) gen + genContVar (UniformDistribution a b) = uniformRM (a,b) diff --git a/Statistics/Distribution/Weibull.hs b/Statistics/Distribution/Weibull.hs new file mode 100644 --- /dev/null +++ b/Statistics/Distribution/Weibull.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +-- | +-- Module : Statistics.Distribution.Lognormal +-- Copyright : (c) 2020 Ximin Luo +-- License : BSD3 +-- +-- Maintainer : infinity0@pwned.gg +-- Stability : experimental +-- Portability : portable +-- +-- The Weibull distribution. This is a continuous probability +-- distribution that describes the occurrence of a single event whose +-- probability changes over time, controlled by the shape parameter. + +module Statistics.Distribution.Weibull + ( + WeibullDistribution + -- * Constructors + , weibullDistr + , weibullDistrErr + , weibullStandard + , weibullDistrApproxMeanStddevErr + ) where + +import Control.Applicative +import Data.Aeson (FromJSON(..), ToJSON, Value(..), (.:)) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Numeric.MathFunctions.Constants (m_eulerMascheroni) +import Numeric.SpecFunctions (expm1, log1p, logGamma) +import qualified Data.Vector.Generic as G + +import qualified Statistics.Distribution as D +import qualified Statistics.Sample as S +import Statistics.Internal + + +-- | The Weibull distribution. +data WeibullDistribution = WD { + wdShape :: {-# UNPACK #-} !Double + , wdLambda :: {-# UNPACK #-} !Double + } deriving (Eq, Typeable, Data, Generic) + +instance Show WeibullDistribution where + showsPrec i (WD k l) = defaultShow2 "weibullDistr" k l i +instance Read WeibullDistribution where + readPrec = defaultReadPrecM2 "weibullDistr" $ + (either (const Nothing) Just .) . weibullDistrErr + +instance ToJSON WeibullDistribution +instance FromJSON WeibullDistribution where + parseJSON (Object v) = do + k <- v .: "wdShape" + l <- v .: "wdLambda" + either fail return $ weibullDistrErr k l + parseJSON _ = empty + +instance Binary WeibullDistribution where + put (WD k l) = put k >> put l + get = do + k <- get + l <- get + either fail return $ weibullDistrErr k l + +instance D.Distribution WeibullDistribution where + cumulative = cumulative + complCumulative = complCumulative + +instance D.ContDistr WeibullDistribution where + logDensity = logDensity + quantile = quantile + complQuantile = complQuantile + +instance D.MaybeMean WeibullDistribution where + maybeMean = Just . D.mean + +instance D.Mean WeibullDistribution where + mean (WD k l) = l * exp (logGamma (1 + 1 / k)) + +instance D.MaybeVariance WeibullDistribution where + maybeStdDev = Just . D.stdDev + maybeVariance = Just . D.variance + +instance D.Variance WeibullDistribution where + variance (WD k l) = l * l * (exp (logGamma (1 + 2 * invk)) - q * q) + where + invk = 1 / k + q = exp (logGamma (1 + invk)) + +instance D.Entropy WeibullDistribution where + entropy (WD k l) = m_eulerMascheroni * (1 - 1 / k) + log (l / k) + 1 + +instance D.MaybeEntropy WeibullDistribution where + maybeEntropy = Just . D.entropy + +instance D.ContGen WeibullDistribution where + genContVar d = D.genContinuous d + +-- | Standard Weibull distribution with scale factor (lambda) 1. +weibullStandard :: Double -> WeibullDistribution +weibullStandard k = weibullDistr k 1.0 + +-- | Create Weibull distribution from parameters. +-- +-- If the shape (first) parameter is @1.0@, the distribution is equivalent to a +-- 'Statistics.Distribution.Exponential.ExponentialDistribution' with parameter +-- @1 / lambda@ the scale (second) parameter. +weibullDistr + :: Double -- ^ Shape + -> Double -- ^ Lambda (scale) + -> WeibullDistribution +weibullDistr k l = either error id $ weibullDistrErr k l + +-- | Create Weibull distribution from parameters. +-- +-- If the shape (first) parameter is @1.0@, the distribution is equivalent to a +-- 'Statistics.Distribution.Exponential.ExponentialDistribution' with parameter +-- @1 / lambda@ the scale (second) parameter. +weibullDistrErr + :: Double -- ^ Shape + -> Double -- ^ Lambda (scale) + -> Either String WeibullDistribution +weibullDistrErr k l | k <= 0 = Left $ errMsg k l + | l <= 0 = Left $ errMsg k l + | otherwise = Right $ WD k l + +errMsg :: Double -> Double -> String +errMsg k l = + "Statistics.Distribution.Weibull.weibullDistr: both shape and lambda must be positive. Got shape " + ++ show k + ++ " and lambda " + ++ show l + +-- | Create Weibull distribution from mean and standard deviation. +-- +-- The algorithm is from "Methods for Estimating Wind Speed Frequency +-- Distributions", C. G. Justus, W. R. Hargreaves, A. Mikhail, D. Graber, 1977. +-- Given the identity: +-- +-- \[ +-- (\frac{\sigma}{\mu})^2 = \frac{\Gamma(1+2/k)}{\Gamma(1+1/k)^2} - 1 +-- \] +-- +-- \(k\) can be approximated by +-- +-- \[ +-- k \approx (\frac{\sigma}{\mu})^{-1.086} +-- \] +-- +-- \(\lambda\) is then calculated straightforwardly via the identity +-- +-- \[ +-- \lambda = \frac{\mu}{\Gamma(1+1/k)} +-- \] +-- +-- Numerically speaking, the approximation for \(k\) is accurate only within a +-- certain range. We arbitrarily pick the range \(0.033 \le \frac{\sigma}{\mu} \le 1.45\) +-- where it is good to ~6%, and will refuse to create a distribution outside of +-- this range. The paper does not cover these details but it is straightforward +-- to check them numerically. +weibullDistrApproxMeanStddevErr + :: Double -- ^ Mean + -> Double -- ^ Stddev + -> Either String WeibullDistribution +weibullDistrApproxMeanStddevErr m s = if r > 1.45 || r < 0.033 + then Left msg + else weibullDistrErr k l + where r = s / m + k = (s / m) ** (-1.086) + l = m / exp (logGamma (1 + 1/k)) + msg = "Statistics.Distribution.Weibull.weibullDistr: stddev-mean ratio " + ++ "outside approximation accuracy range [0.033, 1.45]. Got " + ++ "stddev " ++ show s ++ " and mean " ++ show m + +-- | Uses an approximation based on the mean and standard deviation in +-- 'weibullDistrEstMeanStddevErr', with standard deviation estimated +-- using maximum likelihood method (unbiased estimation). +-- +-- Returns @Nothing@ if sample contains less than one element or +-- variance is zero (all elements are equal), or if the estimated mean +-- and standard-deviation lies outside the range for which the +-- approximation is accurate. +instance D.FromSample WeibullDistribution Double where + fromSample xs + | G.length xs <= 1 = Nothing + | v == 0 = Nothing + | otherwise = either (const Nothing) Just $ + weibullDistrApproxMeanStddevErr m (sqrt v) + where + (m,v) = S.meanVarianceUnb xs + +logDensity :: WeibullDistribution -> Double -> Double +logDensity (WD k l) x + | x < 0 = 0 + | otherwise = log k + (k - 1) * log x - k * log l - (x / l) ** k + +cumulative :: WeibullDistribution -> Double -> Double +cumulative (WD k l) x | x < 0 = 0 + | otherwise = -expm1 (-(x / l) ** k) + +complCumulative :: WeibullDistribution -> Double -> Double +complCumulative (WD k l) x | x < 0 = 1 + | otherwise = exp (-(x / l) ** k) + +quantile :: WeibullDistribution -> Double -> Double +quantile (WD k l) p + | p == 0 = 0 + | p == 1 = inf + | p > 0 && p < 1 = l * (-log1p (-p)) ** (1 / k) + | otherwise = + error $ "Statistics.Distribution.Weibull.quantile: p must be in [0,1] range. Got: " ++ show p + where inf = 1 / 0 + +complQuantile :: WeibullDistribution -> Double -> Double +complQuantile (WD k l) q + | q == 0 = inf + | q == 1 = 0 + | q > 0 && q < 1 = l * (-log q) ** (1 / k) + | otherwise = + error $ "Statistics.Distribution.Weibull.complQuantile: q must be in [0,1] range. Got: " ++ show q + where inf = 1 / 0 diff --git a/Statistics/Function.hs b/Statistics/Function.hs --- a/Statistics/Function.hs +++ b/Statistics/Function.hs @@ -1,8 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleContexts, Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 704 {-# OPTIONS_GHC -fsimpl-tick-factor=200 #-} -#endif - -- | -- Module : Statistics.Function -- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan @@ -47,7 +44,7 @@ import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as M -import Statistics.Function.Comparison (within) +import Numeric.MathFunctions.Comparison (within) -- | Sort a vector. sort :: U.Vector Double -> U.Vector Double @@ -79,8 +76,8 @@ {-# INLINE indices #-} -- | Zip a vector with its indices. -indexed :: (G.Vector v e, G.Vector v Int, G.Vector v (Int,e)) => v e -> v (Int,e) -indexed a = G.zip (indices a) a +indexed :: (G.Vector v e, G.Vector v (Int,e)) => v e -> v (Int,e) +indexed xs = G.imap (,) xs {-# INLINE indexed #-} data MM = MM {-# UNPACK #-} !Double {-# UNPACK #-} !Double diff --git a/Statistics/Function/Comparison.hs b/Statistics/Function/Comparison.hs deleted file mode 100644 --- a/Statistics/Function/Comparison.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | --- Module : Statistics.Function.Comparison --- Copyright : (c) 2011 Bryan O'Sullivan --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : portable --- --- Approximate floating point comparison, based on Bruce Dawson's --- \"Comparing floating point numbers\": --- - -module Statistics.Function.Comparison - ( - within - ) where - -import Control.Monad.ST (runST) -import Data.Primitive.ByteArray (newByteArray, readByteArray, writeByteArray) -import Data.Word (Word64) - --- | Compare two 'Double' values for approximate equality, using --- Dawson's method. --- --- The required accuracy is specified in ULPs (units of least --- precision). If the two numbers differ by the given number of ULPs --- or less, this function returns @True@. -within :: Int -- ^ Number of ULPs of accuracy desired. - -> Double -> Double -> Bool -within ulps a b = runST $ do - buf <- newByteArray 8 - ai0 <- writeByteArray buf 0 a >> readByteArray buf 0 - bi0 <- writeByteArray buf 0 b >> readByteArray buf 0 - let big = 0x8000000000000000 :: Word64 - ai | ai0 < 0 = big - ai0 - | otherwise = ai0 - bi | bi0 < 0 = big - bi0 - | otherwise = bi0 - return $ abs (ai - bi) <= fromIntegral ulps diff --git a/Statistics/Internal.hs b/Statistics/Internal.hs --- a/Statistics/Internal.hs +++ b/Statistics/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} -- | -- Module : Statistics.Internal -- Copyright : (c) 2009 Bryan O'Sullivan @@ -8,34 +7,88 @@ -- Stability : experimental -- Portability : portable -- --- Scary internal functions. +-- +module Statistics.Internal ( + -- * Default definitions for Show + defaultShow1 + , defaultShow2 + , defaultShow3 + -- * Default definitions for Read + , defaultReadPrecM1 + , defaultReadPrecM2 + , defaultReadPrecM3 + -- * Reexports + , Show(..) + , Read(..) + ) where -module Statistics.Internal - ( - inlinePerformIO - ) where +import Control.Applicative +import Control.Monad +import Text.Read -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (IO(IO)) -#else -import GHC.IOBase (IO(IO)) -#endif -import GHC.Base (realWorld#) -#if !defined(__GLASGOW_HASKELL__) -import System.IO.Unsafe (unsafePerformIO) -#endif --- Lifted from Data.ByteString.Internal so we don't introduce an --- otherwise unnecessary dependency on the bytestring package. +---------------------------------------------------------------- +-- Default show implementations +---------------------------------------------------------------- --- | Just like unsafePerformIO, but we inline it. Big performance --- gains as it exposes lots of things to further inlining. /Very --- unsafe/. In particular, you should do no memory allocation inside --- an 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -#if defined(__GLASGOW_HASKELL__) -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -#else -inlinePerformIO = unsafePerformIO -#endif +defaultShow1 :: (Show a) => String -> a -> Int -> ShowS +defaultShow1 con a n + = showParen (n >= 11) + ( showString con + . showChar ' ' + . showsPrec 11 a + ) + +defaultShow2 :: (Show a, Show b) => String -> a -> b -> Int -> ShowS +defaultShow2 con a b n + = showParen (n >= 11) + ( showString con + . showChar ' ' + . showsPrec 11 a + . showChar ' ' + . showsPrec 11 b + ) + +defaultShow3 :: (Show a, Show b, Show c) + => String -> a -> b -> c -> Int -> ShowS +defaultShow3 con a b c n + = showParen (n >= 11) + ( showString con + . showChar ' ' + . showsPrec 11 a + . showChar ' ' + . showsPrec 11 b + . showChar ' ' + . showsPrec 11 c + ) + +---------------------------------------------------------------- +-- Default read implementations +---------------------------------------------------------------- + +defaultReadPrecM1 :: (Read a) => String -> (a -> Maybe r) -> ReadPrec r +defaultReadPrecM1 con f = parens $ prec 10 $ do + expect con + a <- readPrec + maybe empty return $ f a + +defaultReadPrecM2 :: (Read a, Read b) => String -> (a -> b -> Maybe r) -> ReadPrec r +defaultReadPrecM2 con f = parens $ prec 10 $ do + expect con + a <- readPrec + b <- readPrec + maybe empty return $ f a b + +defaultReadPrecM3 :: (Read a, Read b, Read c) + => String -> (a -> b -> c -> Maybe r) -> ReadPrec r +defaultReadPrecM3 con f = parens $ prec 10 $ do + expect con + a <- readPrec + b <- readPrec + c <- readPrec + maybe empty return $ f a b c + +expect :: String -> ReadPrec () +expect str = do + Ident s <- lexP + guard (s == str) diff --git a/Statistics/Math/RootFinding.hs b/Statistics/Math/RootFinding.hs deleted file mode 100644 --- a/Statistics/Math/RootFinding.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} - --- | --- Module : Statistics.Math.RootFinding --- Copyright : (c) 2011 Bryan O'Sullivan --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : portable --- --- Haskell functions for finding the roots of mathematical functions. - -module Statistics.Math.RootFinding - ( - Root(..) - , fromRoot - , ridders - -- * References - -- $references - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Control.Applicative (Alternative(..), Applicative(..)) -import Control.Monad (MonadPlus(..), ap) -import Data.Binary (Binary) -import Data.Binary (put, get) -import Data.Binary.Get (getWord8) -import Data.Binary.Put (putWord8) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) -import Statistics.Function.Comparison (within) - - --- | The result of searching for a root of a mathematical function. -data Root a = NotBracketed - -- ^ The function does not have opposite signs when - -- evaluated at the lower and upper bounds of the search. - | SearchFailed - -- ^ The search failed to converge to within the given - -- error tolerance after the given number of iterations. - | Root a - -- ^ A root was successfully found. - deriving (Eq, Read, Show, Typeable, Data, Generic) - -instance (FromJSON a) => FromJSON (Root a) -instance (ToJSON a) => ToJSON (Root a) - -instance (Binary a) => Binary (Root a) where - put NotBracketed = putWord8 0 - put SearchFailed = putWord8 1 - put (Root a) = putWord8 2 >> put a - - get = do - i <- getWord8 - case i of - 0 -> return NotBracketed - 1 -> return SearchFailed - 2 -> fmap Root get - _ -> fail $ "Root.get: Invalid value: " ++ show i - -instance Functor Root where - fmap _ NotBracketed = NotBracketed - fmap _ SearchFailed = SearchFailed - fmap f (Root a) = Root (f a) - -instance Monad Root where - NotBracketed >>= _ = NotBracketed - SearchFailed >>= _ = SearchFailed - Root a >>= m = m a - - return = Root - -instance MonadPlus Root where - mzero = SearchFailed - - r@(Root _) `mplus` _ = r - _ `mplus` p = p - -instance Applicative Root where - pure = Root - (<*>) = ap - -instance Alternative Root where - empty = SearchFailed - - r@(Root _) <|> _ = r - _ <|> p = p - --- | Returns either the result of a search for a root, or the default --- value if the search failed. -fromRoot :: a -- ^ Default value. - -> Root a -- ^ Result of search for a root. - -> a -fromRoot _ (Root a) = a -fromRoot a _ = a - - --- | Use the method of Ridders to compute a root of a function. --- --- The function must have opposite signs when evaluated at the lower --- and upper bounds of the search (i.e. the root must be bracketed). -ridders :: Double -- ^ Absolute error tolerance. - -> (Double,Double) -- ^ Lower and upper bounds for the search. - -> (Double -> Double) -- ^ Function to find the roots of. - -> Root Double -ridders tol (lo,hi) f - | flo == 0 = Root lo - | fhi == 0 = Root hi - | flo*fhi > 0 = NotBracketed -- root is not bracketed - | otherwise = go lo flo hi fhi 0 - where - go !a !fa !b !fb !i - -- Root is bracketed within 1 ulp. No improvement could be made - | within 1 a b = Root a - -- Root is found. Check that f(m) == 0 is nessesary to ensure - -- that root is never passed to 'go' - | fm == 0 = Root m - | fn == 0 = Root n - | d < tol = Root n - -- Too many iterations performed. Fail - | i >= (100 :: Int) = SearchFailed - -- Ridder's approximation coincide with one of old - -- bounds. Revert to bisection - | n == a || n == b = case () of - _| fm*fa < 0 -> go a fa m fm (i+1) - | otherwise -> go m fm b fb (i+1) - -- Proceed as usual - | fn*fm < 0 = go n fn m fm (i+1) - | fn*fa < 0 = go a fa n fn (i+1) - | otherwise = go n fn b fb (i+1) - where - d = abs (b - a) - dm = (b - a) * 0.5 - !m = a + dm - !fm = f m - !dn = signum (fb - fa) * dm * fm / sqrt(fm*fm - fa*fb) - !n = m - signum dn * min (abs dn) (abs dm - 0.5 * tol) - !fn = f n - !flo = f lo - !fhi = f hi - - --- $references --- --- * Ridders, C.F.J. (1979) A new algorithm for computing a single --- root of a real continuous function. --- /IEEE Transactions on Circuits and Systems/ 26:979–980. diff --git a/Statistics/Matrix.hs b/Statistics/Matrix.hs deleted file mode 100644 --- a/Statistics/Matrix.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE PatternGuards #-} --- | --- Module : Statistics.Matrix --- Copyright : 2011 Aleksey Khudyakov, 2014 Bryan O'Sullivan --- License : BSD3 --- --- Basic matrix operations. --- --- There isn't a widely used matrix package for Haskell yet, so --- we implement the necessary minimum here. - -module Statistics.Matrix - ( -- * Data types - Matrix(..) - , Vector - -- * Conversion from/to lists/vectors - , fromVector - , fromList - , fromRowLists - , fromRows - , fromColumns - , toVector - , toList - , toRows - , toColumns - , toRowLists - -- * Other - , generate - , generateSym - , ident - , diag - , dimension - , center - , multiply - , multiplyV - , transpose - , power - , norm - , column - , row - , map - , for - , unsafeIndex - , hasNaN - , bounds - , unsafeBounds - ) where - -import Prelude hiding (exponent, map, sum) -import Control.Applicative ((<$>)) -import Control.Monad.ST -import qualified Data.Vector.Unboxed as U -import Data.Vector.Unboxed ((!)) -import qualified Data.Vector.Unboxed.Mutable as UM - -import Statistics.Function (for, square) -import Statistics.Matrix.Types -import Statistics.Matrix.Mutable (unsafeNew,unsafeWrite,unsafeFreeze) -import Statistics.Sample.Internal (sum) - - ----------------------------------------------------------------- --- Conversion to/from vectors/lists ----------------------------------------------------------------- - --- | Convert from a row-major list. -fromList :: Int -- ^ Number of rows. - -> Int -- ^ Number of columns. - -> [Double] -- ^ Flat list of values, in row-major order. - -> Matrix -fromList r c = fromVector r c . U.fromList - --- | create a matrix from a list of lists, as rows -fromRowLists :: [[Double]] -> Matrix -fromRowLists = fromRows . fmap U.fromList - --- | Convert from a row-major vector. -fromVector :: Int -- ^ Number of rows. - -> Int -- ^ Number of columns. - -> U.Vector Double -- ^ Flat list of values, in row-major order. - -> Matrix -fromVector r c v - | r*c /= len = error "input size mismatch" - | otherwise = Matrix r c 0 v - where len = U.length v - --- | create a matrix from a list of vectors, as rows -fromRows :: [Vector] -> Matrix -fromRows xs - | [] <- xs = error "Statistics.Matrix.fromRows: empty list of rows!" - | any (/=nCol) ns = error "Statistics.Matrix.fromRows: row sizes do not match" - | nCol == 0 = error "Statistics.Matrix.fromRows: zero columns in matrix" - | otherwise = fromVector nRow nCol (U.concat xs) - where - nCol:ns = U.length <$> xs - nRow = length xs - - --- | create a matrix from a list of vectors, as columns -fromColumns :: [Vector] -> Matrix -fromColumns = transpose . fromRows - --- | Convert to a row-major flat vector. -toVector :: Matrix -> U.Vector Double -toVector (Matrix _ _ _ v) = v - --- | Convert to a row-major flat list. -toList :: Matrix -> [Double] -toList = U.toList . toVector - --- | Convert to a list of lists, as rows -toRowLists :: Matrix -> [[Double]] -toRowLists (Matrix _ nCol _ v) - = chunks $ U.toList v - where - chunks [] = [] - chunks xs = case splitAt nCol xs of - (rowE,rest) -> rowE : chunks rest - - --- | Convert to a list of vectors, as rows -toRows :: Matrix -> [Vector] -toRows (Matrix _ nCol _ v) = chunks v - where - chunks xs - | U.null xs = [] - | otherwise = case U.splitAt nCol xs of - (rowE,rest) -> rowE : chunks rest - --- | Convert to a list of vectors, as columns -toColumns :: Matrix -> [Vector] -toColumns = toRows . transpose - - - ----------------------------------------------------------------- --- Other ----------------------------------------------------------------- - --- | Generate matrix using function -generate :: Int -- ^ Number of rows - -> Int -- ^ Number of columns - -> (Int -> Int -> Double) - -- ^ Function which takes /row/ and /column/ as argument. - -> Matrix -generate nRow nCol f - = Matrix nRow nCol 0 $ U.generate (nRow*nCol) $ \i -> - let (r,c) = i `quotRem` nCol in f r c - --- | Generate symmetric square matrix using function -generateSym - :: Int -- ^ Number of rows and columns - -> (Int -> Int -> Double) - -- ^ Function which takes /row/ and /column/ as argument. It must - -- be symmetric in arguments: @f i j == f j i@ - -> Matrix -generateSym n f = runST $ do - m <- unsafeNew n n - for 0 n $ \r -> do - unsafeWrite m r r (f r r) - for (r+1) n $ \c -> do - let x = f r c - unsafeWrite m r c x - unsafeWrite m c r x - unsafeFreeze m - - --- | Create the square identity matrix with given dimensions. -ident :: Int -> Matrix -ident n = diag $ U.replicate n 1.0 - --- | Create a square matrix with given diagonal, other entries default to 0 -diag :: Vector -> Matrix -diag v - = Matrix n n 0 $ U.create $ do - arr <- UM.replicate (n*n) 0 - for 0 n $ \i -> - UM.unsafeWrite arr (i*n + i) (v ! i) - return arr - where - n = U.length v - --- | Return the dimensions of this matrix, as a (row,column) pair. -dimension :: Matrix -> (Int, Int) -dimension (Matrix r c _ _) = (r, c) - --- | Avoid overflow in the matrix. -avoidOverflow :: Matrix -> Matrix -avoidOverflow m@(Matrix r c e v) - | center m > 1e140 = Matrix r c (e + 140) (U.map (* 1e-140) v) - | otherwise = m - --- | Matrix-matrix multiplication. Matrices must be of compatible --- sizes (/note: not checked/). -multiply :: Matrix -> Matrix -> Matrix -multiply m1@(Matrix r1 _ e1 _) m2@(Matrix _ c2 e2 _) = - Matrix r1 c2 (e1 + e2) $ U.generate (r1*c2) go - where - go t = sum $ U.zipWith (*) (row m1 i) (column m2 j) - where (i,j) = t `quotRem` c2 - --- | Matrix-vector multiplication. -multiplyV :: Matrix -> Vector -> Vector -multiplyV m v - | cols m == c = U.generate (rows m) (sum . U.zipWith (*) v . row m) - | otherwise = error $ "matrix/vector unconformable " ++ show (cols m,c) - where c = U.length v - --- | Raise matrix to /n/th power. Power must be positive --- (/note: not checked). -power :: Matrix -> Int -> Matrix -power mat 1 = mat -power mat n = avoidOverflow res - where - mat2 = power mat (n `quot` 2) - pow = multiply mat2 mat2 - res | odd n = multiply pow mat - | otherwise = pow - --- | Element in the center of matrix (not corrected for exponent). -center :: Matrix -> Double -center mat@(Matrix r c _ _) = - unsafeBounds U.unsafeIndex mat (r `quot` 2) (c `quot` 2) - --- | Calculate the Euclidean norm of a vector. -norm :: Vector -> Double -norm = sqrt . sum . U.map square - --- | Return the given column. -column :: Matrix -> Int -> Vector -column (Matrix r c _ v) i = U.backpermute v $ U.enumFromStepN i c r -{-# INLINE column #-} - --- | Return the given row. -row :: Matrix -> Int -> Vector -row (Matrix _ c _ v) i = U.slice (c*i) c v - -unsafeIndex :: Matrix - -> Int -- ^ Row. - -> Int -- ^ Column. - -> Double -unsafeIndex = unsafeBounds U.unsafeIndex - --- | Apply function to every element of matrix -map :: (Double -> Double) -> Matrix -> Matrix -map f (Matrix r c e v) = Matrix r c e (U.map f v) - --- | Indicate whether any element of the matrix is @NaN@. -hasNaN :: Matrix -> Bool -hasNaN = U.any isNaN . toVector - --- | Given row and column numbers, calculate the offset into the flat --- row-major vector. -bounds :: (Vector -> Int -> r) -> Matrix -> Int -> Int -> r -bounds k (Matrix rs cs _ v) r c - | r < 0 || r >= rs = error "row out of bounds" - | c < 0 || c >= cs = error "column out of bounds" - | otherwise = k v $! r * cs + c -{-# INLINE bounds #-} - --- | Given row and column numbers, calculate the offset into the flat --- row-major vector, without checking. -unsafeBounds :: (Vector -> Int -> r) -> Matrix -> Int -> Int -> r -unsafeBounds k (Matrix _ cs _ v) r c = k v $! r * cs + c -{-# INLINE unsafeBounds #-} - -transpose :: Matrix -> Matrix -transpose m@(Matrix r0 c0 e _) = Matrix c0 r0 e . U.generate (r0*c0) $ \i -> - let (r,c) = i `quotRem` r0 - in unsafeIndex m c r diff --git a/Statistics/Matrix/Algorithms.hs b/Statistics/Matrix/Algorithms.hs deleted file mode 100644 --- a/Statistics/Matrix/Algorithms.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | --- Module : Statistics.Matrix.Algorithms --- Copyright : 2014 Bryan O'Sullivan --- License : BSD3 --- --- Useful matrix functions. - -module Statistics.Matrix.Algorithms - ( - qr - ) where - -import Control.Applicative ((<$>), (<*>)) -import Control.Monad.ST (ST, runST) -import Prelude hiding (sum, replicate) -import Statistics.Matrix (Matrix, column, dimension, for, norm) -import qualified Statistics.Matrix.Mutable as M -import Statistics.Sample.Internal (sum) -import qualified Data.Vector.Unboxed as U - --- | /O(r*c)/ Compute the QR decomposition of a matrix. --- The result returned is the matrices (/q/,/r/). -qr :: Matrix -> (Matrix, Matrix) -qr mat = runST $ do - let (m,n) = dimension mat - r <- M.replicate n n 0 - a <- M.thaw mat - for 0 n $ \j -> do - cn <- M.immutably a $ \aa -> norm (column aa j) - M.unsafeWrite r j j cn - for 0 m $ \i -> M.unsafeModify a i j (/ cn) - for (j+1) n $ \jj -> do - p <- innerProduct a j jj - M.unsafeWrite r j jj p - for 0 m $ \i -> do - aij <- M.unsafeRead a i j - M.unsafeModify a i jj $ subtract (p * aij) - (,) <$> M.unsafeFreeze a <*> M.unsafeFreeze r - -innerProduct :: M.MMatrix s -> Int -> Int -> ST s Double -innerProduct mmat j k = M.immutably mmat $ \mat -> - sum $ U.zipWith (*) (column mat j) (column mat k) diff --git a/Statistics/Matrix/Mutable.hs b/Statistics/Matrix/Mutable.hs deleted file mode 100644 --- a/Statistics/Matrix/Mutable.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | --- Module : Statistics.Matrix.Mutable --- Copyright : (c) 2014 Bryan O'Sullivan --- License : BSD3 --- --- Basic mutable matrix operations. - -module Statistics.Matrix.Mutable - ( - MMatrix(..) - , MVector - , replicate - , thaw - , bounds - , unsafeNew - , unsafeFreeze - , unsafeRead - , unsafeWrite - , unsafeModify - , immutably - , unsafeBounds - ) where - -import Control.Applicative ((<$>)) -import Control.DeepSeq (NFData(..)) -import Control.Monad.ST (ST) -import Statistics.Matrix.Types (Matrix(..), MMatrix(..), MVector) -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as M -import Prelude hiding (replicate) - -replicate :: Int -> Int -> Double -> ST s (MMatrix s) -replicate r c k = MMatrix r c 0 <$> M.replicate (r*c) k - -thaw :: Matrix -> ST s (MMatrix s) -thaw (Matrix r c e v) = MMatrix r c e <$> U.thaw v - -unsafeFreeze :: MMatrix s -> ST s Matrix -unsafeFreeze (MMatrix r c e mv) = Matrix r c e <$> U.unsafeFreeze mv - --- | Allocate new matrix. Matrix content is not initialized hence unsafe. -unsafeNew :: Int -- ^ Number of row - -> Int -- ^ Number of columns - -> ST s (MMatrix s) -unsafeNew r c - | r < 0 = error "Statistics.Matrix.Mutable.unsafeNew: negative number of rows" - | c < 0 = error "Statistics.Matrix.Mutable.unsafeNew: negative number of columns" - | otherwise = do - vec <- M.new (r*c) - return $ MMatrix r c 0 vec - -unsafeRead :: MMatrix s -> Int -> Int -> ST s Double -unsafeRead mat r c = unsafeBounds mat r c M.unsafeRead -{-# INLINE unsafeRead #-} - -unsafeWrite :: MMatrix s -> Int -> Int -> Double -> ST s () -unsafeWrite mat row col k = unsafeBounds mat row col $ \v i -> - M.unsafeWrite v i k -{-# INLINE unsafeWrite #-} - -unsafeModify :: MMatrix s -> Int -> Int -> (Double -> Double) -> ST s () -unsafeModify mat row col f = unsafeBounds mat row col $ \v i -> do - k <- M.unsafeRead v i - M.unsafeWrite v i (f k) -{-# INLINE unsafeModify #-} - --- | Given row and column numbers, calculate the offset into the flat --- row-major vector. -bounds :: MMatrix s -> Int -> Int -> (MVector s -> Int -> r) -> r -bounds (MMatrix rs cs _ mv) r c k - | r < 0 || r >= rs = error "row out of bounds" - | c < 0 || c >= cs = error "column out of bounds" - | otherwise = k mv $! r * cs + c -{-# INLINE bounds #-} - --- | Given row and column numbers, calculate the offset into the flat --- row-major vector, without checking. -unsafeBounds :: MMatrix s -> Int -> Int -> (MVector s -> Int -> r) -> r -unsafeBounds (MMatrix _ cs _ mv) r c k = k mv $! r * cs + c -{-# INLINE unsafeBounds #-} - -immutably :: NFData a => MMatrix s -> (Matrix -> a) -> ST s a -immutably mmat f = do - k <- f <$> unsafeFreeze mmat - rnf k `seq` return k -{-# INLINE immutably #-} diff --git a/Statistics/Matrix/Types.hs b/Statistics/Matrix/Types.hs deleted file mode 100644 --- a/Statistics/Matrix/Types.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | --- Module : Statistics.Matrix.Types --- Copyright : 2014 Bryan O'Sullivan --- License : BSD3 --- --- Basic matrix operations. --- --- There isn't a widely used matrix package for Haskell yet, so --- we implement the necessary minimum here. - -module Statistics.Matrix.Types - ( - Vector - , MVector - , Matrix(..) - , MMatrix(..) - , debug - ) where - -import Data.Char (isSpace) -import Numeric (showFFloat) -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as M - -type Vector = U.Vector Double -type MVector s = M.MVector s Double - --- | Two-dimensional matrix, stored in row-major order. -data Matrix = Matrix { - rows :: {-# UNPACK #-} !Int -- ^ Rows of matrix. - , cols :: {-# UNPACK #-} !Int -- ^ Columns of matrix. - , exponent :: {-# UNPACK #-} !Int - -- ^ In order to avoid overflows during matrix multiplication, a - -- large exponent is stored separately. - , _vector :: !Vector -- ^ Matrix data. - } deriving (Eq) - --- | Two-dimensional mutable matrix, stored in row-major order. -data MMatrix s = MMatrix - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - !(MVector s) - --- The Show instance is useful only for debugging. -instance Show Matrix where - show = debug - -debug :: Matrix -> String -debug (Matrix r c _ vs) = unlines $ zipWith (++) (hdr0 : repeat hdr) rrows - where - rrows = map (cleanEnd . unwords) . split $ zipWith (++) ldone tdone - hdr0 = show (r,c) ++ " " - hdr = replicate (length hdr0) ' ' - pad plus k xs = replicate (k - length xs) ' ' `plus` xs - ldone = map (pad (++) (longest lstr)) lstr - tdone = map (pad (flip (++)) (longest tstr)) tstr - (lstr, tstr) = unzip . map (break (=='.') . render) . U.toList $ vs - longest = maximum . map length - render k = reverse . dropWhile (=='.') . dropWhile (=='0') . reverse . - showFFloat (Just 4) k $ "" - split [] = [] - split xs = i : split rest where (i, rest) = splitAt c xs - cleanEnd = reverse . dropWhile isSpace . reverse diff --git a/Statistics/Quantile.hs b/Statistics/Quantile.hs --- a/Statistics/Quantile.hs +++ b/Statistics/Quantile.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Statistics.Quantile -- Copyright : (c) 2009 Bryan O'Sullivan @@ -15,37 +20,66 @@ -- The number of quantiles is described below by the variable /q/, so -- with /q/=4, a 4-quantile (also known as a /quartile/) has 4 -- intervals, and contains 5 points. The parameter /k/ describes the --- desired point, where 0 ≤ /k/ ≤ /q/. +-- desired point, where 0 ≤ /k/ ≤ /q/. module Statistics.Quantile ( -- * Quantile estimation functions - weightedAvg - , ContParam(..) - , continuousBy - , midspread - - -- * Parameters for the continuous sample method + -- $cont_quantiles + ContParam(..) + , Default(..) + , quantile + , quantiles + , quantilesVec + -- ** Parameters for the continuous sample method , cadpw , hazen - , s , spss + , s , medianUnbiased , normalUnbiased - + -- * Other algorithms + , weightedAvg + -- * Median & other specializations + , median + , mad + , midspread + -- * Deprecated + , continuousBy -- * References -- $references ) where -import Data.Vector.Generic ((!)) -import Numeric.MathFunctions.Constants (m_epsilon) +import Data.Binary (Binary) +import Data.Aeson (ToJSON,FromJSON) +import Data.Data (Data,Typeable) +import Data.Default.Class +import qualified Data.Foldable as F +import Data.Vector.Generic ((!)) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as S +import GHC.Generics (Generic) + import Statistics.Function (partialSort) -import qualified Data.Vector as V -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U --- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample, --- using the weighted average method. + +---------------------------------------------------------------- +-- Quantile estimation +---------------------------------------------------------------- + +-- | O(/n/·log /n/). Estimate the /k/th /q/-quantile of a sample, +-- using the weighted average method. Up to rounding errors it's same +-- as @quantile s@. +-- +-- The following properties should hold otherwise an error will be thrown. +-- +-- * the length of the input is greater than @0@ +-- +-- * the input does not contain @NaN@ +-- +-- * k ≥ 0 and k ≤ q weightedAvg :: G.Vector v Double => Int -- ^ /k/, the desired quantile. -> Int -- ^ /q/, the number of quantiles. @@ -53,10 +87,12 @@ -> Double weightedAvg k q x | G.any isNaN x = modErr "weightedAvg" "Sample contains NaNs" + | n == 0 = modErr "weightedAvg" "Sample is empty" | n == 1 = G.head x | q < 2 = modErr "weightedAvg" "At least 2 quantiles is needed" - | k < 0 || k >= q = modErr "weightedAvg" "Wrong quantile number" - | otherwise = xj + g * (xj1 - xj) + | k == q = G.maximum x + | k >= 0 || k < q = xj + g * (xj1 - xj) + | otherwise = modErr "weightedAvg" "Wrong quantile number" where j = floor idx idx = fromIntegral (n - 1) * fromIntegral k / fromIntegral q @@ -67,101 +103,200 @@ n = G.length x {-# SPECIALIZE weightedAvg :: Int -> Int -> U.Vector Double -> Double #-} {-# SPECIALIZE weightedAvg :: Int -> Int -> V.Vector Double -> Double #-} +{-# SPECIALIZE weightedAvg :: Int -> Int -> S.Vector Double -> Double #-} --- | Parameters /a/ and /b/ to the 'continuousBy' function. -data ContParam = ContParam {-# UNPACK #-} !Double {-# UNPACK #-} !Double --- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample /x/, --- using the continuous sample method with the given parameters. This --- is the method used by most statistical software, such as R, +---------------------------------------------------------------- +-- Quantiles continuous algorithm +---------------------------------------------------------------- + +-- $cont_quantiles +-- +-- Below is family of functions which use same algorithm for estimation +-- of sample quantiles. It approximates empirical CDF as continuous +-- piecewise function which interpolates linearly between points +-- \((X_k,p_k)\) where \(X_k\) is k-th order statistics (k-th smallest +-- element) and \(p_k\) is probability corresponding to +-- it. 'ContParam' determines how \(p_k\) is chosen. For more detailed +-- explanation see [Hyndman1996]. +-- +-- This is the method used by most statistical software, such as R, -- Mathematica, SPSS, and S. -continuousBy :: G.Vector v Double => - ContParam -- ^ Parameters /a/ and /b/. - -> Int -- ^ /k/, the desired quantile. - -> Int -- ^ /q/, the number of quantiles. - -> v Double -- ^ /x/, the sample data. - -> Double -continuousBy (ContParam a b) k q x - | q < 2 = modErr "continuousBy" "At least 2 quantiles is needed" - | k < 0 || k > q = modErr "continuousBy" "Wrong quantile number" - | G.any isNaN x = modErr "continuousBy" "Sample contains NaNs" - | otherwise = (1-h) * item (j-1) + h * item j + + +-- | Parameters /α/ and /β/ to the 'continuousBy' function. Exact +-- meaning of parameters is described in [Hyndman1996] in section +-- \"Piecewise linear functions\" +data ContParam = ContParam {-# UNPACK #-} !Double {-# UNPACK #-} !Double + deriving (Show,Eq,Ord,Data,Typeable,Generic) + +-- | We use 's' as default value which is same as R's default. +instance Default ContParam where + def = s + +instance Binary ContParam +instance ToJSON ContParam +instance FromJSON ContParam + +-- | O(/n/·log /n/). Estimate the /k/th /q/-quantile of a sample /x/, +-- using the continuous sample method with the given parameters. +-- +-- The following properties should hold, otherwise an error will be thrown. +-- +-- * input sample must be nonempty +-- +-- * the input does not contain @NaN@ +-- +-- * 0 ≤ k ≤ q +quantile :: G.Vector v Double + => ContParam -- ^ Parameters /α/ and /β/. + -> Int -- ^ /k/, the desired quantile. + -> Int -- ^ /q/, the number of quantiles. + -> v Double -- ^ /x/, the sample data. + -> Double +quantile param q nQ xs + | nQ < 2 = modErr "continuousBy" "At least 2 quantiles is needed" + | badQ nQ q = modErr "continuousBy" "Wrong quantile number" + | G.any isNaN xs = modErr "continuousBy" "Sample contains NaNs" + | otherwise = estimateQuantile sortedXs pk where - j = floor (t + eps) - t = a + p * (fromIntegral n + 1 - a - b) - p = fromIntegral k / fromIntegral q - h | abs r < eps = 0 - | otherwise = r - where r = t - fromIntegral j - eps = m_epsilon * 4 - n = G.length x - item = (sx !) . bracket - sx = partialSort (bracket j + 1) x - bracket m = min (max m 0) (n - 1) + pk = toPk param n q nQ + sortedXs = psort xs $ floor pk + 1 + n = G.length xs +{-# INLINABLE quantile #-} {-# SPECIALIZE - continuousBy :: ContParam -> Int -> Int -> U.Vector Double -> Double #-} + quantile :: ContParam -> Int -> Int -> U.Vector Double -> Double #-} {-# SPECIALIZE - continuousBy :: ContParam -> Int -> Int -> V.Vector Double -> Double #-} + quantile :: ContParam -> Int -> Int -> V.Vector Double -> Double #-} +{-# SPECIALIZE + quantile :: ContParam -> Int -> Int -> S.Vector Double -> Double #-} --- | O(/n/ log /n/). Estimate the range between /q/-quantiles 1 and --- /q/-1 of a sample /x/, using the continuous sample method with the --- given parameters. +-- | O(/k·n/·log /n/). Estimate set of the /k/th /q/-quantile of a +-- sample /x/, using the continuous sample method with the given +-- parameters. This is faster than calling quantile repeatedly since +-- sample should be sorted only once -- --- For instance, the interquartile range (IQR) can be estimated as --- follows: +-- The following properties should hold, otherwise an error will be thrown. -- --- > midspread medianUnbiased 4 (U.fromList [1,1,2,2,3]) --- > ==> 1.333333 -midspread :: G.Vector v Double => - ContParam -- ^ Parameters /a/ and /b/. - -> Int -- ^ /q/, the number of quantiles. - -> v Double -- ^ /x/, the sample data. - -> Double -midspread (ContParam a b) k x - | G.any isNaN x = modErr "midspread" "Sample contains NaNs" - | k <= 0 = modErr "midspread" "Nonpositive number of quantiles" - | otherwise = quantile (1-frac) - quantile frac +-- * input sample must be nonempty +-- +-- * the input does not contain @NaN@ +-- +-- * for every k in set of quantiles 0 ≤ k ≤ q +quantiles :: (G.Vector v Double, F.Foldable f, Functor f) + => ContParam + -> f Int + -> Int + -> v Double + -> f Double +quantiles param qs nQ xs + | nQ < 2 = modErr "quantiles" "At least 2 quantiles is needed" + | F.any (badQ nQ) qs = modErr "quantiles" "Wrong quantile number" + | G.any isNaN xs = modErr "quantiles" "Sample contains NaNs" + -- Doesn't matter what we put into empty container + | null qs = 0 <$ qs + | otherwise = fmap (estimateQuantile sortedXs) ks' where - quantile i = (1-h i) * item (j i-1) + h i * item (j i) - j i = floor (t i + eps) :: Int - t i = a + i * (fromIntegral n + 1 - a - b) - h i | abs r < eps = 0 - | otherwise = r - where r = t i - fromIntegral (j i) - eps = m_epsilon * 4 - n = G.length x - item = (sx !) . bracket - sx = partialSort (bracket (j (1-frac)) + 1) x - bracket m = min (max m 0) (n - 1) - frac = 1 / fromIntegral k -{-# SPECIALIZE midspread :: ContParam -> Int -> U.Vector Double -> Double #-} -{-# SPECIALIZE midspread :: ContParam -> Int -> V.Vector Double -> Double #-} + ks' = fmap (\q -> toPk param n q nQ) qs + sortedXs = psort xs $ floor (F.maximum ks') + 1 + n = G.length xs +{-# INLINABLE quantiles #-} +{-# SPECIALIZE quantiles + :: (Functor f, F.Foldable f) => ContParam -> f Int -> Int -> V.Vector Double -> f Double #-} +{-# SPECIALIZE quantiles + :: (Functor f, F.Foldable f) => ContParam -> f Int -> Int -> U.Vector Double -> f Double #-} +{-# SPECIALIZE quantiles + :: (Functor f, F.Foldable f) => ContParam -> f Int -> Int -> S.Vector Double -> f Double #-} --- | California Department of Public Works definition, /a/=0, /b/=1. +-- | O(/k·n/·log /n/). Same as quantiles but uses 'G.Vector' container +-- instead of 'Foldable' one. +quantilesVec :: (G.Vector v Double, G.Vector v Int) + => ContParam + -> v Int + -> Int + -> v Double + -> v Double +quantilesVec param qs nQ xs + | nQ < 2 = modErr "quantilesVec" "At least 2 quantiles is needed" + | G.any (badQ nQ) qs = modErr "quantilesVec" "Wrong quantile number" + | G.any isNaN xs = modErr "quantilesVec" "Sample contains NaNs" + | G.null qs = G.empty + | otherwise = G.map (estimateQuantile sortedXs) ks' + where + ks' = G.map (\q -> toPk param n q nQ) qs + sortedXs = psort xs $ floor (G.maximum ks') + 1 + n = G.length xs +{-# INLINABLE quantilesVec #-} +{-# SPECIALIZE quantilesVec + :: ContParam -> V.Vector Int -> Int -> V.Vector Double -> V.Vector Double #-} +{-# SPECIALIZE quantilesVec + :: ContParam -> U.Vector Int -> Int -> U.Vector Double -> U.Vector Double #-} +{-# SPECIALIZE quantilesVec + :: ContParam -> S.Vector Int -> Int -> S.Vector Double -> S.Vector Double #-} + + +-- Returns True if quantile number is out of range +badQ :: Int -> Int -> Bool +badQ nQ q = q < 0 || q > nQ + +-- Obtain k from equation for p_k [Hyndman1996] p.363. Note that +-- equation defines p_k for integer k but we calculate it as real +-- value and will use fractional part for linear interpolation. This +-- is correct since equation is linear. +toPk + :: ContParam + -> Int -- ^ /n/ number of elements + -> Int -- ^ /k/, the desired quantile. + -> Int -- ^ /q/, the number of quantiles. + -> Double +toPk (ContParam a b) (fromIntegral -> n) q nQ + = a + p * (n + 1 - a - b) + where + p = fromIntegral q / fromIntegral nQ + +-- Estimate quantile for given k (including fractional part) +estimateQuantile :: G.Vector v Double => v Double -> Double -> Double +{-# INLINE estimateQuantile #-} +estimateQuantile sortedXs k' + = (1-g) * item (k-1) + g * item k + where + (k,g) = properFraction k' + item = (sortedXs !) . clamp + -- + clamp = max 0 . min (n - 1) + n = G.length sortedXs + +psort :: G.Vector v Double => v Double -> Int -> v Double +psort xs k = partialSort (max 0 $ min (G.length xs - 1) k) xs +{-# INLINE psort #-} + + +-- | California Department of Public Works definition, /α/=0, /β/=1. -- Gives a linear interpolation of the empirical CDF. This -- corresponds to method 4 in R and Mathematica. cadpw :: ContParam cadpw = ContParam 0 1 --- | Hazen's definition, /a/=0.5, /b/=0.5. This is claimed to be +-- | Hazen's definition, /α/=0.5, /β/=0.5. This is claimed to be -- popular among hydrologists. This corresponds to method 5 in R and -- Mathematica. hazen :: ContParam hazen = ContParam 0.5 0.5 --- | Definition used by the SPSS statistics application, with /a/=0, --- /b/=0 (also known as Weibull's definition). This corresponds to +-- | Definition used by the SPSS statistics application, with /α/=0, +-- /β/=0 (also known as Weibull's definition). This corresponds to -- method 6 in R and Mathematica. spss :: ContParam spss = ContParam 0 0 --- | Definition used by the S statistics application, with /a/=1, --- /b/=1. The interpolation points divide the sample range into @n-1@ --- intervals. This corresponds to method 7 in R and Mathematica. +-- | Definition used by the S statistics application, with /α/=1, +-- /β/=1. The interpolation points divide the sample range into @n-1@ +-- intervals. This corresponds to method 7 in R and Mathematica and +-- is default in R. s :: ContParam s = ContParam 1 1 --- | Median unbiased definition, /a/=1\/3, /b/=1\/3. The resulting +-- | Median unbiased definition, /α/=1\/3, /β/=1\/3. The resulting -- quantile estimates are approximately median unbiased regardless of -- the distribution of /x/. This corresponds to method 8 in R and -- Mathematica. @@ -169,7 +304,7 @@ medianUnbiased = ContParam third third where third = 1/3 --- | Normal unbiased definition, /a/=3\/8, /b/=3\/8. An approximately +-- | Normal unbiased definition, /α/=3\/8, /β/=3\/8. An approximately -- unbiased estimate if the empirical distribution approximates the -- normal distribution. This corresponds to method 9 in R and -- Mathematica. @@ -180,11 +315,86 @@ modErr :: String -> String -> a modErr f err = error $ "Statistics.Quantile." ++ f ++ ": " ++ err + +---------------------------------------------------------------- +-- Specializations +---------------------------------------------------------------- + +-- | O(/n/·log /n/) Estimate median of sample +median :: G.Vector v Double + => ContParam -- ^ Parameters /α/ and /β/. + -> v Double -- ^ /x/, the sample data. + -> Double +{-# INLINE median #-} +median p = quantile p 1 2 + +-- | O(/n/·log /n/). Estimate the range between /q/-quantiles 1 and +-- /q/-1 of a sample /x/, using the continuous sample method with the +-- given parameters. +-- +-- For instance, the interquartile range (IQR) can be estimated as +-- follows: +-- +-- > midspread medianUnbiased 4 (U.fromList [1,1,2,2,3]) +-- > ==> 1.333333 +midspread :: G.Vector v Double => + ContParam -- ^ Parameters /α/ and /β/. + -> Int -- ^ /q/, the number of quantiles. + -> v Double -- ^ /x/, the sample data. + -> Double +midspread param k x + | G.any isNaN x = modErr "midspread" "Sample contains NaNs" + | k <= 0 = modErr "midspread" "Nonpositive number of quantiles" + | otherwise = let Pair x1 x2 = quantiles param (Pair 1 (k-1)) k x + in x2 - x1 +{-# INLINABLE midspread #-} +{-# SPECIALIZE midspread :: ContParam -> Int -> U.Vector Double -> Double #-} +{-# SPECIALIZE midspread :: ContParam -> Int -> V.Vector Double -> Double #-} +{-# SPECIALIZE midspread :: ContParam -> Int -> S.Vector Double -> Double #-} + +data Pair a = Pair !a !a + deriving (Functor, F.Foldable) + + +-- | O(/n/·log /n/). Estimate the median absolute deviation (MAD) of a +-- sample /x/ using 'continuousBy'. It's robust estimate of +-- variability in sample and defined as: +-- +-- \[ +-- MAD = \operatorname{median}(| X_i - \operatorname{median}(X) |) +-- \] +mad :: G.Vector v Double + => ContParam -- ^ Parameters /α/ and /β/. + -> v Double -- ^ /x/, the sample data. + -> Double +mad p xs + = median p $ G.map (abs . subtract med) xs + where + med = median p xs +{-# INLINABLE mad #-} +{-# SPECIALIZE mad :: ContParam -> U.Vector Double -> Double #-} +{-# SPECIALIZE mad :: ContParam -> V.Vector Double -> Double #-} +{-# SPECIALIZE mad :: ContParam -> S.Vector Double -> Double #-} + + +---------------------------------------------------------------- +-- Deprecated +---------------------------------------------------------------- + +continuousBy :: G.Vector v Double => + ContParam -- ^ Parameters /α/ and /β/. + -> Int -- ^ /k/, the desired quantile. + -> Int -- ^ /q/, the number of quantiles. + -> v Double -- ^ /x/, the sample data. + -> Double +continuousBy = quantile +{-# DEPRECATED continuousBy "Use quantile instead" #-} + -- $references -- -- * Weisstein, E.W. Quantile. /MathWorld/. -- -- --- * Hyndman, R.J.; Fan, Y. (1996) Sample quantiles in statistical +-- * [Hyndman1996] Hyndman, R.J.; Fan, Y. (1996) Sample quantiles in statistical -- packages. /American Statistician/ -- 50(4):361–365. diff --git a/Statistics/Regression.hs b/Statistics/Regression.hs --- a/Statistics/Regression.hs +++ b/Statistics/Regression.hs @@ -13,18 +13,17 @@ , bootstrapRegress ) where -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.Chan (newChan, readChan, writeChan) +import Control.Concurrent.Async (forConcurrently) import Control.DeepSeq (rnf) -import Control.Monad (forM_, replicateM) +import Control.Monad (when) +import Data.List (nub) import GHC.Conc (getNumCapabilities) import Prelude hiding (pred, sum) import Statistics.Function as F import Statistics.Matrix hiding (map) import Statistics.Matrix.Algorithms (qr) import Statistics.Resampling (splitGen) -import Statistics.Resampling.Bootstrap (Estimate(..)) +import Statistics.Types (Estimate(..),ConfInt,CL,estimateFromInterval,significanceLevel) import Statistics.Sample (mean) import Statistics.Sample.Internal (sum) import System.Random.MWC (GenIO, uniformR) @@ -42,8 +41,15 @@ -- element than the list of predictors; the last element is the -- /y/-intercept value. -- --- * /R²/, the coefficient of determination (see 'rSquare' for +-- * /R²/, the coefficient of determination (see 'rSquare' for -- details). +-- +-- >>> import qualified Data.Vector.Unboxed as VU +-- >>> :{ +-- olsRegress [ VU.fromList [0,1,2,3] +-- ] (VU.fromList [1000, 1001, 1002, 1003]) +-- :} +-- ([1.0000000000000218,999.9999999999999],1.0) olsRegress :: [Vector] -- ^ Non-empty list of predictor vectors. Must all have -- the same length. These will become the columns of @@ -66,7 +72,30 @@ lss@(n:ls) = map G.length preds olsRegress _ _ = error "no predictors given" --- | Compute the ordinary least-squares solution to /A x = b/. +-- | Compute the ordinary least-squares solution to overdetermined +-- linear system \(Ax = b\). In other words it finds +-- +-- \[ \operatorname{argmin}|Ax-b|^2 \]. +-- +-- All columns of \(A\) must be linearly independent. It's not +-- checked function will return nonsensical result if resulting +-- linear system is poorly conditioned. +-- +-- >>> import qualified Data.Vector.Unboxed as VU +-- >>> :{ +-- ols (fromColumns [ VU.fromList [0,1,2,3] +-- , VU.fromList [1,1,1,1] +-- ]) (VU.fromList [1000, 1001, 1002, 1003]) +-- :} +-- [1.0000000000000218,999.9999999999999] +-- +-- >>> :{ +-- ols (fromColumns [ VU.fromList [0,1,2,3] +-- , VU.fromList [4,2,1,1] +-- , VU.fromList [1,1,1,1] +-- ]) (VU.fromList [1000, 1001, 1002, 1003]) +-- :} +-- [1.0000000000005393,4.2290644612446807e-13,999.9999999999983] ols :: Matrix -- ^ /A/ has at least as many rows as columns. -> Vector -- ^ /b/ has the same length as columns in /A/. -> Vector @@ -88,12 +117,12 @@ rfor n 0 $ \i -> do si <- (/ unsafeIndex r i i) <$> M.unsafeRead s i M.unsafeWrite s i si - for 0 i $ \j -> F.unsafeModify s j $ subtract ((unsafeIndex r j i) * si) + F.for 0 i $ \j -> F.unsafeModify s j $ subtract (unsafeIndex r j i * si) return s where n = rows r l = U.length b --- | Compute /R²/, the coefficient of determination that +-- | Compute /R²/, the coefficient of determination that -- indicates goodness-of-fit of a regression. -- -- This value will be 1 if the predictors fit perfectly, dropping to 0 @@ -102,51 +131,71 @@ -> Vector -- ^ Responders. -> Vector -- ^ Regression coefficients. -> Double -rSquare pred resp coeff = 1 - r / t +rSquare pred resp coeff + -- Data has zero variance. If fit is perfect we set R² to 1 else to + -- 0. This is not perfect heuristic. Fit residuals may be nonzero + -- due to rounding. + | t == 0 = if r == 0 then 1 else 0 + -- If fit residuals are worse than average we simply set R² to 0 + | r2 >= 0 && r2 <= 1 = r2 + | otherwise = 0 where - r = sum $ flip U.imap resp $ \i x -> square (x - p i) - t = sum $ flip U.map resp $ \x -> square (x - mean resp) - p i = sum . flip U.imap coeff $ \j -> (* unsafeIndex pred i j) + r2 = 1 - r / t + r = sum $ flip U.imap resp $ \i x -> square (x - p i) + t = sum $ flip U.map resp $ \x -> square (x - mean resp) + p i = sum $ flip U.imap coeff $ \j x -> x * unsafeIndex pred i j -- | Bootstrap a regression function. Returns both the results of the -- regression and the requested confidence interval values. -bootstrapRegress :: GenIO - -> Int -- ^ Number of resamples to compute. - -> Double -- ^ Confidence interval. - -> ([Vector] -> Vector -> (Vector, Double)) - -- ^ Regression function. - -> [Vector] -- ^ Predictor vectors. - -> Vector -- ^ Responder vector. - -> IO (V.Vector Estimate, Estimate) -bootstrapRegress gen0 numResamples ci rgrss preds0 resp0 +bootstrapRegress + :: GenIO + -> Int -- ^ Number of resamples to compute. + -> CL Double -- ^ Confidence level. + -> ([Vector] -> Vector -> (Vector, Double)) + -- ^ Regression function. + -> [Vector] -- ^ Predictor vectors. + -> Vector -- ^ Responder vector. + -> IO (V.Vector (Estimate ConfInt Double), Estimate ConfInt Double) +bootstrapRegress gen0 numResamples cl rgrss preds0 resp0 | numResamples < 1 = error $ "bootstrapRegress: number of resamples " ++ "must be positive" - | ci <= 0 || ci >= 1 = error $ "bootstrapRegress: confidence interval " ++ - "must lie between 0 and 1" | otherwise = do + + -- some error checks so that we do not run into vector index out of bounds. + case nub (map U.length preds0) of + [] -> error "bootstrapRegress: predictor vectors must not be empty" + [plen] -> do + let rlen = U.length resp0 + when (plen /= rlen) $ + error $ "bootstrapRegress: responder vector length [" + ++ show rlen + ++ "] must be the same as predictor vectors' length [" + ++ show plen ++ "]" + xs -> error $ "bootstrapRegress: all predictor vectors must be of the same \ + \length, lengths provided are: " ++ show xs + caps <- getNumCapabilities gens <- splitGen caps gen0 - done <- newChan - forM_ (zip gens (balance caps numResamples)) $ \(gen,count) -> do - forkIO $ do + vs <- forConcurrently (zip gens (balance caps numResamples)) $ \(gen,count) -> do v <- V.replicateM count $ do let n = U.length resp0 ixs <- U.replicateM n $ uniformR (0,n-1) gen let resp = U.backpermute resp0 ixs preds = map (flip U.backpermute ixs) preds0 return $ rgrss preds resp - rnf v `seq` writeChan done v - (coeffsv, r2v) <- (G.unzip . V.concat) <$> replicateM caps (readChan done) + rnf v `seq` return v + let (coeffsv, r2v) = G.unzip (V.concat vs) let coeffs = flip G.imap (G.convert coeffss) $ \i x -> - est x . U.generate numResamples $ \k -> ((coeffsv G.! k) G.! i) + est x . U.generate numResamples $ \k -> (coeffsv G.! k) G.! i r2 = est r2s (G.convert r2v) (coeffss, r2s) = rgrss preds0 resp0 - est s v = Estimate s (w G.! lo) (w G.! hi) ci + est s v = estimateFromInterval s (w G.! lo, w G.! hi) cl where w = F.sort v - lo = round c - hi = truncate (n - c) + bounded i = min (U.length w - 1) (max 0 i) + lo = bounded $ round c + hi = bounded $ truncate (n - c) n = fromIntegral numResamples - c = n * ((1 - ci) / 2) + c = n * (significanceLevel cl / 2) return (coeffs, r2) -- | Balance units of work across workers. diff --git a/Statistics/Resampling.hs b/Statistics/Resampling.hs --- a/Statistics/Resampling.hs +++ b/Statistics/Resampling.hs @@ -1,4 +1,11 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Statistics.Resampling @@ -12,38 +19,54 @@ -- Resampling statistics. module Statistics.Resampling - ( + ( -- * Data types Resample(..) + , Bootstrap(..) + , Estimator(..) + , estimate + -- * Resampling + , resampleST + , resample + , resampleVector + -- * Jackknife , jackknife , jackknifeMean , jackknifeVariance , jackknifeVarianceUnb , jackknifeStdDev - , resample - , estimate + -- * Helper functions , splitGen ) where import Data.Aeson (FromJSON, ToJSON) -import Control.Concurrent (forkIO, newChan, readChan, writeChan) -import Control.Monad (forM_, liftM, replicateM, replicateM_) +import Control.Concurrent.Async (forConcurrently_) +import Control.Monad (forM_, forM, replicateM, liftM2) +import Control.Monad.Primitive (PrimMonad(..)) import Data.Binary (Binary(..)) import Data.Data (Data, Typeable) import Data.Vector.Algorithms.Intro (sort) import Data.Vector.Binary () -import Data.Vector.Generic (unsafeFreeze) +import Data.Vector.Generic (unsafeFreeze,unsafeThaw) import Data.Word (Word32) +import qualified Data.Foldable as T +import qualified Data.Traversable as T +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU + import GHC.Conc (numCapabilities) import GHC.Generics (Generic) import Numeric.Sum (Summation(..), kbn) import Statistics.Function (indices) import Statistics.Sample (mean, stdDev, variance, varianceUnbiased) -import Statistics.Types (Estimator(..), Sample) -import System.Random.MWC (GenIO, initialize, uniform, uniformVector) -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as MU +import Statistics.Types (Sample) +import System.Random.MWC (Gen, GenIO, initialize, uniformR, uniformVector) + +---------------------------------------------------------------- +-- Data types +---------------------------------------------------------------- + -- | A resample drawn randomly, with replacement, from a set of data -- points. Distinct from a normal array to make it harder for your -- humble author's brain to go wrong. @@ -58,6 +81,66 @@ put = put . fromResample get = fmap Resample get +data Bootstrap v a = Bootstrap + { fullSample :: !a + , resamples :: v a + } + deriving (Eq, Read, Show , Generic, Functor, T.Foldable, T.Traversable + , Typeable, Data + ) + +instance (Binary a, Binary (v a)) => Binary (Bootstrap v a) where + get = liftM2 Bootstrap get get + put (Bootstrap fs rs) = put fs >> put rs +instance (FromJSON a, FromJSON (v a)) => FromJSON (Bootstrap v a) +instance (ToJSON a, ToJSON (v a)) => ToJSON (Bootstrap v a) + + + +-- | An estimator of a property of a sample, such as its 'mean'. +-- +-- The use of an algebraic data type here allows functions such as +-- 'jackknife' and 'bootstrapBCA' to use more efficient algorithms +-- when possible. +data Estimator = Mean + | Variance + | VarianceUnbiased + | StdDev + | Function (Sample -> Double) + +-- | Run an 'Estimator' over a sample. +estimate :: Estimator -> Sample -> Double +estimate Mean = mean +estimate Variance = variance +estimate VarianceUnbiased = varianceUnbiased +estimate StdDev = stdDev +estimate (Function est) = est + + +---------------------------------------------------------------- +-- Resampling +---------------------------------------------------------------- + +-- | Single threaded and deterministic version of resample. +resampleST :: PrimMonad m + => Gen (PrimState m) + -> [Estimator] -- ^ Estimation functions. + -> Int -- ^ Number of resamples to compute. + -> U.Vector Double -- ^ Original sample. + -> m [Bootstrap U.Vector Double] +resampleST gen ests numResamples sample = do + -- Generate resamples + res <- forM ests $ \e -> U.replicateM numResamples $ do + v <- resampleVector gen sample + return $! estimate e v + -- Sort resamples + resM <- mapM unsafeThaw res + mapM_ sort resM + resSorted <- mapM unsafeFreeze resM + return $ zipWith Bootstrap [estimate e sample | e <- ests] + resSorted + + -- | /O(e*r*s)/ Resample a data set repeatedly, with replacement, -- computing each estimate over the resampled data. -- @@ -73,42 +156,48 @@ resample :: GenIO -> [Estimator] -- ^ Estimation functions. -> Int -- ^ Number of resamples to compute. - -> Sample -- ^ Original sample. - -> IO [Resample] + -> U.Vector Double -- ^ Original sample. + -> IO [(Estimator, Bootstrap U.Vector Double)] resample gen ests numResamples samples = do - let !numSamples = U.length samples - ixs = scanl (+) 0 $ + let ixs = scanl (+) 0 $ zipWith (+) (replicate numCapabilities q) (replicate r 1 ++ repeat 0) where (q,r) = numResamples `quotRem` numCapabilities results <- mapM (const (MU.new numResamples)) ests - done <- newChan gens <- splitGen numCapabilities gen - forM_ (zip3 ixs (tail ixs) gens) $ \ (start,!end,gen') -> do - forkIO $ do - let loop k ers | k >= end = writeChan done () + forConcurrently_ (zip3 ixs (tail ixs) gens) $ \ (start,!end,gen') -> do + -- on GHCJS it doesn't make sense to do any forking. + -- JavaScript runtime has only single capability. + let loop k ers | k >= end = return () | otherwise = do - re <- U.replicateM numSamples $ do - r <- uniform gen' - return (U.unsafeIndex samples (r `mod` numSamples)) + re <- resampleVector gen' samples forM_ ers $ \(est,arr) -> MU.write arr k . est $ re loop (k+1) ers loop start (zip ests' results) - replicateM_ numCapabilities $ readChan done mapM_ sort results - mapM (liftM Resample . unsafeFreeze) results + -- Build resamples + res <- mapM unsafeFreeze results + return $ zip ests + $ zipWith Bootstrap [estimate e samples | e <- ests] + res where ests' = map estimate ests --- | Run an 'Estimator' over a sample. -estimate :: Estimator -> Sample -> Double -estimate Mean = mean -estimate Variance = variance -estimate VarianceUnbiased = varianceUnbiased -estimate StdDev = stdDev -estimate (Function est) = est +-- | Create vector using resamples +resampleVector :: (PrimMonad m, G.Vector v a) + => Gen (PrimState m) -> v a -> m (v a) +resampleVector gen v + = G.replicateM n $ do i <- uniformR (0,n-1) gen + return $! G.unsafeIndex v i + where + n = G.length v + +---------------------------------------------------------------- +-- Jackknife +---------------------------------------------------------------- + -- | /O(n) or O(n^2)/ Compute a statistical estimate repeatedly over a -- sample, each time omitting a successive element. jackknife :: Estimator -> Sample -> U.Vector Double @@ -152,7 +241,9 @@ -- | /O(n)/ Compute the unbiased jackknife variance of a sample. jackknifeVarianceUnb :: Sample -> U.Vector Double -jackknifeVarianceUnb = jackknifeVariance_ 1 +jackknifeVarianceUnb samp + | G.length samp == 2 = singletonErr "jackknifeVariance" + | otherwise = jackknifeVariance_ 1 samp -- | /O(n)/ Compute the jackknife variance of a sample. jackknifeVariance :: Sample -> U.Vector Double @@ -174,7 +265,7 @@ singletonErr :: String -> a singletonErr func = error $ - "Statistics.Resampling." ++ func ++ ": singleton input" + "Statistics.Resampling." ++ func ++ ": not enough elements in sample" -- | Split a generator into several that can run independently. splitGen :: Int -> GenIO -> IO [GenIO] diff --git a/Statistics/Resampling/Bootstrap.hs b/Statistics/Resampling/Bootstrap.hs --- a/Statistics/Resampling/Bootstrap.hs +++ b/Statistics/Resampling/Bootstrap.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings, - RecordWildCards #-} - -- | -- Module : Statistics.Resampling.Bootstrap -- Copyright : (c) 2009, 2011 Bryan O'Sullivan @@ -13,109 +10,67 @@ -- The bootstrap method for statistical inference. module Statistics.Resampling.Bootstrap - ( - Estimate(..) - , bootstrapBCA - , scale + ( bootstrapBCA + , basicBootstrap -- * References -- $references ) where -import Control.Applicative ((<$>), (<*>)) -import Control.DeepSeq (NFData) -import Control.Exception (assert) -import Control.Monad.Par (parMap, runPar) -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary) -import Data.Binary (put, get) -import Data.Data (Data) -import Data.Typeable (Typeable) -import Data.Vector.Unboxed ((!)) -import GHC.Generics (Generic) +import Data.Vector.Generic ((!)) +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Generic as G + import Statistics.Distribution (cumulative, quantile) import Statistics.Distribution.Normal -import Statistics.Resampling (Resample(..), jackknife) +import Statistics.Resampling (Bootstrap(..), jackknife) import Statistics.Sample (mean) -import Statistics.Types (Estimator, Sample) -import qualified Data.Vector.Unboxed as U -import qualified Statistics.Resampling as R - --- | A point and interval estimate computed via an 'Estimator'. -data Estimate = Estimate { - estPoint :: {-# UNPACK #-} !Double - -- ^ Point estimate. - , estLowerBound :: {-# UNPACK #-} !Double - -- ^ Lower bound of the estimate interval (i.e. the lower bound of - -- the confidence interval). - , estUpperBound :: {-# UNPACK #-} !Double - -- ^ Upper bound of the estimate interval (i.e. the upper bound of - -- the confidence interval). - , estConfidenceLevel :: {-# UNPACK #-} !Double - -- ^ Confidence level of the confidence intervals. - } deriving (Eq, Read, Show, Typeable, Data, Generic) - -instance FromJSON Estimate -instance ToJSON Estimate - -instance Binary Estimate where - put (Estimate w x y z) = put w >> put x >> put y >> put z - get = Estimate <$> get <*> get <*> get <*> get -instance NFData Estimate +import Statistics.Types (Sample, CL, Estimate, ConfInt, estimateFromInterval, + estimateFromErr, CL, significanceLevel) +import Statistics.Function (gsort) --- | Multiply the point, lower bound, and upper bound in an 'Estimate' --- by the given value. -scale :: Double -- ^ Value to multiply by. - -> Estimate -> Estimate -scale f e@Estimate{..} = e { - estPoint = f * estPoint - , estLowerBound = f * estLowerBound - , estUpperBound = f * estUpperBound - } +import qualified Statistics.Resampling as R -estimate :: Double -> Double -> Double -> Double -> Estimate -estimate pt lb ub cl = - assert (lb <= ub) . - assert (cl > 0 && cl < 1) $ - Estimate { estPoint = pt - , estLowerBound = lb - , estUpperBound = ub - , estConfidenceLevel = cl - } +import Control.Parallel.Strategies (parMap, rdeepseq) data T = {-# UNPACK #-} !Double :< {-# UNPACK #-} !Double infixl 2 :< -- | Bias-corrected accelerated (BCA) bootstrap. This adjusts for both --- bias and skewness in the resampled distribution. -bootstrapBCA :: Double -- ^ Confidence level - -> Sample -- ^ Sample data - -> [Estimator] -- ^ Estimators - -> [Resample] -- ^ Resampled data - -> [Estimate] -bootstrapBCA confidenceLevel sample estimators resamples - | confidenceLevel > 0 && confidenceLevel < 1 - = runPar $ parMap (uncurry e) (zip estimators resamples) - | otherwise = error "Statistics.Resampling.Bootstrap.bootstrapBCA: confidence level outside (0,1) range" +-- bias and skewness in the resampled distribution. +-- +-- BCA algorithm is described in ch. 5 of Davison, Hinkley "Confidence +-- intervals" in section 5.3 "Percentile method" +bootstrapBCA + :: CL Double -- ^ Confidence level + -> Sample -- ^ Full data sample + -> [(R.Estimator, Bootstrap U.Vector Double)] + -- ^ Estimates obtained from resampled data and estimator used for + -- this. + -> [Estimate ConfInt Double] +bootstrapBCA confidenceLevel sample resampledData + = parMap rdeepseq e resampledData where - e est (Resample resample) + e (est, Bootstrap pt resample) | U.length sample == 1 || isInfinite bias = - estimate pt pt pt confidenceLevel + estimateFromErr pt (0,0) confidenceLevel | otherwise = - estimate pt (resample ! lo) (resample ! hi) confidenceLevel + estimateFromInterval pt (resample ! lo, resample ! hi) confidenceLevel where - pt = R.estimate est sample - lo = max (cumn a1) 0 + -- Quantile estimates for given CL + lo = min (max (cumn a1) 0) (ni - 1) where a1 = bias + b1 / (1 - accel * b1) b1 = bias + z1 - hi = min (cumn a2) (ni - 1) + hi = max (min (cumn a2) (ni - 1)) 0 where a2 = bias + b2 / (1 - accel * b2) b2 = bias - z1 - z1 = quantile standard ((1 - confidenceLevel) / 2) + -- Number of resamples + ni = U.length resample + n = fromIntegral ni + -- Corrections + z1 = quantile standard (significanceLevel confidenceLevel / 2) cumn = round . (*n) . cumulative standard bias = quantile standard (probN / n) where probN = fromIntegral . U.length . U.filter ( CL Double -- ^ Confidence vector + -> Bootstrap v a -- ^ Estimate from full sample and vector of + -- estimates obtained from resamples + -> Estimate ConfInt a +{-# INLINE basicBootstrap #-} +basicBootstrap cl (Bootstrap e ests) + = estimateFromInterval e (sorted ! lo, sorted ! hi) cl + where + sorted = gsort ests + n = fromIntegral $ G.length ests + c = n * (significanceLevel cl / 2) + -- FIXME: can we have better estimates of quantiles in case when p + -- is not multiple of 1/N + -- + -- FIXME: we could have undercoverage here + lo = round c + hi = truncate (n - c) -- $references -- diff --git a/Statistics/Sample.hs b/Statistics/Sample.hs --- a/Statistics/Sample.hs +++ b/Statistics/Sample.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module : Statistics.Sample -- Copyright : (c) 2008 Don Stewart, 2009 Bryan O'Sullivan @@ -20,6 +21,7 @@ , range -- * Statistics of location + , expectation , mean , welfordMean , meanWeighted @@ -43,6 +45,7 @@ , meanVarianceUnb , stdDev , varianceWeighted + , stdErrMean -- ** Single-pass functions (faster, less safe) -- $cancellation @@ -50,22 +53,25 @@ , fastVarianceUnbiased , fastStdDev - -- * Joint distirbutions + -- * Joint distributions , covariance , correlation + , covariance2 + , correlation2 , pair -- * References -- $references ) where -import Statistics.Function (minMax) +import Statistics.Function (minMax,square) import Statistics.Sample.Internal (robustSumVar, sum) -import Statistics.Types (Sample,WeightedSample) +import Statistics.Types.Internal (Sample,WeightedSample) import qualified Data.Vector as V import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U +import Numeric.Sum (kbn, Summation(zero,add)) --- Operator ^ will be overriden +-- Operator ^ will be overridden import Prelude hiding ((^), sum) -- | /O(n)/ Range. The difference between the largest and smallest @@ -75,9 +81,17 @@ where (lo , hi) = minMax s {-# INLINE range #-} +-- | /O(n)/ Compute expectation of function over for sample. This is +-- simply @mean . map f@ but won't create intermediate vector. +expectation :: (G.Vector v a) => (a -> Double) -> v a -> Double +expectation f xs = kbn (G.foldl' (\s -> add s . f) zero xs) + / fromIntegral (G.length xs) +{-# INLINE expectation #-} + -- | /O(n)/ Arithmetic mean. This uses Kahan-Babuška-Neumaier -- summation, so is more accurate than 'welfordMean' unless the input --- values are very large. +-- values are very large. This function is not subject to stream +-- fusion. mean :: (G.Vector v Double) => v Double -> Double mean xs = sum xs / fromIntegral (G.length xs) {-# SPECIALIZE mean :: U.Vector Double -> Double #-} @@ -121,7 +135,7 @@ -- | /O(n)/ Geometric mean of a sample containing no negative values. geometricMean :: (G.Vector v Double) => v Double -> Double -geometricMean = exp . mean . G.map log +geometricMean = exp . expectation log {-# INLINE geometricMean #-} -- | Compute the /k/th central moment of a sample. The central moment @@ -137,7 +151,7 @@ | a < 0 = error "Statistics.Sample.centralMoment: negative input" | a == 0 = 1 | a == 1 = 0 - | otherwise = sum (G.map go xs) / fromIntegral (G.length xs) + | otherwise = expectation go xs where go x = (x-m) ^ a m = mean xs @@ -214,7 +228,7 @@ -- $variance -- --- The variance—and hence the standard deviation—of a +-- The variance — and hence the standard deviation — of a -- sample of fewer than two elements are both defined to be zero. -- $robust @@ -284,6 +298,13 @@ {-# SPECIALIZE stdDev :: U.Vector Double -> Double #-} {-# SPECIALIZE stdDev :: V.Vector Double -> Double #-} +-- | Standard error of the mean. This is the standard deviation +-- divided by the square root of the sample size. +stdErrMean :: (G.Vector v Double) => v Double -> Double +stdErrMean samp = stdDev samp / (sqrt . fromIntegral . G.length) samp +{-# SPECIALIZE stdErrMean :: U.Vector Double -> Double #-} +{-# SPECIALIZE stdErrMean :: V.Vector Double -> Double #-} + robustSumVarWeighted :: (G.Vector v (Double,Double)) => v (Double,Double) -> V robustSumVarWeighted samp = G.foldl' go (V 0 0) samp where @@ -346,42 +367,79 @@ -- | Covariance of sample of pairs. For empty sample it's set to -- zero -covariance :: (G.Vector v (Double,Double), G.Vector v Double) +covariance :: (G.Vector v (Double,Double)) => v (Double,Double) -> Double covariance xy | n == 0 = 0 - | otherwise = mean $ G.zipWith (*) - (G.map (\x -> x - muX) xs) - (G.map (\y -> y - muY) ys) + | otherwise = expectation (\(x,y) -> (x - muX)*(y - muY)) xy where - n = G.length xy - (xs,ys) = G.unzip xy - muX = mean xs - muY = mean ys + n = G.length xy + muX = expectation fst xy + muY = expectation snd xy {-# SPECIALIZE covariance :: U.Vector (Double,Double) -> Double #-} {-# SPECIALIZE covariance :: V.Vector (Double,Double) -> Double #-} -- | Correlation coefficient for sample of pairs. Also known as -- Pearson's correlation. For empty sample it's set to zero. -correlation :: (G.Vector v (Double,Double), G.Vector v Double) +correlation :: (G.Vector v (Double,Double)) => v (Double,Double) -> Double correlation xy | n == 0 = 0 | otherwise = cov / sqrt (varX * varY) where - n = G.length xy - (xs,ys) = G.unzip xy - (muX,varX) = meanVariance xs - (muY,varY) = meanVariance ys - cov = mean $ G.zipWith (*) - (G.map (\x -> x - muX) xs) - (G.map (\y -> y - muY) ys) + n = G.length xy + muX = expectation (\(x,_) -> x) xy + muY = expectation (\(_,y) -> y) xy + varX = expectation (\(x,_) -> square (x - muX)) xy + varY = expectation (\(_,y) -> square (y - muY)) xy + cov = expectation (\(x,y) -> (x - muX)*(y - muY)) xy {-# SPECIALIZE correlation :: U.Vector (Double,Double) -> Double #-} {-# SPECIALIZE correlation :: V.Vector (Double,Double) -> Double #-} +-- | Covariance of two samples. Both vectors must be of the same +-- length. If both are empty it's set to zero +covariance2 :: (G.Vector v Double) + => v Double + -> v Double + -> Double +covariance2 xs ys + | nx /= ny = error $ "Statistics.Sample.covariance2: both samples must have same length" + | nx == 0 = 0 + | otherwise = sum (G.zipWith (\x y -> (x - muX)*(y - muY)) xs ys) + / fromIntegral nx + where + nx = G.length xs + ny = G.length ys + muX = mean xs + muY = mean ys +{-# SPECIALIZE covariance2 :: U.Vector Double -> U.Vector Double -> Double #-} +{-# SPECIALIZE covariance2 :: V.Vector Double -> V.Vector Double -> Double #-} + +-- | Correlation coefficient for two samples. Both vector must have +-- same length Also known as Pearson's correlation. For empty sample +-- it's set to zero. +correlation2 :: (G.Vector v Double) + => v Double + -> v Double + -> Double +correlation2 xs ys + | nx /= ny = error $ "Statistics.Sample.correlation2: both samples must have same length" + | nx == 0 = 0 + | otherwise = cov / sqrt (varX * varY) + where + nx = G.length xs + ny = G.length ys + (muX,varX) = meanVariance xs + (muY,varY) = meanVariance ys + cov = sum (G.zipWith (\x y -> (x - muX)*(y - muY)) xs ys) + / fromIntegral nx +{-# SPECIALIZE correlation2 :: U.Vector Double -> U.Vector Double -> Double #-} +{-# SPECIALIZE correlation2 :: V.Vector Double -> V.Vector Double -> Double #-} + + -- | Pair two samples. It's like 'G.zip' but requires that both -- samples have equal size. pair :: (G.Vector v a, G.Vector v b, G.Vector v (a,b)) => v a -> v b -> v (a,b) @@ -395,8 +453,9 @@ -- (^) operator from Prelude is just slow. (^) :: Double -> Int -> Double -x ^ 1 = x -x ^ n = x * (x ^ (n-1)) +x0 ^ n0 = go (n0-1) x0 where + go 0 !acc = acc + go n acc = go (n-1) (acc*x0) {-# INLINE (^) #-} -- don't support polymorphism, as we can't get unboxed returns if we use it. diff --git a/Statistics/Sample/Histogram.hs b/Statistics/Sample/Histogram.hs --- a/Statistics/Sample/Histogram.hs +++ b/Statistics/Sample/Histogram.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, BangPatterns, ScopedTypeVariables #-} -- | -- Module : Statistics.Sample.Histogram @@ -19,6 +19,7 @@ , range ) where +import Control.Monad.ST import Numeric.MathFunctions.Constants (m_epsilon,m_tiny) import Statistics.Function (minMax) import qualified Data.Vector.Generic as G @@ -49,7 +50,7 @@ -- -- Interval (bin) sizes are uniform, based on the supplied upper -- and lower bounds. -histogram_ :: (Num b, RealFrac a, G.Vector v0 a, G.Vector v1 b) => +histogram_ :: forall b a v0 v1. (Num b, RealFrac a, G.Vector v0 a, G.Vector v1 b) => Int -- ^ Number of bins. This value must be positive. A zero -- or negative value will cause an error. @@ -65,16 +66,18 @@ -> v1 b histogram_ numBins lo hi xs0 = G.create (GM.replicate numBins 0 >>= bin xs0) where + bin :: forall s. v0 a -> G.Mutable v1 s b -> ST s (G.Mutable v1 s b) bin xs bins = go 0 where go i | i >= len = return bins | otherwise = do let x = xs `G.unsafeIndex` i b = truncate $ (x - lo) / d - GM.write bins b . (+1) =<< GM.read bins b + write' bins b . (+1) =<< GM.read bins b go (i+1) + write' bins' b !e = GM.write bins' b e len = G.length xs - d = ((hi - lo) * (1 + realToFrac m_epsilon)) / fromIntegral numBins + d = ((hi - lo) / fromIntegral numBins) * (1 + realToFrac m_epsilon) {-# INLINE histogram_ #-} -- | /O(n)/ Compute decent defaults for the lower and upper bounds of diff --git a/Statistics/Sample/Internal.hs b/Statistics/Sample/Internal.hs --- a/Statistics/Sample/Internal.hs +++ b/Statistics/Sample/Internal.hs @@ -14,9 +14,10 @@ ( robustSumVar , sum + , sumF ) where -import Numeric.Sum (kbn, sumVector) +import qualified Numeric.Sum as Sum import Prelude hiding (sum) import Statistics.Function (square) import qualified Data.Vector.Generic as G @@ -26,5 +27,9 @@ {-# INLINE robustSumVar #-} sum :: (G.Vector v Double) => v Double -> Double -sum = sumVector kbn +sum = Sum.sumVector Sum.kbn {-# INLINE sum #-} + +sumF :: Foldable f => f Double -> Double +sumF = Sum.sum Sum.kbn +{-# INLINE sumF #-} diff --git a/Statistics/Sample/KernelDensity.hs b/Statistics/Sample/KernelDensity.hs --- a/Statistics/Sample/KernelDensity.hs +++ b/Statistics/Sample/KernelDensity.hs @@ -25,10 +25,11 @@ -- $references ) where +import Data.Default.Class import Numeric.MathFunctions.Constants (m_sqrt_2_pi) +import Numeric.RootFinding (fromRoot, ridders, RiddersParam(..), Tolerance(..)) import Prelude hiding (const, min, max, sum) import Statistics.Function (minMax, nextHighestPowerOfTwo) -import Statistics.Math.RootFinding (fromRoot, ridders) import Statistics.Sample.Histogram (histogram_) import Statistics.Sample.Internal (sum) import Statistics.Transform (CD, dct, idct) @@ -98,8 +99,8 @@ a = dct . G.map (/ sum h) $ h where h = G.map (/ len) $ histogram_ ni min max xs !len = fromIntegral (G.length xs) - !t_star = fromRoot (0.28 * len ** (-0.4)) . ridders 1e-14 (0,0.1) $ \x -> - x - (len * (2 * sqrt pi) * go 6 (f 7 x)) ** (-0.4) + !t_star = fromRoot (0.28 * len ** (-0.4)) . ridders def{ riddersTol = AbsTol 1e-14 } (0,0.1) + $ \x -> x - (len * (2 * sqrt pi) * go 6 (f 7 x)) ** (-0.4) where f q t = 2 * pi ** (q*2) * sum (G.zipWith g iv a2v) where g i a2 = i ** q * a2 * exp ((-i) * sqr pi * t) diff --git a/Statistics/Sample/Normalize.hs b/Statistics/Sample/Normalize.hs new file mode 100644 --- /dev/null +++ b/Statistics/Sample/Normalize.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Statistics.Sample.Normalize +-- Copyright : (c) 2017 Gregory W. Schwartz +-- License : BSD3 +-- +-- Maintainer : gsch@mail.med.upenn.edu +-- Stability : experimental +-- Portability : portable +-- +-- Functions for normalizing samples. + +module Statistics.Sample.Normalize + ( + standardize + ) where + +import Statistics.Sample +import qualified Data.Vector.Generic as G +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as S + +-- | /O(n)/ Normalize a sample using standard scores: +-- +-- \[ z = \frac{x - \mu}{\sigma} \] +-- +-- Where μ is sample mean and σ is standard deviation computed from +-- unbiased variance estimation. If sample to small to compute σ or +-- it's equal to 0 @Nothing@ is returned. +standardize :: (G.Vector v Double) => v Double -> Maybe (v Double) +standardize xs + | G.length xs < 2 = Nothing + | sigma == 0 = Nothing + | otherwise = Just $ G.map (\x -> (x - mu) / sigma) xs + where + mu = mean xs + sigma = stdDev xs +{-# INLINABLE standardize #-} +{-# SPECIALIZE standardize :: V.Vector Double -> Maybe (V.Vector Double) #-} +{-# SPECIALIZE standardize :: U.Vector Double -> Maybe (U.Vector Double) #-} +{-# SPECIALIZE standardize :: S.Vector Double -> Maybe (S.Vector Double) #-} diff --git a/Statistics/Sample/Powers.hs b/Statistics/Sample/Powers.hs --- a/Statistics/Sample/Powers.hs +++ b/Statistics/Sample/Powers.hs @@ -47,23 +47,22 @@ -- $references ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Binary (Binary(..)) -import Data.Data (Data, Typeable) -import Data.Vector.Binary () -import Data.Vector.Generic (unsafeFreeze) -import Data.Vector.Unboxed ((!)) -import GHC.Generics (Generic) +import Control.Monad.ST +import Data.Aeson (FromJSON, ToJSON) +import Data.Binary (Binary(..)) +import Data.Data (Data, Typeable) +import Data.Vector.Binary () +import Data.Vector.Unboxed ((!)) +import GHC.Generics (Generic) import Numeric.SpecFunctions (choose) import Prelude hiding (sum) -import Statistics.Function (indexed) -import Statistics.Internal (inlinePerformIO) -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Vector as V -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U +import Statistics.Function (indexed) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU -import qualified Statistics.Sample.Internal as S +import qualified Statistics.Sample.Internal as S newtype Powers = Powers (U.Vector Double) deriving (Eq, Read, Show, Typeable, Data, Generic) @@ -94,19 +93,22 @@ Int -- ^ /n/, the number of powers, where /n/ >= 2. -> v Double -> Powers -powers k - | k < 2 = error "Statistics.Sample.powers: too few powers" - | otherwise = fini . G.foldl' go (unsafePerformIO $ MU.replicate l 0) +powers k sample + | k < 2 = error "Statistics.Sample.powers: too few powers" + | otherwise = runST $ do + acc <- MU.replicate l 0 + G.forM_ sample $ \x -> + let loop !i !xk + | i == l = return () + | otherwise = do MU.write acc i . (+ xk) =<< MU.read acc i + loop (i+1) (xk * x) + in loop 0 1 + fmap Powers $ U.unsafeFreeze acc where - go ms x = inlinePerformIO $ loop 0 1 - where loop !i !xk | i == l = return ms - | otherwise = do - MU.read ms i >>= MU.write ms i . (+ xk) - loop (i+1) (xk*x) - fini = Powers . unsafePerformIO . unsafeFreeze - l = k + 1 -{-# SPECIALIZE powers :: Int -> U.Vector Double -> Powers #-} -{-# SPECIALIZE powers :: Int -> V.Vector Double -> Powers #-} + l = k + 1 +{-# SPECIALIZE powers :: Int -> U.Vector Double -> Powers #-} +{-# SPECIALIZE powers :: Int -> V.Vector Double -> Powers #-} +{-# SPECIALIZE powers :: Int -> SV.Vector Double -> Powers #-} -- | The order (number) of simple powers collected from a 'sample'. order :: Powers -> Int diff --git a/Statistics/Test/Bartlett.hs b/Statistics/Test/Bartlett.hs new file mode 100644 --- /dev/null +++ b/Statistics/Test/Bartlett.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-| +Module : Statistics.Test.Bartlett +Description : Bartlett's test for homogeneity of variances. +Copyright : (c) Praneya Kumar, Alexey Khudyakov, 2025 +License : BSD-3-Clause + +Bartlett's test is used to check that multiple groups of observations +come from distributions with equal variances. This test assumes that +samples come from normal distribution. If this is not the case it may +simple test for non-normality and Levene's ("Statistics.Test.Levene") +is preferred + +>>> import qualified Data.Vector.Unboxed as VU +>>> import Statistics.Test.Bartlett +>>> :{ +let a = VU.fromList [8.88, 9.12, 9.04, 8.98, 9.00, 9.08, 9.01, 8.85, 9.06, 8.99] + b = VU.fromList [8.88, 8.95, 9.29, 9.44, 9.15, 9.58, 8.36, 9.18, 8.67, 9.05] + c = VU.fromList [8.95, 9.12, 8.95, 8.85, 9.03, 8.84, 9.07, 8.98, 8.86, 8.98] +in bartlettTest [a,b,c] +:} +Right (Test {testSignificance = mkPValue 1.1254782518843598e-5, testStatistics = 22.789434813726768, testDistribution = chiSquared 2}) + +-} +module Statistics.Test.Bartlett ( + bartlettTest, + module Statistics.Distribution.ChiSquared +) where + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Primitive as VP +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VV +#endif + +import Statistics.Distribution (complCumulative) +import Statistics.Distribution.ChiSquared (chiSquared, ChiSquared(..)) +import Statistics.Sample (varianceUnbiased) +import Statistics.Types (mkPValue) +import Statistics.Test.Types (Test(..)) + +-- | Perform Bartlett's test for equal variances. The input is a list +-- of vectors, where each vector represents a group of observations. +bartlettTest :: VG.Vector v Double => [v Double] -> Either String (Test ChiSquared) +bartlettTest groups + | length groups < 2 = Left "At least two groups are required for Bartlett's test." + | any ((< 2) . VG.length) groups = Left "Each group must have at least two observations." + | any ((<= 0) . var) groupVariances = Left "All groups must have positive variance." + | otherwise = Right Test + { testSignificance = pValue + , testStatistics = tStatistic + , testDistribution = chiDist + } + where + -- Number of groups + k = length groups + -- Sample sizes for each group + ni = map (fromIntegral . VG.length) groups + -- Total number of observations across all groups + n_tot = sum $ fromIntegral . VG.length <$> groups + -- Variance estimates + groupVariances = toVar <$> groups + sumWeightedVars = sum [ (n - 1) * v | Var{sampleN=n, var=v} <- groupVariances ] + pooledVariance = sumWeightedVars / fromIntegral (n_tot - k) + -- Numerator of Bartlett's statistic + numerator = + fromIntegral (n_tot - k) * log pooledVariance - + sum [ (n - 1) * log v | Var{sampleN=n, var=v} <- groupVariances ] + -- Denominator correction term + sumReciprocals = sum [1 / (n - 1) | n <- ni] + denomCorrection = + 1 + (sumReciprocals - 1 / fromIntegral (n_tot - k)) / (3 * (fromIntegral k - 1)) + + -- Test statistic and test distrubution + tStatistic = max 0 $ numerator / denomCorrection + chiDist = chiSquared (k - 1) + pValue = mkPValue $ complCumulative chiDist tStatistic +{-# SPECIALIZE bartlettTest :: [V.Vector Double] -> Either String (Test ChiSquared) #-} +{-# SPECIALIZE bartlettTest :: [VU.Vector Double] -> Either String (Test ChiSquared) #-} +{-# SPECIALIZE bartlettTest :: [VS.Vector Double] -> Either String (Test ChiSquared) #-} +{-# SPECIALIZE bartlettTest :: [VP.Vector Double] -> Either String (Test ChiSquared) #-} +#if MIN_VERSION_vector(0,13,2) +{-# SPECIALIZE bartlettTest :: [VV.Vector Double] -> Either String (Test ChiSquared) #-} +#endif + +-- Estimate of variance +data Var = Var + { sampleN :: !Double -- ^ N of elements + , var :: !Double -- ^ Sample variance + } + +toVar :: VG.Vector v Double => v Double -> Var +toVar xs = Var { sampleN = fromIntegral $ VG.length xs + , var = varianceUnbiased xs + } diff --git a/Statistics/Test/ChiSquared.hs b/Statistics/Test/ChiSquared.hs --- a/Statistics/Test/ChiSquared.hs +++ b/Statistics/Test/ChiSquared.hs @@ -2,44 +2,80 @@ -- | Pearson's chi squared test. module Statistics.Test.ChiSquared ( chi2test - -- * Data types - , TestType(..) - , TestResult(..) + , chi2testCont + , module Statistics.Test.Types ) where import Prelude hiding (sum) + import Statistics.Distribution import Statistics.Distribution.ChiSquared -import Statistics.Function (square) +import Statistics.Function (square) import Statistics.Sample.Internal (sum) import Statistics.Test.Types +import Statistics.Types import qualified Data.Vector as V import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U - +import qualified Data.Vector.Fusion.Bundle as F +import qualified Numeric.Sum as Sum -- | Generic form of Pearson chi squared tests for binned data. Data -- sample is supplied in form of tuples (observed quantity, -- expected number of events). Both must be positive. -chi2test :: (G.Vector v (Int,Double), G.Vector v Double) - => Double -- ^ p-value - -> Int -- ^ Number of additional degrees of +-- +-- This test should be used only if all bins have expected values of +-- at least 5. +chi2test :: (G.Vector v (Int,Double)) + => Int -- ^ Number of additional degrees of -- freedom. One degree of freedom -- is due to the fact that the are -- N observation in total and -- accounted for automatically. -> v (Int,Double) -- ^ Observation and expectation. - -> TestResult -chi2test p ndf vec - | ndf < 0 = error $ "Statistics.Test.ChiSquare.chi2test: negative NDF " ++ show ndf - | n < 0 = error $ "Statistics.Test.ChiSquare.chi2test: too short data sample" - | p > 0 && p < 1 = significant $ complCumulative d chi2 < p - | otherwise = error $ "Statistics.Test.ChiSquare.chi2test: bad p-value: " ++ show p + -> Maybe (Test ChiSquared) +chi2test ndf vec + | ndf < 0 = error $ "Statistics.Test.ChiSquare.chi2test: negative NDF " ++ show ndf + | n > 0 = Just Test + { testSignificance = mkPValue $ complCumulative d chi2 + , testStatistics = chi2 + , testDistribution = chiSquared n + } + | otherwise = Nothing where n = G.length vec - ndf - 1 - chi2 = sum $ G.map (\(o,e) -> square (fromIntegral o - e) / e) vec + chi2 = Sum.kbn + $ F.foldl' Sum.add Sum.zero + $ F.map (\(o,e) -> square (fromIntegral o - e) / e) + $ G.stream vec d = chiSquared n +{-# INLINABLE chi2test #-} {-# SPECIALIZE - chi2test :: Double -> Int -> U.Vector (Int,Double) -> TestResult #-} + chi2test :: Int -> U.Vector (Int,Double) -> Maybe (Test ChiSquared) #-} {-# SPECIALIZE - chi2test :: Double -> Int -> V.Vector (Int,Double) -> TestResult #-} + chi2test :: Int -> V.Vector (Int,Double) -> Maybe (Test ChiSquared) #-} + + +-- | Chi squared test for data with normal errors. Data is supplied in +-- form of pair (observation with error, and expectation). +chi2testCont + :: (G.Vector v (Estimate NormalErr Double, Double)) + => Int -- ^ Number of additional + -- degrees of freedom. + -> v (Estimate NormalErr Double, Double) -- ^ Observation and expectation. + -> Maybe (Test ChiSquared) +chi2testCont ndf vec + | ndf < 0 = error $ "Statistics.Test.ChiSquare.chi2testCont: negative NDF " ++ show ndf + | n > 0 = Just Test + { testSignificance = mkPValue $ complCumulative d chi2 + , testStatistics = chi2 + , testDistribution = chiSquared n + } + | otherwise = Nothing + where + n = G.length vec - ndf - 1 + chi2 = Sum.kbn + $ F.foldl' Sum.add Sum.zero + $ F.map (\(Estimate o (NormalErr s),e) -> square (o - e) / s) + $ G.stream vec + d = chiSquared n diff --git a/Statistics/Test/Internal.hs b/Statistics/Test/Internal.hs --- a/Statistics/Test/Internal.hs +++ b/Statistics/Test/Internal.hs @@ -8,6 +8,7 @@ import Data.Ord import Data.Vector.Generic ((!)) import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Generic.Mutable as M import Statistics.Function @@ -23,15 +24,20 @@ -- | Calculate rank of every element of sample. In case of ties ranks -- are averaged. Sample should be already sorted in ascending order. -- --- >>> rank (==) (fromList [10,20,30::Int]) --- > fromList [1.0,2.0,3.0] +-- Rank is index of element in the sample, numeration starts from 1. +-- In case of ties average of ranks of equal elements is assigned +-- to each -- --- >>> rank (==) (fromList [10,10,10,30::Int]) --- > fromList [2.0,2.0,2.0,4.0] -rank :: (G.Vector v a, G.Vector v Double) +-- >>> import qualified Data.Vector.Unboxed as VU +-- >>> rank (==) (VU.fromList [10,20,30::Int]) +-- [1.0,2.0,3.0] +-- +-- >>> rank (==) (VU.fromList [10,10,10,30::Int]) +-- [2.0,2.0,2.0,4.0] +rank :: (G.Vector v a) => (a -> a -> Bool) -- ^ Equivalence relation -> v a -- ^ Vector to rank - -> v Double + -> U.Vector Double rank eq vec = G.unfoldr go (Rank 0 (-1) 1 vec) where go (Rank 0 _ r v) @@ -54,11 +60,10 @@ rankUnsorted :: ( Ord a , G.Vector v a , G.Vector v Int - , G.Vector v Double , G.Vector v (Int, a) ) => v a - -> v Double + -> U.Vector Double rankUnsorted xs = G.create $ do -- Put ranks into their original positions -- NOTE: backpermute will do wrong thing diff --git a/Statistics/Test/KolmogorovSmirnov.hs b/Statistics/Test/KolmogorovSmirnov.hs --- a/Statistics/Test/KolmogorovSmirnov.hs +++ b/Statistics/Test/KolmogorovSmirnov.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Statistics.Test.KolmogorovSmirnov -- Copyright : (c) 2011 Aleksey Khudyakov @@ -7,10 +8,10 @@ -- Stability : experimental -- Portability : portable -- --- Kolmogov-Smirnov tests are non-parametric tests for assesing +-- Kolmogov-Smirnov tests are non-parametric tests for assessing -- whether given sample could be described by distribution or whether -- two samples have the same distribution. It's only applicable to --- continous distributions. +-- continuous distributions. module Statistics.Test.KolmogorovSmirnov ( -- * Kolmogorov-Smirnov test kolmogorovSmirnovTest @@ -20,23 +21,26 @@ , kolmogorovSmirnovCdfD , kolmogorovSmirnovD , kolmogorovSmirnov2D - -- * Probablities + -- * Probabilities , kolmogorovSmirnovProbability - -- * Data types - , TestType(..) - , TestResult(..) -- * References -- $references + , module Statistics.Test.Types ) where import Control.Monad (when) import Prelude hiding (exponent, sum) import Statistics.Distribution (Distribution(..)) -import Statistics.Function (sort, unsafeModify) -import Statistics.Matrix (center, exponent, for, fromVector, power) -import Statistics.Test.Types (TestResult(..), TestType(..), significant) -import Statistics.Types (Sample) -import qualified Data.Vector.Unboxed as U +import Statistics.Function (gsort, unsafeModify) +import Statistics.Matrix (center, for, fromVector) +import qualified Statistics.Matrix as Mat +import Statistics.Test.Types +import Statistics.Types (mkPValue) +import qualified Data.Vector as V +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Generic as G +import Data.Vector.Generic ((!)) import qualified Data.Vector.Unboxed.Mutable as M @@ -44,58 +48,75 @@ -- Test ---------------------------------------------------------------- --- | Check that sample could be described by --- distribution. 'Significant' means distribution is not compatible --- with data for given p-value. +-- | Check that sample could be described by distribution. Returns +-- @Nothing@ is sample is empty -- --- This test uses Marsaglia-Tsang-Wang exact alogorithm for +-- This test uses Marsaglia-Tsang-Wang exact algorithm for -- calculation of p-value. -kolmogorovSmirnovTest :: Distribution d - => d -- ^ Distribution - -> Double -- ^ p-value - -> Sample -- ^ Data sample - -> TestResult -kolmogorovSmirnovTest d = kolmogorovSmirnovTestCdf (cumulative d) +kolmogorovSmirnovTest :: (Distribution d, G.Vector v Double) + => d -- ^ Distribution + -> v Double -- ^ Data sample + -> Maybe (Test ()) +{-# INLINE kolmogorovSmirnovTest #-} +kolmogorovSmirnovTest d + = kolmogorovSmirnovTestCdf (cumulative d) --- | Variant of 'kolmogorovSmirnovTest' which uses CFD in form of + +-- | Variant of 'kolmogorovSmirnovTest' which uses CDF in form of -- function. -kolmogorovSmirnovTestCdf :: (Double -> Double) -- ^ CDF of distribution - -> Double -- ^ p-value - -> Sample -- ^ Data sample - -> TestResult -kolmogorovSmirnovTestCdf cdf p sample - | p > 0 && p < 1 = significant $ 1 - prob < p - | otherwise = error "Statistics.Test.KolmogorovSmirnov.kolmogorovSmirnovTestCdf:bad p-value" +kolmogorovSmirnovTestCdf :: (G.Vector v Double) + => (Double -> Double) -- ^ CDF of distribution + -> v Double -- ^ Data sample + -> Maybe (Test ()) +{-# INLINE kolmogorovSmirnovTestCdf #-} +kolmogorovSmirnovTestCdf cdf sample + | G.null sample = Nothing + | otherwise = Just Test + { testSignificance = mkPValue $ 1 - prob + , testStatistics = d + , testDistribution = () + } where d = kolmogorovSmirnovCdfD cdf sample - prob = kolmogorovSmirnovProbability (U.length sample) d + prob = kolmogorovSmirnovProbability (G.length sample) d + -- | Two sample Kolmogorov-Smirnov test. It tests whether two data -- samples could be described by the same distribution without --- making any assumptions about it. +-- making any assumptions about it. If either of samples is empty +-- returns Nothing. -- --- This test uses approxmate formula for computing p-value. -kolmogorovSmirnovTest2 :: Double -- ^ p-value - -> Sample -- ^ Sample 1 - -> Sample -- ^ Sample 2 - -> TestResult -kolmogorovSmirnovTest2 p xs1 xs2 - | p > 0 && p < 1 = significant $ 1 - prob( d*(en + 0.12 + 0.11/en) ) < p - | otherwise = error "Statistics.Test.KolmogorovSmirnov.kolmogorovSmirnovTest2:bad p-value" +-- This test uses approximate formula for computing p-value. +kolmogorovSmirnovTest2 :: (G.Vector v Double) + => v Double -- ^ Sample 1 + -> v Double -- ^ Sample 2 + -> Maybe (Test ()) +kolmogorovSmirnovTest2 xs1 xs2 + | G.null xs1 || G.null xs2 = Nothing + | otherwise = Just Test + { testSignificance = mkPValue $ 1 - prob d + , testStatistics = d + , testDistribution = () + } where d = kolmogorovSmirnov2D xs1 xs2 + * (en + 0.12 + 0.11/en) -- Effective number of data points - n1 = fromIntegral (U.length xs1) - n2 = fromIntegral (U.length xs2) + n1 = fromIntegral (G.length xs1) + n2 = fromIntegral (G.length xs2) en = sqrt $ n1 * n2 / (n1 + n2) -- prob z | z < 0 = error "kolmogorovSmirnov2D: internal error" - | z == 0 = 1 + | z == 0 = 0 | z < 1.18 = let y = exp( -1.23370055013616983 / (z*z) ) - in 2.25675833419102515 * sqrt( -log(y) ) * (y + y**9 + y**25 + y**49) + in 2.25675833419102515 * sqrt( -log y ) * (y + y**9 + y**25 + y**49) | otherwise = let x = exp(-2 * z * z) in 1 - 2*(x - x**4 + x**9) +{-# INLINABLE kolmogorovSmirnovTest2 #-} +{-# SPECIALIZE kolmogorovSmirnovTest2 :: U.Vector Double -> U.Vector Double -> Maybe (Test ()) #-} +{-# SPECIALIZE kolmogorovSmirnovTest2 :: V.Vector Double -> V.Vector Double -> Maybe (Test ()) #-} +{-# SPECIALIZE kolmogorovSmirnovTest2 :: S.Vector Double -> S.Vector Double -> Maybe (Test ()) #-} -- FIXME: Find source for approximation for D @@ -107,64 +128,76 @@ -- | Calculate Kolmogorov's statistic /D/ for given cumulative -- distribution function (CDF) and data sample. If sample is empty -- returns 0. -kolmogorovSmirnovCdfD :: (Double -> Double) -- ^ CDF function - -> Sample -- ^ Sample +kolmogorovSmirnovCdfD :: G.Vector v Double + => (Double -> Double) -- ^ CDF function + -> v Double -- ^ Sample -> Double kolmogorovSmirnovCdfD cdf sample - | U.null sample = 0 - | otherwise = U.maximum - $ U.zipWith3 (\p a b -> abs (p-a) `max` abs (p-b)) - ps steps (U.tail steps) + | G.null sample = 0 + | otherwise = G.maximum + $ G.zipWith3 (\p a b -> abs (p-a) `max` abs (p-b)) + ps steps (G.tail steps) where - xs = sort sample - n = U.length xs + xs = gsort sample + n = G.length xs -- - ps = U.map cdf xs - steps = U.map ((/ fromIntegral n) . fromIntegral) - $ U.generate (n+1) id + ps = G.map cdf xs + steps = G.map (/ fromIntegral n) + $ G.generate (n+1) fromIntegral +{-# INLINABLE kolmogorovSmirnovCdfD #-} +{-# SPECIALIZE kolmogorovSmirnovCdfD :: (Double -> Double) -> U.Vector Double -> Double #-} +{-# SPECIALIZE kolmogorovSmirnovCdfD :: (Double -> Double) -> V.Vector Double -> Double #-} +{-# SPECIALIZE kolmogorovSmirnovCdfD :: (Double -> Double) -> S.Vector Double -> Double #-} -- | Calculate Kolmogorov's statistic /D/ for given cumulative -- distribution function (CDF) and data sample. If sample is empty -- returns 0. -kolmogorovSmirnovD :: (Distribution d) +kolmogorovSmirnovD :: (Distribution d, G.Vector v Double) => d -- ^ Distribution - -> Sample -- ^ Sample + -> v Double -- ^ Sample -> Double kolmogorovSmirnovD d = kolmogorovSmirnovCdfD (cumulative d) +{-# INLINE kolmogorovSmirnovD #-} + -- | Calculate Kolmogorov's statistic /D/ for two data samples. If -- either of samples is empty returns 0. -kolmogorovSmirnov2D :: Sample -- ^ First sample - -> Sample -- ^ Second sample +kolmogorovSmirnov2D :: (G.Vector v Double) + => v Double -- ^ First sample + -> v Double -- ^ Second sample -> Double kolmogorovSmirnov2D sample1 sample2 - | U.null sample1 || U.null sample2 = 0 + | G.null sample1 || G.null sample2 = 0 | otherwise = worker 0 0 0 where - xs1 = sort sample1 - xs2 = sort sample2 - n1 = U.length xs1 - n2 = U.length xs2 + xs1 = gsort sample1 + xs2 = gsort sample2 + n1 = G.length xs1 + n2 = G.length xs2 en1 = fromIntegral n1 en2 = fromIntegral n2 -- Find new index skip x i xs = go (i+1) - where go n | n >= U.length xs = n - | xs U.! n == x = go (n+1) + where go n | n >= G.length xs = n + | xs ! n == x = go (n+1) | otherwise = n -- Main loop worker d i1 i2 | i1 >= n1 || i2 >= n2 = d | otherwise = worker d' i1' i2' where - d1 = xs1 U.! i1 - d2 = xs2 U.! i2 + d1 = xs1 ! i1 + d2 = xs2 ! i2 i1' | d1 <= d2 = skip d1 i1 xs1 | otherwise = i1 i2' | d2 <= d1 = skip d2 i2 xs2 | otherwise = i2 d' = max d (abs $ fromIntegral i1' / en1 - fromIntegral i2' / en2) +{-# INLINABLE kolmogorovSmirnov2D #-} +{-# SPECIALIZE kolmogorovSmirnov2D :: U.Vector Double -> U.Vector Double -> Double #-} +{-# SPECIALIZE kolmogorovSmirnov2D :: V.Vector Double -> V.Vector Double -> Double #-} +{-# SPECIALIZE kolmogorovSmirnov2D :: S.Vector Double -> S.Vector Double -> Double #-} @@ -178,10 +211,10 @@ -> Double -- ^ D value -> Double kolmogorovSmirnovProbability n d - -- Avoid potencially lengthy calculations for large N and D > 0.999 + -- Avoid potentially lengthy calculations for large N and D > 0.999 | s > 7.24 || (s > 3.76 && n > 99) = 1 - 2 * exp( -(2.000071 + 0.331 / sqrt n' + 1.409 / n') * s) -- Exact computation - | otherwise = fini $ matrix `power` n + | otherwise = fini $ KSMatrix 0 matrix `power` n where s = n' * d * d n' = fromIntegral n @@ -217,13 +250,34 @@ return mat in fromVector size size m -- Last calculation - fini m = loop 1 (center m) (exponent m) + fini (KSMatrix e m) = loop 1 (center m) e where loop i ss eQ | i > n = ss * 10 ^^ eQ | ss' < 1e-140 = loop (i+1) (ss' * 1e140) (eQ - 140) | otherwise = loop (i+1) ss' eQ where ss' = ss * fromIntegral i / fromIntegral n + +data KSMatrix = KSMatrix Int Mat.Matrix + + +multiply :: KSMatrix -> KSMatrix -> KSMatrix +multiply (KSMatrix e1 m1) (KSMatrix e2 m2) = KSMatrix (e1+e2) (Mat.multiply m1 m2) + +power :: KSMatrix -> Int -> KSMatrix +power mat 1 = mat +power mat n = avoidOverflow res + where + mat2 = power mat (n `quot` 2) + pow = multiply mat2 mat2 + res | odd n = multiply pow mat + | otherwise = pow + +avoidOverflow :: KSMatrix -> KSMatrix +avoidOverflow ksm@(KSMatrix e m) + | center m > 1e140 = KSMatrix (e + 140) (Mat.map (* 1e-140) m) + | otherwise = ksm + ---------------------------------------------------------------- diff --git a/Statistics/Test/KruskalWallis.hs b/Statistics/Test/KruskalWallis.hs --- a/Statistics/Test/KruskalWallis.hs +++ b/Statistics/Test/KruskalWallis.hs @@ -8,19 +8,21 @@ -- Portability : portable -- module Statistics.Test.KruskalWallis - ( kruskalWallisRank + ( -- * Kruskal-Wallis test + kruskalWallisTest + -- ** Building blocks + , kruskalWallisRank , kruskalWallis - , kruskalWallisSignificant - , kruskalWallisTest + , module Statistics.Test.Types ) where import Data.Ord (comparing) -import Data.Foldable (foldMap) import qualified Data.Vector.Unboxed as U import Statistics.Function (sort, sortBy, square) -import Statistics.Distribution (quantile) +import Statistics.Distribution (complCumulative) import Statistics.Distribution.ChiSquared (chiSquared) -import Statistics.Test.Types (TestResult(..), significant) +import Statistics.Types +import Statistics.Test.Types import Statistics.Test.Internal (rank) import Statistics.Sample import qualified Statistics.Sample.Internal as Sample(sum) @@ -32,7 +34,7 @@ -- -- The samples and values need not to be ordered but the values in the result -- are ordered. Assigned ranks (ties are given their average rank). -kruskalWallisRank :: [Sample] -> [Sample] +kruskalWallisRank :: (U.Unbox a, Ord a) => [U.Vector a] -> [U.Vector Double] kruskalWallisRank samples = groupByTags . sortBy (comparing fst) . U.zip tags @@ -54,7 +56,7 @@ -- -- In textbooks the output value is usually represented by 'K' or 'H'. This -- function already does the ranking. -kruskalWallis :: [Sample] -> Double +kruskalWallis :: (U.Unbox a, Ord a) => [U.Vector a] -> Double kruskalWallis samples = (nTot - 1) * numerator / denominator where -- Total number of elements in all samples @@ -71,29 +73,25 @@ rsamples = kruskalWallisRank samples --- | Calculates whether the Kruskal-Wallis test is significant. --- --- It uses /Chi-Squared/ distribution for aproximation as long as the sizes are --- larger than 5. Otherwise the test returns 'Nothing'. -kruskalWallisSignificant :: - [Int] -- ^ The samples' size - -> Double -- ^ The p-value at which to test (e.g. 0.05) - -> Double -- ^ K value from 'kruskallWallis' - -> Maybe TestResult -kruskalWallisSignificant ns p k - -- Use chi-squared approximation - | all (>4) ns = Just . significant $ k > x - -- TODO: Implement critical value calculation: kruskalWallisCriticalValue - | otherwise = Nothing - where - x = quantile (chiSquared (length ns - 1)) (1 - p) - -- | Perform Kruskal-Wallis Test for the given samples and required -- significance. For additional information check 'kruskalWallis'. This is just -- a helper function. -kruskalWallisTest :: Double -> [Sample] -> Maybe TestResult -kruskalWallisTest p samples = - kruskalWallisSignificant (map U.length samples) p $ kruskalWallis samples +-- +-- It uses /Chi-Squared/ distribution for approximation as long as the sizes are +-- larger than 5. Otherwise the test returns 'Nothing'. +kruskalWallisTest :: (Ord a, U.Unbox a) => [U.Vector a] -> Maybe (Test ()) +kruskalWallisTest [] = Nothing +kruskalWallisTest samples + -- We use chi-squared approximation here + | all (>4) ns = Just Test { testSignificance = mkPValue $ complCumulative d k + , testStatistics = k + , testDistribution = () + } + | otherwise = Nothing + where + k = kruskalWallis samples + ns = map U.length samples + d = chiSquared (length ns - 1) -- * Helper functions diff --git a/Statistics/Test/Levene.hs b/Statistics/Test/Levene.hs new file mode 100644 --- /dev/null +++ b/Statistics/Test/Levene.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-| +Module : Statistics.Test.Levene +Description : Levene's test for homogeneity of variances. +Copyright : (c) Praneya Kumar, Alexey Khudyakov, 2025 +License : BSD-3-Clause + +Levene's test used to check whether samples have equal variance. Null +hypothesis is all samples are from distributions with same variance +(homoscedacity). Test is robust to non-normality, and versatile with +mean or median centering. + +>>> import qualified Data.Vector.Unboxed as VU +>>> import Statistics.Test.Levene +>>> :{ +let a = VU.fromList [8.88, 9.12, 9.04, 8.98, 9.00, 9.08, 9.01, 8.85, 9.06, 8.99] + b = VU.fromList [8.88, 8.95, 9.29, 9.44, 9.15, 9.58, 8.36, 9.18, 8.67, 9.05] + c = VU.fromList [8.95, 9.12, 8.95, 8.85, 9.03, 8.84, 9.07, 8.98, 8.86, 8.98] +in levenesTest Median [a, b, c] +:} +Right (Test {testSignificance = mkPValue 2.4315059672496814e-3, testStatistics = 7.584952754501659, testDistribution = fDistributionReal 2.0 27.0}) +-} +module Statistics.Test.Levene ( + Center(..), + levenesTest +) where + +import Control.Monad +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Primitive as VP +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VV +#endif +import Statistics.Distribution (complCumulative) +import Statistics.Distribution.FDistribution (fDistribution, FDistribution) +import Statistics.Types (mkPValue) +import Statistics.Test.Types (Test(..)) +import Statistics.Function (gsort) +import Statistics.Sample (mean) + +import qualified Statistics.Sample.Internal as IS +import Statistics.Quantile + + +-- | Center calculation method +data Center + = Mean -- ^ Use arithmetic mean + | Median -- ^ Use median + | Trimmed !Double -- ^ Trimmed mean with given proportion to cut from each end + deriving (Eq, Show) + +-- | Main Levene's test function with full error handling +levenesTest + :: (VG.Vector v Double) + => Center -- ^ Centering method + -> [v Double] -- ^ Input samples + -> Either String (Test FDistribution) +{-# INLINABLE levenesTest #-} +levenesTest center samples + | length samples < 2 = Left "At least two samples required" + -- NOTE: We don't have nice way of computing mean of a list! + | otherwise = do + let residuals = computeResiduals center <$> samples + -- Average of all Z + let n_tot = sum $ VG.length . vecZ <$> residuals -- Total number of samples + let zbar = IS.sumF [ meanZ z * sampleN z + | z <- residuals] + / fromIntegral n_tot + -- Numerator: Sum over (ni * (Z[i] - Z)^2) + let numerator = IS.sumF [ sampleN z * sqr (meanZ z - zbar) + | z <- residuals] + -- Denominator: Sum over Σ((dev_ij - zbari)^2) + let denominator = IS.sumF + [ IS.sum $ VU.map (sqr . subtract (meanZ z)) (vecZ z) + | z <- residuals + ] + -- Handle division by zero and invalid values + when (denominator <= 0 || isNaN denominator || isInfinite denominator) + $ Left "Invalid denominator in W-statistic calculation" + let wStat = (fromIntegral (n_tot - k) / fromIntegral (k - 1)) * (numerator / denominator) + fDist = fDistribution (k - 1) (n_tot - k) + Right Test { testStatistics = wStat + , testSignificance = mkPValue $ complCumulative fDist wStat + , testDistribution = fDist + } + where + k = length samples -- Number of groups +{-# SPECIALIZE levenesTest :: Center -> [V.Vector Double] -> Either String (Test FDistribution) #-} +{-# SPECIALIZE levenesTest :: Center -> [VU.Vector Double] -> Either String (Test FDistribution) #-} +{-# SPECIALIZE levenesTest :: Center -> [VS.Vector Double] -> Either String (Test FDistribution) #-} +{-# SPECIALIZE levenesTest :: Center -> [VP.Vector Double] -> Either String (Test FDistribution) #-} +#if MIN_VERSION_vector(0,13,2) +{-# SPECIALIZE levenesTest :: Center -> [VV.Vector Double] -> Either String (Test FDistribution) #-} +#endif + +---------------------------------------------------------------- +-- Implementation +---------------------------------------------------------------- + +-- | Trim data from both ends with error handling and performance optimization +trimboth :: (Ord a, Fractional a, VG.Vector v a) + => v a + -> Double + -> v a +{-# INLINE trimboth #-} +trimboth vec p + | p < 0 || p >= 0.5 = error "Statistics.Test.Levene: trimming: proportion must be between 0 and 0.5" + | VG.null vec = vec + | otherwise = VG.slice lowerCut (upperCut - lowerCut) sorted + where + n = VG.length vec + sorted = gsort vec + lowerCut = ceiling $ p * fromIntegral n + upperCut = n - lowerCut + +data Residuals = Residuals + { sampleN :: !Double + , meanZ :: !Double + , vecZ :: !(VU.Vector Double) + } + +computeResiduals + :: VG.Vector v Double + => Center + -> v Double + -> Residuals +{-# INLINE computeResiduals #-} +computeResiduals method xs = case method of + Mean -> + let c = mean xs + zs = VU.map (\x -> abs (x - c)) $ VU.convert xs + in makeR zs + Median -> + let c = median medianUnbiased xs + zs = VU.map (\x -> abs (x - c)) $ VU.convert xs + in makeR zs + Trimmed p -> + let trimmed = trimboth xs p + c = mean trimmed + zs = VU.map (\x -> abs (x - c)) $ VU.convert trimmed + in makeR zs + where + makeR zs = Residuals { sampleN = fromIntegral $ VU.length zs + , meanZ = mean zs + , vecZ = zs + } + +sqr :: Double -> Double +sqr x = x * x diff --git a/Statistics/Test/MannWhitneyU.hs b/Statistics/Test/MannWhitneyU.hs --- a/Statistics/Test/MannWhitneyU.hs +++ b/Statistics/Test/MannWhitneyU.hs @@ -8,7 +8,7 @@ -- Portability : portable -- -- Mann-Whitney U test (also know as Mann-Whitney-Wilcoxon and --- Wilcoxon rank sum test) is a non-parametric test for assesing +-- Wilcoxon rank sum test) is a non-parametric test for assessing -- whether two samples of independent observations have different -- mean. module Statistics.Test.MannWhitneyU ( @@ -19,14 +19,11 @@ , mannWhitneyUSignificant -- ** Wilcoxon rank sum test , wilcoxonRankSums - -- * Data types - , TestType(..) - , TestResult(..) + , module Statistics.Test.Types -- * References -- $references ) where -import Control.Applicative ((<$>)) import Data.List (findIndex) import Data.Ord (comparing) import Numeric.SpecFunctions (choose) @@ -36,22 +33,22 @@ import Statistics.Function (sortBy) import Statistics.Sample.Internal (sum) import Statistics.Test.Internal (rank, splitByTags) -import Statistics.Test.Types (TestResult(..), TestType(..), significant) -import Statistics.Types (Sample) +import Statistics.Test.Types (TestResult(..), PositionTest(..), significant) +import Statistics.Types (PValue,pValue) import qualified Data.Vector.Unboxed as U -- | The Wilcoxon Rank Sums Test. -- --- This test calculates the sum of ranks for the given two samples. The samples --- are ordered, and assigned ranks (ties are given their average rank), then these --- ranks are summed for each sample. +-- This test calculates the sum of ranks for the given two samples. +-- The samples are ordered, and assigned ranks (ties are given their +-- average rank), then these ranks are summed for each sample. -- --- The return value is (W₁, W₂) where W₁ is the sum of ranks of the first sample --- and W₂ is the sum of ranks of the second sample. This test is trivially transformed +-- The return value is (W₁, W₂) where W₁ is the sum of ranks of the first sample +-- and W₂ is the sum of ranks of the second sample. This test is trivially transformed -- into the Mann-Whitney U test. You will probably want to use 'mannWhitneyU' -- and the related functions for testing significance, but this function is exposed -- for completeness. -wilcoxonRankSums :: Sample -> Sample -> (Double, Double) +wilcoxonRankSums :: (Ord a, U.Unbox a) => U.Vector a -> U.Vector a -> (Double, Double) wilcoxonRankSums xs1 xs2 = (sum ranks1, sum ranks2) where -- Ranks for each sample @@ -61,7 +58,7 @@ $ sortBy (comparing snd) $ tagSample True xs1 U.++ tagSample False xs2 -- Add tag to a sample - tagSample t = U.map ((,) t) + tagSample t = U.map (\x -> (t,x)) @@ -72,19 +69,19 @@ -- the Wilcoxon's rank sum test (which is provided as 'wilcoxonRankSums'). -- The Mann-Whitney U is a simple transform of Wilcoxon's rank sum test. -- --- Again confusingly, different sources state reversed definitions for U₁ --- and U₂, so it is worth being explicit about what this function returns. --- Given two samples, the first, xs₁, of size n₁ and the second, xs₂, --- of size n₂, this function returns (U₁, U₂) --- where U₁ = W₁ - (n₁(n₁+1))\/2 --- and U₂ = W₂ - (n₂(n₂+1))\/2, --- where (W₁, W₂) is the return value of @wilcoxonRankSums xs1 xs2@. +-- Again confusingly, different sources state reversed definitions for U₁ +-- and U₂, so it is worth being explicit about what this function returns. +-- Given two samples, the first, xs₁, of size n₁ and the second, xs₂, +-- of size n₂, this function returns (U₁, U₂) +-- where U₁ = W₁ - (n₁(n₁+1))\/2 +-- and U₂ = W₂ - (n₂(n₂+1))\/2, +-- where (W₁, W₂) is the return value of @wilcoxonRankSums xs1 xs2@. -- --- Some sources instead state that U₁ and U₂ should be the other way round, often --- expressing this using U₁' = n₁n₂ - U₁ (since U₁ + U₂ = n₁n₂). +-- Some sources instead state that U₁ and U₂ should be the other way round, often +-- expressing this using U₁' = n₁n₂ - U₁ (since U₁ + U₂ = n₁n₂). -- -- All of which you probably don't care about if you just feed this into 'mannWhitneyUSignificant'. -mannWhitneyU :: Sample -> Sample -> (Double, Double) +mannWhitneyU :: (Ord a, U.Unbox a) => U.Vector a -> U.Vector a -> (Double, Double) mannWhitneyU xs1 xs2 = (fst summedRanks - (n1*(n1 + 1))/2 ,snd summedRanks - (n2*(n2 + 1))/2) @@ -105,20 +102,20 @@ -- The algorithm to generate these values is a faster, memoised version of the -- simple unoptimised generating function given in section 2 of \"The Mann Whitney -- Wilcoxon Distribution Using Linked Lists\" -mannWhitneyUCriticalValue :: (Int, Int) -- ^ The sample size - -> Double -- ^ The p-value (e.g. 0.05) for which you want the critical value. - -> Maybe Int -- ^ The critical value (of U). +mannWhitneyUCriticalValue + :: (Int, Int) -- ^ The sample size + -> PValue Double -- ^ The p-value (e.g. 0.05) for which you want the critical value. + -> Maybe Int -- ^ The critical value (of U). mannWhitneyUCriticalValue (m, n) p | m < 1 || n < 1 = Nothing -- Sample must be nonempty - | p >= 1 = Nothing -- Nonsensical p-value - | p' <= 1 = Nothing -- p-value is too small. Null hypothesys couln't be disproved + | p' <= 1 = Nothing -- p-value is too small. Null hypothesis couldn't be disproved | otherwise = findIndex (>= p') $ take (m*n) $ tail $ alookup !! (m+n-2) !! (min m n - 1) where mnCn = (m+n) `choose` n - p' = mnCn * p + p' = mnCn * pValue p {- @@ -181,31 +178,34 @@ -- -- If you use a one-tailed test, the test indicates whether the first sample is -- significantly larger than the second. If you want the opposite, simply reverse --- the order in both the sample size and the (U₁, U₂) pairs. -mannWhitneyUSignificant :: - TestType -- ^ Perform one-tailed test (see description above). - -> (Int, Int) -- ^ The samples' size from which the (U₁,U₂) values were derived. - -> Double -- ^ The p-value at which to test (e.g. 0.05) - -> (Double, Double) -- ^ The (U₁, U₂) values from 'mannWhitneyU'. +-- the order in both the sample size and the (U₁, U₂) pairs. +mannWhitneyUSignificant + :: PositionTest -- ^ Perform one-tailed test (see description above). + -> (Int, Int) -- ^ The samples' size from which the (U₁,U₂) values were derived. + -> PValue Double -- ^ The p-value at which to test (e.g. 0.05) + -> (Double, Double) -- ^ The (U₁, U₂) values from 'mannWhitneyU'. -> Maybe TestResult -- ^ Return 'Nothing' if the sample was too -- small to make a decision. -mannWhitneyUSignificant test (in1, in2) p (u1, u2) - --Use normal approximation +mannWhitneyUSignificant test (in1, in2) pVal (u1, u2) + -- Use normal approximation | in1 > 20 || in2 > 20 = - let mean = n1 * n2 / 2 + let mean = n1 * n2 / 2 -- (u1+u2) / 2 sigma = sqrt $ n1*n2*(n1 + n2 + 1) / 12 z = (mean - u1) / sigma in Just $ case test of - OneTailed -> significant $ z < quantile standard p - TwoTailed -> significant $ abs z > abs (quantile standard (p/2)) + AGreater -> significant $ z < quantile standard p + BGreater -> significant $ (-z) < quantile standard p + SamplesDiffer -> significant $ abs z > abs (quantile standard (p/2)) -- Use exact critical value - | otherwise = do crit <- fromIntegral <$> mannWhitneyUCriticalValue (in1, in2) p + | otherwise = do crit <- fromIntegral <$> mannWhitneyUCriticalValue (in1, in2) pVal return $ case test of - OneTailed -> significant $ u2 <= crit - TwoTailed -> significant $ min u1 u2 <= crit + AGreater -> significant $ u2 <= crit + BGreater -> significant $ u1 <= crit + SamplesDiffer -> significant $ min u1 u2 <= crit where n1 = fromIntegral in1 n2 = fromIntegral in2 + p = pValue pVal -- | Perform Mann-Whitney U Test for two samples and required @@ -215,13 +215,14 @@ -- -- One-tailed test checks whether first sample is significantly larger -- than second. Two-tailed whether they are significantly different. -mannWhitneyUtest :: TestType -- ^ Perform one-tailed test (see description above). - -> Double -- ^ The p-value at which to test (e.g. 0.05) - -> Sample -- ^ First sample - -> Sample -- ^ Second sample - -> Maybe TestResult - -- ^ Return 'Nothing' if the sample was too small to - -- make a decision. +mannWhitneyUtest + :: (Ord a, U.Unbox a) + => PositionTest -- ^ Perform one-tailed test (see description above). + -> PValue Double -- ^ The p-value at which to test (e.g. 0.05) + -> U.Vector a -- ^ First sample + -> U.Vector a -- ^ Second sample + -> Maybe TestResult -- ^ Return 'Nothing' if the sample was too small to + -- make a decision. mannWhitneyUtest ontTail p smp1 smp2 = mannWhitneyUSignificant ontTail (n1,n2) p $ mannWhitneyU smp1 smp2 where diff --git a/Statistics/Test/StudentT.hs b/Statistics/Test/StudentT.hs new file mode 100644 --- /dev/null +++ b/Statistics/Test/StudentT.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts, Rank2Types, ScopedTypeVariables #-} +-- | Student's T-test is for assessing whether two samples have +-- different mean. This module contain several variations of +-- T-test. It's a parametric tests and assumes that samples are +-- normally distributed. +module Statistics.Test.StudentT + ( + studentTTest + , welchTTest + , pairedTTest + , module Statistics.Test.Types + ) where + +import Statistics.Distribution hiding (mean) +import Statistics.Distribution.StudentT +import Statistics.Sample (mean, varianceUnbiased) +import Statistics.Test.Types +import Statistics.Types (mkPValue,PValue) +import Statistics.Function (square) +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as S +import qualified Data.Vector as V + + + +-- | Two-sample Student's t-test. It assumes that both samples are +-- normally distributed and have same variance. Returns @Nothing@ if +-- sample sizes are not sufficient. +studentTTest :: (G.Vector v Double) + => PositionTest -- ^ one- or two-tailed test + -> v Double -- ^ Sample A + -> v Double -- ^ Sample B + -> Maybe (Test StudentT) +studentTTest test sample1 sample2 + | G.length sample1 < 2 || G.length sample2 < 2 = Nothing + | otherwise = Just Test + { testSignificance = significance test t ndf + , testStatistics = t + , testDistribution = studentT ndf + } + where + (t, ndf) = tStatistics True sample1 sample2 +{-# INLINABLE studentTTest #-} +{-# SPECIALIZE studentTTest :: PositionTest -> U.Vector Double -> U.Vector Double -> Maybe (Test StudentT) #-} +{-# SPECIALIZE studentTTest :: PositionTest -> S.Vector Double -> S.Vector Double -> Maybe (Test StudentT) #-} +{-# SPECIALIZE studentTTest :: PositionTest -> V.Vector Double -> V.Vector Double -> Maybe (Test StudentT) #-} + +-- | Two-sample Welch's t-test. It assumes that both samples are +-- normally distributed but doesn't assume that they have same +-- variance. Returns @Nothing@ if sample sizes are not sufficient. +welchTTest :: (G.Vector v Double) + => PositionTest -- ^ one- or two-tailed test + -> v Double -- ^ Sample A + -> v Double -- ^ Sample B + -> Maybe (Test StudentT) +welchTTest test sample1 sample2 + | G.length sample1 < 2 || G.length sample2 < 2 = Nothing + | otherwise = Just Test + { testSignificance = significance test t ndf + , testStatistics = t + , testDistribution = studentT ndf + } + where + (t, ndf) = tStatistics False sample1 sample2 +{-# INLINABLE welchTTest #-} +{-# SPECIALIZE welchTTest :: PositionTest -> U.Vector Double -> U.Vector Double -> Maybe (Test StudentT) #-} +{-# SPECIALIZE welchTTest :: PositionTest -> S.Vector Double -> S.Vector Double -> Maybe (Test StudentT) #-} +{-# SPECIALIZE welchTTest :: PositionTest -> V.Vector Double -> V.Vector Double -> Maybe (Test StudentT) #-} + +-- | Paired two-sample t-test. Two samples are paired in a +-- within-subject design. Returns @Nothing@ if sample size is not +-- sufficient. +pairedTTest :: forall v. (G.Vector v (Double, Double)) + => PositionTest -- ^ one- or two-tailed test + -> v (Double, Double) -- ^ paired samples + -> Maybe (Test StudentT) +pairedTTest test sample + | G.length sample < 2 = Nothing + | otherwise = Just Test + { testSignificance = significance test t ndf + , testStatistics = t + , testDistribution = studentT ndf + } + where + (t, ndf) = tStatisticsPaired sample +{-# INLINABLE pairedTTest #-} +{-# SPECIALIZE pairedTTest :: PositionTest -> U.Vector (Double,Double) -> Maybe (Test StudentT) #-} +{-# SPECIALIZE pairedTTest :: PositionTest -> V.Vector (Double,Double) -> Maybe (Test StudentT) #-} + + +------------------------------------------------------------------------------- + +significance :: PositionTest -- ^ one- or two-tailed + -> Double -- ^ t statistics + -> Double -- ^ degree of freedom + -> PValue Double -- ^ p-value +significance test t df = + case test of + -- Here we exploit symmetry of T-distribution and calculate small tail + SamplesDiffer -> mkPValue $ 2 * tailArea (negate (abs t)) + AGreater -> mkPValue $ tailArea (negate t) + BGreater -> mkPValue $ tailArea t + where + tailArea = cumulative (studentT df) + + +-- Calculate T statistics for two samples +tStatistics :: (G.Vector v Double) + => Bool -- variance equality + -> v Double + -> v Double + -> (Double, Double) +{-# INLINE tStatistics #-} +tStatistics varequal sample1 sample2 = (t, ndf) + where + -- t-statistics + t = (m1 - m2) / sqrt ( + if varequal + then ((n1 - 1) * s1 + (n2 - 1) * s2) / (n1 + n2 - 2) * (1 / n1 + 1 / n2) + else s1 / n1 + s2 / n2) + + -- degree of freedom + ndf | varequal = n1 + n2 - 2 + | otherwise = square (s1 / n1 + s2 / n2) + / (square s1 / (square n1 * (n1 - 1)) + square s2 / (square n2 * (n2 - 1))) + -- statistics of two samples + n1 = fromIntegral $ G.length sample1 + n2 = fromIntegral $ G.length sample2 + m1 = mean sample1 + m2 = mean sample2 + s1 = varianceUnbiased sample1 + s2 = varianceUnbiased sample2 + + +-- Calculate T-statistics for paired sample +tStatisticsPaired :: (G.Vector v (Double, Double)) + => v (Double, Double) + -> (Double, Double) +{-# INLINE tStatisticsPaired #-} +tStatisticsPaired sample = (t, ndf) + where + -- t-statistics + t = let d = U.map (uncurry (-)) $ G.convert sample + sumd = U.sum d + in sumd / sqrt ((n * U.sum (U.map square d) - square sumd) / ndf) + -- degree of freedom + ndf = n - 1 + n = fromIntegral $ G.length sample diff --git a/Statistics/Test/Types.hs b/Statistics/Test/Types.hs --- a/Statistics/Test/Types.hs +++ b/Statistics/Test/Types.hs @@ -1,34 +1,93 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveDataTypeable,DeriveGeneric #-} module Statistics.Test.Types ( - TestType(..) + Test(..) + , isSignificant , TestResult(..) , significant + , PositionTest(..) ) where -import Data.Aeson (FromJSON, ToJSON) +import Control.DeepSeq (NFData(..)) +import Control.Monad (liftM3) +import Data.Aeson (FromJSON, ToJSON) +import Data.Binary (Binary (..)) import Data.Data (Typeable, Data) import GHC.Generics +import Statistics.Types (PValue) --- | Test type. Exact meaning depends on a specific test. But --- generally it's tested whether some statistics is too big (small) --- for 'OneTailed' or whether it too big or too small for 'TwoTailed' -data TestType = OneTailed - | TwoTailed - deriving (Eq,Ord,Show,Typeable,Data,Generic) -instance FromJSON TestType -instance ToJSON TestType - -- | Result of hypothesis testing data TestResult = Significant -- ^ Null hypothesis should be rejected | NotSignificant -- ^ Data is compatible with hypothesis deriving (Eq,Ord,Show,Typeable,Data,Generic) +instance Binary TestResult where + get = do + sig <- get + if sig then return Significant else return NotSignificant + put = put . (== Significant) instance FromJSON TestResult -instance ToJSON TestResult +instance ToJSON TestResult +instance NFData TestResult --- | Significant if parameter is 'True', not significant otherwiser + + +-- | Result of statistical test. +data Test distr = Test + { testSignificance :: !(PValue Double) + -- ^ Probability of getting value of test statistics at least as + -- extreme as measured. + , testStatistics :: !Double + -- ^ Statistic used for test. + , testDistribution :: distr + -- ^ Distribution of test statistics if null hypothesis is correct. + } + deriving (Eq,Ord,Show,Typeable,Data,Generic,Functor) + +instance (Binary d) => Binary (Test d) where + get = liftM3 Test get get get + put (Test sign stat distr) = put sign >> put stat >> put distr +instance (FromJSON d) => FromJSON (Test d) +instance (ToJSON d) => ToJSON (Test d) +instance (NFData d) => NFData (Test d) where + rnf (Test _ _ a) = rnf a + +-- | Check whether test is significant for given p-value. +isSignificant :: PValue Double -> Test d -> TestResult +isSignificant p t + = significant $ p >= testSignificance t + + +-- | Test type for test which compare positional (mean,median etc.) +-- information of samples. +data PositionTest + = SamplesDiffer + -- ^ Test whether samples differ in position. Null hypothesis is + -- samples are not different + | AGreater + -- ^ Test if first sample (A) is larger than second (B). Null + -- hypothesis is first sample is not larger than second. + | BGreater + -- ^ Test if second sample is larger than first. + deriving (Eq,Ord,Show,Typeable,Data,Generic) + +instance Binary PositionTest where + get = do + i <- get + case (i :: Int) of + 0 -> return SamplesDiffer + 1 -> return AGreater + 2 -> return BGreater + _ -> fail "Invalid PositionTest" + put SamplesDiffer = put (0 :: Int) + put AGreater = put (1 :: Int) + put BGreater = put (2 :: Int) +instance FromJSON PositionTest +instance ToJSON PositionTest +instance NFData PositionTest + +-- | significant if parameter is 'True', not significant otherwise significant :: Bool -> TestResult significant True = Significant significant False = NotSignificant diff --git a/Statistics/Test/WilcoxonT.hs b/Statistics/Test/WilcoxonT.hs --- a/Statistics/Test/WilcoxonT.hs +++ b/Statistics/Test/WilcoxonT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Statistics.Test.WilcoxonT -- Copyright : (c) 2010 Neil Brown @@ -8,22 +9,20 @@ -- Portability : portable -- -- The Wilcoxon matched-pairs signed-rank test is non-parametric test --- which could be used to whether two related samples have different --- means. --- --- WARNING: current implementation contain serious bug and couldn't be --- used with samples larger than 1023. --- +-- which could be used to test whether two related samples have +-- different means. module Statistics.Test.WilcoxonT ( -- * Wilcoxon signed-rank matched-pair test + -- ** Test wilcoxonMatchedPairTest + -- ** Building blocks , wilcoxonMatchedPairSignedRank , wilcoxonMatchedPairSignificant , wilcoxonMatchedPairSignificance , wilcoxonMatchedPairCriticalValue - -- * Data types - , TestType(..) - , TestResult(..) + , module Statistics.Test.Types + -- * References + -- $references ) where @@ -38,32 +37,43 @@ -- function in this module to get a meaningful result. -- ranks of the differences where the first parameter is higher) whereas T- is -- the sum of negative ranks (the ranks of the differences where the second parameter is higher). --- to the the length of the shorter sample. +-- to the length of the shorter sample. -import Control.Applicative ((<$>)) import Data.Function (on) import Data.List (findIndex) import Data.Ord (comparing) +import qualified Data.Vector.Unboxed as U import Prelude hiding (sum) import Statistics.Function (sortBy) import Statistics.Sample.Internal (sum) import Statistics.Test.Internal (rank, splitByTags) -import Statistics.Test.Types (TestResult(..), TestType(..), significant) -import Statistics.Types (Sample) -import qualified Data.Vector.Unboxed as U +import Statistics.Test.Types +import Statistics.Types -- (CL,pValue,getPValue) +import Statistics.Distribution +import Statistics.Distribution.Normal -wilcoxonMatchedPairSignedRank :: Sample -> Sample -> (Double, Double) -wilcoxonMatchedPairSignedRank a b = (sum ranks1, negate (sum ranks2)) + +-- | Calculate (n,T⁺,T⁻) values for both samples. Where /n/ is reduced +-- sample where equal pairs are removed. +wilcoxonMatchedPairSignedRank :: (Ord a, Num a, U.Unbox a) => U.Vector (a,a) -> (Int, Double, Double) +wilcoxonMatchedPairSignedRank ab + = (nRed, sum ranks1, negate (sum ranks2)) where + -- Positive and negative ranks (ranks1, ranks2) = splitByTags $ U.zip tags (rank ((==) `on` abs) diffs) + -- Sorted list of differences + diffsSorted = sortBy (comparing abs) -- Sort the differences by absolute difference + $ U.filter (/= 0) -- Remove equal elements + $ U.map (uncurry (-)) ab -- Work out differences + nRed = U.length diffsSorted + -- Sign tags and differences (tags,diffs) = U.unzip - $ U.map (\x -> (x>0 , x)) -- Attack tags to distribution elements - $ U.filter (/= 0.0) -- Remove equal elements - $ sortBy (comparing abs) -- Sort the differences by absolute difference - $ U.zipWith (-) a b -- Work out differences + $ U.map (\x -> (x>0 , x)) -- Attach tags to distribution elements + $ diffsSorted + -- | The coefficients for x^0, x^1, x^2, etc, in the expression -- \prod_{r=1}^s (1 + x^r). See the Mitic paper for details. -- @@ -92,6 +102,8 @@ | n > 1023 = error "Statistics.Test.WilcoxonT.summedCoefficients: sample is too large (see bug #18)" | otherwise = map fromIntegral $ scanl1 (+) $ coefficients n + + -- | Tests whether a given result from a Wilcoxon signed-rank matched-pairs test -- is significant at the given level. -- @@ -105,24 +117,33 @@ -- in the opposite direction, you can either pass the parameters in a different -- order to 'wilcoxonMatchedPairSignedRank', or simply swap the values in the resulting -- pair before passing them to this function. -wilcoxonMatchedPairSignificant :: - TestType -- ^ Perform one- or two-tailed test (see description below). - -> Int -- ^ The sample size from which the (T+,T-) values were derived. - -> Double -- ^ The p-value at which to test (e.g. 0.05) - -> (Double, Double) -- ^ The (T+, T-) values from 'wilcoxonMatchedPairSignedRank'. - -> Maybe TestResult -- ^ Return 'Nothing' if the sample was too - -- small to make a decision. -wilcoxonMatchedPairSignificant test sampleSize p (tPlus, tMinus) = +wilcoxonMatchedPairSignificant + :: PositionTest -- ^ How to compare two samples + -> PValue Double -- ^ The p-value at which to test (e.g. @mkPValue 0.05@) + -> (Int, Double, Double) -- ^ The (n,T⁺, T⁻) values from 'wilcoxonMatchedPairSignedRank'. + -> Maybe TestResult -- ^ Return 'Nothing' if the sample was too + -- small to make a decision. +wilcoxonMatchedPairSignificant test pVal (sampleSize, tPlus, tMinus) = case test of -- According to my nearest book (Understanding Research Methods and Statistics -- by Gary W. Heiman, p590), to check that the first sample is bigger you must -- use the absolute value of T- for a one-tailed check: - OneTailed -> (significant . (abs tMinus <=) . fromIntegral) <$> wilcoxonMatchedPairCriticalValue sampleSize p + AGreater -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize pVal + return $ significant $ abs tMinus <= fromIntegral crit + BGreater -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize pVal + return $ significant $ abs tPlus <= fromIntegral crit -- Otherwise you must use the value of T+ and T- with the smallest absolute value: - TwoTailed -> (significant . (t <=) . fromIntegral) <$> wilcoxonMatchedPairCriticalValue sampleSize (p/2) + -- + -- Note that in absence of ties sum of |T+| and |T-| is constant + -- so by selecting minimal we are performing two-tailed test and + -- look and both tails of distribution of T. + SamplesDiffer -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize (mkPValue $ p/2) + return $ significant $ t <= fromIntegral crit where t = min (abs tPlus) (abs tMinus) + p = pValue pVal + -- | Obtains the critical value of T to compare against, given a sample size -- and a p-value (significance level). Your T value must be less than or -- equal to the return of this function in order for the test to work out @@ -134,39 +155,58 @@ -- However, this function is useful, for example, for generating lookup tables -- for Wilcoxon signed rank critical values. -- --- The return values of this function are generated using the method detailed in --- the paper \"Critical Values for the Wilcoxon Signed Rank Statistic\", Peter --- Mitic, The Mathematica Journal, volume 6, issue 3, 1996, which can be found --- here: . --- According to that paper, the results may differ from other published lookup tables, but --- (Mitic claims) the values obtained by this function will be the correct ones. +-- The return values of this function are generated using the method +-- detailed in the Mitic's paper. According to that paper, the results +-- may differ from other published lookup tables, but (Mitic claims) +-- the values obtained by this function will be the correct ones. wilcoxonMatchedPairCriticalValue :: Int -- ^ The sample size - -> Double -- ^ The p-value (e.g. 0.05) for which you want the critical value. + -> PValue Double -- ^ The p-value (e.g. @mkPValue 0.05@) for which you want the critical value. -> Maybe Int -- ^ The critical value (of T), or Nothing if -- the sample is too small to make a decision. -wilcoxonMatchedPairCriticalValue sampleSize p - = case critical of - Just n | n < 0 -> Nothing - | otherwise -> Just n - Nothing -> Just maxBound -- shouldn't happen: beyond end of list +wilcoxonMatchedPairCriticalValue n pVal + | n < 100 = + case subtract 1 <$> findIndex (> m) (summedCoefficients n) of + Just k | k < 0 -> Nothing + | otherwise -> Just k + Nothing -> error "Statistics.Test.WilcoxonT.wilcoxonMatchedPairCriticalValue: impossible happened" + | otherwise = + case quantile (normalApprox n) p of + z | z < 0 -> Nothing + | otherwise -> Just (round z) where - m = (2 ** fromIntegral sampleSize) * p - critical = subtract 1 <$> findIndex (> m) (summedCoefficients sampleSize) + p = pValue pVal + m = (2 ** fromIntegral n) * p + -- | Works out the significance level (p-value) of a T value, given a sample -- size and a T value from the Wilcoxon signed-rank matched-pairs test. -- -- See the notes on 'wilcoxonCriticalValue' for how this is calculated. -wilcoxonMatchedPairSignificance :: Int -- ^ The sample size - -> Double -- ^ The value of T for which you want the significance. - -> Double -- ^ The significance (p-value). -wilcoxonMatchedPairSignificance sampleSize rnk - = (summedCoefficients sampleSize !! floor rnk) / 2 ** fromIntegral sampleSize +wilcoxonMatchedPairSignificance + :: Int -- ^ The sample size + -> Double -- ^ The value of T for which you want the significance. + -> PValue Double -- ^ The significance (p-value). +wilcoxonMatchedPairSignificance n t + = mkPValue p + where + p | n < 100 = (summedCoefficients n !! floor t) / 2 ** fromIntegral n + | otherwise = cumulative (normalApprox n) t + +-- | Normal approximation for Wilcoxon T statistics +normalApprox :: Int -> NormalDistribution +normalApprox ni + = normalDistr m s + where + m = n * (n + 1) / 4 + s = sqrt $ (n * (n + 1) * (2*n + 1)) / 24 + n = fromIntegral ni + + -- | The Wilcoxon matched-pairs signed-rank test. The samples are -- zipped together: if one is longer than the other, both are --- truncated to the the length of the shorter sample. +-- truncated to the length of the shorter sample. -- -- For one-tailed test it tests whether first sample is significantly -- greater than the second. For two-tailed it checks whether they @@ -174,16 +214,32 @@ -- -- Check 'wilcoxonMatchedPairSignedRank' and -- 'wilcoxonMatchedPairSignificant' for additional information. -wilcoxonMatchedPairTest :: TestType -- ^ Perform one-tailed test. - -> Double -- ^ The p-value at which to test (e.g. 0.05) - -> Sample -- ^ First sample - -> Sample -- ^ Second sample - -> Maybe TestResult - -- ^ Return 'Nothing' if the sample was too - -- small to make a decision. -wilcoxonMatchedPairTest test p smp1 smp2 = - wilcoxonMatchedPairSignificant test (min n1 n2) p - $ wilcoxonMatchedPairSignedRank smp1 smp2 +wilcoxonMatchedPairTest + :: (Ord a, Num a, U.Unbox a) + => PositionTest -- ^ Perform one-tailed test. + -> U.Vector (a,a) -- ^ Sample of pairs + -> Test () -- ^ Return 'Nothing' if the sample was too + -- small to make a decision. +wilcoxonMatchedPairTest test pairs = + Test { testSignificance = pVal + , testStatistics = t + , testDistribution = () + } where - n1 = U.length smp1 - n2 = U.length smp2 + (n,tPlus,tMinus) = wilcoxonMatchedPairSignedRank pairs + (t,pVal) = case test of + AGreater -> (abs tMinus, wilcoxonMatchedPairSignificance n (abs tMinus)) + BGreater -> (abs tPlus, wilcoxonMatchedPairSignificance n (abs tPlus )) + -- Since we take minimum of T+,T- we can't get more + -- that p=0.5 and can multiply it by 2 without risk + -- of error. + SamplesDiffer -> let t' = min (abs tMinus) (abs tPlus) + p = wilcoxonMatchedPairSignificance n t' + in (t', mkPValue $ min 1 $ 2 * pValue p) + + +-- $references +-- +-- * \"Critical Values for the Wilcoxon Signed Rank Statistic\", Peter +-- Mitic, The Mathematica Journal, volume 6, issue 3, 1996 +-- () diff --git a/Statistics/Types.hs b/Statistics/Types.hs --- a/Statistics/Types.hs +++ b/Statistics/Types.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | -- Module : Statistics.Types -- Copyright : (c) 2009 Bryan O'Sullivan @@ -7,34 +13,509 @@ -- Stability : experimental -- Portability : portable -- --- Types for working with statistics. - +-- Data types common used in statistics module Statistics.Types - ( - Estimator(..) + ( -- * Confidence level + CL + -- ** Accessors + , confidenceLevel + , significanceLevel + -- ** Constructors + , mkCL + , mkCLE + , mkCLFromSignificance + , mkCLFromSignificanceE + -- ** Constants and conversion to nσ + , cl90 + , cl95 + , cl99 + -- *** Normal approximation + , nSigma + , nSigma1 + , getNSigma + , getNSigma1 + -- * p-value + , PValue + -- ** Accessors + , pValue + -- ** Constructors + , mkPValue + , mkPValueE + -- * Estimates and upper/lower limits + , Estimate(..) + , NormalErr(..) + , ConfInt(..) + , UpperLimit(..) + , LowerLimit(..) + -- ** Constructors + , estimateNormErr + , (±) + , estimateFromInterval + , estimateFromErr + -- ** Accessors + , confidenceInterval + , asymErrors + , Scale(..) + -- * Other , Sample , WeightedSample , Weights ) where -import qualified Data.Vector.Unboxed as U (Vector) +import Control.Monad ((<=<), liftM2, liftM3) +import Control.DeepSeq (NFData(..)) +import Data.Aeson (FromJSON(..), ToJSON) +import Data.Binary (Binary(..)) +import Data.Data (Data,Typeable) +import Data.Maybe (fromMaybe) +import Data.Vector.Unboxed (Unbox) +import Data.Vector.Unboxed.Deriving (derivingUnbox) +import GHC.Generics (Generic) +import Statistics.Internal +import Statistics.Types.Internal +import Statistics.Distribution +import Statistics.Distribution.Normal --- | Sample data. -type Sample = U.Vector Double --- | Sample with weights. First element of sample is data, second is weight -type WeightedSample = U.Vector (Double,Double) +---------------------------------------------------------------- +-- Data type for confidence level +---------------------------------------------------------------- --- | An estimator of a property of a sample, such as its 'mean'. +-- | +-- Confidence level. In context of confidence intervals it's +-- probability of said interval covering true value of measured +-- value. In context of statistical tests it's @1-α@ where α is +-- significance of test. -- --- The use of an algebraic data type here allows functions such as --- 'jackknife' and 'bootstrapBCA' to use more efficient algorithms --- when possible. -data Estimator = Mean - | Variance - | VarianceUnbiased - | StdDev - | Function (Sample -> Double) +-- Since confidence level are usually close to 1 they are stored as +-- @1-CL@ internally. There are two smart constructors for @CL@: +-- 'mkCL' and 'mkCLFromSignificance' (and corresponding variant +-- returning @Maybe@). First creates @CL@ from confidence level and +-- second from @1 - CL@ or significance level. +-- +-- >>> cl95 +-- mkCLFromSignificance 5.0e-2 +-- +-- Prior to 0.14 confidence levels were passed to function as plain +-- @Doubles@. Use 'mkCL' to convert them to @CL@. +newtype CL a = CL a + deriving (Eq, Typeable, Data, Generic) --- | Weights for affecting the importance of elements of a sample. -type Weights = U.Vector Double +instance Show a => Show (CL a) where + showsPrec n (CL p) = defaultShow1 "mkCLFromSignificance" p n +instance (Num a, Ord a, Read a) => Read (CL a) where + readPrec = defaultReadPrecM1 "mkCLFromSignificance" mkCLFromSignificanceE + +instance (Binary a, Num a, Ord a) => Binary (CL a) where + put (CL p) = put p + get = maybe (fail errMkCL) return . mkCLFromSignificanceE =<< get + +instance (ToJSON a) => ToJSON (CL a) +instance (FromJSON a, Num a, Ord a) => FromJSON (CL a) where + parseJSON = maybe (fail errMkCL) return . mkCLFromSignificanceE <=< parseJSON + +instance NFData a => NFData (CL a) where + rnf (CL a) = rnf a + +-- | +-- >>> cl95 > cl90 +-- True +instance Ord a => Ord (CL a) where + CL a < CL b = a > b + CL a <= CL b = a >= b + CL a > CL b = a < b + CL a >= CL b = a <= b + max (CL a) (CL b) = CL (min a b) + min (CL a) (CL b) = CL (max a b) + + +-- | Create confidence level from probability β or probability +-- confidence interval contain true value of estimate. Will throw +-- exception if parameter is out of [0,1] range +-- +-- >>> mkCL 0.95 -- same as cl95 +-- mkCLFromSignificance 5.0000000000000044e-2 +mkCL :: (Ord a, Num a) => a -> CL a +mkCL + = fromMaybe (error "Statistics.Types.mkCL: probability is out if [0,1] range") + . mkCLE + +-- | Same as 'mkCL' but returns @Nothing@ instead of error if +-- parameter is out of [0,1] range +-- +-- >>> mkCLE 0.95 -- same as cl95 +-- Just (mkCLFromSignificance 5.0000000000000044e-2) +mkCLE :: (Ord a, Num a) => a -> Maybe (CL a) +mkCLE p + | p >= 0 && p <= 1 = Just $ CL (1 - p) + | otherwise = Nothing + +-- | Create confidence level from probability α or probability that +-- confidence interval does not contain true value of estimate. Will +-- throw exception if parameter is out of [0,1] range +-- +-- >>> mkCLFromSignificance 0.05 -- same as cl95 +-- mkCLFromSignificance 5.0e-2 +mkCLFromSignificance :: (Ord a, Num a) => a -> CL a +mkCLFromSignificance = fromMaybe (error errMkCL) . mkCLFromSignificanceE + +-- | Same as 'mkCLFromSignificance' but returns @Nothing@ instead of error if +-- parameter is out of [0,1] range +-- +-- >>> mkCLFromSignificanceE 0.05 -- same as cl95 +-- Just (mkCLFromSignificance 5.0e-2) +mkCLFromSignificanceE :: (Ord a, Num a) => a -> Maybe (CL a) +mkCLFromSignificanceE p + | p >= 0 && p <= 1 = Just $ CL p + | otherwise = Nothing + +errMkCL :: String +errMkCL = "Statistics.Types.mkPValCL: probability is out if [0,1] range" + + +-- | Get confidence level. This function is subject to rounding +-- errors. If @1 - CL@ is needed use 'significanceLevel' instead +confidenceLevel :: (Num a) => CL a -> a +confidenceLevel (CL p) = 1 - p + +-- | Get significance level. +significanceLevel :: CL a -> a +significanceLevel (CL p) = p + + + +-- | 90% confidence level +cl90 :: Fractional a => CL a +cl90 = CL 0.10 + +-- | 95% confidence level +cl95 :: Fractional a => CL a +cl95 = CL 0.05 + +-- | 99% confidence level +cl99 :: Fractional a => CL a +cl99 = CL 0.01 + + + +---------------------------------------------------------------- +-- Data type for p-value +---------------------------------------------------------------- + +-- | Newtype wrapper for p-value. +newtype PValue a = PValue a + deriving (Eq,Ord, Typeable, Data, Generic) + +instance Show a => Show (PValue a) where + showsPrec n (PValue p) = defaultShow1 "mkPValue" p n +instance (Num a, Ord a, Read a) => Read (PValue a) where + readPrec = defaultReadPrecM1 "mkPValue" mkPValueE + +instance (Binary a, Num a, Ord a) => Binary (PValue a) where + put (PValue p) = put p + get = maybe (fail errMkPValue) return . mkPValueE =<< get + +instance (ToJSON a) => ToJSON (PValue a) +instance (FromJSON a, Num a, Ord a) => FromJSON (PValue a) where + parseJSON = maybe (fail errMkPValue) return . mkPValueE <=< parseJSON + +instance NFData a => NFData (PValue a) where + rnf (PValue a) = rnf a + + +-- | Construct PValue. Throws error if argument is out of [0,1] range. +-- +mkPValue :: (Ord a, Num a) => a -> PValue a +mkPValue = fromMaybe (error errMkPValue) . mkPValueE + +-- | Construct PValue. Returns @Nothing@ if argument is out of [0,1] range. +mkPValueE :: (Ord a, Num a) => a -> Maybe (PValue a) +mkPValueE p + | p >= 0 && p <= 1 = Just $ PValue p + | otherwise = Nothing + +-- | Get p-value +pValue :: PValue a -> a +pValue (PValue p) = p + + +-- | P-value expressed in sigma. This is convention widely used in +-- experimental physics. N sigma confidence level corresponds to +-- probability within N sigma of normal distribution. +-- +-- Note that this correspondence is for normal distribution. Other +-- distribution will have different dependency. Also experimental +-- distribution usually only approximately normal (especially at +-- extreme tails). +nSigma :: Double -> PValue Double +nSigma n + | n > 0 = PValue $ 2 * cumulative standard (-n) + | otherwise = error "Statistics.Extra.Error.nSigma: non-positive number of sigma" + +-- | P-value expressed in sigma for one-tail hypothesis. This correspond to +-- probability of obtaining value less than @N·σ@. +nSigma1 :: Double -> PValue Double +nSigma1 n + | n > 0 = PValue $ cumulative standard (-n) + | otherwise = error "Statistics.Extra.Error.nSigma1: non-positive number of sigma" + +-- | Express confidence level in sigmas +getNSigma :: PValue Double -> Double +getNSigma (PValue p) = negate $ quantile standard (p / 2) + +-- | Express confidence level in sigmas for one-tailed hypothesis. +getNSigma1 :: PValue Double -> Double +getNSigma1 (PValue p) = negate $ quantile standard p + + + +errMkPValue :: String +errMkPValue = "Statistics.Types.mkPValue: probability is out if [0,1] range" + + + +---------------------------------------------------------------- +-- Point estimates +---------------------------------------------------------------- + +-- | +-- A point estimate and its confidence interval. It's parametrized by +-- both error type @e@ and value type @a@. This module provides two +-- types of error: 'NormalErr' for normally distributed errors and +-- 'ConfInt' for error with normal distribution. See their +-- documentation for more details. +-- +-- For example @144 ± 5@ (assuming normality) could be expressed as +-- +-- > Estimate { estPoint = 144 +-- > , estError = NormalErr 5 +-- > } +-- +-- Or if we want to express @144 + 6 - 4@ at CL95 we could write: +-- +-- > Estimate { estPoint = 144 +-- > , estError = ConfInt +-- > { confIntLDX = 4 +-- > , confIntUDX = 6 +-- > , confIntCL = cl95 +-- > } +-- > } +-- +-- Prior to statistics 0.14 @Estimate@ data type used following definition: +-- +-- > data Estimate = Estimate { +-- > estPoint :: {-# UNPACK #-} !Double +-- > , estLowerBound :: {-# UNPACK #-} !Double +-- > , estUpperBound :: {-# UNPACK #-} !Double +-- > , estConfidenceLevel :: {-# UNPACK #-} !Double +-- > } +-- +-- Now type @Estimate ConfInt Double@ should be used instead. Function +-- 'estimateFromInterval' allow to easily construct estimate from same inputs. +data Estimate e a = Estimate + { estPoint :: !a + -- ^ Point estimate. + , estError :: !(e a) + -- ^ Confidence interval for estimate. + } deriving (Eq, Read, Show, Generic + , Typeable, Data + ) + +instance (Binary (e a), Binary a) => Binary (Estimate e a) where + get = liftM2 Estimate get get + put (Estimate ep ee) = put ep >> put ee +instance (FromJSON (e a), FromJSON a) => FromJSON (Estimate e a) +instance (ToJSON (e a), ToJSON a) => ToJSON (Estimate e a) +instance (NFData (e a), NFData a) => NFData (Estimate e a) where + rnf (Estimate x dx) = rnf x `seq` rnf dx + + + +-- | +-- Normal errors. They are stored as 1σ errors which corresponds to +-- 68.8% CL. Since we can recalculate them to any confidence level if +-- needed we don't store it. +newtype NormalErr a = NormalErr + { normalError :: a + } + deriving (Eq, Read, Show, Typeable, Data, Generic) + +instance Binary a => Binary (NormalErr a) where + get = fmap NormalErr get + put = put . normalError +instance FromJSON a => FromJSON (NormalErr a) +instance ToJSON a => ToJSON (NormalErr a) +instance NFData a => NFData (NormalErr a) where + rnf (NormalErr x) = rnf x + + +-- | Confidence interval. It assumes that confidence interval forms +-- single interval and isn't set of disjoint intervals. +data ConfInt a = ConfInt + { confIntLDX :: !a + -- ^ Lower error estimate, or distance between point estimate and + -- lower bound of confidence interval. + , confIntUDX :: !a + -- ^ Upper error estimate, or distance between point estimate and + -- upper bound of confidence interval. + , confIntCL :: !(CL Double) + -- ^ Confidence level corresponding to given confidence interval. + } + deriving (Read,Show,Eq,Typeable,Data,Generic) + +instance Binary a => Binary (ConfInt a) where + get = liftM3 ConfInt get get get + put (ConfInt l u cl) = put l >> put u >> put cl +instance FromJSON a => FromJSON (ConfInt a) +instance ToJSON a => ToJSON (ConfInt a) +instance NFData a => NFData (ConfInt a) where + rnf (ConfInt x y _) = rnf x `seq` rnf y + + + +---------------------------------------- +-- Constructors + +-- | Create estimate with normal errors +estimateNormErr :: a -- ^ Point estimate + -> a -- ^ 1σ error + -> Estimate NormalErr a +estimateNormErr x dx = Estimate x (NormalErr dx) + +-- | Synonym for 'estimateNormErr' +(±) :: a -- ^ Point estimate + -> a -- ^ 1σ error + -> Estimate NormalErr a +(±) = estimateNormErr + +-- | Create estimate with asymmetric error. +estimateFromErr + :: a -- ^ Central estimate + -> (a,a) -- ^ Lower and upper errors. Both should be + -- positive but it's not checked. + -> CL Double -- ^ Confidence level for interval + -> Estimate ConfInt a +estimateFromErr x (ldx,udx) cl = Estimate x (ConfInt ldx udx cl) + +-- | Create estimate with asymmetric error. +estimateFromInterval + :: Num a + => a -- ^ Point estimate. Should lie within + -- interval but it's not checked. + -> (a,a) -- ^ Lower and upper bounds of interval + -> CL Double -- ^ Confidence level for interval + -> Estimate ConfInt a +estimateFromInterval x (lx,ux) cl + = Estimate x (ConfInt (x-lx) (ux-x) cl) + + +---------------------------------------- +-- Accessors + +-- | Get confidence interval +confidenceInterval :: Num a => Estimate ConfInt a -> (a,a) +confidenceInterval (Estimate x (ConfInt ldx udx _)) + = (x - ldx, x + udx) + +-- | Get asymmetric errors +asymErrors :: Estimate ConfInt a -> (a,a) +asymErrors (Estimate _ (ConfInt ldx udx _)) = (ldx,udx) + + + +-- | Data types which could be multiplied by constant. +class Scale e where + scale :: (Ord a, Num a) => a -> e a -> e a + +instance Scale NormalErr where + scale a (NormalErr e) = NormalErr (abs a * e) + +instance Scale ConfInt where + scale a (ConfInt l u cl) | a >= 0 = ConfInt (a*l) (a*u) cl + | otherwise = ConfInt (-a*u) (-a*l) cl + +instance Scale e => Scale (Estimate e) where + scale a (Estimate x dx) = Estimate (a*x) (scale a dx) + + + +---------------------------------------------------------------- +-- Upper/lower limit +---------------------------------------------------------------- + +-- | Upper limit. They are usually given for small non-negative values +-- when it's not possible detect difference from zero. +data UpperLimit a = UpperLimit + { upperLimit :: !a + -- ^ Upper limit + , ulConfidenceLevel :: !(CL Double) + -- ^ Confidence level for which limit was calculated + } deriving (Eq, Read, Show, Typeable, Data, Generic) + + +instance Binary a => Binary (UpperLimit a) where + get = liftM2 UpperLimit get get + put (UpperLimit l cl) = put l >> put cl +instance FromJSON a => FromJSON (UpperLimit a) +instance ToJSON a => ToJSON (UpperLimit a) +instance NFData a => NFData (UpperLimit a) where + rnf (UpperLimit x cl) = rnf x `seq` rnf cl + + + +-- | Lower limit. They are usually given for large quantities when +-- it's not possible to measure them. For example: proton half-life +data LowerLimit a = LowerLimit { + lowerLimit :: !a + -- ^ Lower limit + , llConfidenceLevel :: !(CL Double) + -- ^ Confidence level for which limit was calculated + } deriving (Eq, Read, Show, Typeable, Data, Generic) + +instance Binary a => Binary (LowerLimit a) where + get = liftM2 LowerLimit get get + put (LowerLimit l cl) = put l >> put cl +instance FromJSON a => FromJSON (LowerLimit a) +instance ToJSON a => ToJSON (LowerLimit a) +instance NFData a => NFData (LowerLimit a) where + rnf (LowerLimit x cl) = rnf x `seq` rnf cl + + +---------------------------------------------------------------- +-- Deriving unbox instances +---------------------------------------------------------------- + +derivingUnbox "CL" + [t| forall a. Unbox a => CL a -> a |] + [| \(CL a) -> a |] + [| CL |] + +derivingUnbox "PValue" + [t| forall a. Unbox a => PValue a -> a |] + [| \(PValue a) -> a |] + [| PValue |] + +derivingUnbox "Estimate" + [t| forall a e. (Unbox a, Unbox (e a)) => Estimate e a -> (a, e a) |] + [| \(Estimate x dx) -> (x,dx) |] + [| \(x,dx) -> (Estimate x dx) |] + +derivingUnbox "NormalErr" + [t| forall a. Unbox a => NormalErr a -> a |] + [| \(NormalErr a) -> a |] + [| NormalErr |] + +derivingUnbox "ConfInt" + [t| forall a. Unbox a => ConfInt a -> (a, a, CL Double) |] + [| \(ConfInt a b c) -> (a,b,c) |] + [| \(a,b,c) -> ConfInt a b c |] + +derivingUnbox "UpperLimit" + [t| forall a. Unbox a => UpperLimit a -> (a, CL Double) |] + [| \(UpperLimit a b) -> (a,b) |] + [| \(a,b) -> UpperLimit a b |] + +derivingUnbox "LowerLimit" + [t| forall a. Unbox a => LowerLimit a -> (a, CL Double) |] + [| \(LowerLimit a b) -> (a,b) |] + [| \(a,b) -> LowerLimit a b |] diff --git a/Statistics/Types/Internal.hs b/Statistics/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Statistics/Types/Internal.hs @@ -0,0 +1,24 @@ +-- | +-- Module : Statistics.Types.Internal +-- Copyright : (c) 2009 Bryan O'Sullivan +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- Types for working with statistics. +module Statistics.Types.Internal where + + +import qualified Data.Vector.Unboxed as U (Vector) + +-- | Sample data. +type Sample = U.Vector Double + +-- | Sample with weights. First element of sample is data, second is weight +type WeightedSample = U.Vector (Double,Double) + +-- | Weights for affecting the importance of elements of a sample. +type Weights = U.Vector Double + diff --git a/bench-papi/Bench.hs b/bench-papi/Bench.hs new file mode 100644 --- /dev/null +++ b/bench-papi/Bench.hs @@ -0,0 +1,14 @@ +-- | +-- Here we reexport definitions of tasty-bench +module Bench + ( whnf + , nf + , nfIO + , whnfIO + , bench + , bgroup + , defaultMain + , benchIngredients + ) where + +import Test.Tasty.PAPI diff --git a/bench-time/Bench.hs b/bench-time/Bench.hs new file mode 100644 --- /dev/null +++ b/bench-time/Bench.hs @@ -0,0 +1,14 @@ +-- | +-- Here we reexport definitions of tasty-bench +module Bench + ( whnf + , nf + , nfIO + , whnfIO + , bench + , bgroup + , defaultMain + , benchIngredients + ) where + +import Test.Tasty.Bench diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,77 @@ +module Main where + +import Data.Complex +import Statistics.Sample +import Statistics.Transform +import Statistics.Correlation +import System.Random.MWC +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as MVU + +import Bench + + +-- Test sample +sample :: VU.Vector Double +sample = VU.create $ do g <- create + MVU.replicateM 10000 (uniform g) + +-- Weighted test sample +sampleW :: VU.Vector (Double,Double) +sampleW = VU.zip sample (VU.reverse sample) + +-- Complex vector for FFT tests +sampleC :: VU.Vector (Complex Double) +sampleC = VU.zipWith (:+) sample (VU.reverse sample) + + +-- Simple benchmark for functions from Statistics.Sample +main :: IO () +main = + defaultMain + [ bgroup "sample" + [ bench "range" $ nf (\x -> range x) sample + -- Mean + , bench "mean" $ nf (\x -> mean x) sample + , bench "meanWeighted" $ nf (\x -> meanWeighted x) sampleW + , bench "harmonicMean" $ nf (\x -> harmonicMean x) sample + , bench "geometricMean" $ nf (\x -> geometricMean x) sample + -- Variance + , bench "variance" $ nf (\x -> variance x) sample + , bench "varianceUnbiased" $ nf (\x -> varianceUnbiased x) sample + , bench "varianceWeighted" $ nf (\x -> varianceWeighted x) sampleW + -- Correlation + , bench "pearson" $ nf pearson sampleW + , bench "covariance" $ nf covariance sampleW + , bench "correlation" $ nf correlation sampleW + , bench "covariance2" $ nf (covariance2 sample) sample + , bench "correlation2" $ nf (correlation2 sample) sample + -- Other + , bench "stdDev" $ nf (\x -> stdDev x) sample + , bench "skewness" $ nf (\x -> skewness x) sample + , bench "kurtosis" $ nf (\x -> kurtosis x) sample + -- Central moments + , bench "C.M. 2" $ nf (\x -> centralMoment 2 x) sample + , bench "C.M. 3" $ nf (\x -> centralMoment 3 x) sample + , bench "C.M. 4" $ nf (\x -> centralMoment 4 x) sample + , bench "C.M. 5" $ nf (\x -> centralMoment 5 x) sample + ] + , bgroup "FFT" + [ bgroup "fft" + [ bench (show n) $ whnf fft (VU.take n sampleC) | n <- fftSizes ] + , bgroup "ifft" + [ bench (show n) $ whnf ifft (VU.take n sampleC) | n <- fftSizes ] + , bgroup "dct" + [ bench (show n) $ whnf dct (VU.take n sample) | n <- fftSizes ] + , bgroup "dct_" + [ bench (show n) $ whnf dct_ (VU.take n sampleC) | n <- fftSizes ] + , bgroup "idct" + [ bench (show n) $ whnf idct (VU.take n sample) | n <- fftSizes ] + , bgroup "idct_" + [ bench (show n) $ whnf idct_ (VU.take n sampleC) | n <- fftSizes ] + ] + ] + + +fftSizes :: [Int] +fftSizes = [32,128,512,2048] diff --git a/benchmark/bench.hs b/benchmark/bench.hs deleted file mode 100644 --- a/benchmark/bench.hs +++ /dev/null @@ -1,71 +0,0 @@ -import Control.Monad.ST (runST) -import Criterion.Main -import Data.Complex -import Statistics.Sample -import Statistics.Transform -import Statistics.Correlation.Pearson -import System.Random.MWC -import qualified Data.Vector.Unboxed as U - - --- Test sample -sample :: U.Vector Double -sample = runST $ flip uniformVector 10000 =<< create - --- Weighted test sample -sampleW :: U.Vector (Double,Double) -sampleW = U.zip sample (U.reverse sample) - --- Comlex vector for FFT tests -sampleC :: U.Vector (Complex Double) -sampleC = U.zipWith (:+) sample (U.reverse sample) - - --- Simple benchmark for functions from Statistics.Sample -main :: IO () -main = - defaultMain - [ bgroup "sample" - [ bench "range" $ nf (\x -> range x) sample - -- Mean - , bench "mean" $ nf (\x -> mean x) sample - , bench "meanWeighted" $ nf (\x -> meanWeighted x) sampleW - , bench "harmonicMean" $ nf (\x -> harmonicMean x) sample - , bench "geometricMean" $ nf (\x -> geometricMean x) sample - -- Variance - , bench "variance" $ nf (\x -> variance x) sample - , bench "varianceUnbiased" $ nf (\x -> varianceUnbiased x) sample - , bench "varianceWeighted" $ nf (\x -> varianceWeighted x) sampleW - -- Correlation - , bench "pearson" $ nf (\x -> pearson (U.reverse sample) x) sample - , bench "pearson'" $ nf (\x -> pearson' (U.reverse sample) x) sample - , bench "pearsonFast" $ nf (\x -> pearsonFast (U.reverse sample) x) sample - -- Other - , bench "stdDev" $ nf (\x -> stdDev x) sample - , bench "skewness" $ nf (\x -> skewness x) sample - , bench "kurtosis" $ nf (\x -> kurtosis x) sample - -- Central moments - , bench "C.M. 2" $ nf (\x -> centralMoment 2 x) sample - , bench "C.M. 3" $ nf (\x -> centralMoment 3 x) sample - , bench "C.M. 4" $ nf (\x -> centralMoment 4 x) sample - , bench "C.M. 5" $ nf (\x -> centralMoment 5 x) sample - ] - , bgroup "FFT" - [ bgroup "fft" - [ bench (show n) $ whnf fft (U.take n sampleC) | n <- fftSizes ] - , bgroup "ifft" - [ bench (show n) $ whnf ifft (U.take n sampleC) | n <- fftSizes ] - , bgroup "dct" - [ bench (show n) $ whnf dct (U.take n sample) | n <- fftSizes ] - , bgroup "dct_" - [ bench (show n) $ whnf dct_ (U.take n sampleC) | n <- fftSizes ] - , bgroup "idct" - [ bench (show n) $ whnf idct (U.take n sample) | n <- fftSizes ] - , bgroup "idct_" - [ bench (show n) $ whnf idct_ (U.take n sampleC) | n <- fftSizes ] - ] - ] - - -fftSizes :: [Int] -fftSizes = [32,128,512,2048] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,251 @@ -Changes in 0.13.0.0 +## Changes in 0.16.5.0 [2026.01.09] + * `ContGen` and `DiscreteGen` instances for `Poisson` distributions are added. + + +## Changes in 0.16.4.0 [2025.10.23] + + * Bartlett's test (`Statistics.Test.Bartlett`) and Levene's test + (`Statistics.Test.Levene`) for homogeneity of variances is added. + + * Improved performance in calculation of moments. + + * Improved precision in calculation of `logDensity` of Student T distribution. + + +## Changes in 0.16.3.0 + + * `S.Sample.correlation`, `S.Sample.covariance`, + `S.Correlation.pearson` do not allocate temporary arrays. + + * Variants of correlation which take two vectors as input are added: + `S.Sample.correlation2`, `S.Sample.covariance2`, `S.Correlation.pearson2`, + `S.Correlation.spearman2`. + + * Contexts for `S.Function.indexed`, `S.Correlation.spearman`, `S.pairedTTest`, + `S.Sample.correlation`, `S.Sample.covariance`, reduced. + + * Computation of `rSquare` in linear regression has special case for case when + data variation is 0. + + * Doctests added. + + * Benchmarks using `tasty-bench` and `tasty-papi` added. + + * Spurious test failures fixed. + + +## Changes in 0.16.2.1 + + * Unnecessary constraint dropped from `tStatisticsPaired`. + + * Compatibility with QuickCheck-2.14. Test suite doesn't fail every time. + + +## Changes in 0.16.2.0 + + * Improved precision for `complCumulative` for hypergeometric and binomial + distributions. Precision improvements of geometric distribution + + * Negative binomial distribution added. + + +## Changes in 0.16.1.2 + + * Fixed bug in `fromSample` for exponential distribudion (#190) + + +## Changes in 0.16.1.0 + + * Dependency on monad-par is dropped. `parMap` from `parallel` is used instead. + + +## Changes in 0.16.0.2 + + * Bug in constructor of binomial distribution is fixed (#181). It accepted + out-of range probability before. + + +## Changes in 0.16.0.0 + + * Random number generation switched to API introduced in random-1.2 + + * Support of GHC<7.10 is dropped + + * Fix for chi-squared test (#167) which was completely wrong + + * Computation of CDF and quantiles of Cauchy distribution is now numerically + stable. + + * Fix loss of precision in computing of CDF of gamma distribution + + * Log-normal and Weibull distributions added. + + * `DiscreteGen` instance added for `DiscreteUniform` + + +## Changes in 0.15.2.0 + + * Test suite is finally fixed (#42, #123). It took very-very-very long + time but finally happened. + + * Avoid loss of precision when computing CDF for exponential distribution. + + * Avoid loss of precision when computing CDF for geometric distribution. Add + complement of CDF. + + * Correctly handle case of n=0 in poissonCI + + +## Changes in 0.15.1.1 + + * Fix build for GHC8.0 & 7.10 + + +## Changes in 0.15.1.0 + + * GHCJS support + + * Concurrent resampling now uses `async` instead of hand-rolled primitives + + +## Changes in 0.15.0.0 + + * Modules `Statistics.Matrix.*` are split into new package + `dense-linear-algebra` and exponent field is removed from `Matrix` data type. + + * Module `Statistics.Normalize` which contains functions for normalization of + samples + + * Module `Statistics.Quantile` reworked: + + - `ContParam` given `Default` instance + - `quantile` should be used instead of `continuousBy` + - `median` and `mad` are added + - `quantiles` and `quantilesVec` functions for computation of set of + quantiles added. + + * Modules `Statistics.Function.Comparison` and `Statistics.Math.RootFinding` + are removed. Corresponding functionality could be found in `math-functions` + package. + + * Fix vector index out of bounds in `bootstrapBCA` and `bootstrapRegress` + (see issue #149) + +## Changes in 0.14.0.2 + + * Compatibility fixes with older GHC + + +## Changes in 0.14.0.1 + + * Restored compatibility with GHC 7.4 & 7.6 + + +## Changes in 0.14.0.0 + +Breaking update. It seriously changes parts of API. It adds new data types for +dealing with estimates, confidence intervals, confidence levels and +p-value. Also API for statistical tests is changed. + + * Module `Statistis.Types` now contains new data types for estimates, + upper/lower bounds, confidence level, and p-value. + + - `CL` for representing confidence level + - `PValue` for representing p-values + - `Estimate` data type moved here from `Statistis.Resampling.Bootstrap` and + now parametrized by type of error. + - `NormalError` — represents normal error. + - `ConfInt` — generic confidence interval + - `UpperLimit`,`LowerLimit` for upper/lower limits. + + * New API for statistical tests. Instead of simply return significant/not + significant it returns p-value, test statistics and distribution of test + statistics if it's available. Tests also return `Nothing` instead of throwing + error if sample size is not sufficient. Fixes #25. + + * `Statistics.Tests.Types.TestType` data type dropped + + * New smart constructors for distributions are added. They return `Nothing` if + parameters are outside of allowed range. + + * Serialization instances (`Show/Read, Binary, ToJSON/FromJSON`) for + distributions no longer allows to create data types with invalid + parameters. They will fail to parse. Cached values are not serialized either + so `Binary` instances changed normal and F-distributions. + + Encoding to JSON changed for Normal, F-distribution, and χ² + distributions. However data created using older statistics will be + successfully decoded. + + Fixes #59. + + * Statistics.Resample.Bootstrap uses new data types for central estimates. + + * Function for calculation of confidence intervals for Poisson and binomial + distribution added in `Statistics.ConfidenceInt` + + * Tests of position now allow to ask whether first sample on average larger + than second, second larger than first or whether they differ significantly. + Affects Wilcoxon-T, Mann-Whitney-U, and Student-T tests. + + * API for bootstrap changed. New data types added. + + * Bug fixes for #74, #81, #83, #92, #94 + + * `complCumulative` added for many distributions. + + + +## Changes in 0.13.3.0 + + * Kernel density estimation and FFT use generic versions now. + + * Code for calculation of Spearman and Pearson correlation added. Modules + `Statistics.Correlation.Spearman` and `Statistics.Correlation.Pearson`. + + * Function for calculation covariance added in `Statistics.Sample`. + + * `Statistics.Function.pair` added. It zips vector and check that lengths are + equal. + + * New functions added to `Statistics.Matrix` + + * Laplace distribution added. + + +## Changes in 0.13.2.3 + + * Vector dependency restored to >=0.10 + + +## Changes in 0.13.2.2 + + * Vector dependency lowered to >=0.9 + + +## Changes in 0.13.2.1 + + * Vector dependency bumped to >=0.10 + + +## Changes in 0.13.2.0 + + * Support for regression bootstrap added + + +## Changes in 0.13.1.1 + + * Fix for out of bound access in bootstrap (see `bos/criterion#52`) + + +## Changes in 0.13.1.0 + * All types now support JSON encoding and decoding. -Changes in 0.12.0.0 +## Changes in 0.12.0.0 + * The `Statistics.Math` module has been removed, after being deprecated for several years. Use the [math-functions](http://hackage.haskell.org/package/math-functions) @@ -20,7 +262,7 @@ * Added the Kruskal-Wallis test. -Changes in 0.11.0.3 +## Changes in 0.11.0.3 * Fixed a subtle bug in calculation of the jackknifed unbiased variance. @@ -29,7 +271,7 @@ * We now calculate quantiles for normal distribution in a more numerically stable way (bug #64). -Changes in 0.10.6.0 +## Changes in 0.10.6.0 * The Estimator type has become an algebraic data type. This allows the jackknife function to potentially use more efficient jackknife @@ -43,55 +285,55 @@ implementation of mean has better numerical accuracy in almost all cases. -Changes in 0.10.5.2 +## Changes in 0.10.5.2 * histogram correctly chooses range when all elements in the sample are same (bug #57) -Changes in 0.10.5.1 +## Changes in 0.10.5.1 * Bug fix for S.Distributions.Normal.standard introduced in 0.10.5.0 (Bug #56) -Changes in 0.10.5.0 +## Changes in 0.10.5.0 * Enthropy type class for distributions is added. * Probability and probability density of distribution is given in log domain too. -Changes in 0.10.4.0 +## Changes in 0.10.4.0 * Support for versions of GHC older than 7.2 is discontinued. * All datatypes now support 'Data.Binary' and 'GHC.Generics'. -Changes in 0.10.3.0 +## Changes in 0.10.3.0 * Bug fixes -Changes in 0.10.2.0 +## Changes in 0.10.2.0 * Bugs in DCT and IDCT are fixed. - * Accesors for uniform distribution are added. + * Accessors for uniform distribution are added. - * ContGen instances for all continous distribtuions are added. + * ContGen instances for all continuous distributions are added. * Beta distribution is added. - * Constructor for improper gamma distribtuion is added. + * Constructor for improper gamma distribution is added. * Binomial distribution allows zero trials. * Poisson distribution now accept zero parameter. - * Integer overflow in caculation of Wilcoxon-T test is fixed. + * Integer overflow in calculation of Wilcoxon-T test is fixed. * Bug in 'ContGen' instance for normal distribution is fixed. -Changes in 0.10.1.0 +## Changes in 0.10.1.0 * Kolmogorov-Smirnov nonparametric test added. @@ -101,16 +343,16 @@ is added. * Modules 'Statistics.Math' and 'Statistics.Constants' are moved to - the @math-functions@ package. They are still available but marked + the `math-functions` package. They are still available but marked as deprecated. -Changed in 0.10.0.1 +## Changes in 0.10.0.1 - * @dct@ and @idct@ now have type @Vector Double -> Vector Double@ + * `dct` and `idct` now have type `Vector Double -> Vector Double` -Changes in 0.10.0.0 +## Changes in 0.10.0.0 * The type classes Mean and Variance are split in two. This is required for distributions which do not have finite variance or @@ -128,7 +370,7 @@ * Root finding is added, in S.Math.RootFinding. * The complCumulative function is added to the Distribution - class in order to accurately assess probalities P(X>x) which are + class in order to accurately assess probabilities P(X>x) which are used in one-tailed tests. * A stdDev function is added to the Variance class for @@ -143,7 +385,7 @@ * Bugs in quantile estimations for chi-square and gamma distribution are fixed. - * Integer overlow in mannWhitneyUCriticalValue is fixed. It + * Integer overflow in mannWhitneyUCriticalValue is fixed. It produced incorrect critical values for moderately large samples. Something around 20 for 32-bit machines and 40 for 64-bit ones. @@ -154,29 +396,29 @@ * One- and two-tailed tests in S.Tests.NonParametric are selected with sum types instead of Bool. - * Test results returned as enumeration instead of @Bool@. + * Test results returned as enumeration instead of `Bool`. * Performance improvements for Mann-Whitney U and Wilcoxon tests. - * Module @S.Tests.NonParamtric@ is split into @S.Tests.MannWhitneyU@ - and @S.Tests.WilcoxonT@ + * Module `S.Tests.NonParamtric` is split into `S.Tests.MannWhitneyU` + and `S.Tests.WilcoxonT` * sortBy is added to S.Function. * Mean and variance for gamma distribution are fixed. - * Much faster cumulative probablity functions for Poisson and + * Much faster cumulative probability functions for Poisson and hypergeometric distributions. * Better density functions for gamma and Poisson distributions. * Student-T, Fisher-Snedecor F-distributions and Cauchy-Lorentz - distrbution are added. + distribution are added. * The function S.Function.create is removed. Use generateM from the vector package instead. - * Function to perform approximate comparion of doubles is added to + * Function to perform approximate comparison of doubles is added to S.Function.Comparison * Regularized incomplete beta function and its inverse are added to diff --git a/statistics.cabal b/statistics.cabal --- a/statistics.cabal +++ b/statistics.cabal @@ -1,5 +1,8 @@ +cabal-version: 3.0 +build-type: Simple + name: statistics -version: 0.13.3.0 +version: 0.16.5.0 synopsis: A library of statistical types, data, and functions description: This library provides a number of common functions and types useful @@ -22,33 +25,55 @@ * Common statistical tests for significant differences between samples. -license: BSD3 +license: BSD-2-Clause license-file: LICENSE -homepage: https://github.com/bos/statistics -bug-reports: https://github.com/bos/statistics/issues -author: Bryan O'Sullivan -maintainer: Bryan O'Sullivan +homepage: https://github.com/haskell/statistics +bug-reports: https://github.com/haskell/statistics/issues +author: Bryan O'Sullivan , Alexey Khudaykov +maintainer: Alexey Khudaykov copyright: 2009-2014 Bryan O'Sullivan category: Math, Statistics -build-type: Simple -cabal-version: >= 1.8 + extra-source-files: README.markdown - benchmark/bench.hs - changelog.md examples/kde/KDE.hs examples/kde/data/faithful.csv examples/kde/kde.html examples/kde/kde.tpl - tests/Tests/Math/Tables.hs - tests/Tests/Math/gen.py tests/utils/Makefile tests/utils/fftw.c +extra-doc-files: + changelog.md + +tested-with: + GHC ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.2 + || ==9.12.2 + +source-repository head + type: git + location: https://github.com/haskell/statistics + +flag BenchPAPI + Description: Enable building of benchmarks which use instruction counters. + It requires libpapi and only works on Linux so it's protected by flag + Default: False + Manual: True + library + default-language: Haskell2010 exposed-modules: Statistics.Autocorrelation - Statistics.Constants + Statistics.ConfidenceInt Statistics.Correlation Statistics.Correlation.Kendall Statistics.Distribution @@ -56,69 +81,77 @@ Statistics.Distribution.Binomial Statistics.Distribution.CauchyLorentz Statistics.Distribution.ChiSquared + Statistics.Distribution.DiscreteUniform Statistics.Distribution.Exponential Statistics.Distribution.FDistribution Statistics.Distribution.Gamma Statistics.Distribution.Geometric Statistics.Distribution.Hypergeometric Statistics.Distribution.Laplace + Statistics.Distribution.Lognormal + Statistics.Distribution.NegativeBinomial Statistics.Distribution.Normal Statistics.Distribution.Poisson Statistics.Distribution.StudentT Statistics.Distribution.Transform Statistics.Distribution.Uniform + Statistics.Distribution.Weibull Statistics.Function - Statistics.Math.RootFinding - Statistics.Matrix - Statistics.Matrix.Algorithms - Statistics.Matrix.Mutable - Statistics.Matrix.Types Statistics.Quantile Statistics.Regression Statistics.Resampling Statistics.Resampling.Bootstrap Statistics.Sample + Statistics.Sample.Internal Statistics.Sample.Histogram Statistics.Sample.KernelDensity Statistics.Sample.KernelDensity.Simple + Statistics.Sample.Normalize Statistics.Sample.Powers + Statistics.Test.Bartlett + Statistics.Test.Levene Statistics.Test.ChiSquared Statistics.Test.KolmogorovSmirnov Statistics.Test.KruskalWallis Statistics.Test.MannWhitneyU +-- Statistics.Test.Runs + Statistics.Test.StudentT Statistics.Test.Types Statistics.Test.WilcoxonT Statistics.Transform Statistics.Types other-modules: Statistics.Distribution.Poisson.Internal - Statistics.Function.Comparison Statistics.Internal - Statistics.Sample.Internal Statistics.Test.Internal - build-depends: - aeson >= 0.6.0.0, - base >= 4.4 && < 5, - binary >= 0.5.1.0, - deepseq >= 1.1.0.2, - erf, - math-functions >= 0.1.5.2, - monad-par >= 0.3.4, - mwc-random >= 0.13.0.0, - primitive >= 0.3, - vector >= 0.10, - vector-algorithms >= 0.4, - vector-binary-instances >= 0.2.1 + Statistics.Types.Internal + build-depends: base >= 4.9 && < 5 + -- + , math-functions >= 0.3.4.1 + , mwc-random >= 0.15.3.0 + , random >= 1.2 + -- + , aeson >= 0.6.0.0 + , async >= 2.2.2 && <2.3 + , deepseq >= 1.1.0.2 + , binary >= 0.5.1.0 + , primitive >= 0.3 + , dense-linear-algebra >= 0.1 && <0.2 + , parallel >= 3.2.2.0 && <3.4 + , vector >= 0.10 + , vector-algorithms >= 0.4 + , vector-th-unbox + , vector-binary-instances >= 0.2.1 + , data-default-class >= 0.1.2 + + -- Older GHC if impl(ghc < 7.6) build-depends: ghc-prim - - -- gather extensive profiling data for now - ghc-prof-options: -auto-all - ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -test-suite tests +test-suite statistics-tests + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: tests.hs @@ -126,6 +159,7 @@ Tests.ApproxEq Tests.Correlation Tests.Distribution + Tests.ExactDistribution Tests.Function Tests.Helpers Tests.KDE @@ -133,32 +167,75 @@ Tests.Matrix.Types Tests.NonParametric Tests.NonParametric.Table + Tests.Orphanage + Tests.Parametric + Tests.Serialization Tests.Transform - + Tests.Quantile ghc-options: -Wall -threaded -rtsopts -fsimpl-tick-factor=500 + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial + build-depends: base + , statistics + , dense-linear-algebra + , QuickCheck >= 2.7.5 + , binary + , erf + , aeson + , ieee754 >= 0.7.3 + , math-functions + , primitive + , tasty + , tasty-hunit + , tasty-quickcheck + , tasty-expected-failure + , vector + , vector-algorithms +test-suite statistics-doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctest.hs + if impl(ghcjs) || impl(ghc < 8.0) + Buildable: False + -- Linker on macos prints warnings to console which confuses doctests. + -- We simply disable doctests on ma for older GHC + -- > warning: -single_module is obsolete + if os(darwin) && impl(ghc < 9.6) + buildable: False build-depends: - HUnit, - QuickCheck >= 2.7.5, - base, - binary, - erf, - ieee754 >= 0.7.3, - math-functions, - mwc-random, - primitive, - statistics, - test-framework, - test-framework-hunit, - test-framework-quickcheck2, - vector, - vector-algorithms + base -any + , statistics -any + , doctest >=0.15 && <0.25 -source-repository head - type: git - location: https://github.com/bos/statistics +-- We want to be able to build benchmarks using both tasty-bench and tasty-papi. +-- They have similar API so we just create two shim modules which reexport +-- definitions from corresponding library and pick one in cabal file. +common bench-stanza + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base < 5 + , vector >= 0.12.3 + , statistics + , mwc-random + , tasty >=1.3.1 -source-repository head - type: mercurial - location: https://bitbucket.org/bos/statistics +benchmark statistics-bench + import: bench-stanza + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark bench-time + main-is: Main.hs + Other-modules: Bench + build-depends: tasty-bench >= 0.3 + +benchmark statistics-bench-papi + import: bench-stanza + type: exitcode-stdio-1.0 + if impl(ghcjs) || !flag(BenchPAPI) + buildable: False + hs-source-dirs: benchmark bench-papi + main-is: Main.hs + Other-modules: Bench + build-depends: tasty-papi >= 0.1.2 diff --git a/tests/Tests/ApproxEq.hs b/tests/Tests/ApproxEq.hs --- a/tests/Tests/ApproxEq.hs +++ b/tests/Tests/ApproxEq.hs @@ -24,7 +24,8 @@ eql eps a b = counterexample (show a ++ " /=~ " ++ show b) (eq eps a b) (=~) :: a -> a -> Bool - (==~) :: ApproxEq a => a -> a -> Property + + (==~) :: a -> a -> Property a ==~ b = counterexample (show a ++ " /=~ " ++ show b) (a =~ b) instance ApproxEq Double where @@ -77,8 +78,8 @@ instance ApproxEq Matrix where type Bounds Matrix = Double - eq eps (Matrix r1 c1 e1 v1) (Matrix r2 c2 e2 v2) = - (r1,c1,e1) == (r2,c2,e2) && eq eps v1 v2 + eq eps (Matrix r1 c1 v1) (Matrix r2 c2 v2) = + (r1,c1) == (r2,c2) && eq eps v1 v2 (=~) = eq m_epsilon eql eps a b = eqll dimension M.toList (`quotRem` cols a) eps a b (==~) = eql m_epsilon diff --git a/tests/Tests/Correlation.hs b/tests/Tests/Correlation.hs --- a/tests/Tests/Correlation.hs +++ b/tests/Tests/Correlation.hs @@ -5,14 +5,12 @@ import Control.Arrow (Arrow(..)) import qualified Data.Vector as V -import Statistics.Matrix hiding (map) +import Data.Maybe import Statistics.Correlation import Statistics.Correlation.Kendall -import Test.QuickCheck ((==>),Property,counterexample) -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.Framework.Providers.HUnit -import Test.HUnit (Assertion, (@=?), assertBool) +import Test.Tasty +import Test.Tasty.QuickCheck hiding (sample) +import Test.Tasty.HUnit import Tests.ApproxEq @@ -20,7 +18,7 @@ -- Tests list ---------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Correlation" [ testProperty "Pearson correlation" testPearson , testProperty "Spearman correlation is scale invariant" testSpearmanScale @@ -36,15 +34,19 @@ testPearson :: [(Double,Double)] -> Property testPearson sample - = (length sample > 1) ==> (exact ~= fast) + = (length sample > 1 && isJust exact) ==> (case exact of + Just e -> e ~= fast + Nothing -> property False + ) where (~=) = eql 1e-12 exact = exactPearson $ map (realToFrac *** realToFrac) sample fast = pearson $ V.fromList sample -exactPearson :: [(Rational,Rational)] -> Double +exactPearson :: [(Rational,Rational)] -> Maybe Double exactPearson sample - = realToFrac cov / sqrt (realToFrac (varX * varY)) + | varX == 0 || varY == 0 = Nothing + | otherwise = Just $ realToFrac cov / sqrt (realToFrac (varX * varY)) where (xs,ys) = unzip sample n = fromIntegral $ length sample @@ -100,11 +102,11 @@ , 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 @@ -115,8 +117,8 @@ -- 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 diff --git a/tests/Tests/Distribution.hs b/tests/Tests/Distribution.hs --- a/tests/Tests/Distribution.hs +++ b/tests/Tests/Distribution.hs @@ -1,42 +1,48 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, OverlappingInstances, ScopedTypeVariables, +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, ViewPatterns #-} module Tests.Distribution (tests) where -import Control.Applicative ((<$), (<$>), (<*>)) -import Data.Binary (Binary, decode, encode) +import qualified Control.Exception as E import Data.List (find) import Data.Typeable (Typeable) +import Data.Word +import Numeric.MathFunctions.Constants (m_tiny,m_huge,m_epsilon) +import Numeric.MathFunctions.Comparison import Statistics.Distribution -import Statistics.Distribution.Beta (BetaDistribution, betaDistr) -import Statistics.Distribution.Binomial (BinomialDistribution, binomial) +import Statistics.Distribution.Beta (BetaDistribution) +import Statistics.Distribution.Binomial (BinomialDistribution) import Statistics.Distribution.CauchyLorentz -import Statistics.Distribution.ChiSquared (ChiSquared, chiSquared) -import Statistics.Distribution.Exponential (ExponentialDistribution, exponential) -import Statistics.Distribution.FDistribution (FDistribution, fDistribution) -import Statistics.Distribution.Gamma (GammaDistribution, gammaDistr) +import Statistics.Distribution.ChiSquared (ChiSquared) +import Statistics.Distribution.Exponential (ExponentialDistribution) +import Statistics.Distribution.FDistribution (FDistribution,fDistribution) +import Statistics.Distribution.Gamma (GammaDistribution,gammaDistr) import Statistics.Distribution.Geometric import Statistics.Distribution.Hypergeometric -import Statistics.Distribution.Laplace (LaplaceDistribution, laplace) -import Statistics.Distribution.Normal (NormalDistribution, normalDistr) -import Statistics.Distribution.Poisson (PoissonDistribution, poisson) +import Statistics.Distribution.Laplace (LaplaceDistribution) +import Statistics.Distribution.Lognormal (LognormalDistribution) +import Statistics.Distribution.NegativeBinomial (NegativeBinomialDistribution) +import Statistics.Distribution.Normal (NormalDistribution) +import Statistics.Distribution.Poisson (PoissonDistribution) import Statistics.Distribution.StudentT -import Statistics.Distribution.Transform (LinearTransform, linTransDistr) -import Statistics.Distribution.Uniform (UniformDistribution, uniformDistr) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Statistics.Distribution.Transform (LinearTransform) +import Statistics.Distribution.Uniform (UniformDistribution) +import Statistics.Distribution.Weibull (WeibullDistribution) +import Statistics.Distribution.DiscreteUniform (DiscreteUniform) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.ExpectedFailure (ignoreTest) import Test.QuickCheck as QC import Test.QuickCheck.Monadic as QC -import Tests.ApproxEq (ApproxEq(..)) -import Tests.Helpers (T(..), testAssertion, typeName) -import Tests.Helpers (monotonicallyIncreasesIEEE) import Text.Printf (printf) -import qualified Control.Exception as E -import qualified Numeric.IEEE as IEEE +import Tests.ApproxEq (ApproxEq(..)) +import Tests.ExactDistribution (exactDistributionTests) +import Tests.Helpers (T(..), Double01(..), testAssertion, typeName) +import Tests.Helpers (monotonicallyIncreasesIEEE,isDenorm) +import Tests.Orphanage () -- | Tests for all distributions -tests :: Test +tests :: TestTree tests = testGroup "Tests for all distributions" [ contDistrTests (T :: T BetaDistribution ) , contDistrTests (T :: T CauchyDistribution ) @@ -44,18 +50,23 @@ , contDistrTests (T :: T ExponentialDistribution ) , contDistrTests (T :: T GammaDistribution ) , contDistrTests (T :: T LaplaceDistribution ) + , contDistrTests (T :: T LognormalDistribution ) , contDistrTests (T :: T NormalDistribution ) , contDistrTests (T :: T UniformDistribution ) + , contDistrTests (T :: T WeibullDistribution ) , contDistrTests (T :: T StudentT ) - , contDistrTests (T :: T (LinearTransform StudentT) ) + , contDistrTests (T :: T (LinearTransform NormalDistribution)) , contDistrTests (T :: T FDistribution ) , discreteDistrTests (T :: T BinomialDistribution ) , discreteDistrTests (T :: T GeometricDistribution ) , discreteDistrTests (T :: T GeometricDistribution0 ) , discreteDistrTests (T :: T HypergeometricDistribution ) + , discreteDistrTests (T :: T NegativeBinomialDistribution ) , discreteDistrTests (T :: T PoissonDistribution ) + , discreteDistrTests (T :: T DiscreteUniform ) + , exactDistributionTests , unitTests ] @@ -63,37 +74,39 @@ -- Tests ---------------------------------------------------------------- --- Tests for continous distribution -contDistrTests :: (Param d, ContDistr d, QC.Arbitrary d, Typeable d, Show d, Binary d, Eq d) => T d -> Test +-- Tests for continuous distribution +contDistrTests :: (Param d, ContDistr d, QC.Arbitrary d, Typeable d, Show d) => T d -> TestTree contDistrTests t = testGroup ("Tests for: " ++ typeName t) $ cdfTests t ++ [ testProperty "PDF sanity" $ pdfSanityCheck t - , testProperty "Quantile is CDF inverse" $ quantileIsInvCDF t + , (if quantileIsInvCDF_enabled t then id else ignoreTest) + $ testProperty "Quantile is CDF inverse" $ quantileIsInvCDF t , testProperty "quantile fails p<0||p>1" $ quantileShouldFail t , testProperty "log density check" $ logDensityCheck t + , testProperty "complQuantile" $ complQuantileCheck t ] -- Tests for discrete distribution -discreteDistrTests :: (Param d, DiscreteDistr d, QC.Arbitrary d, Typeable d, Show d, Binary d, Eq d) => T d -> Test +discreteDistrTests :: (Param d, DiscreteDistr d, QC.Arbitrary d, Typeable d, Show d) => T d -> TestTree discreteDistrTests t = testGroup ("Tests for: " ++ typeName t) $ cdfTests t ++ [ testProperty "Prob. sanity" $ probSanityCheck t , testProperty "CDF is sum of prob." $ discreteCDFcorrect t , testProperty "Discrete CDF is OK" $ cdfDiscreteIsCorrect t - , testProperty "log probabilty check" $ logProbabilityCheck t + , testProperty "log probability check" $ logProbabilityCheck t ] -- Tests for distributions which have CDF -cdfTests :: (Param d, Distribution d, QC.Arbitrary d, Show d, Binary d, Eq d) => T d -> [Test] +cdfTests :: (Param d, Distribution d, QC.Arbitrary d, Show d) => T d -> [TestTree] cdfTests t = [ testProperty "C.D.F. sanity" $ cdfSanityCheck t , testProperty "CDF limit at +inf" $ cdfLimitAtPosInfinity t - , testProperty "CDF limit at -inf" $ cdfLimitAtNegInfinity t + , (if cdfLimitAtNegInfinity_enabled t then id else ignoreTest) + $ testProperty "CDF limit at -inf" $ cdfLimitAtNegInfinity t , testProperty "CDF at +inf = 1" $ cdfAtPosInfinity t , testProperty "CDF at -inf = 1" $ cdfAtNegInfinity t , testProperty "CDF is nondecreasing" $ cdfIsNondecreasing t , testProperty "1-CDF is correct" $ cdfComplementIsCorrect t - , testProperty "Binary OK" $ p_binary t ] @@ -109,39 +122,46 @@ cdfIsNondecreasing _ d = monotonicallyIncreasesIEEE $ cumulative d -- cumulative d +∞ = 1 -cdfAtPosInfinity :: (Param d, Distribution d) => T d -> d -> Bool +cdfAtPosInfinity :: (Distribution d) => T d -> d -> Bool cdfAtPosInfinity _ d = cumulative d (1/0) == 1 -- cumulative d - ∞ = 0 -cdfAtNegInfinity :: (Param d, Distribution d) => T d -> d -> Bool +cdfAtNegInfinity :: (Distribution d) => T d -> d -> Bool cdfAtNegInfinity _ d = cumulative d (-1/0) == 0 -- CDF limit at +∞ is 1 -cdfLimitAtPosInfinity :: (Param d, Distribution d) => T d -> d -> Property -cdfLimitAtPosInfinity _ d = - okForInfLimit d ==> counterexample ("Last elements: " ++ show (drop 990 probs)) - $ Just 1.0 == (find (>=1) probs) +cdfLimitAtPosInfinity :: (Param d, Distribution d) => T d -> d -> Bool +cdfLimitAtPosInfinity _ d + = Just 1.0 == find (>=1) probs where - probs = take 1000 $ map (cumulative d) $ iterate (*1.4) 1000 + probs = map (cumulative d) + $ takeWhile (< (m_huge/2)) + $ iterate (*1.4) 1 -- CDF limit at -∞ is 0 -cdfLimitAtNegInfinity :: (Param d, Distribution d) => T d -> d -> Property -cdfLimitAtNegInfinity _ d = - okForInfLimit d ==> counterexample ("Last elements: " ++ show (drop 990 probs)) - $ case find (< IEEE.epsilon) probs of - Nothing -> False - Just p -> p >= 0 +cdfLimitAtNegInfinity :: (Param d, Distribution d) => T d -> d -> Bool +cdfLimitAtNegInfinity _ d + = Just 0 == find (<=0) probs where - probs = take 1000 $ map (cumulative d) $ iterate (*1.4) (-1) + probs = map (cumulative d) + $ takeWhile (> (-m_huge/2)) + $ iterate (*1.4) (-1) + -- CDF's complement is implemented correctly -cdfComplementIsCorrect :: (Distribution d) => T d -> d -> Double -> Bool -cdfComplementIsCorrect _ d x = (eq 1e-14) 1 (cumulative d x + complCumulative d x) +cdfComplementIsCorrect :: (Distribution d, Param d) => T d -> d -> Double -> Property +cdfComplementIsCorrect _ d x + = counterexample ("err. tolerance = " ++ show tol) + $ counterexample ("difference = " ++ show delta) + $ delta <= tol + where + tol = prec_complementCDF d + delta = 1 - (cumulative d x + complCumulative d x) -- CDF for discrete distribution uses <= for comparison -cdfDiscreteIsCorrect :: (DiscreteDistr d) => T d -> d -> Property +cdfDiscreteIsCorrect :: (Param d, DiscreteDistr d) => T d -> d -> Property cdfDiscreteIsCorrect _ d = counterexample (unlines badN) $ null badN @@ -150,50 +170,95 @@ -- -- > CDF(i) - CDF(i-e) = P(i) -- - -- Apporixmate equality is tricky here. Scale is set by maximum - -- value of CDF and probability. Case when all proabilities are - -- zero should be trated specially. + -- Approximate equality is tricky here. Scale is set by maximum + -- value of CDF and probability. Case when all probabilities are + -- zero should be treated specially. badN = [ printf "N=%3i p[i]=%g\tp[i+1]=%g\tdP=%g\trelerr=%g" i p p1 dp ((p1-p-dp) / max p1 dp) | i <- [0 .. 100] , let p = cumulative d $ fromIntegral i - 1e-6 p1 = cumulative d $ fromIntegral i dp = probability d i relerr = ((p1 - p) - dp) / max p1 dp - , not (p == 0 && p1 == 0 && dp == 0) - && relerr > 1e-14 + , p > m_tiny || p == 0 + , p1 > m_tiny + , dp > m_tiny + , relerr > tol ] + tol = prec_discreteCDF d -logDensityCheck :: (ContDistr d) => T d -> d -> Double -> Property +logDensityCheck :: (Param d, ContDistr d) => T d -> d -> Double -> Property logDensityCheck _ d x - = counterexample (printf "density = %g" p) - $ counterexample (printf "logDensity = %g" logP) - $ counterexample (printf "log p = %g" (log p)) - $ counterexample (printf "eps = %g" (abs (logP - log p) / max (abs (log p)) (abs logP))) - $ or [ p == 0 && logP == (-1/0) - , p < 1e-308 && logP < 609 - , eq 1e-14 (log p) logP - ] + = not (isDenorm x) + ==> ( counterexample (printf "density = %g" p) + $ counterexample (printf "logDensity = %g" logP) + $ counterexample (printf "log p = %g" (log p)) + $ counterexample (printf "ulps[log] = %i" ulpsLog) + $ counterexample (printf "ulps[lin] = %i" ulpsLin) + $ or [ p == 0 && logP == (-1/0) + , p <= m_tiny && logP < log m_tiny + -- To avoid problems with roundtripping error in case + -- when density is computed as exponent of logDensity we + -- accept either inequality + , (ulpsLog <= n) || (ulpsLin <= n) + ]) where - p = density d x - logP = logDensity d x + p = density d x + logP = logDensity d x + n = prec_logDensity d + ulpsLog = ulpDistance (log p) logP + ulpsLin = ulpDistance p (exp logP) -- PDF is positive pdfSanityCheck :: (ContDistr d) => T d -> d -> Double -> Bool pdfSanityCheck _ d x = p >= 0 where p = density d x +complQuantileCheck :: (ContDistr d) => T d -> d -> Double01 -> Property +complQuantileCheck _ d (Double01 p) + = counterexample (printf "x0 = %g" x0) + $ counterexample (printf "x1 = %g" x1) + $ counterexample (printf "abs err = %g" $ abs (x1 - x0)) + $ counterexample (printf "rel err = %g" $ relativeError x1 x0) + -- We avoid extreme tails of distributions + -- + -- FIXME: all parameters are arbitrary at the moment + $ and [ p > 0.01 + , p < 0.99 + , not $ isInfinite x0 + , not $ isInfinite x1 + ] ==> (if x0 < 1e6 then abs (x1 - x0) < 1e-6 else relativeError x1 x0 < 1e-12) + where + x0 = quantile d (1 - p) + x1 = complQuantile d p + -- Quantile is inverse of CDF -quantileIsInvCDF :: (Param d, ContDistr d) => T d -> d -> Double -> Property -quantileIsInvCDF _ d (snd . properFraction -> p) = - p > 0 && p < 1 ==> ( counterexample (printf "Quantile = %g" q ) - $ counterexample (printf "Probability = %g" p ) - $ counterexample (printf "Probability' = %g" p') - $ counterexample (printf "Error = %e" (abs $ p - p')) - $ abs (p - p') < invQuantilePrec d - ) +quantileIsInvCDF :: (Param d, ContDistr d) => T d -> d -> Double01 -> Property +quantileIsInvCDF _ d (Double01 p) = + and [ p > m_tiny + , p < 1 + , x > m_tiny + , dens > 0 + ] ==> + ( counterexample (printf "Quantile = %g" x ) + $ counterexample (printf "Probability = %g" p ) + $ counterexample (printf "Probability' = %g" p') + $ counterexample (printf "Rel. error = %g" (relativeError p p')) + $ counterexample (printf "Abs. error = %e" (abs $ p - p')) + $ counterexample (printf "Expected err. = %g" err) + $ counterexample (printf "Distance = %i" (ulpDistance p p')) + $ counterexample (printf "Err/est = %g" (fromIntegral (ulpDistance p p') / err)) + $ ulpDistance p p' <= round err + ) where - q = quantile d p - p' = cumulative d q + -- Algorithm for error estimation is taken from here + -- + -- http://sepulcarium.org/posts/2012-07-19-rounding_effect_on_inverse.html + dens = density d x + err = eps + eps' * abs (x / p) * dens + -- + x = quantile d p + p' = cumulative d x + (eps,eps') = prec_quantile_CDF d -- Test that quantile fails if p<0 or p>1 quantileShouldFail :: (ContDistr d) => T d -> d -> Double -> Property @@ -216,9 +281,9 @@ $ counterexample (printf "Sum = %g" p2) $ counterexample (printf "Delta = %g" (abs (p1 - p2))) $ abs (p1 - p2) < 3e-10 - -- Avoid too large differeneces. Otherwise there is to much to sum + -- Avoid too large differences. Otherwise there is to much to sum -- - -- Absolute difference is used guard againist precision loss when + -- Absolute difference is used guard against precision loss when -- close values of CDF are subtracted where n = min a b @@ -226,111 +291,106 @@ p1 = cumulative d (fromIntegral m + 0.5) - cumulative d (fromIntegral n - 0.5) p2 = sum $ map (probability d) [n .. m] -logProbabilityCheck :: (DiscreteDistr d) => T d -> d -> Int -> Property +logProbabilityCheck :: (Param d, DiscreteDistr d) => T d -> d -> Int -> Property logProbabilityCheck _ d x = counterexample (printf "probability = %g" p) $ counterexample (printf "logProbability = %g" logP) $ counterexample (printf "log p = %g" (log p)) - $ counterexample (printf "eps = %g" (abs (logP - log p) / max (abs (log p)) (abs logP))) + $ counterexample (printf "ulps[log] = %i" ulpsLog) + $ counterexample (printf "ulps[lin] = %i" ulpsLin) $ or [ p == 0 && logP == (-1/0) , p < 1e-308 && logP < 609 - , eq 1e-14 (log p) logP + -- To avoid problems with roundtripping error in case + -- when density is computed as exponent of logDensity we + -- accept either inequality + , (ulpsLog <= n) || (ulpsLin <= n) ] where p = probability d x logP = logProbability d x - - -p_binary :: (Eq a, Show a, Binary a) => T a -> a -> Bool -p_binary _ a = a == (decode . encode) a - - - ----------------------------------------------------------------- --- Arbitrary instances for ditributions ----------------------------------------------------------------- - -instance QC.Arbitrary BinomialDistribution where - arbitrary = binomial <$> QC.choose (1,100) <*> QC.choose (0,1) -instance QC.Arbitrary ExponentialDistribution where - arbitrary = exponential <$> QC.choose (0,100) -instance QC.Arbitrary LaplaceDistribution where - arbitrary = laplace <$> QC.choose (-10,10) <*> QC.choose (0, 2) -instance QC.Arbitrary GammaDistribution where - arbitrary = gammaDistr <$> QC.choose (0.1,10) <*> QC.choose (0.1,10) -instance QC.Arbitrary BetaDistribution where - arbitrary = betaDistr <$> QC.choose (1e-3,10) <*> QC.choose (1e-3,10) -instance QC.Arbitrary GeometricDistribution where - arbitrary = geometric <$> QC.choose (0,1) -instance QC.Arbitrary GeometricDistribution0 where - arbitrary = geometric0 <$> QC.choose (0,1) -instance QC.Arbitrary HypergeometricDistribution where - arbitrary = do l <- QC.choose (1,20) - m <- QC.choose (0,l) - k <- QC.choose (1,l) - return $ hypergeometric m l k -instance QC.Arbitrary NormalDistribution where - arbitrary = normalDistr <$> QC.choose (-100,100) <*> QC.choose (1e-3, 1e3) -instance QC.Arbitrary PoissonDistribution where - arbitrary = poisson <$> QC.choose (0,1) -instance QC.Arbitrary ChiSquared where - arbitrary = chiSquared <$> QC.choose (1,100) -instance QC.Arbitrary UniformDistribution where - arbitrary = do a <- QC.arbitrary - b <- QC.arbitrary `suchThat` (/= a) - return $ uniformDistr a b -instance QC.Arbitrary CauchyDistribution where - arbitrary = cauchyDistribution - <$> arbitrary - <*> ((abs <$> arbitrary) `suchThat` (> 0)) -instance QC.Arbitrary StudentT where - arbitrary = studentT <$> ((abs <$> arbitrary) `suchThat` (>0)) -instance QC.Arbitrary (LinearTransform StudentT) where - arbitrary = studentTUnstandardized - <$> ((abs <$> arbitrary) `suchThat` (>0)) - <*> ((abs <$> arbitrary)) - <*> ((abs <$> arbitrary) `suchThat` (>0)) -instance QC.Arbitrary FDistribution where - arbitrary = fDistribution - <$> ((abs <$> arbitrary) `suchThat` (>0)) - <*> ((abs <$> arbitrary) `suchThat` (>0)) - + n = prec_logDensity d + ulpsLog = ulpDistance (log p) logP + ulpsLin = ulpDistance p (exp logP) --- Parameters for distribution testing. Some distribution require --- relaxing parameters a bit +-- | Parameters for distribution testing. Some distribution require +-- relaxing parameters a bit class Param a where - -- Precision for quantileIsInvCDF - invQuantilePrec :: a -> Double - invQuantilePrec _ = 1e-14 - -- Distribution is OK for testing limits - okForInfLimit :: a -> Bool - okForInfLimit _ = True - - -instance Param a + -- | Whether quantileIsInvCDF is enabled + quantileIsInvCDF_enabled :: T a -> Bool + quantileIsInvCDF_enabled _ = True + -- | Whether cdfLimitAtNegInfinity is enabled + cdfLimitAtNegInfinity_enabled :: T a -> Bool + cdfLimitAtNegInfinity_enabled _ = True + -- | Precision for 'quantileIsInvCDF' test + prec_quantile_CDF :: a -> (Double,Double) + prec_quantile_CDF _ = (16,16) + -- | + prec_discreteCDF :: a -> Double + prec_discreteCDF _ = 32 * m_epsilon + -- | Precision of CDF's complement + prec_complementCDF :: a -> Double + prec_complementCDF _ = 1e-14 + -- | Precision for logDensity check + prec_logDensity :: a -> Word64 + prec_logDensity _ = 32 instance Param StudentT where - invQuantilePrec _ = 1e-13 - okForInfLimit d = studentTndf d > 0.75 + -- FIXME: disabled unless incompleteBeta troubles are sorted out + quantileIsInvCDF_enabled _ = False -instance Param (LinearTransform StudentT) where - invQuantilePrec _ = 1e-13 - okForInfLimit d = (studentTndf . linTransDistr) d > 0.75 +instance Param BetaDistribution where + -- FIXME: See https://github.com/haskell/statistics/issues/161 for details + quantileIsInvCDF_enabled _ = False instance Param FDistribution where - invQuantilePrec _ = 1e-12 + -- FIXME: disabled unless incompleteBeta troubles are sorted out + quantileIsInvCDF_enabled _ = False + -- We compute CDF and complement using same method so precision + -- should be very good here. + prec_complementCDF _ = 64 * m_epsilon +instance Param ChiSquared where + prec_quantile_CDF _ = (32,32) +instance Param BinomialDistribution where + prec_discreteCDF _ = 1e-12 + prec_logDensity _ = 48 +instance Param CauchyDistribution where + -- Distribution is long-tailed enough that we may never get to zero + cdfLimitAtNegInfinity_enabled _ = False +instance Param DiscreteUniform +instance Param ExponentialDistribution +instance Param GammaDistribution where + -- We lose precision near `incompleteGamma 10` because of error + -- introduced by exp . logGamma. This could only be fixed in + -- math-function by implementing gamma + prec_quantile_CDF _ = (24,24) + prec_logDensity _ = 512 +instance Param GeometricDistribution +instance Param GeometricDistribution0 +instance Param HypergeometricDistribution +instance Param LaplaceDistribution +instance Param LognormalDistribution where + prec_quantile_CDF _ = (64,64) +instance Param NegativeBinomialDistribution where + prec_discreteCDF _ = 1e-12 + prec_logDensity _ = 48 +instance Param NormalDistribution +instance Param PoissonDistribution +instance Param UniformDistribution +instance Param WeibullDistribution +instance Param a => Param (LinearTransform a) + ---------------------------------------------------------------- -- Unit tests ---------------------------------------------------------------- -unitTests :: Test +unitTests :: TestTree unitTests = testGroup "Unit tests" [ testAssertion "density (gammaDistr 150 1/150) 1 == 4.883311" $ - 4.883311418525483 =~ (density (gammaDistr 150 (1/150)) 1) + 4.883311418525483 =~ density (gammaDistr 150 (1/150)) 1 -- Student-T , testStudentPDF 0.3 1.34 0.0648215 -- PDF , testStudentPDF 1 0.42 0.27058 diff --git a/tests/Tests/ExactDistribution.hs b/tests/Tests/ExactDistribution.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/ExactDistribution.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Tests.ExactDistribution +-- Copyright : (c) 2022 Lorenz Minder +-- License : BSD3 +-- +-- Maintainer : lminder@gmx.net +-- Stability : experimental +-- Portability : portable +-- +-- Tests comparing distributions to exact versions. +-- +-- This module provides exact versions of some distributions, and tests +-- to compare them to the production implementations in +-- Statistics.Distribution.*. It also contains the functionality to +-- test the production distributions against the exact versions. Errors +-- are flagged if data points are discovered where the probability mass +-- function, the cumulative probability function, or its complement +-- deviates too far (more than a prescribed tolerance) from the exact +-- calculation. +-- +-- The distributions here are implemented with rational integer +-- arithmetic, using pretty much the textbook definitions formulas. +-- Numerical problems like overflow or rounding errors cannot occur with +-- this approach, making them are easy to write, read and verify. They +-- are, of course, substantially slower than the production +-- distributions in Statistics.Distribution.*. This makes them +-- unsuitable for most uses other than testing and debugging. (Also, +-- only a handful of distributions can be implemented exactly with +-- rational arithmetic.) +-- +-- This module has the following sub-components: +-- +-- * Exact (rational) definitions of some distribution functions, +-- including both the probability mass as well as the CDF. +-- +-- * QC.Arbitrary implementations to sample test cases (i.e., +-- distribution parameters and evaluation points). +-- +-- * "Linkage": a mechanism to construct a production distribution +-- corresponding to a test case for an exact distribution. +-- +-- * A set of tests for the distributions derived using all of the above +-- components. +-- +-- This module exports a number symbols which can be useful for +-- debugging and experimentation. For use in a test suite, only the +-- `exactDistributionTests` function is needed. + +module Tests.ExactDistribution ( + -- * Exact math functions + exactChoose + + -- * Exact distributions + , ExactDiscreteDistr(..) + + , ExactBinomialDistr(..) + , ExactDiscreteUniformDistr(..) + , ExactGeometricDistr(..) + , ExactHypergeomDistr(..) + + -- * Linking to production distributions + , ProductionLinkage + + -- * Individual test routines + , pmfMatch + , cdfMatch + , complCdfMatch + + -- * Test groups + , Tag(..) + , distTests + , exactDistributionTests +) where + +---------------------------------------------------------------- + +import Data.Foldable +import Data.Ratio + +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 +import Statistics.Distribution.DiscreteUniform +import Statistics.Distribution.Geometric +import Statistics.Distribution.Hypergeometric + +---------------------------------------------------------------- +-- +-- Math functions. +-- +-- Used for implementing the distributions below. +-- +---------------------------------------------------------------- + +-- | Exactly compute binomial coefficient. +-- +-- /n/ need not be an integer, can be fractional. +exactChoose :: Ratio Integer -> Integer -> Ratio Integer +exactChoose n k + | k < 0 = 0 + | otherwise = foldl' (*) 1 factors + where factors = [ (n - k' + j) / j | j <- [1..k'] ] + k' = fromInteger k :: Ratio Integer + +---------------------------------------------------------------- +-- +-- Exact distributions. +-- +---------------------------------------------------------------- + +-- | Exact discrete distribution. +class ExactDiscreteDistr a where + -- | Probability mass function. + exactProb :: a -> Integer -> Ratio Integer + exactProb d x = exactCumulative d x - exactCumulative d (x - 1) + + -- | Cumulative distribution function. + exactCumulative :: a -> Integer -> Ratio Integer + +-- | Exact Binomial distribution. +data ExactBinomialDistr = ExactBD Integer (Ratio Integer) + deriving(Show) + +instance ExactDiscreteDistr ExactBinomialDistr where + -- Probability mass, computed with textbook formula. + exactProb (ExactBD n p) k + | k < 0 || k > n = 0 + | otherwise = exactChoose n' k * p^k * (1-p)^(n-k) + where n' = fromIntegral n + -- CDF + -- + -- Computed iteratively by summing up all the probabilities + -- <= /k/. Rather than computing everything from scratch for each + -- probability, we reuse previous results. The meanings of the + -- variables in the "update" function are: + -- + -- bc is the binomial coefficient (n choose j), + -- pj is the term p^j, + -- pnj is the term (1 - p)^(n - j) + -- r is the (partial) sum of the probabilities + -- + exactCumulative (ExactBD n p) k + | k < 0 = 0 + | k >= n = 1 + -- Special case for p = 1, since in the below fold we + -- divide by (1 - p). + | p == 1 = if k == n then 1 else 0 + | otherwise + = result $ foldl' update (1, 1, (1 - p)^n, (1 - p)^n) [1..k] + where update (!bc, !pj, !pnj, !r) !j = + let bc' = bc * (n - j + 1) `div` j + pj' = pj * p + pnj' = pnj / (1 - p) + r' = r + (fromIntegral bc') * pj' * pnj' + in (bc', pj', pnj', r') + result (_, _, _, r) = r + +-- | Exact Discrete Uniform distribution. +data ExactDiscreteUniformDistr = ExactDU Integer Integer + deriving(Show) + +instance ExactDiscreteDistr ExactDiscreteUniformDistr where + exactProb (ExactDU lower upper) k + | k < lower || k > upper = 0 + | otherwise = 1 % (upper - lower + 1) + exactCumulative (ExactDU lower upper) k + | k < lower = 0 + | k > upper = 1 + | otherwise = + let d = (k - lower + 1) + in d % (upper - lower + 1) + +-- | Geometric distribution. +data ExactGeometricDistr = ExactGeom (Ratio Integer) + deriving(Show) + +instance ExactDiscreteDistr ExactGeometricDistr where + exactProb (ExactGeom p) k + | k < 1 = 0 + | otherwise = (1 - p)^(k - 1) * p + + exactCumulative (ExactGeom p) k = 1 - (1 - p)^k + +-- | Hypergeometric distribution. +-- +-- Parameters are /K/, /N/ and /n/, where: +-- - /N/ is the total sample space size. +-- - /K/ is number of "good" objects among /N/. +-- - /n/ is the number of draws without replacement. +data ExactHypergeomDistr = ExactHG Integer Integer Integer + deriving(Show) + +instance ExactDiscreteDistr ExactHypergeomDistr where + exactProb (ExactHG nK nN n) k + | k < 0 = 0 + | k > n || k > nN = 0 + | otherwise = + exactChoose nK' k * exactChoose (nN' - nK') (n - k) + / exactChoose nN' n + where nN' = fromIntegral nN + nK' = fromIntegral nK + + exactCumulative d k = sum [ exactProb d i | i <- [0..k] ] + +---------------------------------------------------------------- +-- +-- TestCase construction. +-- +-- Contains the TestCase data type which encapsulates an instance of an +-- exact distribution together with an evaluation point. +-- +-- Then in contains the QC.Arbitrary implementations for TestCases of +-- the different exact distributions. As a general rule, we try the +-- sampling to be relatively efficient, i.e., we only want to sample +-- valid distribution parameters. The evaluation points are sampled +-- such that most points are within the support of the distribution. +-- +---------------------------------------------------------------- + +-- Divisor to compute a rational number from an integer. +-- +-- We want input parameters to be exactly representable as +-- Double values. This is so that the production distribution does not +-- mismatch the exact one simply because the input values don't exactly +-- match. (This can happen if the derivative of the distribution +-- function is large.) For this reason, the gd value needs to be a +-- power of 2, and <= 2^53, since the mantissa of a Double is 53 bits. +-- +-- A value of 2^53 gives the most accurate and diverse tests, but the +-- cost is increased running times, as the computed numerators and +-- denominators will become quite large. +gd :: Integer +gd = 2^(16 :: Int) + +-- TestCase +-- +-- Combination of an exact distribution together with an evaluation point. +data TestCase a = TestCase a Integer deriving (Show) + +instance QC.Arbitrary (TestCase ExactBinomialDistr) where + arbitrary = do + -- This somewhat odd sampling of /n/ is done so that lower + -- values (<1000) are more often represented as the larger ones. + n <- (*) <$> chooseInteger (1,1000) <*> chooseInteger(1,2) + p <- (% gd) <$> chooseInteger (0, gd) + k <- chooseInteger (-1, n + 1) + return $ TestCase (ExactBD n p) k + shrink _ = [] + +instance QC.Arbitrary (TestCase ExactDiscreteUniformDistr) where + arbitrary = do + a <- chooseInteger (-1000, 1000) + sz <- chooseInteger (1, 1000) + let b = a + sz + k <- chooseInteger (a - 10, b + 10) + return $ TestCase (ExactDU a b) k + shrink _ = [] + +instance QC.Arbitrary (TestCase ExactGeometricDistr) where + arbitrary = do + p <- (% gd) <$> chooseInteger (1, gd) + let lim = (floor $ 100 / p) :: Integer + k <- chooseInteger (0, lim) + return $ TestCase (ExactGeom p) k + shrink _ = [] + +instance QC.Arbitrary (TestCase ExactHypergeomDistr) where + arbitrary = do + nN <- chooseInteger (1, 100) -- XXX lower bound should be 0 + nK <- chooseInteger (0, nN) + n <- chooseInteger (1, nN) -- XXX lower bound should be 0 + k <- chooseInteger (0, min n nK) + return $ TestCase (ExactHG nK nN n) k + shrink _ = [] + +---------------------------------------------------------------- +-- +-- Linking to the production distributions +-- +-- This section contains the ProductionLinkage typeclass and +-- implementation, that allows to obtain a functions for evaluating +-- the production distribution functions for a corresponding exact +-- distribution. +-- +---------------------------------------------------------------- + +class (ExactDiscreteDistr a, DiscreteDistr (ProdDistrib a) + ) => ProductionLinkage a where + type ProdDistrib a + toProd :: a -> ProdDistrib a + +instance ProductionLinkage ExactBinomialDistr where + type ProdDistrib ExactBinomialDistr = BinomialDistribution + toProd (ExactBD n p) = binomial (fromIntegral n) (fromRational p) + +instance ProductionLinkage ExactDiscreteUniformDistr where + type ProdDistrib ExactDiscreteUniformDistr = DiscreteUniform + toProd (ExactDU lower upper) = discreteUniformAB (fromIntegral lower) (fromIntegral upper) + +instance ProductionLinkage ExactGeometricDistr where + type ProdDistrib ExactGeometricDistr = GeometricDistribution + toProd (ExactGeom p) = geometric $ fromRational p + +instance ProductionLinkage ExactHypergeomDistr where + 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 -> 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) + = 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) + = 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 :: 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 @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 @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 + ] diff --git a/tests/Tests/Function.hs b/tests/Tests/Function.hs --- a/tests/Tests/Function.hs +++ b/tests/Tests/Function.hs @@ -1,14 +1,14 @@ module Tests.Function ( tests ) where import Statistics.Function -import Test.Framework -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty +import Test.Tasty.QuickCheck import Test.QuickCheck import Tests.Helpers import qualified Data.Vector.Unboxed as U -tests :: Test +tests :: TestTree tests = testGroup "S.Function" [ testProperty "Sort is sort" p_sort , testAssertion "nextHighestPowerOfTwo is OK" p_nextHighestPowerOfTwo diff --git a/tests/Tests/Helpers.hs b/tests/Tests/Helpers.hs --- a/tests/Tests/Helpers.hs +++ b/tests/Tests/Helpers.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- | Helpers for testing module Tests.Helpers ( -- * helpers T(..) , typeName + , Double01(..) + -- * IEEE 754 + , isDenorm -- * Generic QC tests , monotonicallyIncreases , monotonicallyIncreasesIEEE @@ -16,11 +20,12 @@ ) where import Data.Typeable -import Test.Framework -import Test.Framework.Providers.HUnit +import Numeric.MathFunctions.Constants (m_tiny) +import Test.Tasty +import Test.Tasty.HUnit import Test.QuickCheck -import qualified Numeric.IEEE as IEEE -import qualified Test.HUnit as HU +import qualified Numeric.IEEE as IEEE +import qualified Test.Tasty.HUnit as HU -- | Phantom typed value used to select right instance in QC tests data T a = T @@ -32,6 +37,18 @@ typeParam :: T a -> a typeParam _ = undefined +-- | Check if Double denormalized +isDenorm :: Double -> Bool +isDenorm x = let ax = abs x in ax > 0 && ax < m_tiny + +-- | Generates Doubles in range [0,1] +newtype Double01 = Double01 Double + deriving (Show) +instance Arbitrary Double01 where + arbitrary = do + (_::Int, x) <- fmap properFraction arbitrary + return $ Double01 x + ---------------------------------------------------------------- -- Generic QC ---------------------------------------------------------------- @@ -43,8 +60,8 @@ -- Check that function is nondecreasing taking rounding errors into -- account. -- --- In fact funstion is allowed to decrease less than one ulp in order --- to guard againist problems with excess precision. On x86 FPU works +-- In fact function is allowed to decrease less than one ulp in order +-- to guard against problems with excess precision. On x86 FPU works -- with 80-bit numbers but doubles are 64-bit so rounding happens -- whenever values are moved from registers to memory monotonicallyIncreasesIEEE :: (Ord a, IEEE.IEEE b) => (a -> b) -> a -> a -> Bool @@ -58,10 +75,10 @@ -- HUnit helpers ---------------------------------------------------------------- -testAssertion :: String -> Bool -> Test +testAssertion :: String -> Bool -> TestTree testAssertion str cont = testCase str $ HU.assertBool str cont -testEquality :: (Show a, Eq a) => String -> a -> a -> Test +testEquality :: (Show a, Eq a) => String -> a -> a -> TestTree testEquality msg a b = testCase msg $ HU.assertEqual msg a b unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property diff --git a/tests/Tests/KDE.hs b/tests/Tests/KDE.hs --- a/tests/Tests/KDE.hs +++ b/tests/Tests/KDE.hs @@ -3,17 +3,17 @@ tests )where -import Data.Vector.Unboxed ((!)) -import Numeric.Sum (kbn, sumVector) +import Data.Vector.Unboxed ((!)) +import Numeric.Sum (kbn, sumVector) import Statistics.Sample.KernelDensity -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Property, (==>), counterexample) -import Text.Printf (printf) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck (Property, (==>), counterexample) +import Text.Printf (printf) import qualified Data.Vector.Unboxed as U -tests :: Test +tests :: TestTree tests = testGroup "KDE" [ testProperty "integral(PDF) == 1" t_densityIsPDF ] diff --git a/tests/Tests/Math/Tables.hs b/tests/Tests/Math/Tables.hs deleted file mode 100644 --- a/tests/Tests/Math/Tables.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Tests.Math.Tables where - -tableLogGamma :: [(Double,Double)] -tableLogGamma = - [(0.000001250000000, 13.592366285131769033) - , (0.000068200000000, 9.5930266308318756785) - , (0.000246000000000, 8.3100370767447966358) - , (0.000880000000000, 7.03508133735248542) - , (0.003120000000000, 5.768129358365567505) - , (0.026700000000000, 3.6082588918892977148) - , (0.077700000000000, 2.5148371858768232556) - , (0.234000000000000, 1.3579557559432759994) - , (0.860000000000000, 0.098146578027685615897) - , (1.340000000000000, -0.11404757557207759189) - , (1.890000000000000, -0.0425116422978701336) - , (2.450000000000000, 0.25014296569217625565) - , (3.650000000000000, 1.3701041997380685178) - , (4.560000000000000, 2.5375143317949580002) - , (6.660000000000000, 5.9515377269550207018) - , (8.250000000000000, 9.0331869196051233217) - , (11.300000000000001, 15.814180681373947834) - , (25.600000000000001, 56.711261598328121636) - , (50.399999999999999, 146.12815158702164808) - , (123.299999999999997, 468.85500075897556371) - , (487.399999999999977, 2526.9846647543727158) - , (853.399999999999977, 4903.9359135978220365) - , (2923.300000000000182, 20402.93198938705973) - , (8764.299999999999272, 70798.268343590112636) - , (12630.000000000000000, 106641.77264982508495) - , (34500.000000000000000, 325976.34838781820145) - , (82340.000000000000000, 849629.79603036714252) - , (234800.000000000000000, 2668846.4390507959761) - , (834300.000000000000000, 10540830.912557534873) - , (1230000.000000000000000, 16017699.322315014899) - ] -tableIncompleteBeta :: [(Double,Double,Double,Double)] -tableIncompleteBeta = - [(2.000000000000000, 3.000000000000000, 0.030000000000000, 0.0051864299999999996862) - , (2.000000000000000, 3.000000000000000, 0.230000000000000, 0.22845923000000001313) - , (2.000000000000000, 3.000000000000000, 0.760000000000000, 0.95465728000000005249) - , (4.000000000000000, 2.300000000000000, 0.890000000000000, 0.93829812158347802864) - , (1.000000000000000, 1.000000000000000, 0.550000000000000, 0.55000000000000004441) - , (0.300000000000000, 12.199999999999999, 0.110000000000000, 0.95063000053947077639) - , (13.100000000000000, 9.800000000000001, 0.120000000000000, 1.3483109941962659385e-07) - , (13.100000000000000, 9.800000000000001, 0.420000000000000, 0.071321857831804780226) - , (13.100000000000000, 9.800000000000001, 0.920000000000000, 0.99999578339197081611) - ] diff --git a/tests/Tests/Math/gen.py b/tests/Tests/Math/gen.py deleted file mode 100644 --- a/tests/Tests/Math/gen.py +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/python -""" -""" - -from mpmath import * - -def printListLiteral(lines) : - print " [" + "\n , ".join(lines) + "\n ]" - -################################################################ -# Generate header -print "module Tests.Math.Tables where" -print - -################################################################ -## Generate table for logGamma -print "tableLogGamma :: [(Double,Double)]" -print "tableLogGamma =" - -gammaArg = [ 1.25e-6, 6.82e-5, 2.46e-4, 8.8e-4, 3.12e-3, 2.67e-2, - 7.77e-2, 0.234, 0.86, 1.34, 1.89, 2.45, - 3.65, 4.56, 6.66, 8.25, 11.3, 25.6, - 50.4, 123.3, 487.4, 853.4, 2923.3, 8764.3, - 1.263e4, 3.45e4, 8.234e4, 2.348e5, 8.343e5, 1.23e6, - ] -printListLiteral( - [ '(%.15f, %.20g)' % (x, log(gamma(x))) for x in gammaArg ] - ) - - -################################################################ -## Generate table for incompleteBeta - -print "tableIncompleteBeta :: [(Double,Double,Double,Double)]" -print "tableIncompleteBeta =" - -incompleteBetaArg = [ - (2, 3, 0.03), - (2, 3, 0.23), - (2, 3, 0.76), - (4, 2.3, 0.89), - (1, 1, 0.55), - (0.3, 12.2, 0.11), - (13.1, 9.8, 0.12), - (13.1, 9.8, 0.42), - (13.1, 9.8, 0.92), - ] -printListLiteral( - [ '(%.15f, %.15f, %.15f, %.20g)' % (p,q,x, betainc(p,q,0,x, regularized=True)) - for (p,q,x) in incompleteBetaArg - ]) diff --git a/tests/Tests/Matrix.hs b/tests/Tests/Matrix.hs --- a/tests/Tests/Matrix.hs +++ b/tests/Tests/Matrix.hs @@ -2,10 +2,9 @@ import Statistics.Matrix hiding (map) import Statistics.Matrix.Algorithms -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck -import Tests.ApproxEq (ApproxEq(..)) import Tests.Matrix.Types import qualified Data.Vector.Unboxed as U @@ -27,13 +26,24 @@ t_transpose m = U.concat (map (column n) [0..rows m-1]) === toVector m where n = transpose m -t_qr :: Matrix -> Property -t_qr a = hasNaN p .||. eql 1e-10 a p - where p = uncurry multiply (qr a) +t_qr :: Property +t_qr = property $ do + a <- do (r,c) <- arbitrary + fromMat <$> arbMatWith r c (fromIntegral <$> choose (-10, 10::Int)) + let (q,r) = qr a + a' = multiply q r + pure $ counterexample ("A = \n"++show a) + $ counterexample ("A' = \n"++show a') + $ counterexample ("Q = \n"++show q) + $ counterexample ("R = \n"++show r) + $ dimension a == dimension a' + && ( hasNaN a' + || and (zipWith (\x y -> abs (x - y) < 1e-12) (toList a) (toList a')) + ) -tests :: Test -tests = testGroup "Matrix" [ - testProperty "t_row" t_row +tests :: TestTree +tests = testGroup "Matrix" + [ testProperty "t_row" t_row , testProperty "t_column" t_column , testProperty "t_center" t_center , testProperty "t_transpose" t_transpose diff --git a/tests/Tests/Matrix/Types.hs b/tests/Tests/Matrix/Types.hs --- a/tests/Tests/Matrix/Types.hs +++ b/tests/Tests/Matrix/Types.hs @@ -6,6 +6,8 @@ Mat(..) , fromMat , toMat + , arbMat + , arbMatWith ) where import Control.Monad (join) @@ -23,7 +25,7 @@ fromMat (Mat r c xs) = fromList r c (concat xs) toMat :: Matrix -> Mat Double -toMat (Matrix r c _ v) = Mat r c . split . U.toList $ v +toMat (Matrix r c v) = Mat r c . split . U.toList $ v where split xs@(_:_) = let (h,t) = splitAt c xs in h : split t split [] = [] @@ -32,10 +34,21 @@ arbitrary = small $ join (arbMat <$> arbitrary <*> arbitrary) shrink (Mat r c xs) = Mat r c <$> shrinkFixedList (shrinkFixedList shrink) xs -arbMat :: (Arbitrary a) => Positive (Small Int) -> Positive (Small Int) - -> Gen (Mat a) -arbMat (Positive (Small r)) (Positive (Small c)) = - Mat r c <$> vectorOf r (vector c) +arbMat + :: (Arbitrary a) + => Positive (Small Int) + -> Positive (Small Int) + -> Gen (Mat a) +arbMat r c = arbMatWith r c arbitrary + +arbMatWith + :: (Arbitrary a) + => Positive (Small Int) + -> Positive (Small Int) + -> Gen a + -> Gen (Mat a) +arbMatWith (Positive (Small r)) (Positive (Small c)) genA = + Mat r c <$> vectorOf r (vectorOf c genA) instance Arbitrary Matrix where arbitrary = fromMat <$> arbitrary diff --git a/tests/Tests/NonParametric.hs b/tests/Tests/NonParametric.hs --- a/tests/Tests/NonParametric.hs +++ b/tests/Tests/NonParametric.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} -- Tests for Statistics.Test.NonParametric module Tests.NonParametric (tests) where @@ -6,16 +8,18 @@ import Statistics.Test.MannWhitneyU import Statistics.Test.KruskalWallis import Statistics.Test.WilcoxonT -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit -import Test.HUnit (assertEqual) -import Tests.ApproxEq (eq) -import Tests.Helpers (testAssertion, testEquality) +import Statistics.Types (PValue,pValue,mkPValue) + +import Test.Tasty (testGroup) +import Test.Tasty.HUnit +import Tests.ApproxEq (eq) +import Tests.Helpers (testAssertion, testEquality) import Tests.NonParametric.Table (tableKSD, tableKS2D) +import qualified Test.Tasty as Tst import qualified Data.Vector.Unboxed as U -tests :: Test +tests :: Tst.TestTree tests = testGroup "Nonparametric tests" $ concat [ mannWhitneyTests , wilcoxonSumTests @@ -27,20 +31,20 @@ ---------------------------------------------------------------- -mannWhitneyTests :: [Test] +mannWhitneyTests :: [Tst.TestTree] mannWhitneyTests = zipWith test [(0::Int)..] testData ++ [ testEquality "Mann-Whitney U Critical Values, m=1" (replicate (20*3) Nothing) - [mannWhitneyUCriticalValue (1,x) p | x <- [1..20], p <- [0.005,0.01,0.025]] + [mannWhitneyUCriticalValue (1,x) (mkPValue p) | x <- [1..20], p <- [0.005,0.01,0.025]] , testEquality "Mann-Whitney U Critical Values, m=2, p=0.025" (replicate 7 Nothing ++ map Just [0,0,0,0,1,1,1,1,1,2,2,2,2]) - [mannWhitneyUCriticalValue (2,x) 0.025 | x <- [1..20]] + [mannWhitneyUCriticalValue (2,x) (mkPValue 0.025) | x <- [1..20]] , testEquality "Mann-Whitney U Critical Values, m=6, p=0.05" (replicate 1 Nothing ++ map Just [0, 2,3,5,7,8,10,12,14,16,17,19,21,23,25,26,28,30,32]) - [mannWhitneyUCriticalValue (6,x) 0.05 | x <- [1..20]] + [mannWhitneyUCriticalValue (6,x) (mkPValue 0.05) | x <- [1..20]] , testEquality "Mann-Whitney U Critical Values, m=20, p=0.025" (replicate 1 Nothing ++ map Just [2,8,14,20,27,34,41,48,55,62,69,76,83,90,98,105,112,119,127]) - [mannWhitneyUCriticalValue (20,x) 0.025 | x <- [1..20]] + [mannWhitneyUCriticalValue (20,x) (mkPValue 0.025) | x <- [1..20]] ] where test n (a, b, c, d) @@ -49,7 +53,7 @@ assertEqual ("Mann-Whitney U Sig " ++ show n) d ss where us = mannWhitneyU (U.fromList a) (U.fromList b) - ss = mannWhitneyUSignificant TwoTailed (length a, length b) 0.05 us + ss = mannWhitneyUSignificant SamplesDiffer (length a, length b) p005 us -- List of (Sample A, Sample B, (Positive Rank, Negative Rank)) testData :: [([Double], [Double], (Double, Double), Maybe TestResult)] testData = [ ( [3,4,2,6,2,5] @@ -84,7 +88,7 @@ ) ] -wilcoxonSumTests :: [Test] +wilcoxonSumTests :: [Tst.TestTree] wilcoxonSumTests = zipWith test [(0::Int)..] testData where test n (a, b, c) = testCase "Wilcoxon Sum" @@ -101,62 +105,64 @@ ) ] -wilcoxonPairTests :: [Test] +wilcoxonPairTests :: [Tst.TestTree] wilcoxonPairTests = zipWith test [(0::Int)..] testData ++ -- Taken from the Mitic paper: [ testAssertion "Sig 16, 35" (to4dp 0.0467 $ wilcoxonMatchedPairSignificance 16 35) , testAssertion "Sig 16, 36" (to4dp 0.0523 $ wilcoxonMatchedPairSignificance 16 36) , testEquality "Wilcoxon critical values, p=0.05" (replicate 4 Nothing ++ map Just [0,2,3,5,8,10,13,17,21,25,30,35,41,47,53,60,67,75,83,91,100,110,119]) - [wilcoxonMatchedPairCriticalValue x 0.05 | x <- [1..27]] + [wilcoxonMatchedPairCriticalValue x (mkPValue 0.05) | x <- [1..27]] , testEquality "Wilcoxon critical values, p=0.025" (replicate 5 Nothing ++ map Just [0,2,3,5,8,10,13,17,21,25,29,34,40,46,52,58,65,73,81,89,98,107]) - [wilcoxonMatchedPairCriticalValue x 0.025 | x <- [1..27]] + [wilcoxonMatchedPairCriticalValue x (mkPValue 0.025) | x <- [1..27]] , testEquality "Wilcoxon critical values, p=0.01" (replicate 6 Nothing ++ map Just [0,1,3,5,7,9,12,15,19,23,27,32,37,43,49,55,62,69,76,84,92]) - [wilcoxonMatchedPairCriticalValue x 0.01 | x <- [1..27]] + [wilcoxonMatchedPairCriticalValue x (mkPValue 0.01) | x <- [1..27]] , testEquality "Wilcoxon critical values, p=0.005" (replicate 7 Nothing ++ map Just [0,1,3,5,7,9,12,15,19,23,27,32,37,42,48,54,61,68,75,83]) - [wilcoxonMatchedPairCriticalValue x 0.005 | x <- [1..27]] + [wilcoxonMatchedPairCriticalValue x (mkPValue 0.005) | x <- [1..27]] ] where test n (a, b, c) = testEquality ("Wilcoxon Paired " ++ show n) c res - where res = (wilcoxonMatchedPairSignedRank (U.fromList a) (U.fromList b)) + where res = wilcoxonMatchedPairSignedRank (U.zip (U.fromList a) (U.fromList b)) -- List of (Sample A, Sample B, (Positive Rank, Negative Rank)) - testData :: [([Double], [Double], (Double, Double))] - testData = [ ([1..10], [1..10], (0, 0 )) - , ([1..5], [6..10], (0, 5*(-3))) + testData :: [([Double], [Double], (Int,Double, Double))] + testData = [ ([1..10], [1..10], (0, 0, 0 )) + , ([1..5], [6..10], (5, 0, 5*(-3))) -- Worked example from the Internet: , ( [125,115,130,140,140,115,140,125,140,135] , [110,122,125,120,140,124,123,137,135,145] - , ( sum $ filter (> 0) [7,-3,1.5,9,0,-4,8,-6,1.5,-5] + , ( 9 + , sum $ filter (> 0) [7,-3,1.5,9,0,-4,8,-6,1.5,-5] , sum $ filter (< 0) [7,-3,1.5,9,0,-4,8,-6,1.5,-5] ) ) -- Worked examples from books/papers: , ( [2.4,1.9,2.3,1.9,2.4,2.5] , [2.0,2.1,2.0,2.0,1.8,2.0] - , (18, -3) + , (6, 18, -3) ) , ( [130,170,125,170,130,130,145,160] , [120,163,120,135,143,136,144,120] - , (27, -9) + , (8, 27, -9) ) , ( [540,580,600,680,430,740,600,690,605,520] , [760,710,1105,880,500,990,1050,640,595,520] - , (3, -42) + , (9, 3, -42) ) ] - to4dp tgt x = x >= tgt - 0.00005 && x < tgt + 0.00005 + to4dp tgt (pValue -> x) = x >= tgt - 0.00005 && x < tgt + 0.00005 ---------------------------------------------------------------- -kruskalWallisRankTests :: [Test] +kruskalWallisRankTests :: [Tst.TestTree] kruskalWallisRankTests = zipWith test [(0::Int)..] testData where test n (a, b) = testCase "Kruskal-Wallis Ranking" $ assertEqual ("Kruskal-Wallis " ++ show n) (map U.fromList b) (kruskalWallisRank $ map U.fromList a) + testData :: [([[Int]],[[Double]])] testData = [ ( [ [68,93,123,83,108,122] , [119,116,101,103,113,84] , [70,68,54,73,81,68] @@ -170,18 +176,19 @@ ) ] -kruskalWallisTests :: [Test] +kruskalWallisTests :: [Tst.TestTree] kruskalWallisTests = zipWith test [(0::Int)..] testData where test n (a, b, c) = testCase "Kruskal-Wallis" $ do assertEqual ("Kruskal-Wallis " ++ show n) (round100 b) (round100 kw) assertEqual ("Kruskal-Wallis Sig " ++ show n) c kwt where - kw = kruskalWallis $ map U.fromList a - kwt = kruskalWallisTest 0.05 $ map U.fromList a + kw = kruskalWallis $ map U.fromList a + kwt = isSignificant p005 `fmap` kruskalWallisTest (map U.fromList a) round100 :: Double -> Integer round100 = round . (*100) + testData :: [([[Double]], Double, Maybe TestResult)] testData = [ ( [ [68,93,123,83,108,122] , [119,116,101,103,113,84] , [70,68,54,73,81,68] @@ -220,7 +227,7 @@ ---------------------------------------------------------------- -kolmogorovSmirnovDTest :: [Test] +kolmogorovSmirnovDTest :: [Tst.TestTree] kolmogorovSmirnovDTest = [ testAssertion "K-S D statistics" $ and [ eq 1e-6 (kolmogorovSmirnovD standard (toU sample)) reference @@ -291,3 +298,6 @@ , (0.392 , 30, 0.99988478803318 ) , (0.09 , 100, 0.629367974413669 ) ] + +p005 :: PValue Double +p005 = mkPValue 0.05 diff --git a/tests/Tests/Orphanage.hs b/tests/Tests/Orphanage.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Orphanage.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Orphan instances for common data types +module Tests.Orphanage where + +import Control.Applicative +import Statistics.Distribution.Beta (BetaDistribution, betaDistr) +import Statistics.Distribution.Binomial (BinomialDistribution, binomial) +import Statistics.Distribution.CauchyLorentz +import Statistics.Distribution.ChiSquared (ChiSquared, chiSquared) +import Statistics.Distribution.Exponential (ExponentialDistribution, exponential) +import Statistics.Distribution.FDistribution (FDistribution, fDistribution) +import Statistics.Distribution.Gamma (GammaDistribution, gammaDistr) +import Statistics.Distribution.Geometric +import Statistics.Distribution.Hypergeometric +import Statistics.Distribution.Laplace (LaplaceDistribution, laplace) +import Statistics.Distribution.Lognormal (LognormalDistribution, lognormalDistr) +import Statistics.Distribution.NegativeBinomial (NegativeBinomialDistribution, negativeBinomial) +import Statistics.Distribution.Normal (NormalDistribution, normalDistr) +import Statistics.Distribution.Poisson (PoissonDistribution, poisson) +import Statistics.Distribution.StudentT +import Statistics.Distribution.Transform (LinearTransform, scaleAround) +import Statistics.Distribution.Uniform (UniformDistribution, uniformDistr) +import Statistics.Distribution.Weibull (WeibullDistribution, weibullDistr) +import Statistics.Distribution.DiscreteUniform (DiscreteUniform, discreteUniformAB) +import Statistics.Types + +import Test.QuickCheck as QC + + +---------------------------------------------------------------- +-- Arbitrary instances for distributions +---------------------------------------------------------------- + +instance QC.Arbitrary BinomialDistribution where + arbitrary = binomial <$> QC.choose (1,100) <*> QC.choose (0,1) +instance QC.Arbitrary ExponentialDistribution where + arbitrary = exponential <$> QC.choose (0,100) +instance QC.Arbitrary LaplaceDistribution where + arbitrary = laplace <$> QC.choose (-10,10) <*> QC.choose (0, 2) +instance QC.Arbitrary GammaDistribution where + arbitrary = gammaDistr <$> QC.choose (0.1,100) <*> QC.choose (0.1,100) +instance QC.Arbitrary BetaDistribution where + arbitrary = betaDistr <$> QC.choose (1e-3,10) <*> QC.choose (1e-3,10) +instance QC.Arbitrary GeometricDistribution where + arbitrary = geometric <$> QC.choose (1e-10,1) +instance QC.Arbitrary GeometricDistribution0 where + arbitrary = geometric0 <$> QC.choose (1e-10,1) +instance QC.Arbitrary HypergeometricDistribution where + arbitrary = do l <- QC.choose (1,20) + m <- QC.choose (0,l) + k <- QC.choose (1,l) + return $ hypergeometric m l k +instance QC.Arbitrary LognormalDistribution where + -- can't choose sigma too big, otherwise goes outside of double-float limit + arbitrary = lognormalDistr <$> QC.choose (-100,100) <*> QC.choose (1e-10, 20) +instance QC.Arbitrary NegativeBinomialDistribution where + arbitrary = negativeBinomial <$> QC.choose (1,100) <*> QC.choose (1e-10,1) +instance QC.Arbitrary NormalDistribution where + arbitrary = normalDistr <$> QC.choose (-100,100) <*> QC.choose (1e-3, 1e3) +instance QC.Arbitrary PoissonDistribution where + arbitrary = poisson <$> QC.choose (0,1) +instance QC.Arbitrary ChiSquared where + arbitrary = chiSquared <$> QC.choose (1,100) +instance QC.Arbitrary UniformDistribution where + arbitrary = do a <- QC.arbitrary + b <- QC.arbitrary `suchThat` (/= a) + return $ uniformDistr a b +instance QC.Arbitrary WeibullDistribution where + arbitrary = weibullDistr <$> QC.choose (1e-3,1e3) <*> QC.choose (1e-3, 1e3) +instance QC.Arbitrary CauchyDistribution where + arbitrary = cauchyDistribution + <$> arbitrary + <*> ((abs <$> arbitrary) `suchThat` (> 0)) +instance QC.Arbitrary StudentT where + arbitrary = studentT <$> ((abs <$> arbitrary) `suchThat` (>0)) +instance QC.Arbitrary d => QC.Arbitrary (LinearTransform d) where + arbitrary = do + m <- QC.choose (-10,10) + s <- QC.choose (1e-1,1e1) + d <- arbitrary + return $ scaleAround m s d +instance QC.Arbitrary FDistribution where + arbitrary = fDistribution + <$> ((abs <$> arbitrary) `suchThat` (>0)) + <*> ((abs <$> arbitrary) `suchThat` (>0)) + + +instance (Arbitrary a, Ord a, RealFrac a) => Arbitrary (PValue a) where + arbitrary = do + (_::Int,x) <- properFraction <$> arbitrary + return $ mkPValue $ abs x + +instance (Arbitrary a, Ord a, RealFrac a) => Arbitrary (CL a) where + arbitrary = do + (_::Int,x) <- properFraction <$> arbitrary + return $ mkCLFromSignificance $ abs x + +instance Arbitrary a => Arbitrary (NormalErr a) where + arbitrary = NormalErr <$> arbitrary + +instance Arbitrary a => Arbitrary (ConfInt a) where + arbitrary = liftA3 ConfInt arbitrary arbitrary arbitrary + +instance (Arbitrary (e a), Arbitrary a) => Arbitrary (Estimate e a) where + arbitrary = liftA2 Estimate arbitrary arbitrary + +instance (Arbitrary a) => Arbitrary (UpperLimit a) where + arbitrary = liftA2 UpperLimit arbitrary arbitrary + +instance (Arbitrary a) => Arbitrary (LowerLimit a) where + arbitrary = liftA2 LowerLimit arbitrary arbitrary + +instance QC.Arbitrary DiscreteUniform where + arbitrary = discreteUniformAB <$> QC.choose (1,1000) <*> QC.choose(1,1000) diff --git a/tests/Tests/Parametric.hs b/tests/Tests/Parametric.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Parametric.hs @@ -0,0 +1,224 @@ +module Tests.Parametric (tests) where + +import Data.Maybe (fromJust) +import Statistics.Test.StudentT +import Statistics.Types +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.HUnit (testCase, assertBool) +import Tests.Helpers (testEquality) +import qualified Test.Tasty as Tst + +import Statistics.Test.Levene +import Statistics.Test.Bartlett + + +tests :: Tst.TestTree +tests = testGroup "Parametric tests" [studentTTests, bartlettTests, leveneTests] + +-- 2 samples x 20 obs data +-- +-- Both samples are samples from normal distributions with the same variance (= 1.0), +-- but their means are different (0.0 and 0.5, respectively). +-- +-- You can reproduce the data with R (3.1.0) as follows: +-- set.seed(0) +-- sample1 = rnorm(20) +-- sample2 = rnorm(20, 0.5) +-- student = t.test(sample1, sample2, var.equal=T) +-- welch = t.test(sample1, sample2) +-- paired = t.test(sample1, sample2, paired=T) +sample1, sample2 :: U.Vector Double +sample1 = U.fromList [ + 1.262954284880793e+00, + -3.262333607056494e-01, + 1.329799262922501e+00, + 1.272429321429405e+00, + 4.146414344564082e-01, + -1.539950041903710e+00, + -9.285670347135381e-01, + -2.947204467905602e-01, + -5.767172747536955e-03, + 2.404653388857951e+00, + 7.635934611404596e-01, + -7.990092489893682e-01, + -1.147657009236351e+00, + -2.894615736882233e-01, + -2.992151178973161e-01, + -4.115108327950670e-01, + 2.522234481561323e-01, + -8.919211272845686e-01, + 4.356832993557186e-01, + -1.237538421929958e+00] +sample2 = U.fromList [ + 2.757321147216907e-01, + 8.773956459817011e-01, + 6.333363608148415e-01, + 1.304189509744908e+00, + 4.428932256161913e-01, + 1.003607972233726e+00, + 1.585769362145687e+00, + -1.909538396968303e-01, + -7.845993538721883e-01, + 5.467261721883520e-01, + 2.642934435604988e-01, + -4.288825501025439e-02, + 6.668968254321778e-02, + -1.494716467962331e-01, + 1.226750747385451e+00, + 1.651911754087200e+00, + 1.492160365445798e+00, + 7.048689050811874e-02, + 1.738304100853380e+00, + 2.206537181457307e-01] + + +testTTest :: String + -> PValue Double + -> Test d + -> [Tst.TestTree] +testTTest name pVal test = + [ testEquality name (isSignificant pVal test) NotSignificant + , testEquality name (isSignificant (mkPValue $ pValue pVal + 1e-5) test) + Significant + ] + +studentTTests :: Tst.TestTree +studentTTests = testGroup "StudentT test" $ concat + [ -- R: t.test(sample1, sample2, alt="two.sided", var.equal=T) + testTTest "two-sample t-test SamplesDiffer Student" + (mkPValue 0.03410) (fromJust $ studentTTest SamplesDiffer sample1 sample2) + -- R: t.test(sample1, sample2, alt="two.sided", var.equal=F) + , testTTest "two-sample t-test SamplesDiffer Welch" + (mkPValue 0.03483) (fromJust $ welchTTest SamplesDiffer sample1 sample2) + -- R: t.test(sample1, sample2, alt="two.sided", paired=T) + , testTTest "two-sample t-test SamplesDiffer Paired" + (mkPValue 0.03411) (fromJust $ pairedTTest SamplesDiffer sample12) + -- R: t.test(sample1, sample2, alt="less", var.equal=T) + , testTTest "two-sample t-test BGreater Student" + (mkPValue 0.01705) (fromJust $ studentTTest BGreater sample1 sample2) + -- R: t.test(sample1, sample2, alt="less", var.equal=F) + , testTTest "two-sample t-test BGreater Welch" + (mkPValue 0.01741) (fromJust $ welchTTest BGreater sample1 sample2) + -- R: t.test(sample1, sample2, alt="less", paired=F) + , testTTest "two-sample t-test BGreater Paired" + (mkPValue 0.01705) (fromJust $ pairedTTest BGreater sample12) + ] + where sample12 = U.zip sample1 sample2 + + +------------------------------------------------------------ +-- Bartlett's Test +------------------------------------------------------------ + +bartlettTests :: TestTree +bartlettTests = testGroup "Bartlett's test" + [ testCase "a,b,c" $ testBartlettTest [a,b,c] 1.8027132567760222 0.40601846976301237 + , testCase "a,b" $ testBartlettTest [a,b] 0.005221063776321886 0.9423974408021293 + , testCase "a,c" $ testBartlettTest [a,c] 1.1531619271845452 0.2828882244527482 + , testCase "a,a" $ testBartlettTest [a,a] 0.0 1.0 + ] + where + a = U.fromList [9.88, 9.12, 9.04, 8.98, 9.00, 9.08, 9.01, 8.85, 9.06, 8.99] + b = U.fromList [8.88, 8.95, 9.29, 9.44, 9.15, 9.58, 9.36, 9.18, 8.67, 9.05] + c = U.fromList [8.95, 8.12, 8.95, 8.85, 8.03, 8.84, 8.07, 8.98, 8.86, 8.98] + +testBartlettTest + :: [U.Vector Double] + -> Double + -> Double + -> IO () +testBartlettTest samples w p = do + r <- case bartlettTest samples of + Left _ -> error "Bartlett's test failed" + Right r -> pure r + approxEqual "W" 1e-9 (testStatistics r) w + approxEqual "p" 1e-9 (pValue $ testSignificance r) p + +------------------------------------------------------------ +-- Levene's Test (Trimmed Mean) +------------------------------------------------------------ + +leveneTests :: TestTree +leveneTests = testGroup "Levene test" + -- Statistics' value and p-values are computed using + [ testCase "a,b,c Mean" $ testLeveneTest [a,b,c] Mean 7.905194483442054 0.001983795817472731 + , testCase "a,b Mean" $ testLeveneTest [a,b] Mean 8.83873787256358 0.008149720958328811 + , testCase "a,a Mean" $ testLeveneTest [a,a] Mean 0.0 1.0 + , testCase "a,b,c Median" $ testLeveneTest [a,b,c] Median 7.584952754501659 0.002431505967249681 + , testCase "a,b Median" $ testLeveneTest [a,b] Median 8.461374333228711 0.009364737715584399 + , testCase "aL,bL Mean" $ testLeveneTest [aL,bL] Mean 5.84424549939465 0.01653410652558999 + , testCase "aL,bL Trimmed" $ testLeveneTest [aL,bL] (Trimmed 0.05) 8.368311226366314 0.004294953946529551 + ] + where + a = V.fromList [8.88, 9.12, 9.04, 8.98, 9.00, 9.08, 9.01, 8.85, 9.06, 8.99] + b = V.fromList [8.88, 8.95, 9.29, 9.44, 9.15, 9.58, 8.36, 9.18, 8.67, 9.05] + c = V.fromList [8.95, 9.12, 8.95, 8.85, 9.03, 8.84, 9.07, 8.98, 8.86, 8.98] + -- Large samples for testing trimmed + aL = V.fromList [ + -0.18919252, -1.62837673, 5.21332355, -0.00962043, -0.28417847, + -0.88128233, 1.49698436, 6.1780359 , -1.22301348, 3.34598245, + 5.33227264, -0.88732069, 0.14487346, 2.61060215, 4.22033907, + 2.53139215, -0.72131061, 0.53063607, -0.60510374, -0.73230842, + 1.54037043, -2.81103963, 3.40763063, 0.49005324, 2.13085513, + 5.68650547, 4.16397279, -0.17325097, 1.12664972, 4.23297516, + 4.15943436, -1.01452078, 2.40391646, 0.83019962, 0.29665879, + -3.83031046, -1.98576933, 1.5356527 , 1.30773365, 0.292818 , + 2.45877828, 1.06482289, -0.63241873, 1.58465379, 1.96577614, + 2.25791943, 4.13769848, -2.38595767, -0.65801423, -2.54007791, + 3.17428087, 4.32096964, 0.92240335, -2.38101319, 1.35692587, + 1.48279101, -0.04438309, 0.50296642, 2.08261495, 1.33181215, + -1.95427198, 4.95406809, 1.51294898, -2.68536129, -0.2441218 , + 2.41142613, 4.71051493, 2.66618697, 1.12668301, -0.25732583, + 1.25021838, -1.27523641, 5.01638744, 3.38864442, 0.17979744, + -0.88481645, 3.89346357, -0.51512217, -1.60542888, 0.88378679, + -2.12962732, -1.35989539, 5.09215112, -1.37442481, 0.83578405, + 0.13829571, 1.25171481, 3.60552158, -3.24051591, -0.44301834, + 0.78253445, 1.76098254, 1.79677434, -0.19010505, 3.07640466, + 3.02853882, 1.24849063, 4.84505382, 6.82274999, 2.24063474] + bL = V.fromList [ + 2.15584101, -2.74876744, -0.82231894, 1.97518087, 2.59280595, + 1.28703417, 2.40450278, 1.9761031 , 2.35186598, 1.15611047, + 2.26709318, 1.2832138 , -2.1486074 , 0.27563011, -0.51816861, + 0.89658424, 3.27069545, 1.72846646, 3.84454277, 5.58301459, + -0.40878188, 3.41602853, 1.1281526 , 0.9665913 , 0.76567084, + 1.69522855, 1.69133014, 0.70529264, 2.65243202, -1.0088019 , + -0.62431026, 3.76667396, 3.66225181, 0.73217579, 0.04478736, + 0.4169833 , 0.77065631, -1.31484093, 1.23858618, -0.08339456, + 3.14154286, 1.84358218, -0.53511423, -3.4919477 , 0.24076997, + 3.59381684, 1.99497806, 2.95499775, 1.67157731, 0.0214764 , + 3.32161612, -2.64762427, 0.06486472, 0.19653897, 1.34954235, + 1.18568747, -0.54434597, -3.35544223, 1.41933109, 0.95100195, + 2.7182116 , 1.1334068 , -0.95297806, -0.05421818, 1.42248799, + -3.96201277, -3.21309254, -0.21209211, 0.9689551 , 0.13526401, + -0.88656198, 0.41331783, -3.18766064, 4.34948246, 1.35656384, + 0.41920101, -0.46578994, 1.55181583, 2.43937014, 2.49040644, + 4.10505494, 1.68856296, 1.31503895, 0.41123368, 0.73242999, + 0.2804349 , -1.83494592, -0.31073195, 2.61185513, 2.91645094, + 1.26097638, 2.64197134, 3.88931972, 0.03783002, 2.55209729, + 3.46869549, 0.96348003, 2.27658242, 2.7613171 , -0.1372434 ] + + +testLeveneTest + :: [V.Vector Double] + -> Center + -> Double + -> Double + -> IO () +testLeveneTest samples center w p = do + r <- case levenesTest center samples of + Left _ -> error "Levene's test failed" + Right r -> pure r + approxEqual "W" 1e-9 (testStatistics r) w + approxEqual "p" 1e-9 (pValue $ testSignificance r) p + + +---------------------------------------------------------------- + +approxEqual :: String -> Double -> Double -> Double -> IO () +approxEqual name epsilon actual expected = + assertBool (name ++ ": expected ≈ " ++ show expected ++ ", got " ++ show actual) + (diff < epsilon) + where + diff = abs (actual - expected) diff --git a/tests/Tests/Quantile.hs b/tests/Tests/Quantile.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Quantile.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ViewPatterns #-} +-- | +-- Tests for quantile +module Tests.Quantile (tests) where + +import Control.Exception +import qualified Data.Vector.Unboxed as U +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck hiding (sample) +import Numeric.MathFunctions.Comparison (ulpDelta,ulpDistance) +import Statistics.Quantile + +tests :: TestTree +tests = testGroup "Quantiles" + [ testCase "R alg. 4" $ compareWithR cadpw (0.00, 0.50, 2.50, 8.25, 10.00) + , testCase "R alg. 5" $ compareWithR hazen (0.00, 1.00, 5.00, 9.00, 10.00) + , testCase "R alg. 6" $ compareWithR spss (0.00, 0.75, 5.00, 9.25, 10.00) + , testCase "R alg. 7" $ compareWithR s (0.000, 1.375, 5.000, 8.625,10.00) + , testCase "R alg. 8" $ compareWithR medianUnbiased + (0.0, 0.9166666666666667, 5.000000000000003, 9.083333333333334, 10.0) + , testCase "R alg. 9" $ compareWithR normalUnbiased + (0.0000, 0.9375, 5.0000, 9.0625, 10.0000) + , testProperty "alg 7." propWeigtedAverage + -- Test failures + , testCase "weightedAvg should throw errors" $ do + let xs = U.fromList [1,2,3] + xs0 = U.fromList [] + shouldError "Empty sample" $ weightedAvg 1 4 xs0 + shouldError "N=0" $ weightedAvg 1 0 xs + shouldError "N=1" $ weightedAvg 1 1 xs + shouldError "k<0" $ weightedAvg (-1) 4 xs + shouldError "k>N" $ weightedAvg 5 4 xs + , testCase "quantile should throw errors" $ do + let xs = U.fromList [1,2,3] + xs0 = U.fromList [] + shouldError "Empty xs" $ quantile s 1 4 xs0 + shouldError "N=0" $ quantile s 1 0 xs + shouldError "N=1" $ quantile s 1 1 xs + shouldError "k<0" $ quantile s (-1) 4 xs + shouldError "k>N" $ quantile s 5 4 xs + -- + , testProperty "quantiles are OK" propQuantiles + , testProperty "quantilesVec are OK" propQuantilesVec + ] + +sample :: U.Vector Double +sample = U.fromList [0, 1, 2.5, 7.5, 9, 10] + +-- Compare quantiles implementation with reference R implementation +compareWithR :: ContParam -> (Double,Double,Double,Double,Double) -> Assertion +compareWithR p (q0,q1,q2,q3,q4) = do + assertEqual "Q 0" q0 $ quantile p 0 4 sample + assertEqual "Q 1" q1 $ quantile p 1 4 sample + assertEqual "Q 2" q2 $ quantile p 2 4 sample + assertEqual "Q 3" q3 $ quantile p 3 4 sample + assertEqual "Q 4" q4 $ quantile p 4 4 sample + +propWeigtedAverage :: Positive Int -> Positive Int -> Property +propWeigtedAverage (Positive k) (Positive q) = + (q >= 2 && k <= q) ==> let q1 = weightedAvg k q sample + q2 = quantile s k q sample + in counterexample ("weightedAvg = " ++ show q1) + $ counterexample ("quantile = " ++ show q2) + $ counterexample ("delta in ulps = " ++ show (ulpDelta q1 q2)) + $ ulpDistance q1 q2 <= 16 + +propQuantiles :: Positive Int -> Int -> Int -> NonEmptyList Double -> Property +propQuantiles (Positive n) + ((`mod` n) -> k1) + ((`mod` n) -> k2) + (NonEmpty xs) + = n >= 2 + ==> [x1,x2] == quantiles s [k1,k2] n rndXs + where + rndXs = U.fromList xs + x1 = quantile s k1 n rndXs + x2 = quantile s k2 n rndXs + +propQuantilesVec :: Positive Int -> Int -> Int -> NonEmptyList Double -> Property +propQuantilesVec (Positive n) + ((`mod` n) -> k1) + ((`mod` n) -> k2) + (NonEmpty xs) + = n >= 2 + ==> U.fromList [x1,x2] == quantilesVec s (U.fromList [k1,k2]) n rndXs + where + rndXs = U.fromList xs + x1 = quantile s k1 n rndXs + x2 = quantile s k2 n rndXs + + +shouldError :: String -> a -> Assertion +shouldError nm x = do + r <- try (evaluate x) + case r of + Left (ErrorCall{}) -> return () + Right _ -> assertFailure ("Should call error: " ++ nm) diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Serialization.hs @@ -0,0 +1,96 @@ +-- | +-- Tests for data serialization instances +module Tests.Serialization where + +import Data.Binary (Binary,decode,encode) +import Data.Aeson (FromJSON,ToJSON,Result(..),toJSON,fromJSON) +import Data.Typeable + +import Statistics.Distribution.Beta (BetaDistribution) +import Statistics.Distribution.Binomial (BinomialDistribution) +import Statistics.Distribution.CauchyLorentz +import Statistics.Distribution.ChiSquared (ChiSquared) +import Statistics.Distribution.Exponential (ExponentialDistribution) +import Statistics.Distribution.FDistribution (FDistribution) +import Statistics.Distribution.Gamma (GammaDistribution) +import Statistics.Distribution.Geometric +import Statistics.Distribution.Hypergeometric +import Statistics.Distribution.Laplace (LaplaceDistribution) +import Statistics.Distribution.Lognormal (LognormalDistribution) +import Statistics.Distribution.NegativeBinomial (NegativeBinomialDistribution) +import Statistics.Distribution.Normal (NormalDistribution) +import Statistics.Distribution.Poisson (PoissonDistribution) +import Statistics.Distribution.StudentT +import Statistics.Distribution.Transform (LinearTransform) +import Statistics.Distribution.Uniform (UniformDistribution) +import Statistics.Distribution.Weibull (WeibullDistribution) +import Statistics.Types + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck as QC + +import Tests.Helpers +import Tests.Orphanage () + + +tests :: TestTree +tests = testGroup "Test for data serialization" + [ serializationTests (T :: T (CL Float)) + , serializationTests (T :: T (CL Double)) + , serializationTests (T :: T (PValue Float)) + , serializationTests (T :: T (PValue Double)) + , serializationTests (T :: T (NormalErr Double)) + , serializationTests (T :: T (ConfInt Double)) + , serializationTests' "T (Estimate NormalErr Double)" (T :: T (Estimate NormalErr Double)) + , serializationTests' "T (Estimate ConfInt Double)" (T :: T (Estimate ConfInt Double)) + , serializationTests (T :: T (LowerLimit Double)) + , serializationTests (T :: T (UpperLimit Double)) + -- Distributions + , serializationTests (T :: T BetaDistribution ) + , serializationTests (T :: T CauchyDistribution ) + , serializationTests (T :: T ChiSquared ) + , serializationTests (T :: T ExponentialDistribution ) + , serializationTests (T :: T GammaDistribution ) + , serializationTests (T :: T LaplaceDistribution ) + , serializationTests (T :: T LognormalDistribution ) + , serializationTests (T :: T NegativeBinomialDistribution ) + , serializationTests (T :: T NormalDistribution ) + , serializationTests (T :: T UniformDistribution ) + , serializationTests (T :: T WeibullDistribution ) + , serializationTests (T :: T StudentT ) + , serializationTests (T :: T (LinearTransform NormalDistribution)) + , serializationTests (T :: T FDistribution ) + , serializationTests (T :: T BinomialDistribution ) + , serializationTests (T :: T GeometricDistribution ) + , serializationTests (T :: T GeometricDistribution0 ) + , serializationTests (T :: T HypergeometricDistribution ) + , serializationTests (T :: T PoissonDistribution ) + ] + + +serializationTests + :: (Eq a, Typeable a, Binary a, Show a, Read a, ToJSON a, FromJSON a, Arbitrary a) + => T a -> TestTree +serializationTests t = serializationTests' (typeName t) t + +-- Not all types are Typeable, unfortunately +serializationTests' + :: (Eq a, Binary a, Show a, Read a, ToJSON a, FromJSON a, Arbitrary a) + => String -> T a -> TestTree +serializationTests' name t = testGroup ("Tests for: " ++ name) + [ testProperty "show/read" (p_showRead t) + , testProperty "binary" (p_binary t) + , testProperty "aeson" (p_aeson t) + ] + + + +p_binary :: (Eq a, Binary a) => T a -> a -> Bool +p_binary _ a = a == (decode . encode) a + +p_showRead :: (Eq a, Read a, Show a) => T a -> a -> Bool +p_showRead _ a = a == (read . show) a + +p_aeson :: (Eq a, ToJSON a, FromJSON a) => T a -> a -> Bool +p_aeson _ a = Data.Aeson.Success a == (fromJSON . toJSON) a diff --git a/tests/Tests/Transform.hs b/tests/Tests/Transform.hs --- a/tests/Tests/Transform.hs +++ b/tests/Tests/Transform.hs @@ -8,13 +8,13 @@ import Data.Bits ((.&.), shiftL) import Data.Complex (Complex((:+))) -import Data.Functor ((<$>)) import Numeric.Sum (kbn, sumVector) import Statistics.Function (within) import Statistics.Transform (CD, dct, fft, idct, ifft) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Positive(..), Arbitrary(..), Gen, choose, vectorOf, counterexample) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck ( Positive(..), Arbitrary(..), Blind(..), (==>), Gen + , choose, vectorOf, counterexample, forAll) import Test.QuickCheck.Property (Property(..)) import Tests.Helpers (testAssertion) import Text.Printf (printf) @@ -22,7 +22,7 @@ import qualified Data.Vector.Unboxed as U -tests :: Test +tests :: TestTree tests = testGroup "fft" [ testProperty "t_impulse" t_impulse , testProperty "t_impulse_offset" t_impulse_offset @@ -68,8 +68,11 @@ -- If a real-valued impulse is offset from the beginning of an -- otherwise zero vector, the sum-of-squares of each component of the -- result should equal the square of the impulse. -t_impulse_offset :: Double -> Positive Int -> Positive Int -> Bool -t_impulse_offset k (Positive x) (Positive m) = U.all ok (fft v) +t_impulse_offset :: Double -> Positive Int -> Positive Int -> Property +t_impulse_offset k (Positive x) (Positive m) + -- For numbers smaller than 1e-162 their square underflows and test + -- fails spuriously + = abs k >= 1e-100 ==> U.all ok (fft v) where v = G.concat [G.replicate xn 0, G.singleton i, G.replicate (n-xn-1) 0] ok (re :+ im) = within ulps (re*re + im*im) (k*k) i = k :+ 0 @@ -83,15 +86,14 @@ -- whole are approximate equal. t_fftInverse :: (HasNorm (U.Vector a), U.Unbox a, Num a, Show a, Arbitrary a) => (U.Vector a -> U.Vector a) -> Property -t_fftInverse roundtrip = MkProperty $ do - x <- genFftVector - let n = G.length x - x' = roundtrip x - d = G.zipWith (-) x x' - nd = vectorNorm d - nx = vectorNorm x - unProperty - $ counterexample "Original vector" +t_fftInverse roundtrip = + forAll (Blind <$> genFftVector) $ \(Blind x) -> + let n = G.length x + x' = roundtrip x + d = G.zipWith (-) x x' + nd = vectorNorm d + nx = vectorNorm x + in counterexample "Original vector" $ counterexample (show x ) $ counterexample "Transformed one" $ counterexample (show x') @@ -100,13 +102,13 @@ $ nd <= 3e-14 * nx -- Test discrete cosine transform -testDCT :: [Double] -> [Double] -> Test +testDCT :: [Double] -> [Double] -> TestTree testDCT (U.fromList -> vec) (U.fromList -> res) = testAssertion ("DCT test for " ++ show vec) $ vecEqual 3e-14 (dct vec) res -- Test inverse discrete cosine transform -testIDCT :: [Double] -> [Double] -> Test +testIDCT :: [Double] -> [Double] -> TestTree testIDCT (U.fromList -> vec) (U.fromList -> res) = testAssertion ("IDCT test for " ++ show vec) $ vecEqual 3e-14 (idct vec) res diff --git a/tests/doctest.hs b/tests/doctest.hs new file mode 100644 --- /dev/null +++ b/tests/doctest.hs @@ -0,0 +1,5 @@ +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["-XHaskell2010", "Statistics"] + diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,18 +1,26 @@ -import Test.Framework (defaultMain) -import qualified Tests.Distribution as Distribution -import qualified Tests.Function as Function -import qualified Tests.KDE as KDE -import qualified Tests.Matrix as Matrix -import qualified Tests.NonParametric as NonParametric -import qualified Tests.Transform as Transform -import qualified Tests.Correlation as Correlation +import Test.Tasty (defaultMain,testGroup) +import qualified Tests.Distribution +import qualified Tests.Function +import qualified Tests.KDE +import qualified Tests.Matrix +import qualified Tests.NonParametric +import qualified Tests.Parametric +import qualified Tests.Transform +import qualified Tests.Correlation +import qualified Tests.Serialization +import qualified Tests.Quantile + main :: IO () -main = defaultMain [ Distribution.tests - , Function.tests - , KDE.tests - , Matrix.tests - , NonParametric.tests - , Transform.tests - , Correlation.tests - ] +main = defaultMain $ testGroup "statistics" + [ Tests.Distribution.tests + , Tests.Function.tests + , Tests.KDE.tests + , Tests.Matrix.tests + , Tests.NonParametric.tests + , Tests.Parametric.tests + , Tests.Transform.tests + , Tests.Correlation.tests + , Tests.Serialization.tests + , Tests.Quantile.tests + ]