math-functions-0.3.1.0/0000755000000000000000000000000013372631456013010 5ustar0000000000000000math-functions-0.3.1.0/changelog.md0000644000000000000000000000556213372631456015271 0ustar0000000000000000## Changes in 0.3.1.0 * Exported data types for iteration steps in root finding * Defaults for root finding algorithm are documented ## Changes in 0.3.0.2 * Fix license field in cabal file ## Changes in 0.3.0.0 * `Semigroup` and `Monoid` instances added for data types from `Numeric.Sum` * API for finding roots of real functions reworked. 1) All algorithm parameters are now tweakable. 2) Functions for getting list of iterations added. * `Foldable` and `Traversable` instances for `Root` were added. ## Changes in 0.2.1.0 * `log1p` and `expm1` are simply reexported from `GHC.Float`. They're methods of `Floating` type class. * On windows `expm1` is implemented in pure haskell for older GHCs. ## Changes in 0.2.0.0 * Bug fixes and documentation tweaks ## Changes in 0.2.0.0 * `logGamma` now uses Lancsoz approximation and same as `logGammaL`. Old implementation of `logGamma` moved to `Numeric.SpecFunctions.Extra.logGammaAS245`. * Precision of `logGamma` for z<1 improved. * New much more precise implementation for `incompleteGamma` * Dependency on `erf` package dropped. `erf` and `erfc` just do direct calls to C. * `Numeric.SpecFunctions.expm1` added * `Numeric.SpecFunctions.log1pmx` added. * `logGammaCorrection` exported in `Numeric.SpecFunctions.Extra`. * Module `Numeric.Series` added for working with infinite sequences, series summation and evaluation of continued fractions. * Module `statistics: Statistics.Math.RootFinding` copied to `Numeric.RootFinding`. Instances for `binary` and `aeson` dropped. * Root-finding using Newton-Raphson added * `Numeric.MathFunctions.Comparison.ulpDelta` added. It calculates signed distance between two doubles. * Other bug fixes. ## Changes in 0.1.7.0 * Module `statistics: Statistics.Function.Comparison` moved to `Numeric.MathFunctions.Comparison`. Old implementation if `within` compared negative numbers incorrectly. * `addUlps` and `ulpDistance` added to `Numeric.MathFunctions.Comparison`. * `relativeError` and `eqRelErr` added to `Numeric.MathFunctions.Comparison`. * Precision of `logFactorial` is slightly improved. ## Changes in 0.1.6.0 * `logChoose` added for calculation of logarithm of binomial coefficient * `chooseExact` and `logChooseFast` added * `sinc` added ## Changes in 0.1.5.3 * Fix for test suite on 32bit platform ## 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.3.1.0/Setup.hs0000644000000000000000000000005613372631456014445 0ustar0000000000000000import Distribution.Simple main = defaultMain math-functions-0.3.1.0/math-functions.cabal0000644000000000000000000000617613372631456016745 0ustar0000000000000000name: math-functions version: 0.3.1.0 cabal-version: >= 1.10 license: BSD2 license-file: LICENSE author: Bryan O'Sullivan , Alexey Khudyakov maintainer: Alexey Khudyakov homepage: https://github.com/bos/math-functions bug-reports: https://github.com/bos/math-functions/issues category: Math, Numeric build-type: Simple synopsis: Collection of tools for numeric computations description: This library contain collection of various utilities for numerical computing. So far there're special mathematical functions, compensated summation algorithm, summation of series, root finding for real functions, polynomial summation and Chebyshev polynomials. extra-source-files: changelog.md README.markdown tests/*.hs tests/Tests/*.hs tests/Tests/SpecFunctions/gen.py doc/sinc.hs library default-language: Haskell2010 other-extensions: BangPatterns CPP DeriveDataTypeable FlexibleContexts MultiParamTypeClasses ScopedTypeVariables TemplateHaskell TypeFamilies DeriveGeneric ghc-options: -Wall -O2 build-depends: base >= 4.5 && < 5 , deepseq , data-default-class >= 0.1.2.0 , vector >= 0.7 , primitive , vector-th-unbox >= 0.2.1.6 if flag(system-expm1) || !os(windows) cpp-options: -DUSE_SYSTEM_EXPM1 exposed-modules: Numeric.MathFunctions.Constants Numeric.MathFunctions.Comparison Numeric.Polynomial Numeric.Polynomial.Chebyshev Numeric.RootFinding Numeric.SpecFunctions Numeric.SpecFunctions.Extra Numeric.Series Numeric.Sum other-modules: Numeric.SpecFunctions.Internal flag system-expm1 description: Use expm1 provided by system. Only have effect on windows default: False manual: True test-suite tests default-language: Haskell2010 other-extensions: ViewPatterns type: exitcode-stdio-1.0 ghc-options: -Wall -threaded if arch(i386) -- The Sum tests require SSE2 on i686 to pass (because of excess precision) ghc-options: -msse2 hs-source-dirs: tests main-is: tests.hs other-modules: Tests.Helpers Tests.Chebyshev Tests.Comparison Tests.RootFinding Tests.SpecFunctions Tests.SpecFunctions.Tables Tests.Sum build-depends: base >=4.5 && <5 , math-functions , data-default-class >= 0.1.2.0 , deepseq , primitive , vector >= 0.7 , vector-th-unbox , erf , HUnit >= 1.2 , QuickCheck >= 2.7 , 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.3.1.0/LICENSE0000644000000000000000000000246113372631456014020 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.3.1.0/README.markdown0000644000000000000000000000262713372631456015520 0ustar0000000000000000# math-functions: collection of tools for numeric computations [![Build Status](https://travis-ci.org/Shimuuar/math-functions.png?branch=master)](https://travis-ci.org/Shimuuar/math-functions) [![Build status](https://ci.appveyor.com/api/projects/status/6xexxj9g6rnbg2q4/branch/master?svg=true)](https://ci.appveyor.com/project/Shimuuar/math-functions/branch/master) This package provides collection of various tools for numeric computations. Namely: - Number pure haskell implementations of special function which are used in statistical and numerical computing. - Compensated summation (Kahan summation) which allows to - Root finding for functions of single real variable - Series summation - Functions for comparing IEEE754 numbers 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.3.1.0/tests/0000755000000000000000000000000013372631456014152 5ustar0000000000000000math-functions-0.3.1.0/tests/tests.hs0000644000000000000000000000104013372631456015643 0ustar0000000000000000import Test.Framework (defaultMain) import qualified Tests.Chebyshev import qualified Tests.Comparison import qualified Tests.RootFinding import qualified Tests.SpecFunctions import qualified Tests.Sum main :: IO () main = defaultMain [ Tests.SpecFunctions.tests -- FIXME: tests for chebyshev polynomials fail intermittently -- , Tests.Chebyshev.tests , Tests.Sum.tests , Tests.Comparison.tests , Tests.RootFinding.tests ] math-functions-0.3.1.0/tests/Tests/0000755000000000000000000000000013372631456015254 5ustar0000000000000000math-functions-0.3.1.0/tests/Tests/Comparison.hs0000644000000000000000000000321213372631456017720 0ustar0000000000000000-- | -- Tests for approximate comparison module Tests.Comparison (tests) where import Test.Framework import Test.Framework.Providers.QuickCheck2 import Tests.Helpers import Numeric.MathFunctions.Comparison import Numeric.MathFunctions.Constants (m_epsilon) tests :: Test tests = testGroup "Comparison" [ testProperty "addUlps 0" $ \x -> x == addUlps 0 x , testProperty "addUlps sym" $ \i x -> x == (addUlps (-i) . addUlps i) x , testProperty "ulpDistance==0" $ \x -> ulpDistance x x == 0 , testProperty "ulpDistance sym" $ \x y -> ulpDistance x y == ulpDistance y x , testProperty "ulpDistance/addUlps" $ \x i -> ulpDistance x (addUlps i x) == fromIntegral (abs i) -- Test that code is correct for m_epsilon , testAssertion "eps distance" $ ulpDistance 1 (1+m_epsilon) == 1 , testAssertion "eps add" $ addUlps 1 1 == 1 + m_epsilon -- , testProperty "relativeError sym" $ \x y -> relativeError x y == relativeError y x , testAssertion "relativeError inf 1" $ isNaN $ relativeError inf 1 , testAssertion "relativeError 1 inf" $ isNaN $ relativeError 1 inf , testAssertion "relativeError -inf 1" $ isNaN $ relativeError (-inf) 1 , testAssertion "relativeError 1 -inf" $ isNaN $ relativeError 1 (-inf) , testAssertion "relativeError inf inf" $ isNaN $ relativeError inf inf , testAssertion "relativeError inf-inf" $ isNaN $ relativeError inf (-inf) , testAssertion "relativeError 1 Nan" $ isNaN $ relativeError 1 nan , testAssertion "relativeError NaN 1" $ isNaN $ relativeError nan 1 , testAssertion "relativeError NaN Nan" $ isNaN $ relativeError nan nan ] where inf = 1/0 nan = 0/0 math-functions-0.3.1.0/tests/Tests/Helpers.hs0000644000000000000000000000403613372631456017215 0ustar0000000000000000-- | Helpers for testing module Tests.Helpers ( -- * helpers T(..) , typeName , eq , eqC -- * Generic QC tests , monotonicallyIncreases -- * HUnit helpers , testAssertion , testEquality ) where import Data.Complex import Data.Typeable import qualified Test.HUnit as HU import Test.Framework import Test.Framework.Providers.HUnit import Numeric.MathFunctions.Comparison ---------------------------------------------------------------- -- 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 = eqRelErr -- | 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) ---------------------------------------------------------------- -- 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.3.1.0/tests/Tests/Sum.hs0000644000000000000000000000506313372631456016360 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.3.1.0/tests/Tests/RootFinding.hs0000644000000000000000000000323413372631456020034 0ustar0000000000000000-- | module Tests.RootFinding ( tests ) where import Data.Default.Class import Test.Framework import Test.Framework.Providers.HUnit import Numeric.RootFinding import Tests.Helpers tests :: Test tests = testGroup "Root finding" [ testGroup "Ridders" [ testAssertion "sin x - 0.525 [exact]" $ testRiddersSin0_525 (AbsTol 0) , testAssertion "sin x - 0.525 [abs 1e-12]" $ testRiddersSin0_525 (AbsTol 1e-12) , testAssertion "sin x - 0.525 [abs 1e-6]" $ testRiddersSin0_525 (AbsTol 1e-6) , testAssertion "sin x - 0.525 [rel 1e-12]" $ testRiddersSin0_525 (RelTol 1e-12) , testAssertion "sin x - 0.525 [rel 1e-6]" $ testRiddersSin0_525 (RelTol 1e-6) ] , testGroup "Newton-Raphson" [ testAssertion "sin x - 0.525 [rel 1e-12]" $ testNewtonSin0_525 (RelTol 1e-12) , testAssertion "sin x - 0.525 [rel 1e-6]" $ testNewtonSin0_525 (RelTol 1e-6) , testAssertion "sin x - 0.525 [abs 1e-12]" $ testNewtonSin0_525 (AbsTol 1e-12) , testAssertion "sin x - 0.525 [abs 1e-6]" $ testNewtonSin0_525 (AbsTol 1e-6) , testAssertion "1/x - 0.5 [0]" $ let Root r = newtonRaphson def{newtonTol=RelTol 0} (1,1000,1000) (\x -> (1/x - 0.5, -1/(x*x))) in r == 2 ] ] where -- Exact root for equation: sin x - 0.525 = 0 exactRoot = 0.5527151130967832 -- testRiddersSin0_525 tol = withinTolerance tol r exactRoot where Root r = ridders def{riddersTol = tol} (0, pi/2) (\x -> sin x - 0.525) -- testNewtonSin0_525 tol = withinTolerance tol r exactRoot where Root r = newtonRaphson def{newtonTol=tol} (0, pi/4, pi/2) (\x -> (sin x - 0.525, cos x)) math-functions-0.3.1.0/tests/Tests/SpecFunctions.hs0000644000000000000000000002253613372631456020403 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,within) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.Framework.Providers.HUnit import Test.HUnit (assertBool) import Tests.Helpers import Tests.SpecFunctions.Tables import Numeric.SpecFunctions import Numeric.MathFunctions.Comparison (within,relativeError) import Numeric.MathFunctions.Constants (m_epsilon,m_tiny) 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 , testProperty "invIncompleteGamma = gamma^-1" $ invIGammaIsInverse -- XXX FIXME DISABLED due to failures -- , testProperty "invIncompleteBeta = B^-1" $ invIBetaIsInverse , testProperty "gamma - increases" $ \(abs -> s) (abs -> x) (abs -> y) -> s > 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]] , testAssertion "logGammaL is expected to be precise at 1e-10 level [fractional points]" $ and [ eq (64*m_epsilon) (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 ] -- , let deviations = [ ( "p=",p, "q=",q, "x=",x , "ib=",ib, "ib'=",ib' , "err=",relativeError ib ib' / m_epsilon) | (p,q,x,ib) <- tableIncompleteBeta , let ib' = incompleteBeta p q x , not $ eq (64 * m_epsilon) ib' ib ] in testCase "incompleteBeta is expected to be precise at 32*m_epsilon level" $ assertBool (unlines (map show deviations)) (null deviations) , 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..1000], k <- [0..n]] , testAssertion "logChoose == log . choose" $ and [ let n' = fromIntegral n k' = fromIntegral k in within 2 (logChoose n' k') (log $ choose n' k') | n <- [0::Int .. 1000], 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 > m_tiny && p > m_tiny && p < 1 ==> ( counterexample ("a = " ++ show a ) $ counterexample ("p = " ++ show p ) $ counterexample ("x = " ++ show x ) $ counterexample ("p' = " ++ show p') $ counterexample ("err = " ++ show (relativeError p p')) $ counterexample ("pred = " ++ show δ) $ relativeError p p' < δ ) where x = invIncompleteGamma a p f' = exp ( log x * (a-1) - x - logGamma a) p' = incompleteGamma a x -- FIXME: 128 is big constant. It should be replaced by something -- smaller when #42 is fixed δ = (m_epsilon/2) * (256 + 1 * (1 + abs (x * f' / p))) -- invErfc is inverse of erfc invErfcIsInverse :: Double -> Property invErfcIsInverse ((*2) . range01 -> p) = counterexample ("p = " ++ show p ) $ counterexample ("x = " ++ show x ) $ counterexample ("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 = counterexample ("p = " ++ show p ) $ counterexample ("x = " ++ show x ) $ counterexample ("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 ==> ( counterexample ("p = " ++ show p ) $ counterexample ("q = " ++ show q ) $ counterexample ("x = " ++ show x ) $ counterexample ("x' = " ++ show x') $ counterexample ("a = " ++ show a) $ counterexample ("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.3.1.0/tests/Tests/Chebyshev.hs0000644000000000000000000000447313372631456017540 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(..),counterexample,Property) import Tests.Helpers import Numeric.Polynomial.Chebyshev import Numeric.MathFunctions.Comparison tests :: Test tests = testGroup "Chebyshev polynomials" [ testProperty "Chebyshev 0" $ \a0 (Ch x) -> testCheb [a0] x , 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] -> Property testBroucke _ [] = counterexample "" True testBroucke (Ch x) (c:cs) = counterexample (">>> Chebyshev = " ++ show c1) $ counterexample (">>> Brouke = " ++ show cb) $ counterexample (">>> rel.err. = " ++ show (relativeError c1 cb)) $ counterexample (">>> diff. ulps = " ++ show (ulpDistance c1 cb)) $ within 64 c1 cb where c1 = chebyshev x (fromList $ c : cs) cb = chebyshevBroucke x (fromList $ c*2 : cs) testCheb :: [Double] -> Double -> Property testCheb as x = counterexample (">>> Exact = " ++ show exact) $ counterexample (">>> Numeric = " ++ show num ) $ counterexample (">>> rel.err. = " ++ show err ) $ counterexample (">>> diff. ulps = " ++ show (ulpDistance num exact)) $ eq 1e-12 num exact where exact = evalCheb as x num = chebyshev x (fromList as) err = relativeError num 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.3.1.0/tests/Tests/SpecFunctions/0000755000000000000000000000000013372631456020037 5ustar0000000000000000math-functions-0.3.1.0/tests/Tests/SpecFunctions/gen.py0000644000000000000000000000354313372631456021167 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.3.1.0/tests/Tests/SpecFunctions/Tables.hs0000644000000000000000000001625413372631456021615 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) ] math-functions-0.3.1.0/doc/0000755000000000000000000000000013372631456013555 5ustar0000000000000000math-functions-0.3.1.0/doc/sinc.hs0000644000000000000000000000142013372631456015042 0ustar0000000000000000-- Description of choice of approximation boundaries in sinc function module Sinc where import Numeric.MathFunctions.Constants (m_epsilon) -- Approximations for sinc up to 6th order and "exact" implementation f2,f4,f6,f :: Double -> Double f2 x = 1 - x*x/6 f4 x = 1 - x*x/6 + x*x*x*x/120 f6 x = 1 - x*x/6 + x*x*x*x/120 - x*x*x*x*x*x/5040 f x = sin x / x -- When next term becomes so small that (1-e)==1 we can neglect it: e0,e2,e4 :: Double e0 = sqrt (6 * m_epsilon / 4) e2 = (30 * m_epsilon) ** (1/4) / 2 e4 = (1260 * m_epsilon) ** (1/6) / 2 test :: IO () test = do print ("e0",e0) print $ f e0 == 1 print $ f2 e0 == 1 -- print ("e2",e2) print $ f e2 == f2 e2 print $ f2 e2 == f4 e2 -- print ("e4",e4) print $ f e4 == f4 e4 print $ f4 e4 == f6 e4 math-functions-0.3.1.0/Numeric/0000755000000000000000000000000013372631456014412 5ustar0000000000000000math-functions-0.3.1.0/Numeric/Series.hs0000644000000000000000000001175513372631456016211 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Numeric.Series -- Copyright : (c) 2016 Alexey Khudyakov -- License : BSD3 -- -- Maintainer : alexey.skladnoy@gmail.com, bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Functions for working with infinite sequences. In particular -- summation of series and evaluation of continued fractions. module Numeric.Series ( -- * Data type for infinite sequences. Sequence(..) -- * Constructors , enumSequenceFrom , enumSequenceFromStep , scanSequence -- * Summation of series , sumSeries , sumPowerSeries , sequenceToList -- * Evaluation of continued fractions , evalContFractionB ) where import Control.Applicative import Data.List (unfoldr) import Numeric.MathFunctions.Constants (m_epsilon) ---------------------------------------------------------------- -- | Infinite series. It's represented as opaque state and step -- function. data Sequence a = forall s. Sequence s (s -> (a,s)) instance Functor Sequence where fmap f (Sequence s0 step) = Sequence s0 (\s -> let (a,s') = step s in (f a, s')) {-# INLINE fmap #-} instance Applicative Sequence where pure a = Sequence () (\() -> (a,())) Sequence sA fA <*> Sequence sB fB = Sequence (sA,sB) $ \(!sa,!sb) -> let (a,sa') = fA sa (b,sb') = fB sb in (a b, (sa',sb')) {-# INLINE pure #-} {-# INLINE (<*>) #-} -- | Elementwise operations with sequences instance Num a => Num (Sequence a) where (+) = liftA2 (+) (*) = liftA2 (*) (-) = liftA2 (-) {-# INLINE (+) #-} {-# INLINE (*) #-} {-# INLINE (-) #-} abs = fmap abs signum = fmap signum fromInteger = pure . fromInteger {-# INLINE abs #-} {-# INLINE signum #-} {-# INLINE fromInteger #-} -- | Elementwise operations with sequences instance Fractional a => Fractional (Sequence a) where (/) = liftA2 (/) recip = fmap recip fromRational = pure . fromRational {-# INLINE (/) #-} {-# INLINE recip #-} {-# INLINE fromRational #-} ---------------------------------------------------------------- -- Constructors ---------------------------------------------------------------- -- | @enumSequenceFrom x@ generate sequence: -- -- \[ a_n = x + n \] enumSequenceFrom :: Num a => a -> Sequence a enumSequenceFrom i = Sequence i (\n -> (n,n+1)) {-# INLINE enumSequenceFrom #-} -- | @enumSequenceFromStep x d@ generate sequence: -- -- \[ a_n = x + nd \] enumSequenceFromStep :: Num a => a -> a -> Sequence a enumSequenceFromStep n d = Sequence n (\i -> (i,i+d)) {-# INLINE enumSequenceFromStep #-} -- | Analog of 'scanl' for sequence. scanSequence :: (b -> a -> b) -> b -> Sequence a -> Sequence b {-# INLINE scanSequence #-} scanSequence f b0 (Sequence s0 step) = Sequence (b0,s0) $ \(b,s) -> let (a,s') = step s b' = f b a in (b,(b',s')) ---------------------------------------------------------------- -- Evaluation of series ---------------------------------------------------------------- -- | Calculate sum of series -- -- \[ \sum_{i=0}^\infty a_i \] -- -- Summation is stopped when -- -- \[ a_{n+1} < \varepsilon\sum_{i=0}^n a_i \] -- -- where ε is machine precision ('m_epsilon') sumSeries :: Sequence Double -> Double {-# INLINE sumSeries #-} sumSeries (Sequence sInit step) = go x0 s0 where (x0,s0) = step sInit go x s | abs (d/x) >= m_epsilon = go x' s' | otherwise = x' where (d,s') = step s x' = x + d -- | Calculate sum of series -- -- \[ \sum_{i=0}^\infty x^ia_i \] -- -- Calculation is stopped when next value in series is less than -- ε·sum. sumPowerSeries :: Double -> Sequence Double -> Double sumPowerSeries x ser = sumSeries $ liftA2 (*) (scanSequence (*) 1 (pure x)) ser {-# INLINE sumPowerSeries #-} -- | Convert series to infinite list sequenceToList :: Sequence a -> [a] sequenceToList (Sequence s f) = unfoldr (Just . f) s ---------------------------------------------------------------- -- Evaluation of continued fractions ---------------------------------------------------------------- -- | -- Evaluate continued fraction using modified Lentz algorithm. -- Sequence contain pairs (a[i],b[i]) which form following expression: -- -- \[ -- b_0 + \frac{a_1}{b_1+\frac{a_2}{b_2+\frac{a_3}{b_3 + \cdots}}} -- \] -- -- Modified Lentz algorithm is described in Numerical recipes 5.2 -- "Evaluation of Continued Fractions" evalContFractionB :: Sequence (Double,Double) -> Double {-# INLINE evalContFractionB #-} evalContFractionB (Sequence sInit step) = let ((_,b0),s0) = step sInit f0 = maskZero b0 in go f0 f0 0 s0 where tiny = 1e-60 maskZero 0 = tiny maskZero x = x go f c d s | abs (delta - 1) >= m_epsilon = go f' c' d' s' | otherwise = f' where ((a,b),s') = step s d' = recip $ maskZero $ b + a*d c' = maskZero $ b + a/c delta = c'*d' f' = f*delta math-functions-0.3.1.0/Numeric/Sum.hs0000644000000000000000000002201613372631456015513 0ustar0000000000000000{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, CPP #-} {-# 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.Monoid (Monoid(..)) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..)) #endif import Data.Vector.Generic (Vector(..), foldl') import Data.Vector.Unboxed.Deriving (derivingUnbox) -- Needed for GHC 7.2 & 7.4 to derive Unbox instances import Data.Vector.Generic.Mutable (MVector(..)) 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 !_ = () instance Monoid KahanSum where mempty = zero s `mappend` KahanSum s' _ = add s s' #if MIN_VERSION_base(4,9,0) instance Semigroup KahanSum where (<>) = mappend #endif 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 !_ = () instance Monoid KBNSum where mempty = zero s `mappend` KBNSum s' c' = add (add s s') c' #if MIN_VERSION_base(4,9,0) instance Semigroup KBNSum where (<>) = mappend #endif 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 !_ = () instance Monoid KB2Sum where mempty = zero s `mappend` KB2Sum s' c' cc' = add (add (add s s') c') cc' #if MIN_VERSION_base(4,9,0) instance Semigroup KB2Sum where (<>) = mappend #endif 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.3.1.0/Numeric/RootFinding.hs0000644000000000000000000003442213372631456017175 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Numeric.RootFinding -- Copyright : (c) 2011 Bryan O'Sullivan, 2018 Alexey Khudyakov -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Haskell functions for finding the roots of real functions of real -- arguments. These algorithms are iterative so we provide both -- function returning root (or failure to find root) and list of -- iterations. module Numeric.RootFinding ( -- * Data types Root(..) , fromRoot , Tolerance(..) , withinTolerance , IterationStep(..) , findRoot -- * Ridders algorithm , RiddersParam(..) , ridders , riddersIterations , RiddersStep(..) -- * Newton-Raphson algorithm , NewtonParam(..) , newtonRaphson , newtonRaphsonIterations , NewtonStep(..) -- * References -- $references ) where import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad (MonadPlus(..), ap) import Control.DeepSeq (NFData(..)) import Data.Data (Data, Typeable) import Data.Monoid (Monoid(..)) import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Data.Default.Class #if __GLASGOW_HASKELL__ > 704 import GHC.Generics (Generic) #endif import Numeric.MathFunctions.Comparison (within,eqRelErr) import Numeric.MathFunctions.Constants (m_epsilon) ---------------------------------------------------------------- -- Data types ---------------------------------------------------------------- -- | 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, Foldable, Traversable #if __GLASGOW_HASKELL__ > 704 , Generic #endif ) instance (NFData a) => NFData (Root a) where rnf NotBracketed = () rnf SearchFailed = () rnf (Root a) = rnf a instance Functor Root where fmap _ NotBracketed = NotBracketed fmap _ SearchFailed = SearchFailed fmap f (Root a) = Root (f a) instance Applicative Root where pure = return (<*>) = ap instance Monad Root where NotBracketed >>= _ = NotBracketed SearchFailed >>= _ = SearchFailed Root a >>= f = f a return = Root instance MonadPlus Root where mzero = empty mplus = (<|>) instance Alternative Root where empty = NotBracketed r@Root{} <|> _ = r _ <|> r@Root{} = r NotBracketed <|> r = r r <|> NotBracketed = r _ <|> r = r -- | 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 -- | Error tolerance for finding root. It describes when root finding -- algorithm should stop trying to improve approximation. data Tolerance = RelTol !Double -- ^ Relative error tolerance. Given @RelTol ε@ two values are -- considered approximately equal if -- \[ \frac{|a - b|}{|\operatorname{max}(a,b)} < \varepsilon \] | AbsTol !Double -- ^ Absolute error tolerance. Given @AbsTol δ@ two values are -- considered approximately equal if \[ |a - b| < \delta \]. -- Note that @AbsTol 0@ could be used to require to find -- approximation within machine precision. deriving (Eq, Read, Show, Typeable, Data #if __GLASGOW_HASKELL__ > 704 , Generic #endif ) -- | Check that two values are approximately equal. In addition to -- specification values are considered equal if they're within 1ulp -- of precision. No further improvement could be done anyway. withinTolerance :: Tolerance -> Double -> Double -> Bool withinTolerance _ a b | within 1 a b = True withinTolerance (RelTol eps) a b = eqRelErr eps a b withinTolerance (AbsTol tol) a b = abs (a - b) < tol -- | Type class for checking whether iteration converged already. class IterationStep a where -- | Return @Just root@ is current iteration converged within -- required error tolerance. Returns @Nothing@ otherwise. matchRoot :: Tolerance -> a -> Maybe (Root Double) -- | Find root in lazy list of iterations. findRoot :: IterationStep a => Int -- ^ Maximum -> Tolerance -- ^ Error tolerance -> [a] -> Root Double findRoot maxN tol = go 0 where go !i _ | i >= maxN = SearchFailed go !_ [] = SearchFailed go i (x:xs) = case matchRoot tol x of Just r -> r Nothing -> go (i+1) xs {-# INLINABLE findRoot #-} {-# SPECIALIZE findRoot :: Int -> Tolerance -> [RiddersStep] -> Root Double #-} {-# SPECIALIZE findRoot :: Int -> Tolerance -> [NewtonStep] -> Root Double #-} ---------------------------------------------------------------- -- Attaching information to roots ---------------------------------------------------------------- -- | Parameters for 'ridders' root finding data RiddersParam = RiddersParam { riddersMaxIter :: !Int -- ^ Maximum number of iterations. Default = 100 , riddersTol :: !Tolerance -- ^ Error tolerance for root approximation. Default is relative -- error 4·ε, where ε is machine precision. } deriving (Eq, Read, Show, Typeable, Data #if __GLASGOW_HASKELL__ > 704 , Generic #endif ) instance Default RiddersParam where def = RiddersParam { riddersMaxIter = 100 , riddersTol = RelTol (4 * m_epsilon) } -- | Single Ridders step. It's a bracket of root data RiddersStep = RiddersStep !Double !Double -- ^ Ridders step. Parameters are bracket for the root | RiddersBisect !Double !Double -- ^ Bisection step. It's fallback which is taken when Ridders -- update takes us out of bracket | RiddersRoot !Double -- ^ Root found | RiddersNoBracket -- ^ Root is not bracketed deriving (Eq, Read, Show, Typeable, Data #if __GLASGOW_HASKELL__ > 704 , Generic #endif ) instance NFData RiddersStep where rnf x = x `seq` () instance IterationStep RiddersStep where matchRoot tol r = case r of RiddersRoot x -> Just $ Root x RiddersNoBracket -> Just NotBracketed RiddersStep a b | withinTolerance tol a b -> Just $ Root ((a + b) / 2) | otherwise -> Nothing RiddersBisect a b | withinTolerance tol a b -> Just $ Root ((a + b) / 2) | otherwise -> Nothing -- | Use the method of Ridders[Ridders1979] to compute a root of a -- function. It doesn't require derivative and provide quadratic -- convergence (number of significant digits grows quadratically -- with number of iterations). -- -- The function must have opposite signs when evaluated at the lower -- and upper bounds of the search (i.e. the root must be -- bracketed). If there's more that one root in the bracket -- iteration will converge to some root in the bracket. ridders :: RiddersParam -- ^ Parameters for algorithms. @def@ -- provides reasonable defaults -> (Double,Double) -- ^ Bracket for root -> (Double -> Double) -- ^ Function to find roots -> Root Double ridders p bracket fun = findRoot (riddersMaxIter p) (riddersTol p) $ riddersIterations bracket fun -- | List of iterations for Ridders methods. See 'ridders' for -- documentation of parameters riddersIterations :: (Double,Double) -> (Double -> Double) -> [RiddersStep] riddersIterations (lo,hi) f | flo == 0 = [RiddersRoot lo] | fhi == 0 = [RiddersRoot hi] -- root is not bracketed | flo*fhi > 0 = [RiddersNoBracket] -- Ensure that a= b = case () of _| fm*fa < 0 -> recBisect a fa m fm | otherwise -> recBisect m fm b fb | fn*fm < 0 = recRidders n fn m fm | fn*fa < 0 = recRidders a fa n fn | otherwise = recRidders n fn b fb where recBisect x fx y fy = RiddersBisect x y : go x fx y fy recRidders x fx y fy = RiddersStep x y : go x fx y fy -- dm = (b - a) * 0.5 -- Mean point m = (a + b) / 2 fm = f m -- Ridders update n = m - signum (fb - fa) * dm * fm / sqrt(fm*fm - fa*fb) fn = f n ---------------------------------------------------------------- -- Newton-Raphson algorithm ---------------------------------------------------------------- -- | Parameters for 'ridders' root finding data NewtonParam = NewtonParam { newtonMaxIter :: !Int -- ^ Maximum number of iterations. Default = 50 , newtonTol :: !Tolerance -- ^ Error tolerance for root approximation. Default is relative -- error 4·ε, where ε is machine precision } deriving (Eq, Read, Show, Typeable, Data #if __GLASGOW_HASKELL__ > 704 , Generic #endif ) instance Default NewtonParam where def = NewtonParam { newtonMaxIter = 50 , newtonTol = RelTol (4 * m_epsilon) } -- | Steps for Newton iterations data NewtonStep = NewtonStep !Double !Double -- ^ Normal Newton-Raphson update. Parameters are: old guess, new guess | NewtonBisection !Double !Double -- ^ Bisection fallback when Newton-Raphson iteration doesn't -- work. Parameters are bracket on root | NewtonRoot !Double -- ^ Root is found | NewtonNoBracket -- ^ Root is not bracketed deriving (Eq, Read, Show, Typeable, Data #if __GLASGOW_HASKELL__ > 704 , Generic #endif ) instance NFData NewtonStep where rnf x = x `seq` () instance IterationStep NewtonStep where matchRoot tol r = case r of NewtonRoot x -> Just (Root x) NewtonNoBracket -> Just NotBracketed NewtonStep x x' | withinTolerance tol x x' -> Just (Root x') | otherwise -> Nothing NewtonBisection a b | withinTolerance tol a b -> Just (Root ((a + b) / 2)) | otherwise -> Nothing {-# INLINE matchRoot #-} -- | Solve equation using Newton-Raphson iterations. -- -- This method require both initial guess and bounds for root. If -- Newton step takes us out of bounds on root function reverts to -- bisection. newtonRaphson :: NewtonParam -- ^ Parameters for algorithm. @def@ -- provide reasonable defaults. -> (Double,Double,Double) -- ^ Triple of @(low bound, initial -- guess, upper bound)@. If initial -- guess if out of bracket middle -- of bracket is taken as -- approximation -> (Double -> (Double,Double)) -- ^ Function to find root of. It -- returns pair of function value and -- its first derivative -> Root Double newtonRaphson p guess fun = findRoot (newtonMaxIter p) (newtonTol p) $ newtonRaphsonIterations guess fun -- | List of iteration for Newton-Raphson algorithm. See documentation -- for 'newtonRaphson' for meaning of parameters. newtonRaphsonIterations :: (Double,Double,Double) -> (Double -> (Double,Double)) -> [NewtonStep] newtonRaphsonIterations (lo,guess,hi) function | flo == 0 = [NewtonRoot lo] | fhi == 0 = [NewtonRoot hi] | flo*fhi > 0 = [NewtonNoBracket] -- Ensure that function value on low bound is negative | flo > 0 = go hi guess' lo | otherwise = go lo guess hi where (flo,_) = function lo (fhi,_) = function hi -- Ensure that initial guess is within bracket guess' | guess >= lo && guess <= hi = guess | guess >= hi && guess <= lo = guess | otherwise = (lo + hi) / 2 -- Newton iterations. Invariant: -- > f xA < 0 -- > f xB > 0 go xA x xB | f == 0 = [NewtonRoot x] | f' == 0 = bisectionStep -- Accept Newton step since it stays within bracket. | (x' - xA) * (x' - xB) < 0 = newtonStep -- Otherwise bracket root and pick new approximation as -- midpoint. | otherwise = bisectionStep where -- Calculate Newton step (f,f') = function x x' = x - f / f' -- Newton step newtonStep | f > 0 = NewtonStep x x' : go xA x' x | otherwise = NewtonStep x x' : go x x' xB -- Fallback bisection step bisectionStep | f > 0 = NewtonBisection xA x : go xA ((xA + x) / 2) x | otherwise = NewtonBisection x xB : go x ((x + xB) / 2) xB ---------------------------------------------------------------- -- Internal functions ---------------------------------------------------------------- -- $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. -- -- * Press W.H.; Teukolsky S.A.; Vetterling W.T.; Flannery B.P. -- (2007). \"Section 9.2.1. Ridders' Method\". /Numerical Recipes: The -- Art of Scientific Computing (3rd ed.)./ New York: Cambridge -- University Press. ISBN 978-0-521-88068-8. math-functions-0.3.1.0/Numeric/SpecFunctions.hs0000644000000000000000000000636213372631456017540 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- 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 -- * Sinc , sinc -- * Logarithm -- $log1p , log1p , log1pmx , log2 -- * Exponent , expm1 -- * Factorial , factorial , logFactorial , stirlingError -- * Combinatorics , choose , logChoose -- * References -- $references ) where import Numeric.SpecFunctions.Internal #if MIN_VERSION_base(4,9,0) import GHC.Float (log1p, expm1) #endif -- $log1p -- -- Base starting from @4.9.0@ (GHC 8.0) provides 'log1p' and 'expm1' -- as method of class 'Floating'. In this case we simply reexport -- these function. Otherwise we provide our own with more restrictive -- signature @Double → Double@. -- $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 -- -- -- * Temme, N.M. (1992) Asymptotic inversion of the incomplete beta -- function. /Journal of Computational and Applied Mathematics -- 41(1992) 145-157. -- -- * Temme, N.M. (1994) A set of algorithms for the incomplete gamma -- functions. /Probability in the Engineering and Informational -- Sciences/, 8, 1994, 291-307. Printed in the U.S.A. math-functions-0.3.1.0/Numeric/Polynomial.hs0000644000000000000000000000513213372631456017072 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.3.1.0/Numeric/MathFunctions/0000755000000000000000000000000013372631456017174 5ustar0000000000000000math-functions-0.3.1.0/Numeric/MathFunctions/Comparison.hs0000644000000000000000000001120513372631456021641 0ustar0000000000000000-- | -- Module : Numeric.MathFunctions.Comparison -- Copyright : (c) 2011 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Functions for approximate comparison of floating point numbers. -- -- Approximate floating point comparison, based on Bruce Dawson's -- \"Comparing floating point numbers\": -- module Numeric.MathFunctions.Comparison ( -- * Relative erros relativeError , eqRelErr -- * Ulps-based comparison , addUlps , ulpDistance , ulpDelta , within ) where import Control.Monad.ST (runST) import Data.Primitive.ByteArray (newByteArray, readByteArray, writeByteArray) import Data.Word (Word64) import Data.Int (Int64) ---------------------------------------------------------------- -- Ulps-based comparison ---------------------------------------------------------------- -- | -- Calculate relative error of two numbers: -- -- \[ \frac{|a - b|}{\max(|a|,|b|)} \] -- -- It lies in [0,1) interval for numbers with same sign and (1,2] for -- numbers with different sign. If both arguments are zero or negative -- zero function returns 0. If at least one argument is transfinite it -- returns NaN relativeError :: Double -> Double -> Double relativeError a b | a == 0 && b == 0 = 0 | otherwise = abs (a - b) / max (abs a) (abs b) -- | Check that relative error between two numbers @a@ and @b@. If -- 'relativeError' returns NaN it returns @False@. eqRelErr :: Double -- ^ /eps/ relative error should be in [0,1) range -> Double -- ^ /a/ -> Double -- ^ /b/ -> Bool eqRelErr eps a b = relativeError a b < eps ---------------------------------------------------------------- -- Ulps-based comparison ---------------------------------------------------------------- -- | -- Add N ULPs (units of least precision) to @Double@ number. addUlps :: Int -> Double -> Double addUlps n a = runST $ do buf <- newByteArray 8 ai0 <- writeByteArray buf 0 a >> readByteArray buf 0 -- Convert to ulps number represented as Int64 let big = 0x8000000000000000 order :: Word64 -> Int64 order i | i < big = fromIntegral i | otherwise = fromIntegral $ maxBound - (i - big) unorder :: Int64 -> Word64 unorder i | i >= 0 = fromIntegral i | otherwise = big + (maxBound - (fromIntegral i)) let ai0' = unorder $ order ai0 + fromIntegral n writeByteArray buf 0 ai0' >> readByteArray buf 0 -- | -- Measure distance between two @Double@s in ULPs (units of least -- precision). Note that it's different from @abs (ulpDelta a b)@ -- since it returns correct result even when 'ulpDelta' overflows. ulpDistance :: Double -> Double -> Word64 ulpDistance a b = runST $ do buf <- newByteArray 8 ai0 <- writeByteArray buf 0 a >> readByteArray buf 0 bi0 <- writeByteArray buf 0 b >> readByteArray buf 0 -- IEEE754 floats use most significant bit as sign bit (not -- 2-complement) and we need to rearrange representations of float -- number so that they could be compared lexicographically as -- Word64. let big = 0x8000000000000000 order i | i < big = i + big | otherwise = maxBound - i ai = order ai0 bi = order bi0 d | ai > bi = ai - bi | otherwise = bi - ai return $! d -- | -- Measure signed distance between two @Double@s in ULPs (units of least -- precision). Note that unlike 'ulpDistance' it can overflow. -- -- > >>> ulpDelta 1 (1 + m_epsilon) -- > 1 ulpDelta :: Double -> Double -> Int64 ulpDelta a b = runST $ do buf <- newByteArray 8 ai0 <- writeByteArray buf 0 a >> readByteArray buf 0 bi0 <- writeByteArray buf 0 b >> readByteArray buf 0 -- IEEE754 floats use most significant bit as sign bit (not -- 2-complement) and we need to rearrange representations of float -- number so that they could be compared lexicographically as -- Word64. let big = 0x8000000000000000 :: Word64 order i | i < big = i + big | otherwise = maxBound - i ai = order ai0 bi = order bi0 return $! fromIntegral $ bi - ai -- | 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 | ulps < 0 = False | otherwise = ulpDistance a b <= fromIntegral ulps math-functions-0.3.1.0/Numeric/MathFunctions/Constants.hs0000644000000000000000000000547613372631456021520 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 , m_max_log , m_min_log -- * 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 ---------------------------------------------------------------- -- | Largest representable finite value. m_huge :: Double m_huge = 1.7976931348623157e308 {-# INLINE m_huge #-} -- | The smallest representable positive normalized value. 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 #-} -- | Maximum possible finite value of @log x@ m_max_log :: Double m_max_log = 709.782712893384 {-# INLINE m_max_log #-} -- | Logarithm of smallest normalized double ('m_tiny') m_min_log :: Double m_min_log = -708.3964185322641 {-# INLINE m_min_log #-} ---------------------------------------------------------------- -- 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.3.1.0/Numeric/SpecFunctions/0000755000000000000000000000000013372631456017175 5ustar0000000000000000math-functions-0.3.1.0/Numeric/SpecFunctions/Internal.hs0000644000000000000000000011257313372631456021316 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, ForeignFunctionInterface #-} -- | -- Module : Numeric.SpecFunctions.Internal -- Copyright : (c) 2009, 2011, 2012 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Internal module with implementation of special functions. module Numeric.SpecFunctions.Internal where #if !MIN_VERSION_base(4,9,0) import Control.Applicative #endif import Data.Bits ((.&.), (.|.), shiftR) import Data.Int (Int64) import Data.Word (Word) import Data.Default.Class import qualified Data.Vector.Unboxed as U import Data.Vector.Unboxed ((!)) import Text.Printf #if MIN_VERSION_base(4,9,0) import GHC.Float (log1p,expm1) #endif import Numeric.Polynomial.Chebyshev (chebyshevBroucke) import Numeric.Polynomial (evaluatePolynomialL,evaluateEvenPolynomialL,evaluateOddPolynomialL) import Numeric.RootFinding (Root(..), newtonRaphson, NewtonParam(..), Tolerance(..)) import Numeric.Series import Numeric.MathFunctions.Constants ---------------------------------------------------------------- -- Error function ---------------------------------------------------------------- -- | Error function. -- -- \[ -- \operatorname{erf}(x) = \frac{2}{\sqrt{\pi}} \int_{0}^{x} \exp(-t^2) dt -- \] -- -- Function limits are: -- -- \[ -- \begin{aligned} -- &\operatorname{erf}(-\infty) &=& -1 \\ -- &\operatorname{erf}(0) &=& \phantom{-}\,0 \\ -- &\operatorname{erf}(+\infty) &=& \phantom{-}\,1 \\ -- \end{aligned} -- \] erf :: Double -> Double {-# INLINE erf #-} erf = c_erf -- | Complementary error function. -- -- \[ -- \operatorname{erfc}(x) = 1 - \operatorname{erf}(x) -- \] -- -- Function limits are: -- -- \[ -- \begin{aligned} -- &\operatorname{erf}(-\infty) &=&\, 2 \\ -- &\operatorname{erf}(0) &=&\, 1 \\ -- &\operatorname{erf}(+\infty) &=&\, 0 \\ -- \end{aligned} -- \] erfc :: Double -> Double {-# INLINE erfc #-} erfc = c_erfc foreign import ccall "erf" c_erf :: Double -> Double foreign import ccall "erfc" c_erfc :: Double -> Double -- | 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 ---------------------------------------------------------------- data L = L {-# UNPACK #-} !Double {-# UNPACK #-} !Double -- | Compute the logarithm of the gamma function, Γ(/x/). -- -- \[ -- \Gamma(x) = \int_0^{\infty}t^{x-1}e^{-t}\,dt = (x - 1)! -- \] -- -- This implementation uses Lanczos approximation. It gives 14 or more -- significant decimal digits, 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). logGamma :: Double -> Double logGamma x | x <= 0 = m_pos_inf | x < 1 = lanczos (1+x) - log x | otherwise = lanczos x where -- Evaluate Lanczos approximation for γ=6 lanczos z = fini $ U.foldl' go (L 0 (z+7)) a where fini (L l _) = log (l+a0) + log m_sqrt_2_pi - z65 + (z-0.5) * log z65 go (L l t) k = L (l + k / t) (t-1) z65 = z + 6.5 -- Coefficients for Lanczos approximation a0 = 0.9999999999995183 a = U.fromList [ 0.1659470187408462e-06 , 0.9934937113930748e-05 , -0.1385710331296526 , 12.50734324009056 , -176.6150291498386 , 771.3234287757674 , -1259.139216722289 , 676.5203681218835 ] -- | Synonym for 'logGamma'. Retained for compatibility logGammaL :: Double -> Double logGammaL = logGamma -- | -- Compute the log gamma correction factor for Stirling -- approximation for @x@ ≥ 10. This correction factor is -- suitable for an alternate (but less numerically accurate) -- definition of 'logGamma': -- -- \[ -- \log\Gamma(x) = \frac{1}{2}\log(2\pi) + (x-\frac{1}{2})\log x - x + \operatorname{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 -- γ(/z/,/x/). Normalization means that γ(/z/,∞)=1 -- -- \[ -- \gamma(z,x) = \frac{1}{\Gamma(z)}\int_0^{x}t^{z-1}e^{-t}\,dt -- \] -- -- Uses Algorithm AS 239 by Shea. incompleteGamma :: Double -- ^ /z/ ∈ (0,∞) -> Double -- ^ /x/ ∈ (0,∞) -> Double -- Notation used: -- + P(a,x) - regularized lower incomplete gamma -- + Q(a,x) - regularized upper incomplete gamma incompleteGamma a x | a <= 0 || x < 0 = error $ "incompleteGamma: Domain error z=" ++ show a ++ " x=" ++ show x | x == 0 = 0 | x == m_pos_inf = 1 -- For very small x we use following expansion for P: -- -- See http://functions.wolfram.com/GammaBetaErf/GammaRegularized/06/01/05/01/01/ | x < sqrt m_epsilon && a > 1 = x**a / a / exp (logGammaL a) * (1 - a*x / (a + 1)) | x < 0.5 = case () of _| (-0.4)/log x < a -> taylorSeriesP | otherwise -> taylorSeriesComplQ | x < 1.1 = case () of _| 0.75*x < a -> taylorSeriesP | otherwise -> taylorSeriesComplQ | a > 20 && useTemme = uniformExpansion | x - (1 / (3 * x)) < a = taylorSeriesP | otherwise = contFraction where mu = (x - a) / a useTemme = (a > 200 && 20/a > mu*mu) || (abs mu < 0.4) -- Gautschi's algorithm. -- -- Evaluate series for P(a,x). See [Temme1994] Eq. 5.5 -- -- FIXME: Term `exp (log x * z - x - logGamma (z+1))` doesn't give full precision taylorSeriesP = sumPowerSeries x (scanSequence (/) 1 $ enumSequenceFrom (a+1)) * exp (log x * a - x - logGamma (a+1)) -- Series for 1-Q(a,x). See [Temme1994] Eq. 5.5 taylorSeriesComplQ = sumPowerSeries (-x) (scanSequence (/) 1 (enumSequenceFrom 1) / enumSequenceFrom a) * x**a / exp(logGammaL a) -- Legendre continued fractions contFraction = 1 - ( exp ( log x * a - x - logGamma a ) / evalContFractionB frac ) where frac = (\k -> (k*(a-k), x - a + 2*k + 1)) <$> enumSequenceFrom 0 -- Evaluation based on uniform expansions. See [Temme1994] 5.2 uniformExpansion = let -- Coefficients f_m in paper fm :: U.Vector Double fm = U.fromList [ 1.00000000000000000000e+00 ,-3.33333333333333370341e-01 , 8.33333333333333287074e-02 ,-1.48148148148148153802e-02 , 1.15740740740740734316e-03 , 3.52733686067019369930e-04 ,-1.78755144032921825352e-04 , 3.91926317852243766954e-05 ,-2.18544851067999240532e-06 ,-1.85406221071515996597e-06 , 8.29671134095308545622e-07 ,-1.76659527368260808474e-07 , 6.70785354340149841119e-09 , 1.02618097842403069078e-08 ,-4.38203601845335376897e-09 , 9.14769958223679020897e-10 ,-2.55141939949462514346e-11 ,-5.83077213255042560744e-11 , 2.43619480206674150369e-11 ,-5.02766928011417632057e-12 , 1.10043920319561347525e-13 , 3.37176326240098513631e-13 ] y = - log1pmx mu eta = sqrt (2 * y) * signum mu -- Evaluate S_α (Eq. 5.9) loop !_ !_ u 0 = u loop bm1 bm0 u i = let t = (fm ! i) + (fromIntegral i + 1)*bm1 / a u' = eta * u + t in loop bm0 t u' (i-1) s_a = let n = U.length fm in loop (fm ! (n-1)) (fm ! (n-2)) 0 (n-3) / exp (logGammaCorrection a) in 1/2 * erfc(-eta*sqrt(a/2)) - exp(-(a*y)) / sqrt (2*pi*a) * s_a -- Adapted from Numerical Recipes §6.2.1 -- | Inverse incomplete gamma function. It's approximately inverse of -- 'incompleteGamma' for the same /z/. So following equality -- approximately holds: -- -- > invIncompleteGamma z . incompleteGamma z ≈ id invIncompleteGamma :: Double -- ^ /z/ ∈ (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. -- -- \[ -- B(a,b) = \int_0^1 t^{a-1}(1-t)^{1-b}\,dt = \frac{\Gamma(a)\Gamma(b)}{\Gamma(a+b)} -- \] logBeta :: Double -- ^ /a/ > 0 -> Double -- ^ /b/ > 0 -> 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. -- -- \[ -- I(x;a,b) = \frac{1}{B(a,b)} \int_0^x t^{a-1}(1-t)^{1-b}\,dt -- \] -- -- Uses algorithm AS63 by Majumder and Bhattachrjee and quadrature -- approximation for large /p/ and /q/. incompleteBeta :: Double -- ^ /a/ > 0 -> Double -- ^ /b/ > 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 -- ^ /a/ > 0 -> Double -- ^ /b/ > 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 "incompleteBeta_: 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 = log1p (-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 -- Common multiplies for expansion. Accurate calculation is a bit -- tricky. Performing calculation in log-domain leads to slight -- loss of precision for small x, while using ** prone to -- underflows. -- -- If either beta function of x**p·(1-x)**(q-1) underflows we -- switch to log domain. It could waste work but there's no easy -- switch criterion. factor | beta < m_min_log || prod < m_tiny = exp( p * log x + (q - 1) * log cx - beta) | otherwise = prod / exp beta where prod = x**p * cx**(q - 1) -- Soper's expansion of incomplete beta function loop !psq (ns :: Int) ai term betain | done = betain' * factor / 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 -- ^ /a/ > 0 -> Double -- ^ /b/ > 0 -> Double -- ^ /x/ ∈ [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 | otherwise = invIncompleteBetaWorker (logBeta p q) p q a invIncompleteBetaWorker :: Double -> Double -> Double -> Double -> Double invIncompleteBetaWorker beta a b p = loop (0::Int) (invIncBetaGuess beta a b p) 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 * log1p (-x) - beta u = f / f' -- We bound Halley correction to Newton-Raphson to (-1,1) range corr | d > 1 = 1 | d < -1 = -1 | isNaN d = 0 | otherwise = d where d = u * (a1 / x - b1 / (1 - x)) dx = u / (1 - 0.5 * corr) -- 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 for inverse incomplete beta function. invIncBetaGuess :: Double -> Double -> Double -> Double -> Double -- Calculate initial guess. for solving equation for inverse incomplete beta. -- It's really hodgepodge of different approximations accumulated over years. -- -- 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. invIncBetaGuess beta a b p -- If both a and b are less than 1 incomplete beta have inflection -- point. -- -- > x = (1 - a) / (2 - a - b) -- -- We approximate incomplete beta by neglecting one of factors under -- integral and then rescaling result of integration into [0,1] -- range. | a < 1 && b < 1 = let x_infl = (1 - a) / (2 - a - b) p_infl = incompleteBeta a b x_infl x | p < p_infl = let xg = (a * p * exp beta) ** (1/a) in xg / (1+xg) | otherwise = let xg = (b * (1-p) * exp beta) ** (1/b) in 1 - xg/(1+xg) in x -- If both a and b larger or equal that 1 but not too big we use -- same approximation as above but calculate it a bit differently | a+b <= 6 && a>1 && b>1 = let x_infl = (a - 1) / (a + b - 2) p_infl = incompleteBeta a b x_infl x | p < p_infl = exp ((log(p * a) + beta) / a) | otherwise = 1 - exp((log((1-p) * b) + beta) / b) in x -- For small a and not too big b we use approximation from boost. | b < 5 && a <= 1 = let x | p**(1/a) < 0.5 = (p * a * exp beta) ** (1/a) | otherwise = 1 - (1 - p ** (b * exp beta))**(1/b) in x -- When a>>b and both are large approximation from [Temme1992], -- section 4 "the incomplete gamma function case" used. In this -- region it greatly improves over other approximation (AS109, AS64, -- "Numerical Recipes") -- -- FIXME: It could be used when b>>a too but it require inverse of -- upper incomplete gamma to be precise enough. In current -- implementation it loses precision in horrible way (40 -- order of magnitude off for sufficiently small p) | a+b > 5 && a/b > 4 = let -- Calculate initial approximation to eta using eq 4.1 eta0 = invIncompleteGamma b (1-p) / a mu = b / a -- Eq. 4.3 -- A lot of helpers for calculation of w = sqrt(1 + mu) -- Eq. 4.9 w_2 = w * w w_3 = w_2 * w w_4 = w_2 * w_2 w_5 = w_3 * w_2 w_6 = w_3 * w_3 w_7 = w_4 * w_3 w_8 = w_4 * w_4 w_9 = w_5 * w_4 w_10 = w_5 * w_5 d = eta0 - mu d_2 = d * d d_3 = d_2 * d d_4 = d_2 * d_2 w1 = w + 1 w1_2 = w1 * w1 w1_3 = w1 * w1_2 w1_4 = w1_2 * w1_2 -- Evaluation of eq 4.10 e1 = (w + 2) * (w - 1) / (3 * w) + (w_3 + 9 * w_2 + 21 * w + 5) * d / (36 * w_2 * w1) - (w_4 - 13 * w_3 + 69 * w_2 + 167 * w + 46) * d_2 / (1620 * w1_2 * w_3) - (7 * w_5 + 21 * w_4 + 70 * w_3 + 26 * w_2 - 93 * w - 31) * d_3 / (6480 * w1_3 * w_4) - (75 * w_6 + 202 * w_5 + 188 * w_4 - 888 * w_3 - 1345 * w_2 + 118 * w + 138) * d_4 / (272160 * w1_4 * w_5) e2 = (28 * w_4 + 131 * w_3 + 402 * w_2 + 581 * w + 208) * (w - 1) / (1620 * w1 * w_3) - (35 * w_6 - 154 * w_5 - 623 * w_4 - 1636 * w_3 - 3983 * w_2 - 3514 * w - 925) * d / (12960 * w1_2 * w_4) - ( 2132 * w_7 + 7915 * w_6 + 16821 * w_5 + 35066 * w_4 + 87490 * w_3 + 141183 * w_2 + 95993 * w + 21640 ) * d_2 / (816480 * w_5 * w1_3) - ( 11053 * w_8 + 53308 * w_7 + 117010 * w_6 + 163924 * w_5 + 116188 * w_4 - 258428 * w_3 - 677042 * w_2 - 481940 * w - 105497 ) * d_3 / (14696640 * w1_4 * w_6) e3 = -( (3592 * w_7 + 8375 * w_6 - 1323 * w_5 - 29198 * w_4 - 89578 * w_3 - 154413 * w_2 - 116063 * w - 29632 ) * (w - 1) ) / (816480 * w_5 * w1_2) - ( 442043 * w_9 + 2054169 * w_8 + 3803094 * w_7 + 3470754 * w_6 + 2141568 * w_5 - 2393568 * w_4 - 19904934 * w_3 - 34714674 * w_2 - 23128299 * w - 5253353 ) * d / (146966400 * w_6 * w1_3) - ( 116932 * w_10 + 819281 * w_9 + 2378172 * w_8 + 4341330 * w_7 + 6806004 * w_6 + 10622748 * w_5 + 18739500 * w_4 + 30651894 * w_3 + 30869976 * w_2 + 15431867 * w + 2919016 ) * d_2 / (146966400 * w1_4 * w_7) eta = evaluatePolynomialL (1/a) [eta0, e1, e2, e3] -- Now we solve eq 4.2 to recover x using Newton iterations u = eta - mu * log eta + (1 + mu) * log(1 + mu) - mu cross = 1 / (1 + mu); lower = if eta < mu then cross else 0 upper = if eta < mu then 1 else cross x_guess = (lower + upper) / 2 func x = ( u + log x + mu*log(1 - x) , 1/x - mu/(1-x) ) Root x0 = newtonRaphson def{newtonTol=RelTol 1e-8} (lower, x_guess, upper) func in x0 -- For large a and b approximation from AS109 (Carter -- approximation). It's reasonably good in this region | 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 [AS64 2] ratio = (4*a + 2*b - 2) / chi2 -- Quantile of chi-squared distribution. Formula [AS64 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 ---------------------------------------------------------------- -- Sinc function ---------------------------------------------------------------- -- | Compute sinc function @sin(x)\/x@ sinc :: Double -> Double sinc x | ax < eps_0 = 1 | ax < eps_2 = 1 - x2/6 | ax < eps_4 = 1 - x2/6 + x2*x2/120 | otherwise = sin x / x where ax = abs x x2 = x*x -- For explanation of choice see `doc/sinc.hs' eps_0 = 1.8250120749944284e-8 -- sqrt (6ε/4) eps_2 = 1.4284346431400855e-4 -- (30ε)**(1/4) / 2 eps_4 = 4.043633626430947e-3 -- (1206ε)**(1/6) / 2 ---------------------------------------------------------------- -- Logarithm ---------------------------------------------------------------- -- GHC.Float provides log1p and expm1 since 4.9.0 #if !MIN_VERSION_base(4,9,0) -- | 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 ] -- | Compute @exp x - 1@ without loss of accuracy for x near zero. expm1 :: Double -> Double #ifdef USE_SYSTEM_EXPM1 expm1 = c_expm1 foreign import ccall "expm1" c_expm1 :: Double -> Double #else -- NOTE: this is simplest implementation and not terribly efficient. expm1 x | x < (-37.42994775023705) = -1 | x > m_max_log = m_pos_inf | abs x > 0.5 = exp x - 1 | otherwise = sumSeries $ liftA2 (*) (scanSequence (*) x (pure x)) (1 / scanSequence (*) 1 (enumSequenceFrom 2)) #endif #endif -- | Compute log(1+x)-x: log1pmx :: Double -> Double log1pmx x | x < -1 = error "Domain error" | x == -1 = m_neg_inf | ax > 0.95 = log(1 + x) - x | ax < m_epsilon = -(x * x) /2 | otherwise = - x * x * sumPowerSeries (-x) (recip <$> enumSequenceFrom 2) where ax = abs x -- | /O(log n)/ Compute the logarithm in base 2 of the given value. log2 :: Int -> Int log2 v0 | v0 <= 0 = modErr $ "log2: nonpositive 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 [ 0x02, 0x0c, 0xf0, 0xff00 , fromIntegral (0xffff0000 :: Word) , fromIntegral (0xffffffff00000000 :: Word)] !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 -- N.B. Γ(n+1) = n! -- -- We use here asymptotic series for gamma function. See -- http://mathworld.wolfram.com/StirlingsSeries.html | otherwise = (x - 0.5) * log x - x + m_ln_sqrt_2_pi + evaluateOddPolynomialL (1/x) [1/12, -1/360, 1/1260, -1/1680] where x = fromIntegral n + 1 {-# SPECIALIZE logFactorial :: Int -> Double #-} -- | Calculate the error term of the Stirling approximation. This is -- only defined for non-negative values. -- -- \[ -- \operatorname{stirlingError}(n) = \log(n!) - \log(\sqrt{2\pi n}\frac{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. -- -- Less numerically stable: -- -- > exp $ lg (n+1) - lg (k+1) - lg (n-k+1) -- > where lg = logGamma . fromIntegral logChooseFast :: Double -> Double -> Double logChooseFast n k = -log (n + 1) - logBeta (n - k + 1) (k + 1) -- | Calculate binomial coefficient using exact formula chooseExact :: Int -> Int -> Double n `chooseExact` k = U.foldl' go 1 $ U.enumFromTo 1 k where go a i = a * (nk + j) / j where j = fromIntegral i :: Double nk = fromIntegral (n - k) -- | Compute logarithm of the binomial coefficient. logChoose :: Int -> Int -> Double n `logChoose` k | k > n = (-1) / 0 -- For very large N exact algorithm overflows double so we -- switch to beta-function based one | k' < 50 && (n < 20000000) = log $ chooseExact n k' | otherwise = logChooseFast (fromIntegral n) (fromIntegral k) where k' = min k (n-k) -- | Compute the binomial coefficient /n/ @\``choose`\`@ /k/. For -- values of /k/ > 50, 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 = chooseExact n k' | approx < max64 = fromIntegral . round64 $ approx | otherwise = approx where k' = min k (n-k) approx = exp $ logChooseFast (fromIntegral n) (fromIntegral k') max64 = fromIntegral (maxBound :: Int64) round64 x = round x :: Int64 -- | Compute ψ(/x/), the first logarithmic derivative of the gamma -- function. -- -- \[ -- \psi(x) = \frac{d}{dx} \ln \left(\Gamma(x)\right) = \frac{\Gamma'(x)}{\Gamma(x)} -- \] -- -- 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 math-functions-0.3.1.0/Numeric/SpecFunctions/Extra.hs0000644000000000000000000000674413372631456020627 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 , chooseExact , logChooseFast , logGammaAS245 , logGammaCorrection ) where import Numeric.MathFunctions.Constants (m_NaN,m_pos_inf) import Numeric.SpecFunctions.Internal (chooseExact,logChooseFast,logGammaCorrection) -- | 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' -- | 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). logGammaAS245 :: Double -> Double -- Adapted from http://people.sc.fsu.edu/~burkardt/f_src/asa245/asa245.html logGammaAS245 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 math-functions-0.3.1.0/Numeric/Polynomial/0000755000000000000000000000000013372631456016535 5ustar0000000000000000math-functions-0.3.1.0/Numeric/Polynomial/Chebyshev.hs0000644000000000000000000000464413372631456021021 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: -- -- \[\begin{aligned} -- T_0(x) &= 1 \\ -- T_1(x) &= x \\ -- T_{n+1}(x) &= 2xT_n(x) - T_{n-1}(x) \\ -- \end{aligned} -- \] 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. --