math-functions-0.1.5.2/0000755000000000000000000000000012305441036013000 5ustar0000000000000000math-functions-0.1.5.2/ChangeLog0000644000000000000000000000075412305441036014560 0ustar0000000000000000-*- text -*- Changes in 0.1.5 * Numeric.Sum: new module adds accurate floating point summation. Changes in 0.1.4 * logFactorial type is genberalized. It accepts any `Integral' type * Evaluation of polynomials using Horner's method where coefficients are store in lists added Changes in 0.1.3 * Error function and its inverse added. * Digamma function added * Evaluation of polynomials using Horner's method added. * Crash bug in the inverse incomplete beta fixed. math-functions-0.1.5.2/LICENSE0000644000000000000000000000246112305441036014010 0ustar0000000000000000Copyright (c) 2009, 2010 Bryan O'Sullivan All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. math-functions-0.1.5.2/math-functions.cabal0000644000000000000000000000361512305441036016730 0ustar0000000000000000name: math-functions version: 0.1.5.2 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE author: Bryan O'Sullivan , Aleksey Khudyakov maintainer: Bryan O'Sullivan homepage: https://github.com/bos/math-functions bug-reports: https://github.com/bos/math-functions/issues category: Math, Numeric build-type: Simple synopsis: Special functions and Chebyshev polynomials description: This library provides implementations of special mathematical functions and Chebyshev polynomials. These functions are often useful in statistical and numerical computing. extra-source-files: ChangeLog README.markdown benchmark/*.hs tests/*.hs tests/Tests/*.hs tests/Tests/SpecFunctions/gen.py library ghc-options: -Wall build-depends: base >=3 && <5, deepseq, erf >= 2, vector >= 0.7, vector-th-unbox exposed-modules: Numeric.MathFunctions.Constants Numeric.Polynomial Numeric.Polynomial.Chebyshev Numeric.SpecFunctions Numeric.SpecFunctions.Extra Numeric.Sum test-suite tests type: exitcode-stdio-1.0 ghc-options: -Wall -threaded hs-source-dirs: tests main-is: tests.hs other-modules: Tests.Helpers Tests.Chebyshev Tests.SpecFunctions Tests.SpecFunctions.Tables Tests.Sum build-depends: math-functions, base >=3 && <5, vector >= 0.7, ieee754 >= 0.7.3, HUnit >= 1.2, QuickCheck >= 2.4, test-framework, test-framework-hunit, test-framework-quickcheck2 source-repository head type: git location: https://github.com/bos/math-functions source-repository head type: mercurial location: https://bitbucket.org/bos/math-functions math-functions-0.1.5.2/README.markdown0000644000000000000000000000154312305441036015504 0ustar0000000000000000# math-functions: efficient, special purpose mathematical functions This package provides a number of special-purpose mathematical functions used in statistical and numerical computing. Where possible, we give citations and computational complexity estimates for the algorithms used. # Get involved! Please report bugs via the [github issue tracker](https://github.com/bos/math-functions/issues). Master [git mirror](https://github.com/bos/math-functions): * `git clone git://github.com/bos/math-functions.git` There's also a [Mercurial mirror](https://bitbucket.org/bos/math-functions): * `hg clone https://bitbucket.org/bos/math-functions` (You can create and contribute changes using either Mercurial or git.) # Authors This library is written and maintained by Bryan O'Sullivan and Aleksey Khudyakov . math-functions-0.1.5.2/Setup.hs0000644000000000000000000000005612305441036014435 0ustar0000000000000000import Distribution.Simple main = defaultMain math-functions-0.1.5.2/benchmark/0000755000000000000000000000000012305441036014732 5ustar0000000000000000math-functions-0.1.5.2/benchmark/bench.hs0000644000000000000000000000443612305441036016354 0ustar0000000000000000import Criterion.Main import qualified Data.Vector.Unboxed as U import Numeric.SpecFunctions import Numeric.Polynomial import Text.Printf -- Uniformly sample logGamma performance between 10^-6 to 10^6 benchmarkLogGamma logG = [ bench (printf "%.3g" x) $ nf logG x | x <- [ m * 10**n | n <- [ -8 .. 8 ] , m <- [ 10**(i / tics) | i <- [0 .. tics-1] ] ] ] where tics = 3 {-# INLINE benchmarkLogGamma #-} -- Power of polynomial to be evaluated (In other words length of coefficients vector) coef_size :: [Int] coef_size = [ 1,2,3,4,5,6,7,8,9 , 10, 30 , 100, 300 , 1000, 3000 , 10000, 30000 ] {-# INLINE coef_size #-} -- Precalculated coefficients coef_list :: [U.Vector Double] coef_list = [ U.replicate n 1.2 | n <- coef_size] {-# NOINLINE coef_list #-} main :: IO () main = defaultMain [ bgroup "logGamma" $ benchmarkLogGamma logGamma , bgroup "logGammaL" $ benchmarkLogGamma logGammaL , bgroup "incompleteGamma" $ [ bench (show p) $ nf (incompleteGamma p) p | p <- [ 0.1 , 1, 3 , 10, 30 , 100, 300 , 999, 1000 ] ] , bgroup "factorial" [ bench (show n) $ nf factorial n | n <- [ 0, 1, 3, 6, 9, 11, 15 , 20, 30, 40, 50, 60, 70, 80, 90, 100 ] ] , bgroup "incompleteBeta" [ bench (show (p,q,x)) $ nf (incompleteBeta p q) x | (p,q,x) <- [ (10, 10, 0.5) , (101, 101, 0.5) , (1010, 1010, 0.5) , (10100, 10100, 0.5) , (100100, 100100, 0.5) , (1001000, 1001000, 0.5) , (10010000,10010000,0.5) ] ] , bgroup "log1p" [ bench (show x) $ nf log1p x | x <- [ -0.9 , -0.5 , -0.1 , 0.1 , 0.5 , 1 , 10 , 100 ] ] , bgroup "poly" $ [ bench ("vector_"++show (U.length coefs)) $ nf (\x -> evaluatePolynomial x coefs) (1 :: Double) | coefs <- coef_list ] ++ [ bench ("unpacked_"++show n) $ nf (\x -> evaluatePolynomialL x (map fromIntegral [1..n])) (1 :: Double) | n <- coef_size ] ] math-functions-0.1.5.2/benchmark/Summation.hs0000644000000000000000000000067612305441036017253 0ustar0000000000000000import Criterion.Main import Numeric.Sum as Sum import System.Random.MWC import qualified Data.Vector.Unboxed as U main = do gen <- createSystemRandom v <- uniformVector gen 10000000 :: IO (U.Vector Double) defaultMain [ bench "naive" $ whnf U.sum v , bench "pairwise" $ whnf pairwiseSum v , bench "kahan" $ whnf (sumVector kahan) v , bench "kbn" $ whnf (sumVector kbn) v , bench "kb2" $ whnf (sumVector kb2) v ] math-functions-0.1.5.2/Numeric/0000755000000000000000000000000012305441036014402 5ustar0000000000000000math-functions-0.1.5.2/Numeric/Polynomial.hs0000644000000000000000000000513212305441036017062 0ustar0000000000000000-- | -- Module : Numeric.Polynomial -- Copyright : (c) 2012 Aleksey Khudyakov -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Function for evaluating polynomials using Horher's method. module Numeric.Polynomial ( -- * Polynomials evaluatePolynomial , evaluateEvenPolynomial , evaluateOddPolynomial -- ** Lists -- $list , evaluatePolynomialL , evaluateEvenPolynomialL , evaluateOddPolynomialL ) where import qualified Data.Vector.Generic as G import qualified Data.Vector as V import Data.Vector.Generic (Vector) -- | Evaluate polynomial using Horner's method. Coefficients starts -- from lowest. In pseudocode: -- -- > evaluateOddPolynomial x [1,2,3] = 1 + 2*x + 3*x^2 evaluatePolynomial :: (Vector v a, Num a) => a -- ^ /x/ -> v a -- ^ Coefficients -> a {-# INLINE evaluatePolynomial #-} evaluatePolynomial x v | G.null v = 0 | otherwise = G.foldr1 (\a r -> a + r*x) v -- | Evaluate polynomial with only even powers using Horner's method. -- Coefficients starts from lowest. In pseudocode: -- -- > evaluateOddPolynomial x [1,2,3] = 1 + 2*x^2 + 3*x^4 evaluateEvenPolynomial :: (Vector v a, Num a) => a -- ^ /x/ -> v a -- ^ Coefficients -> a {-# INLINE evaluateEvenPolynomial #-} evaluateEvenPolynomial x = evaluatePolynomial (x*x) -- | Evaluate polynomial with only odd powers using Horner's method. -- Coefficients starts from lowest. In pseudocode: -- -- > evaluateOddPolynomial x [1,2,3] = 1*x + 2*x^3 + 3*x^5 evaluateOddPolynomial :: (Vector v a, Num a) => a -- ^ /x/ -> v a -- ^ Coefficients -> a {-# INLINE evaluateOddPolynomial #-} evaluateOddPolynomial x coefs = x * evaluatePolynomial (x*x) coefs -- $lists -- -- When all coefficients are known statically it's more convenient to -- pass coefficient in a list instad of vector. Functions below -- provide just that functionality. If list is known statically it -- will be inlined anyway. evaluatePolynomialL :: (Num a) => a -> [a] -> a evaluatePolynomialL x = evaluatePolynomial x . V.fromList {-# INLINE evaluatePolynomialL #-} evaluateEvenPolynomialL :: (Num a) => a -> [a] -> a evaluateEvenPolynomialL x = evaluateEvenPolynomial x . V.fromList {-# INLINE evaluateEvenPolynomialL #-} evaluateOddPolynomialL :: (Num a) => a -> [a] -> a evaluateOddPolynomialL x = evaluateOddPolynomial x . V.fromList {-# INLINE evaluateOddPolynomialL #-} math-functions-0.1.5.2/Numeric/SpecFunctions.hs0000644000000000000000000007710112305441036017527 0ustar0000000000000000{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -- | -- Module : Numeric.SpecFunctions -- Copyright : (c) 2009, 2011, 2012 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Special functions and factorials. module Numeric.SpecFunctions ( -- * Error function erf , erfc , invErf , invErfc -- * Gamma function , logGamma , logGammaL , incompleteGamma , invIncompleteGamma , digamma -- * Beta function , logBeta , incompleteBeta , incompleteBeta_ , invIncompleteBeta -- * Logarithm , log1p , log2 -- * Factorial , factorial , logFactorial , stirlingError -- * Combinatorics , choose -- * References -- $references ) where import Data.Bits ((.&.), (.|.), shiftR) import Data.Int (Int64) import qualified Data.Number.Erf as Erf (erfc,erf) import qualified Data.Vector.Unboxed as U import Numeric.Polynomial.Chebyshev (chebyshevBroucke) import Numeric.Polynomial (evaluateEvenPolynomialL,evaluateOddPolynomialL) import Numeric.MathFunctions.Constants ( m_epsilon, m_NaN, m_neg_inf, m_pos_inf , m_sqrt_2_pi, m_ln_sqrt_2_pi, m_sqrt_2 , m_eulerMascheroni ) import Text.Printf ---------------------------------------------------------------- -- Error function ---------------------------------------------------------------- -- | Error function. -- -- > erf -∞ = -1 -- > erf 0 = 0 -- > erf +∞ = 1 erf :: Double -> Double {-# INLINE erf #-} erf = Erf.erf -- | Complementary error function. -- -- > erfc -∞ = 2 -- > erfc 0 = 1 -- > errc +∞ = 0 erfc :: Double -> Double {-# INLINE erfc #-} erfc = Erf.erfc -- | Inverse of 'erf'. invErf :: Double -- ^ /p/ ∈ [-1,1] -> Double invErf p = invErfc (1 - p) -- | Inverse of 'erfc'. invErfc :: Double -- ^ /p/ ∈ [0,2] -> Double invErfc p | p == 2 = m_neg_inf | p == 0 = m_pos_inf | p >0 && p < 2 = if p <= 1 then r else -r | otherwise = modErr $ "invErfc: p must be in [0,2] got " ++ show p where pp = if p <= 1 then p else 2 - p t = sqrt $ -2 * log( 0.5 * pp) -- Initial guess x0 = -0.70711 * ((2.30753 + t * 0.27061) / (1 + t * (0.99229 + t * 0.04481)) - t) r = loop 0 x0 -- loop :: Int -> Double -> Double loop !j !x | j >= 2 = x | otherwise = let err = erfc x - pp x' = x + err / (1.12837916709551257 * exp(-x * x) - x * err) -- // Halley in loop (j+1) x' ---------------------------------------------------------------- -- Gamma function ---------------------------------------------------------------- -- Adapted from http://people.sc.fsu.edu/~burkardt/f_src/asa245/asa245.html -- | Compute the logarithm of the gamma function Γ(/x/). Uses -- Algorithm AS 245 by Macleod. -- -- Gives an accuracy of 10-12 significant decimal digits, except -- for small regions around /x/ = 1 and /x/ = 2, where the function -- goes to zero. For greater accuracy, use 'logGammaL'. -- -- Returns ∞ if the input is outside of the range (0 < /x/ ≤ 1e305). logGamma :: Double -> Double logGamma x | x <= 0 = m_pos_inf -- Handle positive infinity. logGamma overflows before 1e308 so -- it's safe | x > 1e308 = m_pos_inf -- Normal cases | x < 1.5 = a + c * ((((r1_4 * b + r1_3) * b + r1_2) * b + r1_1) * b + r1_0) / ((((b + r1_8) * b + r1_7) * b + r1_6) * b + r1_5) | x < 4 = (x - 2) * ((((r2_4 * x + r2_3) * x + r2_2) * x + r2_1) * x + r2_0) / ((((x + r2_8) * x + r2_7) * x + r2_6) * x + r2_5) | x < 12 = ((((r3_4 * x + r3_3) * x + r3_2) * x + r3_1) * x + r3_0) / ((((x + r3_8) * x + r3_7) * x + r3_6) * x + r3_5) | x > 3e6 = k | otherwise = k + x1 * ((r4_2 * x2 + r4_1) * x2 + r4_0) / ((x2 + r4_4) * x2 + r4_3) where (a , b , c) | x < 0.5 = (-y , x + 1 , x) | otherwise = (0 , x , x - 1) y = log x k = x * (y-1) - 0.5 * y + alr2pi alr2pi = 0.918938533204673 x1 = 1 / x x2 = x1 * x1 r1_0 = -2.66685511495; r1_1 = -24.4387534237; r1_2 = -21.9698958928 r1_3 = 11.1667541262; r1_4 = 3.13060547623; r1_5 = 0.607771387771 r1_6 = 11.9400905721; r1_7 = 31.4690115749; r1_8 = 15.2346874070 r2_0 = -78.3359299449; r2_1 = -142.046296688; r2_2 = 137.519416416 r2_3 = 78.6994924154; r2_4 = 4.16438922228; r2_5 = 47.0668766060 r2_6 = 313.399215894; r2_7 = 263.505074721; r2_8 = 43.3400022514 r3_0 = -2.12159572323e5; r3_1 = 2.30661510616e5; r3_2 = 2.74647644705e4 r3_3 = -4.02621119975e4; r3_4 = -2.29660729780e3; r3_5 = -1.16328495004e5 r3_6 = -1.46025937511e5; r3_7 = -2.42357409629e4; r3_8 = -5.70691009324e2 r4_0 = 0.279195317918525; r4_1 = 0.4917317610505968; r4_2 = 0.0692910599291889; r4_3 = 3.350343815022304 r4_4 = 6.012459259764103 data L = L {-# UNPACK #-} !Double {-# UNPACK #-} !Double -- | Compute the logarithm of the gamma function, Γ(/x/). Uses a -- Lanczos approximation. -- -- This function is slower than 'logGamma', but gives 14 or more -- significant decimal digits of accuracy, except around /x/ = 1 and -- /x/ = 2, where the function goes to zero. -- -- Returns ∞ if the input is outside of the range (0 < /x/ -- ≤ 1e305). logGammaL :: Double -> Double logGammaL x | x <= 0 = m_pos_inf -- Lanroz approximation loses precision for small arguments | x <= 1e-3 = logGamma x | otherwise = fini . U.foldl' go (L 0 (x+7)) $ a where fini (L l _) = log (l+a0) + log m_sqrt_2_pi - x65 + (x-0.5) * log x65 go (L l t) k = L (l + k / t) (t-1) x65 = x + 6.5 a0 = 0.9999999999995183 a = U.fromList [ 0.1659470187408462e-06 , 0.9934937113930748e-05 , -0.1385710331296526 , 12.50734324009056 , -176.6150291498386 , 771.3234287757674 , -1259.139216722289 , 676.5203681218835 ] -- | Compute the log gamma correction factor for @x@ ≥ 10. This -- correction factor is suitable for an alternate (but less -- numerically accurate) definition of 'logGamma': -- -- >lgg x = 0.5 * log(2*pi) + (x-0.5) * log x - x + logGammaCorrection x logGammaCorrection :: Double -> Double logGammaCorrection x | x < 10 = m_NaN | x < big = chebyshevBroucke (t * t * 2 - 1) coeffs / x | otherwise = 1 / (x * 12) where big = 94906265.62425156 t = 10 / x coeffs = U.fromList [ 0.1666389480451863247205729650822e+0, -0.1384948176067563840732986059135e-4, 0.9810825646924729426157171547487e-8, -0.1809129475572494194263306266719e-10, 0.6221098041892605227126015543416e-13, -0.3399615005417721944303330599666e-15, 0.2683181998482698748957538846666e-17 ] -- | Compute the normalized lower incomplete gamma function -- γ(/s/,/x/). Normalization means that -- γ(/s/,∞)=1. Uses Algorithm AS 239 by Shea. incompleteGamma :: Double -- ^ /s/ ∈ (0,∞) -> Double -- ^ /x/ ∈ (0,∞) -> Double incompleteGamma p x | isNaN p || isNaN x = m_NaN | x < 0 || p <= 0 = m_pos_inf | x == 0 = 0 -- For very large `p' normal approximation gives <1e-10 error | p >= 2e5 = norm (3 * sqrt p * ((x/p) ** (1/3) + 1/(9*p) - 1)) | p >= 500 = approx -- Dubious approximation | x >= 1e8 = 1 | x <= 1 || x < p = let a = p * log x - x - logGamma (p + 1) g = a + log (pearson p 1 1) in if g > limit then exp g else 0 | otherwise = let g = p * log x - x - logGamma p + log cf in if g > limit then 1 - exp g else 1 where -- CDF for standard normal distributions norm a = 0.5 * erfc (- a / m_sqrt_2) -- For large values of `p' we use 18-point Gauss-Legendre -- integration. approx | ans > 0 = 1 - ans | otherwise = -ans where -- Set upper limit for integration xu | x > p1 = (p1 + 11.5*sqrtP1) `max` (x + 6*sqrtP1) | otherwise = max 0 $ (p1 - 7.5*sqrtP1) `min` (x - 5*sqrtP1) s = U.sum $ U.zipWith go coefY coefW go y w = let t = x + (xu - x)*y in w * exp( -(t-p1) + p1*(log t - lnP1) ) ans = s * (xu - x) * exp( p1 * (lnP1 - 1) - logGamma p) -- p1 = p - 1 lnP1 = log p1 sqrtP1 = sqrt p1 -- pearson !a !c !g | c' <= tolerance = g' | otherwise = pearson a' c' g' where a' = a + 1 c' = c * x / a' g' = g + c' cf = let a = 1 - p b = a + x + 1 p3 = x + 1 p4 = x * b in contFrac a b 0 1 x p3 p4 (p3/p4) contFrac !a !b !c !p1 !p2 !p3 !p4 !g | abs (g - rn) <= min tolerance (tolerance * rn) = g | otherwise = contFrac a' b' c' (f p3) (f p4) (f p5) (f p6) rn where a' = a + 1 b' = b + 2 c' = c + 1 an = a' * c' p5 = b' * p3 - an * p1 p6 = b' * p4 - an * p2 rn = p5 / p6 f n | abs p5 > overflow = n / overflow | otherwise = n limit = -88 tolerance = 1e-14 overflow = 1e37 -- Adapted from Numerical Recipes §6.2.1 -- | Inverse incomplete gamma function. It's approximately inverse of -- 'incompleteGamma' for the same /s/. So following equality -- approximately holds: -- -- > invIncompleteGamma s . incompleteGamma s = id invIncompleteGamma :: Double -- ^ /s/ ∈ (0,∞) -> Double -- ^ /p/ ∈ [0,1] -> Double invIncompleteGamma a p | a <= 0 = modErr $ printf "invIncompleteGamma: a must be positive. a=%g p=%g" a p | p < 0 || p > 1 = modErr $ printf "invIncompleteGamma: p must be in [0,1] range. a=%g p=%g" a p | p == 0 = 0 | p == 1 = 1 / 0 | otherwise = loop 0 guess where -- Solve equation γ(a,x) = p using Halley method loop :: Int -> Double -> Double loop i x | i >= 12 = x' -- For small s derivative becomes approximately 1/x*exp(-x) and -- skyrockets for small x. If it happens correct answer is 0. | isInfinite f' = 0 | abs dx < eps * x' = x' | otherwise = loop (i + 1) x' where -- Value of γ(a,x) - p f = incompleteGamma a x - p -- dγ(a,x)/dx f' | a > 1 = afac * exp( -(x - a1) + a1 * (log x - lna1)) | otherwise = exp( -x + a1 * log x - gln) u = f / f' -- Halley correction to Newton-Rapson step corr = u * (a1 / x - 1) dx = u / (1 - 0.5 * min 1.0 corr) -- New approximation to x x' | x < dx = 0.5 * x -- Do not go below 0 | otherwise = x - dx -- Calculate inital guess for root guess -- | a > 1 = let t = sqrt $ -2 * log(if p < 0.5 then p else 1 - p) x1 = (2.30753 + t * 0.27061) / (1 + t * (0.99229 + t * 0.04481)) - t x2 = if p < 0.5 then -x1 else x1 in max 1e-3 (a * (1 - 1/(9*a) - x2 / (3 * sqrt a)) ** 3) -- For a <= 1 use following approximations: -- γ(a,1) ≈ 0.253a + 0.12a² -- -- γ(a,x) ≈ γ(a,1)·x^a x < 1 -- γ(a,x) ≈ γ(a,1) + (1 - γ(a,1))(1 - exp(1 - x)) x >= 1 | otherwise = let t = 1 - a * (0.253 + a*0.12) in if p < t then (p / t) ** (1 / a) else 1 - log( 1 - (p-t) / (1-t)) -- Constants a1 = a - 1 lna1 = log a1 afac = exp( a1 * (lna1 - 1) - gln ) gln = logGamma a eps = 1e-8 ---------------------------------------------------------------- -- Beta function ---------------------------------------------------------------- -- | Compute the natural logarithm of the beta function. logBeta :: Double -> Double -> Double logBeta a b | p < 0 = m_NaN | p == 0 = m_pos_inf | p >= 10 = log q * (-0.5) + m_ln_sqrt_2_pi + logGammaCorrection p + c + (p - 0.5) * log ppq + q * log1p(-ppq) | q >= 10 = logGamma p + c + p - p * log pq + (q - 0.5) * log1p(-ppq) | otherwise = logGamma p + logGamma q - logGamma pq where p = min a b q = max a b ppq = p / pq pq = p + q c = logGammaCorrection q - logGammaCorrection pq -- | Regularized incomplete beta function. Uses algorithm AS63 by -- Majumder and Bhattachrjee and quadrature approximation for large -- /p/ and /q/. incompleteBeta :: Double -- ^ /p/ > 0 -> Double -- ^ /q/ > 0 -> Double -- ^ /x/, must lie in [0,1] range -> Double incompleteBeta p q = incompleteBeta_ (logBeta p q) p q -- | Regularized incomplete beta function. Same as 'incompleteBeta' -- but also takes logarithm of beta function as parameter. incompleteBeta_ :: Double -- ^ logarithm of beta function for given /p/ and /q/ -> Double -- ^ /p/ > 0 -> Double -- ^ /q/ > 0 -> Double -- ^ /x/, must lie in [0,1] range -> Double incompleteBeta_ beta p q x | p <= 0 || q <= 0 = modErr $ printf "incompleteBeta_: p <= 0 || q <= 0. p=%g q=%g x=%g" p q x | x < 0 || x > 1 || isNaN x = modErr $ printf "incompletBeta_: x out of [0,1] range. p=%g q=%g x=%g" p q x | x == 0 || x == 1 = x | p >= (p+q) * x = incompleteBetaWorker beta p q x | otherwise = 1 - incompleteBetaWorker beta q p (1 - x) -- Approximation of incomplete beta by quandrature. -- -- Note that x =< p/(p+q) incompleteBetaApprox :: Double -> Double -> Double -> Double -> Double incompleteBetaApprox beta p q x | ans > 0 = 1 - ans | otherwise = -ans where -- Constants p1 = p - 1 q1 = q - 1 mu = p / (p + q) lnmu = log mu lnmuc = log (1 - mu) -- Upper limit for integration xu = max 0 $ min (mu - 10*t) (x - 5*t) where t = sqrt $ p*q / ( (p+q) * (p+q) * (p + q + 1) ) -- Calculate incomplete beta by quadrature go y w = let t = x + (xu - x) * y in w * exp( p1 * (log t - lnmu) + q1 * (log(1-t) - lnmuc) ) s = U.sum $ U.zipWith go coefY coefW ans = s * (xu - x) * exp( p1 * lnmu + q1 * lnmuc - beta ) -- Worker for incomplete beta function. It is separate function to -- avoid confusion with parameter during parameter swapping incompleteBetaWorker :: Double -> Double -> Double -> Double -> Double incompleteBetaWorker beta p q x -- For very large p and q this method becomes very slow so another -- method is used. | p > 3000 && q > 3000 = incompleteBetaApprox beta p q x | otherwise = loop (p+q) (truncate $ q + cx * (p+q)) 1 1 1 where -- Constants eps = 1e-15 cx = 1 - x -- Loop loop !psq (ns :: Int) ai term betain | done = betain' * exp( p * log x + (q - 1) * log cx - beta) / p | otherwise = loop psq' (ns - 1) (ai + 1) term' betain' where -- New values term' = term * fact / (p + ai) betain' = betain + term' fact | ns > 0 = (q - ai) * x/cx | ns == 0 = (q - ai) * x | otherwise = psq * x -- Iterations are complete done = db <= eps && db <= eps*betain' where db = abs term' psq' = if ns < 0 then psq + 1 else psq -- | Compute inverse of regularized incomplete beta function. Uses -- initial approximation from AS109, AS64 and Halley method to solve -- equation. invIncompleteBeta :: Double -- ^ /p/ > 0 -> Double -- ^ /q/ > 0 -> Double -- ^ /a/ ∈ [0,1] -> Double invIncompleteBeta p q a | p <= 0 || q <= 0 = modErr $ printf "invIncompleteBeta p <= 0 || q <= 0. p=%g q=%g a=%g" p q a | a < 0 || a > 1 = modErr $ printf "invIncompleteBeta x must be in [0,1]. p=%g q=%g a=%g" p q a | a == 0 || a == 1 = a | a > 0.5 = 1 - invIncompleteBetaWorker (logBeta p q) q p (1 - a) | otherwise = invIncompleteBetaWorker (logBeta p q) p q a invIncompleteBetaWorker :: Double -> Double -> Double -> Double -> Double -- NOTE: p <= 0.5. invIncompleteBetaWorker beta a b p = loop (0::Int) guess where a1 = a - 1 b1 = b - 1 -- Solve equation using Halley method loop !i !x -- We cannot continue at this point so we simply return `x' | x == 0 || x == 1 = x -- When derivative becomes infinite we cannot continue -- iterations. It can only happen in vicinity of 0 or 1. It's -- hardly possible to get good answer in such circumstances but -- `x' is already reasonable. | isInfinite f' = x -- Iterations limit reached. Most of the time solution will -- converge to answer because of discreteness of Double. But -- solution have good precision already. | i >= 10 = x -- Solution converges | abs dx <= 16 * m_epsilon * x = x' | otherwise = loop (i+1) x' where -- Calculate Halley step. f = incompleteBeta_ beta a b x - p f' = exp $ a1 * log x + b1 * log (1 - x) - beta u = f / f' dx = u / (1 - 0.5 * min 1 (u * (a1 / x - b1 / (1 - x)))) -- Next approximation. If Halley step leads us out of [0,1] -- range we revert to bisection. x' | z < 0 = x / 2 | z > 1 = (x + 1) / 2 | otherwise = z where z = x - dx -- Calculate initial guess. Approximations from AS64, AS109 and -- Numerical recipes are used. -- -- Equations are referred to by name of paper and number e.g. [AS64 2] -- In AS64 papers equations are not numbered so they are refered -- to by number of appearance starting from definition of -- incomplete beta. guess -- In this region we use approximation from AS109 (Carter -- approximation). It's reasonably good (2 iterations on -- average) | a > 1 && b > 1 = let r = (y*y - 3) / 6 s = 1 / (2*a - 1) t = 1 / (2*b - 1) h = 2 / (s + t) w = y * sqrt(h + r) / h - (t - s) * (r + 5/6 - 2 / (3 * h)) in a / (a + b * exp(2 * w)) -- Otherwise we revert to approximation from AS64 derived from -- [AS64 2] when it's applicable. -- -- It slightly reduces average number of iterations when `a' and -- `b' have different magnitudes. | chi2 > 0 && ratio > 1 = 1 - 2 / (ratio + 1) -- If all else fails we use approximation from "Numerical -- Recipes". It's very similar to approximations [AS64 4,5] but -- it never goes out of [0,1] interval. | otherwise = case () of _| p < t / w -> (a * p * w) ** (1/a) | otherwise -> 1 - (b * (1 - p) * w) ** (1/b) where lna = log $ a / (a+b) lnb = log $ b / (a+b) t = exp( a * lna ) / a u = exp( b * lnb ) / b w = t + u where -- Formula [2] ratio = (4*a + 2*b - 2) / chi2 -- Quantile of chi-squared distribution. Formula [3]. chi2 = 2 * b * (1 - t + y * sqrt t) ** 3 where t = 1 / (9 * b) -- `y' is Hasting's approximation of p'th quantile of standard -- normal distribution. y = r - ( 2.30753 + 0.27061 * r ) / ( 1.0 + ( 0.99229 + 0.04481 * r ) * r ) where r = sqrt $ - 2 * log p ---------------------------------------------------------------- -- Logarithm ---------------------------------------------------------------- -- | Compute the natural logarithm of 1 + @x@. This is accurate even -- for values of @x@ near zero, where use of @log(1+x)@ would lose -- precision. log1p :: Double -> Double log1p x | x == 0 = 0 | x == -1 = m_neg_inf | x < -1 = m_NaN | x' < m_epsilon * 0.5 = x | (x >= 0 && x < 1e-8) || (x >= -1e-9 && x < 0) = x * (1 - x * 0.5) | x' < 0.375 = x * (1 - x * chebyshevBroucke (x / 0.375) coeffs) | otherwise = log (1 + x) where x' = abs x coeffs = U.fromList [ 0.10378693562743769800686267719098e+1, -0.13364301504908918098766041553133e+0, 0.19408249135520563357926199374750e-1, -0.30107551127535777690376537776592e-2, 0.48694614797154850090456366509137e-3, -0.81054881893175356066809943008622e-4, 0.13778847799559524782938251496059e-4, -0.23802210894358970251369992914935e-5, 0.41640416213865183476391859901989e-6, -0.73595828378075994984266837031998e-7, 0.13117611876241674949152294345011e-7, -0.23546709317742425136696092330175e-8, 0.42522773276034997775638052962567e-9, -0.77190894134840796826108107493300e-10, 0.14075746481359069909215356472191e-10, -0.25769072058024680627537078627584e-11, 0.47342406666294421849154395005938e-12, -0.87249012674742641745301263292675e-13, 0.16124614902740551465739833119115e-13, -0.29875652015665773006710792416815e-14, 0.55480701209082887983041321697279e-15, -0.10324619158271569595141333961932e-15 ] -- | /O(log n)/ Compute the logarithm in base 2 of the given value. log2 :: Int -> Int log2 v0 | v0 <= 0 = modErr $ "log2: negative input, got " ++ show v0 | otherwise = go 5 0 v0 where go !i !r !v | i == -1 = r | v .&. b i /= 0 = let si = U.unsafeIndex sv i in go (i-1) (r .|. si) (v `shiftR` si) | otherwise = go (i-1) r v b = U.unsafeIndex bv !bv = U.fromList [0x2, 0xc, 0xf0, 0xff00, 0xffff0000, 0xffffffff00000000] !sv = U.fromList [1,2,4,8,16,32] ---------------------------------------------------------------- -- Factorial ---------------------------------------------------------------- -- | Compute the factorial function /n/!. Returns +∞ if the -- input is above 170 (above which the result cannot be represented by -- a 64-bit 'Double'). factorial :: Int -> Double factorial n | n < 0 = error "Numeric.SpecFunctions.factorial: negative input" | n <= 1 = 1 | n <= 170 = U.product $ U.map fromIntegral $ U.enumFromTo 2 n | otherwise = m_pos_inf -- | Compute the natural logarithm of the factorial function. Gives -- 16 decimal digits of precision. logFactorial :: Integral a => a -> Double logFactorial n | n < 0 = error "Numeric.SpecFunctions.logFactorial: negative input" | n <= 14 = log $ factorial $ fromIntegral n | otherwise = (x - 0.5) * log x - x + 9.1893853320467e-1 + z / x where x = fromIntegral n + 1 y = 1 / (x * x) z = ((-(5.95238095238e-4 * y) + 7.936500793651e-4) * y - 2.7777777777778e-3) * y + 8.3333333333333e-2 {-# SPECIALIZE logFactorial :: Int -> Double #-} -- | Calculate the error term of the Stirling approximation. This is -- only defined for non-negative values. -- -- > stirlingError @n@ = @log(n!) - log(sqrt(2*pi*n)*(n/e)^n) stirlingError :: Double -> Double stirlingError n | n <= 15.0 = case properFraction (n+n) of (i,0) -> sfe `U.unsafeIndex` i _ -> logGamma (n+1.0) - (n+0.5) * log n + n - m_ln_sqrt_2_pi | n > 500 = evaluateOddPolynomialL (1/n) [s0,-s1] | n > 80 = evaluateOddPolynomialL (1/n) [s0,-s1,s2] | n > 35 = evaluateOddPolynomialL (1/n) [s0,-s1,s2,-s3] | otherwise = evaluateOddPolynomialL (1/n) [s0,-s1,s2,-s3,s4] where s0 = 0.083333333333333333333 -- 1/12 s1 = 0.00277777777777777777778 -- 1/360 s2 = 0.00079365079365079365079365 -- 1/1260 s3 = 0.000595238095238095238095238 -- 1/1680 s4 = 0.0008417508417508417508417508 -- 1/1188 sfe = U.fromList [ 0.0, 0.1534264097200273452913848, 0.0810614667953272582196702, 0.0548141210519176538961390, 0.0413406959554092940938221, 0.03316287351993628748511048, 0.02767792568499833914878929, 0.02374616365629749597132920, 0.02079067210376509311152277, 0.01848845053267318523077934, 0.01664469118982119216319487, 0.01513497322191737887351255, 0.01387612882307074799874573, 0.01281046524292022692424986, 0.01189670994589177009505572, 0.01110455975820691732662991, 0.010411265261972096497478567, 0.009799416126158803298389475, 0.009255462182712732917728637, 0.008768700134139385462952823, 0.008330563433362871256469318, 0.007934114564314020547248100, 0.007573675487951840794972024, 0.007244554301320383179543912, 0.006942840107209529865664152, 0.006665247032707682442354394, 0.006408994188004207068439631, 0.006171712263039457647532867, 0.005951370112758847735624416, 0.005746216513010115682023589, 0.005554733551962801371038690 ] ---------------------------------------------------------------- -- Combinatorics ---------------------------------------------------------------- -- | Quickly compute the natural logarithm of /n/ @`choose`@ /k/, with -- no checking. logChooseFast :: Double -> Double -> Double logChooseFast n k = -log (n + 1) - logBeta (n - k + 1) (k + 1) -- | Compute the binomial coefficient /n/ @\``choose`\`@ /k/. For -- values of /k/ > 30, this uses an approximation for performance -- reasons. The approximation is accurate to 12 decimal places in the -- worst case -- -- Example: -- -- > 7 `choose` 3 == 35 choose :: Int -> Int -> Double n `choose` k | k > n = 0 | k' < 50 = U.foldl' go 1 . U.enumFromTo 1 $ k' | approx < max64 = fromIntegral . round64 $ approx | otherwise = approx where k' = min k (n-k) approx = exp $ logChooseFast (fromIntegral n) (fromIntegral k') -- Less numerically stable: -- exp $ lg (n+1) - lg (k+1) - lg (n-k+1) -- where lg = logGamma . fromIntegral go a i = a * (nk + j) / j where j = fromIntegral i :: Double nk = fromIntegral (n - k') max64 = fromIntegral (maxBound :: Int64) round64 x = round x :: Int64 -- | Compute ψ0(/x/), the first logarithmic derivative of the gamma -- function. Uses Algorithm AS 103 by Bernardo, based on Minka's C -- implementation. digamma :: Double -> Double digamma x | isNaN x || isInfinite x = m_NaN -- FIXME: -- This is ugly. We are testing here that number is in fact -- integer. It's somewhat tricky question to answer. When ε for -- given number becomes 1 or greater every number is represents -- an integer. We also must make sure that excess precision -- won't bite us. | x <= 0 && fromIntegral (truncate x :: Int64) == x = m_neg_inf -- Jeffery's reflection formula | x < 0 = digamma (1 - x) + pi / tan (negate pi * x) | x <= 1e-6 = - γ - 1/x + trigamma1 * x | x' < c = r -- De Moivre's expansion | otherwise = let s = 1/x' in evaluateEvenPolynomialL s [ r + log x' - 0.5 * s , - 1/12 , 1/120 , - 1/252 , 1/240 , - 1/132 , 391/32760 ] where γ = m_eulerMascheroni c = 12 -- Reduce to digamma (x + n) where (x + n) >= c (r, x') = reduce 0 x where reduce !s y | y < c = reduce (s - 1 / y) (y + 1) | otherwise = (s, y) ---------------------------------------------------------------- -- Constants ---------------------------------------------------------------- -- Coefficients for 18-point Gauss-Legendre integration. They are -- used in implementation of incomplete gamma and beta functions. coefW,coefY :: U.Vector Double coefW = U.fromList [ 0.0055657196642445571, 0.012915947284065419, 0.020181515297735382 , 0.027298621498568734, 0.034213810770299537, 0.040875750923643261 , 0.047235083490265582, 0.053244713977759692, 0.058860144245324798 , 0.064039797355015485, 0.068745323835736408, 0.072941885005653087 , 0.076598410645870640, 0.079687828912071670, 0.082187266704339706 , 0.084078218979661945, 0.085346685739338721, 0.085983275670394821 ] coefY = U.fromList [ 0.0021695375159141994, 0.011413521097787704, 0.027972308950302116 , 0.051727015600492421, 0.082502225484340941, 0.12007019910960293 , 0.16415283300752470, 0.21442376986779355, 0.27051082840644336 , 0.33199876341447887, 0.39843234186401943, 0.46931971407375483 , 0.54413605556657973, 0.62232745288031077, 0.70331500465597174 , 0.78649910768313447, 0.87126389619061517, 0.95698180152629142 ] {-# NOINLINE coefW #-} {-# NOINLINE coefY #-} trigamma1 :: Double trigamma1 = 1.6449340668482264365 -- pi**2 / 6 modErr :: String -> a modErr msg = error $ "Numeric.SpecFunctions." ++ msg -- $references -- -- * Bernardo, J. (1976) Algorithm AS 103: Psi (digamma) -- function. /Journal of the Royal Statistical Society. Series C -- (Applied Statistics)/ 25(3):315-317. -- -- -- * Cran, G.W., Martin, K.J., Thomas, G.E. (1977) Remark AS R19 -- and Algorithm AS 109: A Remark on Algorithms: AS 63: The -- Incomplete Beta Integral AS 64: Inverse of the Incomplete Beta -- Function Ratio. /Journal of the Royal Statistical Society. Series -- C (Applied Statistics)/ Vol. 26, No. 1 (1977), pp. 111-114 -- -- -- * Lanczos, C. (1964) A precision approximation of the gamma -- function. /SIAM Journal on Numerical Analysis B/ -- 1:86–96. -- -- * Loader, C. (2000) Fast and Accurate Computation of Binomial -- Probabilities. -- -- * Macleod, A.J. (1989) Algorithm AS 245: A robust and reliable -- algorithm for the logarithm of the gamma function. -- /Journal of the Royal Statistical Society, Series C (Applied Statistics)/ -- 38(2):397–402. -- -- * Majumder, K.L., Bhattacharjee, G.P. (1973) Algorithm AS 63: The -- Incomplete Beta Integral. /Journal of the Royal Statistical -- Society. Series C (Applied Statistics)/ Vol. 22, No. 3 (1973), -- pp. 409-411. -- -- * Majumder, K.L., Bhattacharjee, G.P. (1973) Algorithm AS 64: -- Inverse of the Incomplete Beta Function Ratio. /Journal of the -- Royal Statistical Society. Series C (Applied Statistics)/ -- Vol. 22, No. 3 (1973), pp. 411-414 -- -- -- * Shea, B. (1988) Algorithm AS 239: Chi-squared and incomplete -- gamma integral. /Applied Statistics/ -- 37(3):466–473. math-functions-0.1.5.2/Numeric/Sum.hs0000644000000000000000000002044512305441036015507 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | -- Module : Numeric.Sum -- Copyright : (c) 2014 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Functions for summing floating point numbers more accurately than -- the naive 'Prelude.sum' function and its counterparts in the -- @vector@ package and elsewhere. -- -- When used with floating point numbers, in the worst case, the -- 'Prelude.sum' function accumulates numeric error at a rate -- proportional to the number of values being summed. The algorithms -- in this module implement different methods of /compensated -- summation/, which reduce the accumulation of numeric error so that -- it either grows much more slowly than the number of inputs -- (e.g. logarithmically), or remains constant. module Numeric.Sum ( -- * Summation type class Summation(..) , sumVector -- ** Usage -- $usage -- * Kahan-Babuška-Neumaier summation , KBNSum(..) , kbn -- * Order-2 Kahan-Babuška summation , KB2Sum(..) , kb2 -- * Less desirable approaches -- ** Kahan summation , KahanSum(..) , kahan -- ** Pairwise summation , pairwiseSum -- * References -- $references ) where import Control.Arrow ((***)) import Control.DeepSeq (NFData(..)) import Data.Bits (shiftR) import Data.Data (Typeable, Data) import Data.Vector.Generic (Vector(..), foldl') import Data.Vector.Generic.Mutable (MVector(..)) import Data.Vector.Unboxed.Deriving (derivingUnbox) import qualified Data.Foldable as F import qualified Data.Vector as V import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U -- | A class for summation of floating point numbers. class Summation s where -- | The identity for summation. zero :: s -- | Add a value to a sum. add :: s -> Double -> s -- | Sum a collection of values. -- -- Example: -- @foo = 'sum' 'kbn' [1,2,3]@ sum :: (F.Foldable f) => (s -> Double) -> f Double -> Double sum f = f . F.foldl' add zero {-# INLINE sum #-} instance Summation Double where zero = 0 add = (+) -- | Kahan summation. This is the least accurate of the compensated -- summation methods. In practice, it only beats naive summation for -- inputs with large magnitude. Kahan summation can be /less/ -- accurate than naive summation for small-magnitude inputs. -- -- This summation method is included for completeness. Its use is not -- recommended. In practice, 'KBNSum' is both 30% faster and more -- accurate. data KahanSum = KahanSum {-# UNPACK #-} !Double {-# UNPACK #-} !Double deriving (Eq, Show, Typeable, Data) derivingUnbox "KahanSum" [t| KahanSum -> (Double, Double) |] [| \ (KahanSum a b) -> (a, b) |] [| \ (a, b) -> KahanSum a b |] instance Summation KahanSum where zero = KahanSum 0 0 add = kahanAdd instance NFData KahanSum where rnf !_ = () kahanAdd :: KahanSum -> Double -> KahanSum kahanAdd (KahanSum sum c) x = KahanSum sum' c' where sum' = sum + y c' = (sum' - sum) - y y = x - c -- | Return the result of a Kahan sum. kahan :: KahanSum -> Double kahan (KahanSum sum _) = sum -- | Kahan-Babuška-Neumaier summation. This is a little more -- computationally costly than plain Kahan summation, but is /always/ -- at least as accurate. data KBNSum = KBNSum {-# UNPACK #-} !Double {-# UNPACK #-} !Double deriving (Eq, Show, Typeable, Data) derivingUnbox "KBNSum" [t| KBNSum -> (Double, Double) |] [| \ (KBNSum a b) -> (a, b) |] [| \ (a, b) -> KBNSum a b |] instance Summation KBNSum where zero = KBNSum 0 0 add = kbnAdd instance NFData KBNSum where rnf !_ = () kbnAdd :: KBNSum -> Double -> KBNSum kbnAdd (KBNSum sum c) x = KBNSum sum' c' where c' | abs sum >= abs x = c + ((sum - sum') + x) | otherwise = c + ((x - sum') + sum) sum' = sum + x -- | Return the result of a Kahan-Babuška-Neumaier sum. kbn :: KBNSum -> Double kbn (KBNSum sum c) = sum + c -- | Second-order Kahan-Babuška summation. This is more -- computationally costly than Kahan-Babuška-Neumaier summation, -- running at about a third the speed. Its advantage is that it can -- lose less precision (in admittedly obscure cases). -- -- This method compensates for error in both the sum and the -- first-order compensation term, hence the use of \"second order\" in -- the name. data KB2Sum = KB2Sum {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double deriving (Eq, Show, Typeable, Data) derivingUnbox "KB2Sum" [t| KB2Sum -> (Double, Double, Double) |] [| \ (KB2Sum a b c) -> (a, b, c) |] [| \ (a, b, c) -> KB2Sum a b c |] instance Summation KB2Sum where zero = KB2Sum 0 0 0 add = kb2Add instance NFData KB2Sum where rnf !_ = () kb2Add :: KB2Sum -> Double -> KB2Sum kb2Add (KB2Sum sum c cc) x = KB2Sum sum' c' cc' where sum' = sum + x c' = c + k cc' | abs c >= abs k = cc + ((c - c') + k) | otherwise = cc + ((k - c') + c) k | abs sum >= abs x = (sum - sum') + x | otherwise = (x - sum') + sum -- | Return the result of an order-2 Kahan-Babuška sum. kb2 :: KB2Sum -> Double kb2 (KB2Sum sum c cc) = sum + c + cc -- | /O(n)/ Sum a vector of values. sumVector :: (Vector v Double, Summation s) => (s -> Double) -> v Double -> Double sumVector f = f . foldl' add zero {-# INLINE sumVector #-} -- | /O(n)/ Sum a vector of values using pairwise summation. -- -- This approach is perhaps 10% faster than 'KBNSum', but has poorer -- bounds on its error growth. Instead of having roughly constant -- error regardless of the size of the input vector, in the worst case -- its accumulated error grows with /O(log n)/. pairwiseSum :: (Vector v Double) => v Double -> Double pairwiseSum v | len <= 256 = G.sum v | otherwise = uncurry (+) . (pairwiseSum *** pairwiseSum) . G.splitAt (len `shiftR` 1) $ v where len = G.length v {-# SPECIALIZE pairwiseSum :: V.Vector Double -> Double #-} {-# SPECIALIZE pairwiseSum :: U.Vector Double -> Double #-} -- $usage -- -- Most of these summation algorithms are intended to be used via the -- 'Summation' typeclass interface. Explicit type annotations should -- not be necessary, as the use of a function such as 'kbn' or 'kb2' -- to extract the final sum out of a 'Summation' instance gives the -- compiler enough information to determine the precise type of -- summation algorithm to use. -- -- As an example, here is a (somewhat silly) function that manually -- computes the sum of elements in a list. -- -- @ -- sillySumList :: [Double] -> Double -- sillySumList = loop 'zero' -- where loop s [] = 'kbn' s -- loop s (x:xs) = 'seq' s' loop s' xs -- where s' = 'add' s x -- @ -- -- In most instances, you can simply use the much more general 'sum' -- function instead of writing a summation function by hand. -- -- @ -- -- Avoid ambiguity around which sum function we are using. -- import Prelude hiding (sum) -- -- -- betterSumList :: [Double] -> Double -- betterSumList xs = 'sum' 'kbn' xs -- @ -- Note well the use of 'seq' in the example above to force the -- evaluation of intermediate values. If you must write a summation -- function by hand, and you forget to evaluate the intermediate -- values, you are likely to incur a space leak. -- -- Here is an example of how to compute a prefix sum in which the -- intermediate values are as accurate as possible. -- -- @ -- prefixSum :: [Double] -> [Double] -- prefixSum xs = map 'kbn' . 'scanl' 'add' 'zero' $ xs -- @ -- $references -- -- * Kahan, W. (1965), Further remarks on reducing truncation -- errors. /Communications of the ACM/ 8(1):40. -- -- * Neumaier, A. (1974), Rundungsfehleranalyse einiger Verfahren zur -- Summation endlicher Summen. -- /Zeitschrift für Angewandte Mathematik und Mechanik/ 54:39–51. -- -- * Klein, A. (2006), A Generalized -- Kahan-Babuška-Summation-Algorithm. /Computing/ 76(3):279-293. -- -- * Higham, N.J. (1993), The accuracy of floating point -- summation. /SIAM Journal on Scientific Computing/ 14(4):783–799. math-functions-0.1.5.2/Numeric/MathFunctions/0000755000000000000000000000000012305441036017164 5ustar0000000000000000math-functions-0.1.5.2/Numeric/MathFunctions/Constants.hs0000644000000000000000000000472712305441036021506 0ustar0000000000000000-- | -- Module : Numeric.MathFunctions.Constants -- Copyright : (c) 2009, 2011 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Constant values common to much numeric code. module Numeric.MathFunctions.Constants ( -- * IEE754 constants m_epsilon , m_huge , m_tiny , m_max_exp , m_pos_inf , m_neg_inf , m_NaN -- * Mathematical constants , m_1_sqrt_2 , m_2_sqrt_pi , m_ln_sqrt_2_pi , m_sqrt_2 , m_sqrt_2_pi , m_eulerMascheroni ) where ---------------------------------------------------------------- -- IEE754 constants ---------------------------------------------------------------- -- | A very large number. m_huge :: Double m_huge = 1.7976931348623157e308 {-# INLINE m_huge #-} m_tiny :: Double m_tiny = 2.2250738585072014e-308 {-# INLINE m_tiny #-} -- | The largest 'Int' /x/ such that 2**(/x/-1) is approximately -- representable as a 'Double'. m_max_exp :: Int m_max_exp = 1024 -- | Positive infinity. m_pos_inf :: Double m_pos_inf = 1/0 {-# INLINE m_pos_inf #-} -- | Negative infinity. m_neg_inf :: Double m_neg_inf = -1/0 {-# INLINE m_neg_inf #-} -- | Not a number. m_NaN :: Double m_NaN = 0/0 {-# INLINE m_NaN #-} ---------------------------------------------------------------- -- Mathematical constants ---------------------------------------------------------------- -- | @sqrt 2@ m_sqrt_2 :: Double m_sqrt_2 = 1.4142135623730950488016887242096980785696718753769480731766 {-# INLINE m_sqrt_2 #-} -- | @sqrt (2 * pi)@ m_sqrt_2_pi :: Double m_sqrt_2_pi = 2.5066282746310005024157652848110452530069867406099383166299 {-# INLINE m_sqrt_2_pi #-} -- | @2 / sqrt pi@ m_2_sqrt_pi :: Double m_2_sqrt_pi = 1.1283791670955125738961589031215451716881012586579977136881 {-# INLINE m_2_sqrt_pi #-} -- | @1 / sqrt 2@ m_1_sqrt_2 :: Double m_1_sqrt_2 = 0.7071067811865475244008443621048490392848359376884740365883 {-# INLINE m_1_sqrt_2 #-} -- | The smallest 'Double' ε such that 1 + ε ≠ 1. m_epsilon :: Double m_epsilon = encodeFloat (signif+1) expo - 1.0 where (signif,expo) = decodeFloat (1.0::Double) -- | @log(sqrt((2*pi))@ m_ln_sqrt_2_pi :: Double m_ln_sqrt_2_pi = 0.9189385332046727417803297364056176398613974736377834128171 {-# INLINE m_ln_sqrt_2_pi #-} -- | Euler–Mascheroni constant (γ = 0.57721...) m_eulerMascheroni :: Double m_eulerMascheroni = 0.5772156649015328606065121 {-# INLINE m_eulerMascheroni #-} math-functions-0.1.5.2/Numeric/Polynomial/0000755000000000000000000000000012305441036016525 5ustar0000000000000000math-functions-0.1.5.2/Numeric/Polynomial/Chebyshev.hs0000644000000000000000000000455312305441036021010 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Numeric.Polynomial.Chebyshev -- Copyright : (c) 2009, 2011 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Chebyshev polynomials. module Numeric.Polynomial.Chebyshev ( -- * Chebyshev polinomials -- $chebyshev chebyshev , chebyshevBroucke -- * References -- $references ) where import qualified Data.Vector.Generic as G -- $chebyshev -- -- A Chebyshev polynomial of the first kind is defined by the -- following recurrence: -- -- > t 0 _ = 1 -- > t 1 x = x -- > t n x = 2 * x * t (n-1) x - t (n-2) x data C = C {-# UNPACK #-} !Double {-# UNPACK #-} !Double -- | Evaluate a Chebyshev polynomial of the first kind. Uses -- Clenshaw's algorithm. chebyshev :: (G.Vector v Double) => Double -- ^ Parameter of each function. -> v Double -- ^ Coefficients of each polynomial term, in increasing order. -> Double chebyshev x a = fini . G.foldr' step (C 0 0) . G.tail $ a where step k (C b0 b1) = C (k + x2 * b0 - b1) b0 fini (C b0 b1) = G.head a + x * b0 - b1 x2 = x * 2 {-# INLINE chebyshev #-} data B = B {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double -- | Evaluate a Chebyshev polynomial of the first kind. Uses Broucke's -- ECHEB algorithm, and his convention for coefficient handling. It -- treat 0th coefficient different so -- -- > chebyshev x [a0,a1,a2...] == chebyshevBroucke [2*a0,a1,a2...] chebyshevBroucke :: (G.Vector v Double) => Double -- ^ Parameter of each function. -> v Double -- ^ Coefficients of each polynomial term, in increasing order. -> Double chebyshevBroucke x = fini . G.foldr' step (B 0 0 0) where step k (B b0 b1 _) = B (k + x2 * b0 - b1) b0 b1 fini (B b0 _ b2) = (b0 - b2) * 0.5 x2 = x * 2 {-# INLINE chebyshevBroucke #-} -- $references -- -- * Broucke, R. (1973) Algorithm 446: Ten subroutines for the -- manipulation of Chebyshev series. /Communications of the ACM/ -- 16(4):254–256. -- -- * Clenshaw, C.W. (1962) Chebyshev series for mathematical -- functions. /National Physical Laboratory Mathematical Tables 5/, -- Her Majesty's Stationery Office, London. -- math-functions-0.1.5.2/Numeric/SpecFunctions/0000755000000000000000000000000012305441036017165 5ustar0000000000000000math-functions-0.1.5.2/Numeric/SpecFunctions/Extra.hs0000644000000000000000000000174312305441036020611 0ustar0000000000000000-- | -- Module : Numeric.SpecFunctions.Extra -- Copyright : (c) 2009, 2011 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Less common mathematical functions. module Numeric.SpecFunctions.Extra ( bd0 ) where import Numeric.MathFunctions.Constants (m_NaN) -- | Evaluate the deviance term @x log(x/np) + np - x@. bd0 :: Double -- ^ @x@ -> Double -- ^ @np@ -> Double bd0 x np | isInfinite x || isInfinite np || np == 0 = m_NaN | abs x_np >= 0.1*(x+np) = x * log (x/np) - x_np | otherwise = loop 1 (ej0*vv) s0 where x_np = x - np v = x_np / (x+np) s0 = x_np * v ej0 = 2*x*v vv = v*v loop j ej s = case s + ej/(2*j+1) of s' | s' == s -> s' -- FIXME: Comparing Doubles for equality! | otherwise -> loop (j+1) (ej*vv) s' math-functions-0.1.5.2/tests/0000755000000000000000000000000012305441036014142 5ustar0000000000000000math-functions-0.1.5.2/tests/tests.hs0000644000000000000000000000045612305441036015645 0ustar0000000000000000import Test.Framework (defaultMain) import qualified Tests.SpecFunctions import qualified Tests.Chebyshev import qualified Tests.Sum main :: IO () main = defaultMain [ Tests.SpecFunctions.tests , Tests.Chebyshev.tests , Tests.Sum.tests ] math-functions-0.1.5.2/tests/Tests/0000755000000000000000000000000012305441036015244 5ustar0000000000000000math-functions-0.1.5.2/tests/Tests/Chebyshev.hs0000644000000000000000000000404012305441036017516 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Tests.Chebyshev ( tests ) where import Data.Vector.Unboxed (fromList) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck (Arbitrary(..),printTestCase,Property) import Tests.Helpers import Numeric.Polynomial.Chebyshev tests :: Test tests = testGroup "Chebyshev polynomials" [ testProperty "Chebyshev 0" $ \a0 (Ch x) -> testCheb [a0] x -- XXX FIXME DISABLED due to failure -- , testProperty "Chebyshev 1" $ \a0 a1 (Ch x) -> -- testCheb [a0,a1] x -- , testProperty "Chebyshev 2" $ \a0 a1 a2 (Ch x) -> -- testCheb [a0,a1,a2] x -- , testProperty "Chebyshev 3" $ \a0 a1 a2 a3 (Ch x) -> -- testCheb [a0,a1,a2,a3] x -- , testProperty "Chebyshev 4" $ \a0 a1 a2 a3 a4 (Ch x) -> -- testCheb [a0,a1,a2,a3,a4] x -- , testProperty "Broucke" $ testBroucke ] where testBroucke :: Ch -> [Double] -> Bool testBroucke _ [] = True testBroucke (Ch x) (c:cs) = let c1 = chebyshev x (fromList $ c : cs) cb = chebyshevBroucke x (fromList $ c*2 : cs) in eq 1e-15 c1 cb testCheb :: [Double] -> Double -> Property testCheb as x = printTestCase (">>> Exact = " ++ show exact) $ printTestCase (">>> Numeric = " ++ show num ) $ printTestCase (">>> rel.err.= " ++ show err ) $ eq 1e-12 num exact where exact = evalCheb as x num = chebyshev x (fromList as) err = abs (num - exact) / abs exact evalCheb :: [Double] -> Double -> Double evalCheb as x = realToFrac $ sum $ zipWith (*) (map realToFrac as) $ map ($ realToFrac x) cheb -- Chebyshev polynomials of low order cheb :: [Rational -> Rational] cheb = [ \_ -> 1 , \x -> x , \x -> 2*x^2 - 1 , \x -> 4*x^3 - 3*x , \x -> 8*x^4 - 8*x^2 + 1 ] -- Double in the [-1 .. 1] range newtype Ch = Ch Double deriving Show instance Arbitrary Ch where arbitrary = do x <- arbitrary return $ Ch $ 2 * (abs . snd . properFraction) x - 1 math-functions-0.1.5.2/tests/Tests/Helpers.hs0000644000000000000000000000531012305441036017201 0ustar0000000000000000-- | Helpers for testing module Tests.Helpers ( -- * helpers T(..) , typeName , eq , eqC -- * Generic QC tests , monotonicallyIncreases , monotonicallyIncreasesIEEE -- * HUnit helpers , testAssertion , testEquality ) where import Data.Complex import Data.Typeable import qualified Numeric.IEEE as IEEE import qualified Test.HUnit as HU import Test.Framework import Test.Framework.Providers.HUnit ---------------------------------------------------------------- -- Helpers ---------------------------------------------------------------- -- | Phantom typed value used to select right instance in QC tests data T a = T -- | String representation of type name typeName :: Typeable a => T a -> String typeName = show . typeOf . typeParam where typeParam :: T a -> a typeParam _ = undefined -- | Approximate equality for 'Double'. Doesn't work well for numbers -- which are almost zero. eq :: Double -- ^ Relative error -> Double -> Double -> Bool eq eps a b | a == 0 && b == 0 = True | otherwise = abs (a - b) <= eps * max (abs a) (abs b) -- | Approximate equality for 'Complex Double' eqC :: Double -- ^ Relative error -> Complex Double -> Complex Double -> Bool eqC eps a@(ar :+ ai) b@(br :+ bi) | a == 0 && b == 0 = True | otherwise = abs (ar - br) <= eps * d && abs (ai - bi) <= eps * d where d = max (realPart $ abs a) (realPart $ abs b) ---------------------------------------------------------------- -- Generic QC ---------------------------------------------------------------- -- Check that function is nondecreasing monotonicallyIncreases :: (Ord a, Ord b) => (a -> b) -> a -> a -> Bool monotonicallyIncreases f x1 x2 = f (min x1 x2) <= f (max x1 x2) -- 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 -- 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 monotonicallyIncreasesIEEE f x1 x2 = y1 <= y2 || (y1 - y2) < y2 * IEEE.epsilon where y1 = f (min x1 x2) y2 = f (max x1 x2) ---------------------------------------------------------------- -- HUnit helpers ---------------------------------------------------------------- testAssertion :: String -> Bool -> Test testAssertion str cont = testCase str $ HU.assertBool str cont testEquality :: (Show a, Eq a) => String -> a -> a -> Test testEquality msg a b = testCase msg $ HU.assertEqual msg a b math-functions-0.1.5.2/tests/Tests/SpecFunctions.hs0000644000000000000000000002102012305441036020356 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} -- | Tests for Statistics.Math module Tests.SpecFunctions ( tests ) where import qualified Data.Vector as V import Data.Vector ((!)) import Test.QuickCheck hiding (choose) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Tests.Helpers import Tests.SpecFunctions.Tables import Numeric.SpecFunctions tests :: Test tests = testGroup "Special functions" [ testProperty "Gamma(x+1) = x*Gamma(x) [logGamma]" $ gammaReccurence logGamma 3e-8 , testProperty "Gamma(x+1) = x*Gamma(x) [logGammaL]" $ gammaReccurence logGammaL 2e-13 , testProperty "gamma(1,x) = 1 - exp(-x)" $ incompleteGammaAt1Check , testProperty "0 <= gamma <= 1" $ incompleteGammaInRange , testProperty "0 <= I[B] <= 1" $ incompleteBetaInRange -- XXX FIXME DISABLED due to failures -- , testProperty "invIncompleteGamma = gamma^-1" $ invIGammaIsInverse -- , testProperty "invIncompleteBeta = B^-1" $ invIBetaIsInverse -- , testProperty "gamma - increases" $ -- \s x y -> s > 0 && x > 0 && y > 0 ==> monotonicallyIncreases (incompleteGamma s) x y , testProperty "invErfc = erfc^-1" $ invErfcIsInverse , testProperty "invErf = erf^-1" $ invErfIsInverse -- Unit tests , testAssertion "Factorial is expected to be precise at 1e-15 level" $ and [ eq 1e-15 (factorial (fromIntegral n :: Int)) (fromIntegral (factorial' n)) |n <- [0..170]] , testAssertion "Log factorial is expected to be precise at 1e-15 level" $ and [ eq 1e-15 (logFactorial (fromIntegral n :: Int)) (log $ fromIntegral $ factorial' n) | n <- [2..170]] , testAssertion "logGamma is expected to be precise at 1e-9 level [integer points]" $ and [ eq 1e-9 (logGamma (fromIntegral n)) (logFactorial (n-1)) | n <- [3..10000::Int]] , testAssertion "logGamma is expected to be precise at 1e-9 level [fractional points]" $ and [ eq 1e-9 (logGamma x) lg | (x,lg) <- tableLogGamma ] , testAssertion "logGammaL is expected to be precise at 1e-15 level" $ and [ eq 1e-15 (logGammaL (fromIntegral n)) (logFactorial (n-1)) | n <- [3..10000::Int]] -- FIXME: Too low! , testAssertion "logGammaL is expected to be precise at 1e-10 level [fractional points]" $ and [ eq 1e-10 (logGammaL x) lg | (x,lg) <- tableLogGamma ] -- FIXME: loss of precision when logBeta p q ≈ 0. -- Relative error doesn't work properly in this case. , testAssertion "logBeta is expected to be precise at 1e-6 level" $ and [ eq 1e-6 (logBeta p q) (logGammaL p + logGammaL q - logGammaL (p+q)) | p <- [0.1,0.2 .. 0.9] ++ [2 .. 20] , q <- [0.1,0.2 .. 0.9] ++ [2 .. 20] ] , testAssertion "digamma is expected to be precise at 1e-14 [integers]" $ digammaTestIntegers 1e-14 -- Relative precision is lost when digamma(x) ≈ 0 , testAssertion "digamma is expected to be precise at 1e-12" $ and [ eq 1e-12 r (digamma x) | (x,r) <- tableDigamma ] -- FIXME: Why 1e-8? Is it due to poor precision of logBeta? , testAssertion "incompleteBeta is expected to be precise at 1e-8 level" $ and [ eq 1e-8 (incompleteBeta p q x) ib | (p,q,x,ib) <- tableIncompleteBeta ] , testAssertion "incompleteBeta with p > 3000 and q > 3000" $ and [ eq 1e-11 (incompleteBeta p q x) ib | (x,p,q,ib) <- [ (0.495, 3001, 3001, 0.2192546757957825068677527085659175689142653854877723) , (0.501, 3001, 3001, 0.5615652382981522803424365187631195161665429270531389) , (0.531, 3500, 3200, 0.9209758089734407825580172472327758548870610822321278) , (0.501, 13500, 13200, 0.0656209987264794057358373443387716674955276089622780) ] ] , testAssertion "choose is expected to precise at 1e-12 level" $ and [ eq 1e-12 (choose (fromIntegral n) (fromIntegral k)) (fromIntegral $ choose' n k) | n <- [0..300], k <- [0..n]] ---------------------------------------------------------------- -- Self tests , testProperty "Self-test: 0 <= range01 <= 1" $ \x -> let f = range01 x in f <= 1 && f >= 0 ] ---------------------------------------------------------------- -- QC tests ---------------------------------------------------------------- -- Γ(x+1) = x·Γ(x) gammaReccurence :: (Double -> Double) -> Double -> Double -> Property gammaReccurence logG ε x = (x > 0 && x < 100) ==> (abs (g2 - g1 - log x) < ε) where g1 = logG x g2 = logG (x+1) -- γ(s,x) is in [0,1] range incompleteGammaInRange :: Double -> Double -> Property incompleteGammaInRange (abs -> s) (abs -> x) = x >= 0 && s > 0 ==> let i = incompleteGamma s x in i >= 0 && i <= 1 -- γ(1,x) = 1 - exp(-x) -- Since Γ(1) = 1 normalization doesn't make any difference incompleteGammaAt1Check :: Double -> Property incompleteGammaAt1Check (abs -> x) = x > 0 ==> (incompleteGamma 1 x + exp(-x)) ≈ 1 where (≈) = eq 1e-13 -- invIncompleteGamma is inverse of incompleteGamma invIGammaIsInverse :: Double -> Double -> Property invIGammaIsInverse (abs -> a) (range01 -> p) = a > 0 && p > 0 && p < 1 ==> ( printTestCase ("a = " ++ show a ) $ printTestCase ("p = " ++ show p ) $ printTestCase ("x = " ++ show x ) $ printTestCase ("p' = " ++ show p') $ printTestCase ("Δp = " ++ show (p - p')) $ abs (p - p') <= 1e-12 ) where x = invIncompleteGamma a p p' = incompleteGamma a x -- invErfc is inverse of erfc invErfcIsInverse :: Double -> Property invErfcIsInverse ((*2) . range01 -> p) = printTestCase ("p = " ++ show p ) $ printTestCase ("x = " ++ show x ) $ printTestCase ("p' = " ++ show p') $ abs (p - p') <= 1e-14 where x = invErfc p p' = erfc x -- invErf is inverse of erf invErfIsInverse :: Double -> Property invErfIsInverse a = printTestCase ("p = " ++ show p ) $ printTestCase ("x = " ++ show x ) $ printTestCase ("p' = " ++ show p') $ abs (p - p') <= 1e-14 where x = invErf p p' = erf x p | a < 0 = - range01 a | otherwise = range01 a -- B(s,x) is in [0,1] range incompleteBetaInRange :: Double -> Double -> Double -> Property incompleteBetaInRange (abs -> p) (abs -> q) (range01 -> x) = p > 0 && q > 0 ==> let i = incompleteBeta p q x in i >= 0 && i <= 1 -- invIncompleteBeta is inverse of incompleteBeta invIBetaIsInverse :: Double -> Double -> Double -> Property invIBetaIsInverse (abs -> p) (abs -> q) (range01 -> x) = p > 0 && q > 0 ==> ( printTestCase ("p = " ++ show p ) $ printTestCase ("q = " ++ show q ) $ printTestCase ("x = " ++ show x ) $ printTestCase ("x' = " ++ show x') $ printTestCase ("a = " ++ show a) $ printTestCase ("err = " ++ (show $ abs $ (x - x') / x)) $ abs (x - x') <= 1e-12 ) where x' = incompleteBeta p q a a = invIncompleteBeta p q x -- Table for digamma function: -- -- Uses equality ψ(n) = H_{n-1} - γ where -- H_{n} = Σ 1/k, k = [1 .. n] - harmonic number -- γ = 0.57721566490153286060 - Euler-Mascheroni number digammaTestIntegers :: Double -> Bool digammaTestIntegers eps = all (uncurry $ eq eps) $ take 3000 digammaInt where ok approx exact = approx -- Harmonic numbers starting from 0 harmN = scanl (\a n -> a + 1/n) 0 [1::Rational .. ] gam = 0.57721566490153286060 -- Digamma values digammaInt = zipWith (\i h -> (digamma i, realToFrac h - gam)) [1..] harmN ---------------------------------------------------------------- -- Unit tests ---------------------------------------------------------------- -- Lookup table for fact factorial calculation. It has fixed size -- which is bad but it's OK for this particular case factorial_table :: V.Vector Integer factorial_table = V.generate 2000 (\n -> product [1..fromIntegral n]) -- Exact implementation of factorial factorial' :: Integer -> Integer factorial' n = factorial_table ! fromIntegral n -- Exact albeit slow implementation of choose choose' :: Integer -> Integer -> Integer choose' n k = factorial' n `div` (factorial' k * factorial' (n-k)) -- Truncate double to [0,1] range01 :: Double -> Double range01 = abs . (snd :: (Integer, Double) -> Double) . properFraction math-functions-0.1.5.2/tests/Tests/Sum.hs0000644000000000000000000000506312305441036016350 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Tests.Sum (tests) where import Control.Applicative ((<$>)) import Numeric.Sum as Sum import Prelude hiding (sum) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary(..)) import qualified Prelude t_sum :: ([Double] -> Double) -> [Double] -> Bool t_sum f xs = f xs == trueSum xs t_sum_error :: ([Double] -> Double) -> [Double] -> Bool t_sum_error f xs = abs (ts - f xs) <= abs (ts - Prelude.sum xs) where ts = trueSum xs t_sum_shifted :: ([Double] -> Double) -> [Double] -> Bool t_sum_shifted f = t_sum_error f . zipWith (+) badvec trueSum :: (Fractional b, Real a) => [a] -> b trueSum xs = fromRational . Prelude.sum . map toRational $ xs badvec :: [Double] badvec = cycle [1,1e16,-1e16] tests :: Test tests = testGroup "Summation" [ testGroup "ID" [ -- plain summation loses precision quickly -- testProperty "t_sum" $ t_sum (sum id) -- tautological tests: -- testProperty "t_sum_error" $ t_sum_error (sum id) -- testProperty "t_sum_shifted" $ t_sum_shifted (sum id) ] , testGroup "Kahan" [ -- tests that cannot pass: -- testProperty "t_sum" $ t_sum (sum kahan) -- testProperty "t_sum_error" $ t_sum_error (sum kahan) -- kahan summation only beats normal summation with large values testProperty "t_sum_shifted" $ t_sum_shifted (sum kahan) ] , testGroup "KBN" [ testProperty "t_sum" $ t_sum (sum kbn) , testProperty "t_sum_error" $ t_sum_error (sum kbn) , testProperty "t_sum_shifted" $ t_sum_shifted (sum kbn) ] , testGroup "KB2" [ testProperty "t_sum" $ t_sum (sum kb2) , testProperty "t_sum_error" $ t_sum_error (sum kb2) , testProperty "t_sum_shifted" $ t_sum_shifted (sum kb2) ] ] instance Arbitrary KahanSum where arbitrary = toKahan <$> arbitrary shrink = map toKahan . shrink . fromKahan toKahan :: (Double, Double) -> KahanSum toKahan (a,b) = KahanSum a b fromKahan :: KahanSum -> (Double, Double) fromKahan (KahanSum a b) = (a,b) instance Arbitrary KBNSum where arbitrary = toKBN <$> arbitrary shrink = map toKBN . shrink . fromKBN toKBN :: (Double, Double) -> KBNSum toKBN (a,b) = KBNSum a b fromKBN :: KBNSum -> (Double, Double) fromKBN (KBNSum a b) = (a,b) instance Arbitrary KB2Sum where arbitrary = toKB2 <$> arbitrary shrink = map toKB2 . shrink . fromKB2 toKB2 :: (Double, Double, Double) -> KB2Sum toKB2 (a,b,c) = KB2Sum a b c fromKB2 :: KB2Sum -> (Double, Double, Double) fromKB2 (KB2Sum a b c) = (a,b,c) math-functions-0.1.5.2/tests/Tests/SpecFunctions/0000755000000000000000000000000012305441036020027 5ustar0000000000000000math-functions-0.1.5.2/tests/Tests/SpecFunctions/gen.py0000644000000000000000000000354312305441036021157 0ustar0000000000000000#!/usr/bin/python """ """ from mpmath import * import random # Set very-very large precision mp.dps = 100 # Set fixed seed in order to get repeatable results random.seed( 279570842 ) def printListLiteral(lines) : print " [" + "\n , ".join(lines) + "\n ]" ################################################################ # Generate header print "module Tests.SpecFunctions.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 ]) ################################################################ ## Generate table for digamma print "tableDigamma :: [(Double,Double)]" print "tableDigamma =" printListLiteral( [ '(%.16f, %.20g)' % (x, digamma(x)) for x in [ random.expovariate(0.1) for i in xrange(100) ] ] ) math-functions-0.1.5.2/tests/Tests/SpecFunctions/Tables.hs0000644000000000000000000001625412305441036021605 0ustar0000000000000000module Tests.SpecFunctions.Tables where tableLogGamma :: [(Double,Double)] tableLogGamma = [(0.000001250000000, 13.592366285131767256) , (0.000068200000000, 9.5930266308318756785) , (0.000246000000000, 8.3100370767447948595) , (0.000880000000000, 7.0350813373524845318) , (0.003120000000000, 5.7681293583655666168) , (0.026700000000000, 3.6082588918892972707) , (0.077700000000000, 2.5148371858768232556) , (0.234000000000000, 1.3579557559432757774) , (0.860000000000000, 0.098146578027685588141) , (1.340000000000000, -0.11404757557207759189) , (1.890000000000000, -0.042511642297870140539) , (2.450000000000000, 0.25014296569217620014) , (3.650000000000000, 1.3701041997380685178) , (4.560000000000000, 2.5375143317949575561) , (6.660000000000000, 5.9515377269550207018) , (8.250000000000000, 9.0331869196051215454) , (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.7726498250704) , (34500.000000000000000, 325976.34838781820145) , (82340.000000000000000, 849629.79603036714252) , (234800.000000000000000, 2668846.4390507955104) , (834300.000000000000000, 10540830.912557533011) , (1230000.000000000000000, 16017699.322315014899) ] tableIncompleteBeta :: [(Double,Double,Double,Double)] tableIncompleteBeta = [(2.000000000000000, 3.000000000000000, 0.030000000000000, 0.0051864299999999988189) , (2.000000000000000, 3.000000000000000, 0.230000000000000, 0.22845923000000001313) , (2.000000000000000, 3.000000000000000, 0.760000000000000, 0.95465727999999994147) , (4.000000000000000, 2.300000000000000, 0.890000000000000, 0.93829812158347791762) , (1.000000000000000, 1.000000000000000, 0.550000000000000, 0.55000000000000004441) , (0.300000000000000, 12.199999999999999, 0.110000000000000, 0.95063000053947066537) , (13.100000000000000, 9.800000000000001, 0.120000000000000, 1.3483109941962659385e-07) , (13.100000000000000, 9.800000000000001, 0.420000000000000, 0.071321857831804780226) , (13.100000000000000, 9.800000000000001, 0.920000000000000, 0.99999578339197070509) ] tableDigamma :: [(Double,Double)] tableDigamma = [(10.0261172557341425, 2.2544954834170942704) , (0.9070101446062873, -0.74152778337908598072) , (3.4679213262860156, 1.0925031389314479036) , (28.5703089405901878, 3.3347652650101657912) , (5.9700184459319399, 1.7006665338476731897) , (20.5303177686997920, 2.9973508205248808878) , (5.6622605630542511, 1.6429280447671743559) , (4.4741465342999014, 1.3824198603491071324) , (21.4416006516504787, 3.0418326144933285349) , (47.6946291432301663, 3.8542988022858128971) , (11.2357450115053670, 2.37393979612347783) , (0.3352840110772935, -3.1124447967622668187) , (2.5037441860153118, 0.70499097759044615508) , (0.5241560861477529, -1.8489960634174653631) , (0.1972018552655726, -5.3635382066874592866) , (0.8289440927562556, -0.90024805153750442344) , (2.0717397641759350, 0.4680412969073853291) , (9.1173553049782452, 2.1543380160183831507) , (1.1815938184339669, -0.31262126373727594508) , (7.3600347508772019, 1.9265946441432049152) , (19.7457045917841398, 2.9574003365402390386) , (4.1956416643620571, 1.3101672771843546617) , (7.3868205159465790, 1.9304848277860633399) , (1.2786090750546355, -0.19373178842778399078) , (10.6498308581562604, 2.3178608134278069208) , (10.6750266252851169, 2.3203381265132185796) , (10.6883248506773985, 2.3216431742802625671) , (14.3373372205836365, 2.6275879484098640937) , (3.3932538441985769, 1.0672611106295626371) , (11.4168205413938768, 2.3906538776946248959) , (3.2500957742991048, 1.0170253699094919941) , (2.7573211981404855, 0.82209952378707851217) , (21.8943170241258827, 3.063216323919045081) , (16.7950471612825254, 2.7910180230044043803) , (9.2578640399661225, 2.1704940538770385317) , (5.3213868642873896, 1.5748408574979930741) , (9.4381079039564071, 2.1908443398518979706) , (13.1568457441413429, 2.538458049596743038) , (10.6478950333943825, 2.3176702242110884811) , (6.4894496431749733, 1.7911554320176725774) , (20.3998669454332315, 2.9908182167188113176) , (3.6989463639934752, 1.1668268193484248041) , (3.4716258279958572, 1.093739186127963281) , (24.7013029455164919, 3.1864775907749920414) , (1.1608524325026863, -0.33982067949719851896) , (1.9482800424522431, 0.3888762195060542215) , (30.4956621109554185, 3.4010990755913685923) , (16.3105956379859052, 2.7608468922073350349) , (10.6908820268137070, 2.3218939328714371939) , (3.4369121607821915, 1.082096765647714065) , (2.2914619096171260, 0.5953971130541900747) , (24.1273989930028883, 3.1624816269998849982) , (14.9455957898231535, 2.6705890837495616097) , (32.2002179941400826, 3.4563650137673369578) , (1.7232417075599473, 0.22682264125689588496) , (9.9662376350778192, 2.248195612105357899) , (10.9702870318273966, 2.348920912357223223) , (18.8934063317711676, 2.912115343761407793) , (8.6720493874148570, 2.1013420151521415846) , (20.4905634096258815, 2.9953645521238549954) , (1.4654265058258678, 0.0036653372399428492921) , (15.4401781010745509, 2.7042406258657996077) , (13.6688064138713390, 2.5780909087521290957) , (2.4073661551765566, 0.65668881914974130964) , (0.8108729056729371, -0.94026521559981879328) , (29.5024809785193902, 3.367430902728568487) , (7.5321882978878660, 1.9513375601887514854) , (3.3716588961200955, 1.0598414578703589939) , (2.9310065630306474, 0.89516303667430119351) , (7.2023118361897769, 1.9033764996201536501) , (3.1362387322050900, 0.97520764792577085966) , (6.5709053027851487, 1.8046329737306385788) , (3.7348491113356177, 1.1779005641199544741) , (1.2328105814385013, -0.24823346907893503732) , (7.9098387372709587, 2.0035651569967258823) , (2.8590898311999715, 0.86554629114604864082) , (2.1964374279534344, 0.54225028515290207842) , (3.8933394033155189, 1.2253803767351847398) , (10.7410508007627694, 2.3268008547643748152) , (2.4921048837305193, 0.69927782909414781809) , (2.2101710538553756, 0.55010424351998354897) , (14.0357118427322334, 2.6055587167248708269) , (4.1320729121597584, 1.2929216807716104043) , (0.2766365979680845, -3.8108738889017752527) , (27.9448247140513644, 3.3122329205038494315) , (9.3081256750537182, 2.1762105230057038341) , (1.4222181352589696, -0.038843893649701873028) , (1.5107587188614726, 0.046499571962236106726) , (3.3467578222470555, 1.0512176183500512305) , (12.2373583939228876, 2.4630788434421742039) , (0.9385094944630431, -0.68317598609698348966) , (5.8655552400886410, 1.6814385243672138603) , (17.1377048621110468, 2.8118219246156086477) , (4.0502102843199079, 1.2702685434611069581) , (2.2041235084734976, 0.54665320805956585382) , (0.9498749870396368, -0.66283138696545962354) , (5.5020466797149687, 1.6115010556650317675) , (1.8741725410778542, 0.33826100356492333487) , (14.1730624058772161, 2.6156503142962224118) , (1.0704026637921555, -0.46701211139417769802) ]