├── .README.imgs ├── criterion.png └── gauge.png ├── .appveyor.yml ├── .gitignore ├── .gitmodules ├── .haskell-ci ├── .travis.yml ├── Gauge.hs ├── Gauge ├── Analysis.hs ├── Benchmark.hs ├── CSV.hs ├── Format.hs ├── IO │ └── Printf.hs ├── ListMap.hs ├── Main.hs ├── Main │ └── Options.hs ├── Measurement.hs ├── Monad.hs ├── Optional.hs ├── Source │ ├── GC.hs │ ├── RUsage.hsc │ └── Time.hsc └── Time.hs ├── LICENSE ├── README.markdown ├── Setup.lhs ├── benchs └── Main.hs ├── cbits ├── cycles.c ├── cycles.h ├── gauge-time.h ├── time-osx.c ├── time-posix.c └── time-windows.c ├── changelog.md ├── gauge.cabal ├── math-functions ├── LICENSE └── Numeric │ ├── MathFunctions │ ├── Comparison.hs │ └── Constants.hs │ ├── SpecFunctions.hs │ ├── SpecFunctions │ └── Internal.hs │ └── Sum.hs ├── mwc-random ├── LICENSE └── System │ └── Random │ └── MWC.hs ├── stack.yaml ├── statistics ├── LICENSE └── Statistics │ ├── Distribution.hs │ ├── Distribution │ └── Normal.hs │ ├── Function.hs │ ├── Internal.hs │ ├── Math │ └── RootFinding.hs │ ├── Matrix.hs │ ├── Matrix │ ├── Algorithms.hs │ ├── Mutable.hs │ └── Types.hs │ ├── Quantile.hs │ ├── Regression.hs │ ├── Resampling.hs │ ├── Resampling │ └── Bootstrap.hs │ ├── Sample.hs │ ├── Sample │ ├── Histogram.hs │ ├── Internal.hs │ └── KernelDensity.hs │ ├── Transform.hs │ ├── Types.hs │ └── Types │ └── Internal.hs └── tests ├── Cleanup.hs └── Sanity.hs /.README.imgs/criterion.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vincenthz/hs-gauge/303a6b611804c85b9a6bc1cea5de4e6ce3429d24/.README.imgs/criterion.png -------------------------------------------------------------------------------- /.README.imgs/gauge.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vincenthz/hs-gauge/303a6b611804c85b9a6bc1cea5de4e6ce3429d24/.README.imgs/gauge.png -------------------------------------------------------------------------------- /.appveyor.yml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 6fe771eb91c98411c32b04cdd782a37cb1da7bdb7b6f346f6d98808d73808888 ~*~ 2 | 3 | version: "{build}" 4 | clone_folder: C:\project 5 | build: off 6 | cache: 7 | - "C:\\SR -> .appveyor.yml" 8 | 9 | environment: 10 | global: 11 | STACK_ROOT: "C:\\SR" 12 | matrix: 13 | - { BUILD: "ghc-8.6", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-14.4, packages: [ '.' ], extra-deps: [], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" } 14 | - { BUILD: "ghc-8.8", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: ghc-8.8.1, packages: [ '.' ], extra-deps: [ \"basement-0.0.11@sha256:af43e2e334e515b52ca309919b135c51b5e9411e6d4c68d0e8950d61eb5f25d1,5711\", \"vector-0.12.0.3@sha256:1422b0bcf4e7675116ca8d9f473bf239850c58c4518a56010e3bfebeac345ace,7171\", \"primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416\", \"foundation-0.0.25@sha256:e24936100ca6c1778d671994eb3f179cf18ca7c772cc831a2c8b380dcad445df,12036\" ], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" } 15 | 16 | matrix: 17 | fast_finish: true 18 | 19 | install: 20 | - set PATH=C:\Program Files\Git\mingw64\bin;%PATH% 21 | - curl -ostack.zip -L %STACKURL% 22 | - 7z x stack.zip stack.exe 23 | - refreshenv 24 | test_script: 25 | - echo %STACKCFG% > stack.yaml 26 | - stack setup > nul 27 | - echo "" | %STACKCMD% 28 | 29 | 30 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | .stack-work/ 4 | cabal.sandbox.config 5 | .cabal-sandbox 6 | *~ 7 | .\#* 8 | *.swp 9 | stack.yaml.lock 10 | sanity.* 11 | copydeps/ 12 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vincenthz/hs-gauge/303a6b611804c85b9a6bc1cea5de4e6ce3429d24/.gitmodules -------------------------------------------------------------------------------- /.haskell-ci: -------------------------------------------------------------------------------- 1 | # compiler supported and their equivalent LTS 2 | compiler: ghc-7.10 lts-6.35 3 | compiler: ghc-8.0 lts-9.21 4 | compiler: ghc-8.2 lts-10.4 5 | compiler: ghc-8.4 lts-12.26 6 | compiler: ghc-8.6 lts-14.4 7 | compiler: ghc-8.6-noanalysis lts-14.4 8 | compiler: ghc-8.8 ghc-8.8.1 9 | 10 | # options 11 | # option: alias x=y z=v 12 | 13 | # builds 14 | build: ghc-7.10 extradep=basement-0.0.6 extradep=foundation-0.0.19 15 | build: ghc-8.0 16 | build: ghc-8.6-noanalysis flag=gauge:-analysis 17 | build: ghc-8.2 os=linux 18 | build: ghc-8.4 os=linux 19 | build: ghc-8.6 os=linux,osx,windows 20 | build: ghc-8.8 os=linux,osx,windows extradep=basement-0.0.11@sha256:af43e2e334e515b52ca309919b135c51b5e9411e6d4c68d0e8950d61eb5f25d1,5711 extradep=vector-0.12.0.3@sha256:1422b0bcf4e7675116ca8d9f473bf239850c58c4518a56010e3bfebeac345ace,7171 extradep=primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 extradep=foundation-0.0.25@sha256:e24936100ca6c1778d671994eb3f179cf18ca7c772cc831a2c8b380dcad445df,12036 21 | 22 | # packages 23 | package: '.' 24 | 25 | # extra builds 26 | hlint: allowed-failure 27 | weeder: allowed-failure 28 | coverall: false 29 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 6fe771eb91c98411c32b04cdd782a37cb1da7bdb7b6f346f6d98808d73808888 ~*~ 2 | 3 | # Use new container infrastructure to enable caching 4 | sudo: false 5 | 6 | # Caching so the next build will be fast too. 7 | cache: 8 | directories: 9 | - $HOME/.ghc 10 | - $HOME/.stack 11 | - $HOME/.local 12 | 13 | matrix: 14 | include: 15 | - { env: BUILD=stack RESOLVER=ghc-7.10, compiler: ghc-7.10, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 16 | - { env: BUILD=stack RESOLVER=ghc-8.0, compiler: ghc-8.0, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 17 | - { env: BUILD=stack RESOLVER=ghc-8.6-noanalysis, compiler: ghc-8.6-noanalysis, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 18 | - { env: BUILD=stack RESOLVER=ghc-8.2, compiler: ghc-8.2, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 19 | - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 20 | - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 21 | - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx } 22 | - { env: BUILD=stack RESOLVER=ghc-8.8, compiler: ghc-8.8, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 23 | - { env: BUILD=stack RESOLVER=ghc-8.8, compiler: ghc-8.8, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx } 24 | - { env: BUILD=hlint, compiler: hlint, language: generic } 25 | - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 26 | allow_failures: 27 | - { env: BUILD=hlint, compiler: hlint, language: generic } 28 | - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 29 | 30 | install: 31 | - export PATH=$HOME/.local/bin::$HOME/.cabal/bin:$PATH 32 | - mkdir -p ~/.local/bin 33 | - | 34 | case "$BUILD" in 35 | stack|weeder) 36 | if [ `uname` = "Darwin" ] 37 | then 38 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 39 | else 40 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 41 | fi 42 | ;; 43 | cabal) 44 | ;; 45 | esac 46 | 47 | script: 48 | - | 49 | set -ex 50 | if [ "x${RUNTEST}" = "xfalse" ]; then exit 0; fi 51 | case "$BUILD" in 52 | stack) 53 | # create the build stack.yaml 54 | case "$RESOLVER" in 55 | ghc-7.10) 56 | echo "{ resolver: lts-6.35, packages: [ '.' ], extra-deps: [ basement-0.0.6, foundation-0.0.19 ], flags: {} }" > stack.yaml 57 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 58 | ;; 59 | ghc-8.0) 60 | echo "{ resolver: lts-9.21, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml 61 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 62 | ;; 63 | ghc-8.6-noanalysis) 64 | echo "{ resolver: lts-14.4, packages: [ '.' ], extra-deps: [], flags: { gauge: { analysis: false } } }" > stack.yaml 65 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 66 | ;; 67 | ghc-8.2) 68 | echo "{ resolver: lts-10.4, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml 69 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 70 | ;; 71 | ghc-8.4) 72 | echo "{ resolver: lts-12.26, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml 73 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 74 | ;; 75 | ghc-8.6) 76 | echo "{ resolver: lts-14.4, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml 77 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 78 | ;; 79 | ghc-8.8) 80 | echo "{ resolver: ghc-8.8.1, packages: [ '.' ], extra-deps: [ \"basement-0.0.11@sha256:af43e2e334e515b52ca309919b135c51b5e9411e6d4c68d0e8950d61eb5f25d1,5711\", \"vector-0.12.0.3@sha256:1422b0bcf4e7675116ca8d9f473bf239850c58c4518a56010e3bfebeac345ace,7171\", \"primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416\", \"foundation-0.0.25@sha256:e24936100ca6c1778d671994eb3f179cf18ca7c772cc831a2c8b380dcad445df,12036\" ], flags: {} }" > stack.yaml 81 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 82 | ;; 83 | esac 84 | ;; 85 | hlint) 86 | curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s . --cpp-define=__GLASGOW_HASKELL__=800 --cpp-define=x86_64_HOST_ARCH=1 --cpp-define=mingw32_HOST_OS=1 87 | ;; 88 | weeder) 89 | stack --no-terminal build --install-ghc 90 | curl -sL https://raw.github.com/ndmitchell/weeder/master/misc/travis.sh | sh -s . 91 | ;; 92 | esac 93 | set +ex 94 | 95 | 96 | -------------------------------------------------------------------------------- /Gauge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- Module : Gauge 4 | -- Copyright : (c) 2009-2014 Bryan O'Sullivan 5 | -- 6 | -- License : BSD-style 7 | -- Maintainer : bos@serpentine.com 8 | -- Stability : experimental 9 | -- Portability : GHC 10 | -- 11 | -- Fast and reliable micro benchmarking. 12 | 13 | module Gauge 14 | ( module Gauge.Benchmark 15 | , module Gauge.Main 16 | , module Gauge.Main.Options 17 | ) where 18 | 19 | import Gauge.Benchmark 20 | import Gauge.Main 21 | import Gauge.Main.Options 22 | -------------------------------------------------------------------------------- /Gauge/CSV.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Gauge.CSV 3 | -- Copyright : (c) 2017 Vincent Hanquez 4 | -- 5 | -- a very simple CSV printer 6 | -- 7 | -- import qualified for best result 8 | -- 9 | module Gauge.CSV 10 | ( Row(..) 11 | , outputRow 12 | , Field 13 | , float 14 | , integral 15 | , string 16 | , write 17 | ) where 18 | 19 | import Data.List (intercalate) 20 | 21 | -- | a CSV Field (numerical or string) 22 | -- 23 | -- The content inside is properly escaped 24 | newtype Field = Field { unField :: String } 25 | deriving (Show, Eq) 26 | 27 | -- | A Row of fields 28 | newtype Row = Row [Field] 29 | deriving (Show, Eq) 30 | 31 | -- | Create a field from Double 32 | float :: Double -> Field 33 | float d = Field $ show d 34 | 35 | -- | Create a field for numerical integral 36 | integral :: Integral a => a -> Field 37 | integral i = Field $ show (toInteger i) 38 | 39 | -- | Create a field from String 40 | string :: String -> Field 41 | string s = 42 | -- potentially a random string need to be escape, 43 | -- first find out how it need to escaped, then 44 | -- escape the data properly. 45 | case needEscape NoEscape s of 46 | NoEscape -> Field s 47 | Escape -> Field ('"' : (s ++ "\"")) 48 | EscapeDoubling -> Field ('"' : doubleQuotes s) 49 | where 50 | needEscape EscapeDoubling _ = EscapeDoubling 51 | needEscape e [] = e 52 | needEscape e (x:xs) 53 | | x == '"' = EscapeDoubling 54 | | x `elem` toEscape = needEscape (max e Escape) xs 55 | | otherwise = needEscape e xs 56 | 57 | toEscape = ",\r\n" 58 | 59 | doubleQuotes [] = ['"'] 60 | doubleQuotes (x:xs) 61 | | x == '"' = '"':'"':doubleQuotes xs 62 | | otherwise = x : doubleQuotes xs 63 | 64 | -- | Output a row to a String 65 | outputRow :: Row -> String 66 | outputRow (Row fields) = intercalate "," $ map unField fields 67 | 68 | -- | 3 Possible modes of escaping: 69 | -- * none 70 | -- * normal quotes escapes 71 | -- * content need doubling because of double quote in content 72 | data Escaping = NoEscape | Escape | EscapeDoubling 73 | deriving (Show, Eq, Ord) 74 | 75 | write :: Maybe FilePath 76 | -> Row 77 | -> IO () 78 | write Nothing _ = return () 79 | write (Just fp) r = appendFile fp (outputRow r ++ "\r\n") 80 | -------------------------------------------------------------------------------- /Gauge/Format.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Gauge.Format 3 | -- Copyright : (c) 2017 Vincent Hanquez 4 | -- 5 | -- Formatting helpers 6 | -- 7 | -- shame there's no leftPad package to use. /s 8 | -- 9 | module Gauge.Format 10 | ( printNanoseconds 11 | , printSubNanoseconds 12 | , tableMarkdown 13 | , reset 14 | , green 15 | , red 16 | , yellow 17 | ) where 18 | 19 | import Gauge.Time 20 | import Data.List 21 | import Data.Word 22 | import Text.Printf 23 | import qualified Basement.Terminal.ANSI as ANSI 24 | import Basement.Bounded (zn64) 25 | import GHC.Exts (toList) 26 | 27 | -- | Print a NanoSeconds quantity with a human friendly format 28 | -- that make it easy to compare different values 29 | -- 30 | -- Given a separator Char of '_': 31 | -- 32 | -- 0 -> " 0" 33 | -- 1000 -> " 1_000" 34 | -- 1234567 -> " 1_234_567" 35 | -- 10200300400 -> "10_200_300_400" 36 | -- 37 | -- Note that the seconds parameters is aligned considered 38 | -- maximum of 2 characters (i.e. 99 seconds). 39 | -- 40 | printNanoseconds :: Maybe Char -> NanoSeconds -> String 41 | printNanoseconds thousandSeparator (NanoSeconds absNs) = 42 | case divSub1000 0 absNs of 43 | [ns] -> padLeft maxLength $ printSpace ns 44 | [ns,us] -> padLeft maxLength $ addSeparators1000 [printSpace us,print3 ns] 45 | [ns,us,ms] -> padLeft maxLength $ addSeparators1000 [printSpace ms,print3 us,print3 ns] 46 | [ns,us,ms,s] -> padLeft maxLength $ addSeparators1000 [printSpace s,print3 ms,print3 us,print3 ns] 47 | _ -> error "printNanoSeconds: internal error: invalid format" 48 | where 49 | maxLength = 3 + 3 + 3 + 2 + (sepLength * 3) 50 | 51 | (addSeparators1000, sepLength) = 52 | case thousandSeparator of 53 | Nothing -> (concat, 0) 54 | Just c -> (intercalate [c], 1) 55 | 56 | printSpace :: Word64 -> String 57 | printSpace n = printf "%3d" n 58 | print3 :: Word64 -> String 59 | print3 n = printf "%03d" n 60 | 61 | divSub1000 :: Int -> Word64 -> [Word64] 62 | divSub1000 n i 63 | | n == 3 = [i] 64 | | otherwise = 65 | let (d,m) = i `divMod` 1000 66 | in if d == 0 then [m] else m : divSub1000 (n+1) d 67 | 68 | printSubNanoseconds :: Maybe Char -> PicoSeconds100 -> String 69 | printSubNanoseconds ts p = 70 | printNanoseconds ts ns ++ "." ++ show fragment 71 | where 72 | (ns, fragment) = picosecondsToNanoSeconds p 73 | 74 | 75 | -- | Produce a table in markdown 76 | -- 77 | -- This is handy when wanting to copy paste to a markdown flavor destination. 78 | tableMarkdown :: String -- ^ top left corner label 79 | -> [String] -- ^ columns labels 80 | -> [[String]] -- ^ a list of row labels followed by content rows 81 | -> String -- ^ the resulting string 82 | tableMarkdown name cols rows = 83 | let hdr = "| " ++ intercalate " | " (padList (name : cols)) ++ " |\n" 84 | sep = "|-" ++ intercalate "-|-" (map (map (const '-')) (padList (name : cols))) ++ "-|\n" 85 | in hdr ++ sep ++ concatMap printRow (map padList rows) 86 | where 87 | printRow :: [String] -> String 88 | printRow l = "| " ++ intercalate " | " l ++ " |\n" 89 | 90 | getColN n = map (flip (!!) n) rows 91 | 92 | sizeCols :: [Int] 93 | sizeCols = map (\(i, c) -> maximum $ map length (c : getColN i)) $ zip [0..] (name : cols) 94 | 95 | padList l = zipWith padCenter sizeCols l 96 | 97 | padLeft :: Int -> String -> String 98 | padLeft sz s 99 | | sz <= len = s 100 | | otherwise = replicate leftPad ' ' ++ s 101 | where 102 | len = length s 103 | leftPad = (sz - len) 104 | 105 | padCenter :: Int -> String -> String 106 | padCenter sz s 107 | | sz <= len = s 108 | | otherwise = replicate leftPad ' ' ++ s ++ replicate rightPad ' ' 109 | where 110 | len = length s 111 | (leftPad, r) = (sz - len) `divMod` 2 112 | rightPad = leftPad + r 113 | 114 | -- | reset, green, red, yellow ANSI escape 115 | reset, green, red, yellow :: String 116 | reset = toList ANSI.sgrReset 117 | green = toList $ ANSI.sgrForeground (zn64 2) True 118 | red = toList $ ANSI.sgrForeground (zn64 1) True 119 | yellow = toList $ ANSI.sgrForeground (zn64 3) True 120 | -------------------------------------------------------------------------------- /Gauge/IO/Printf.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Gauge.IO.Printf 3 | -- Copyright : (c) 2009-2014 Bryan O'Sullivan 4 | -- 5 | -- License : BSD-style 6 | -- Maintainer : bos@serpentine.com 7 | -- Stability : experimental 8 | -- Portability : GHC 9 | -- 10 | -- Input and output actions. 11 | 12 | {-# LANGUAGE CPP, FlexibleInstances, Rank2Types, TypeSynonymInstances #-} 13 | module Gauge.IO.Printf 14 | ( CritHPrintfType 15 | , note 16 | , printError 17 | , prolix 18 | , rewindClearLine 19 | ) where 20 | 21 | import Control.Monad (when) 22 | import Gauge.Monad (Gauge, askConfig, gaugeIO) 23 | import Gauge.Main.Options (Config(verbosity), Verbosity(..)) 24 | import System.IO (Handle, hFlush, stderr, stdout) 25 | import Text.Printf (PrintfArg) 26 | import qualified Text.Printf (HPrintfType, hPrintf) 27 | 28 | -- First item is the action to print now, given all the arguments 29 | -- gathered together so far. The second item is the function that 30 | -- will take a further argument and give back a new PrintfCont. 31 | data PrintfCont = PrintfCont (IO ()) (forall a . PrintfArg a => a -> PrintfCont) 32 | 33 | -- | An internal class that acts like Printf/HPrintf. 34 | -- 35 | -- The implementation is visible to the rest of the program, but the 36 | -- details of the class are not. 37 | class CritHPrintfType a where 38 | chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a 39 | 40 | 41 | instance CritHPrintfType (Gauge a) where 42 | chPrintfImpl check (PrintfCont final _) 43 | = do x <- askConfig 44 | when (check x) (gaugeIO (final >> hFlush stderr >> hFlush stdout)) 45 | return undefined 46 | 47 | instance CritHPrintfType (IO a) where 48 | chPrintfImpl _ (PrintfCont final _) 49 | = final >> hFlush stderr >> hFlush stdout >> return undefined 50 | 51 | instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where 52 | chPrintfImpl check (PrintfCont _ anotherArg) x 53 | = chPrintfImpl check (anotherArg x) 54 | 55 | chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r 56 | chPrintf shouldPrint h s 57 | = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s) 58 | (Text.Printf.hPrintf h s)) 59 | where 60 | make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) => 61 | a -> r) -> PrintfCont 62 | make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) 63 | (curCall' x)) 64 | 65 | {- A demonstration of how to write printf in this style, in case it is 66 | ever needed 67 | in fututre: 68 | 69 | cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r 70 | cPrintf shouldPrint s 71 | = chPrintfImpl shouldPrint (make (Text.Printf.printf s) 72 | (Text.Printf.printf s)) 73 | where 74 | make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont 75 | make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x)) 76 | -} 77 | 78 | -- | Print a \"normal\" note. 79 | note :: (CritHPrintfType r) => String -> r 80 | note = chPrintf ((> Quiet) . verbosity) stdout 81 | 82 | -- | Print verbose output. 83 | prolix :: (CritHPrintfType r) => String -> r 84 | prolix = chPrintf ((== Verbose) . verbosity) stdout 85 | 86 | -- | Print an error message. 87 | printError :: (CritHPrintfType r) => String -> r 88 | printError = chPrintf (const True) stderr 89 | 90 | -- | ansi escape on unix to rewind and clear the line to the end 91 | rewindClearLine :: String 92 | #ifdef mingw32_HOST_OS 93 | rewindClearLine = "\n" 94 | #else 95 | rewindClearLine = "\r\ESC[0K" 96 | #endif 97 | 98 | -------------------------------------------------------------------------------- /Gauge/ListMap.hs: -------------------------------------------------------------------------------- 1 | -- This is an extremely cheap (code-wise) implementation of Map. 2 | -- it's not meant to be efficient, but just provide 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | module Gauge.ListMap 7 | ( Map 8 | , fromList 9 | , toList 10 | , lookup 11 | ) where 12 | 13 | import Data.Typeable 14 | import GHC.Generics 15 | import Prelude hiding (lookup) 16 | import qualified Prelude as P 17 | import Control.DeepSeq (NFData) 18 | import Data.List hiding (lookup) 19 | import Data.Function (on) 20 | 21 | newtype Map k v = Map [(k,v)] 22 | deriving (Show, Eq, Typeable, Generic, NFData) 23 | 24 | fromList :: Ord k => [(k,v)] -> Map k v 25 | fromList = Map . map head . groupBy ((==) `on` fst) . sortBy (compare `on` fst) 26 | 27 | toList :: Map k v -> [(k,v)] 28 | toList (Map l) = l 29 | 30 | lookup :: Eq k => k -> Map k v -> Maybe v 31 | lookup k (Map l) = P.lookup k l 32 | -------------------------------------------------------------------------------- /Gauge/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | 5 | -- | 6 | -- Module : Gauge.Main 7 | -- Copyright : (c) 2009-2014 Bryan O'Sullivan 8 | -- 9 | -- License : BSD-style 10 | -- Maintainer : bos@serpentine.com 11 | -- Stability : experimental 12 | -- Portability : GHC 13 | -- 14 | -- Wrappers for compiling and running benchmarks quickly and easily. 15 | -- See 'defaultMain' below for an example. 16 | 17 | module Gauge.Main 18 | ( 19 | -- * Turning a suite of benchmarks into a program 20 | defaultMain 21 | , defaultMainWith 22 | , runMode 23 | -- * Running Benchmarks Interactively 24 | , benchmark 25 | , benchmarkWith 26 | , module Gauge.Benchmark 27 | ) where 28 | 29 | import Control.Applicative 30 | import Control.Monad (unless, when) 31 | import qualified Gauge.CSV as CSV 32 | #ifdef HAVE_ANALYSIS 33 | import Gauge.Analysis (analyseBenchmark) 34 | #endif 35 | import Gauge.IO.Printf (note, printError, rewindClearLine) 36 | import Gauge.Benchmark 37 | import Gauge.Main.Options 38 | import Gauge.Measurement (Measured, measureAccessors_, rescale) 39 | import Gauge.Monad (Gauge, askConfig, withConfig, gaugeIO) 40 | import Data.List (sort) 41 | import Data.Traversable 42 | import System.Environment (getProgName, getArgs) 43 | import System.Exit (ExitCode(..), exitWith) 44 | -- import System.FilePath.Glob 45 | import System.IO (BufferMode(..), hSetBuffering, stdout) 46 | import Basement.Terminal (initialize) 47 | import qualified Data.Vector as V 48 | import Prelude -- Silence redundant import warnings 49 | 50 | -- | An entry point that can be used as a @main@ function. 51 | -- 52 | -- > import Gauge.Main 53 | -- > 54 | -- > fib :: Int -> Int 55 | -- > fib 0 = 0 56 | -- > fib 1 = 1 57 | -- > fib n = fib (n-1) + fib (n-2) 58 | -- > 59 | -- > main = defaultMain [ 60 | -- > bgroup "fib" [ bench "10" $ whnf fib 10 61 | -- > , bench "35" $ whnf fib 35 62 | -- > , bench "37" $ whnf fib 37 63 | -- > ] 64 | -- > ] 65 | defaultMain :: [Benchmark] -> IO () 66 | defaultMain = defaultMainWith defaultConfig 67 | 68 | -- | Display an error message from a command line parsing failure, and 69 | -- exit. 70 | parseError :: String -> IO a 71 | parseError msg = do 72 | _ <- printError "Error: %s\n" msg 73 | _ <- printError "Run \"%s --help\" for usage information\n" =<< getProgName 74 | exitWith (ExitFailure 64) 75 | 76 | selectBenches :: MatchType -> [String] -> Benchmark -> IO (String -> Bool) 77 | selectBenches matchType benches bsgroup = do 78 | let toRun = makeSelector matchType benches 79 | unless (null benches || any toRun (benchNames bsgroup)) $ 80 | parseError "none of the specified names matches a benchmark" 81 | return toRun 82 | 83 | -- | Analyse a single benchmark, printing just the time by default and all 84 | -- stats in verbose mode. 85 | quickAnalyse :: String -> V.Vector Measured -> Gauge () 86 | quickAnalyse desc meas = do 87 | Config{..} <- askConfig 88 | let timeAccessor = filter (("time" ==) . fst) measureAccessors_ 89 | accessors = 90 | if verbosity == Verbose 91 | then measureAccessors_ 92 | else timeAccessor 93 | 94 | _ <- note "%s%-40s " rewindClearLine desc 95 | if verbosity == Verbose then gaugeIO (putStrLn "") else return () 96 | _ <- traverse 97 | (\(k, (a, s, _)) -> reportStat a s k) 98 | accessors 99 | _ <- note "\n" 100 | 101 | _ <- traverse 102 | (\(_, (a, _, _)) -> writeToCSV csvFile a) 103 | timeAccessor 104 | pure () 105 | 106 | where 107 | 108 | reportStat accessor sh msg = 109 | when (not $ V.null meas) $ 110 | let val = (accessor . rescale) $ V.last meas 111 | in maybe (return ()) (\x -> note "%-20s %-10s\n" msg (sh x)) val 112 | 113 | writeToCSV file accessor = 114 | when (not $ V.null meas) $ do 115 | let val = (accessor . rescale) $ V.last meas 116 | case val of 117 | Nothing -> pure () 118 | Just v -> 119 | gaugeIO $ CSV.write file $ CSV.Row 120 | [ CSV.string desc 121 | , CSV.float v 122 | ] 123 | 124 | -- | Run a benchmark interactively with supplied config, and analyse its 125 | -- performance. 126 | benchmarkWith :: Config -> Benchmarkable -> IO () 127 | benchmarkWith cfg bm = 128 | withConfig cfg $ 129 | runBenchmark (const True) (Benchmark "function" bm) (BenchmarkNormal quickAnalyse) 130 | 131 | -- | Run a benchmark interactively with default config, and analyse its 132 | -- performance. 133 | benchmark :: Benchmarkable -> IO () 134 | benchmark = benchmarkWith defaultConfig 135 | 136 | -- | An entry point that can be used as a @main@ function, with 137 | -- configurable defaults. 138 | -- 139 | -- Example: 140 | -- 141 | -- > import Gauge.Main.Options 142 | -- > import Gauge.Main 143 | -- > 144 | -- > myConfig = defaultConfig { 145 | -- > -- Do not GC between runs. 146 | -- > forceGC = False 147 | -- > } 148 | -- > 149 | -- > main = defaultMainWith myConfig [ 150 | -- > bench "fib 30" $ whnf fib 30 151 | -- > ] 152 | -- 153 | -- If you save the above example as @\"Fib.hs\"@, you should be able 154 | -- to compile it as follows: 155 | -- 156 | -- > ghc -O --make Fib 157 | -- 158 | -- Run @\"Fib --help\"@ on the command line to get a list of command 159 | -- line options. 160 | defaultMainWith :: Config 161 | -> [Benchmark] 162 | -> IO () 163 | defaultMainWith defCfg bs = do 164 | initialize 165 | args <- getArgs 166 | let (cfg, extra) = parseWith defCfg args 167 | #ifdef HAVE_ANALYSIS 168 | let cfg' = cfg 169 | #else 170 | let cfg' = cfg {quickMode = True} 171 | #endif 172 | runMode (mode cfg') cfg' extra bs 173 | 174 | -- | Run a set of 'Benchmark's with the given 'Mode'. 175 | -- 176 | -- This can be useful if you have a 'Mode' from some other source (e.g. from a 177 | -- one in your benchmark driver's command-line parser). 178 | runMode :: Mode -> Config -> [String] -> [Benchmark] -> IO () 179 | runMode wat cfg benches bs = 180 | -- TBD: This has become messy. We use mode as well as cfg options for the 181 | -- same purpose It is possible to specify multiple exclusive options. We 182 | -- need to handle the exclusive options in a better way. 183 | case wat of 184 | List -> mapM_ putStrLn . sort . concatMap benchNames $ bs 185 | Version -> putStrLn versionInfo 186 | Help -> putStrLn describe 187 | DefaultMode -> runDefault 188 | where 189 | runDefault = do 190 | -- write the raw csv file header 191 | CSV.write (csvRawFile cfg) $ CSV.Row $ map CSV.string $ 192 | ["name"] ++ map fst measureAccessors_ 193 | 194 | -- write the csv file header 195 | CSV.write (csvFile cfg) $ CSV.Row $ map CSV.string $ ["Name"] ++ 196 | if quickMode cfg 197 | then ["Time"] 198 | -- This requires statistical analysis support. This must 199 | -- remain compatible with criterion. 200 | else ["Mean","MeanLB","MeanUB","Stddev","StddevLB","StddevUB"] 201 | 202 | hSetBuffering stdout NoBuffering 203 | selector <- selectBenches (match cfg) benches bsgroup 204 | 205 | -- if compiled without analysis step, then default to quickmode 206 | #ifdef HAVE_ANALYSIS 207 | let compiledAnalyseStep = analyseBenchmark 208 | #else 209 | let compiledAnalyseStep = quickAnalyse 210 | #endif 211 | 212 | let mode = case (measureOnly cfg, iters cfg, quickMode cfg) of 213 | (Just outfile, _ , _ ) -> BenchmarkNormal $ \_ r -> gaugeIO (writeFile outfile (show r)) 214 | (Nothing , Just nbIters, _ ) -> BenchmarkIters nbIters 215 | (Nothing , Nothing , True) -> BenchmarkNormal quickAnalyse 216 | (Nothing , Nothing , False) -> BenchmarkNormal compiledAnalyseStep 217 | 218 | withConfig cfg $ runBenchmark selector bsgroup mode 219 | 220 | bsgroup = BenchGroup "" bs 221 | -------------------------------------------------------------------------------- /Gauge/Main/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 2 | 3 | -- | 4 | -- Module : Gauge.Main.Options 5 | -- Copyright : (c) 2014 Bryan O'Sullivan 6 | -- 7 | -- License : BSD-style 8 | -- Maintainer : bos@serpentine.com 9 | -- Stability : experimental 10 | -- Portability : GHC 11 | -- 12 | -- Benchmarking command-line configuration. 13 | 14 | module Gauge.Main.Options 15 | ( defaultConfig 16 | , makeSelector 17 | , parseWith 18 | , describe 19 | , versionInfo 20 | , Config (..) 21 | , Verbosity (..) 22 | , DisplayMode (..) 23 | , MatchType (..) 24 | , Mode (..) 25 | ) where 26 | 27 | import Gauge.Measurement 28 | (validateAccessors, defaultMinSamplesNormal, 29 | defaultMinSamplesQuick, defaultTimeLimitNormal, 30 | defaultTimeLimitQuick) 31 | import Gauge.Time (MilliSeconds(..)) 32 | import Data.Char (isSpace, toLower) 33 | import Data.List (foldl') 34 | import Data.Version (showVersion) 35 | import System.Console.GetOpt 36 | import Paths_gauge (version) 37 | import Data.Data (Data, Typeable) 38 | import Data.Int (Int64) 39 | import Data.List (isInfixOf, isPrefixOf) 40 | import GHC.Generics (Generic) 41 | 42 | -- | Control the amount of information displayed. 43 | data Verbosity = Quiet 44 | | Normal 45 | | Verbose 46 | deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, 47 | Generic) 48 | 49 | -- | How to match a benchmark name. 50 | data MatchType = Exact 51 | -- ^ Match the exact benchmark name 52 | | Prefix 53 | -- ^ Match by prefix. For example, a prefix of 54 | -- @\"foo\"@ will match @\"foobar\"@. 55 | | Pattern 56 | -- ^ Match by searching given substring in benchmark 57 | -- paths. 58 | | IPattern 59 | -- ^ Same as 'Pattern', but case insensitive. 60 | deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, 61 | Generic) 62 | 63 | -- | Execution mode for a benchmark program. 64 | data Mode = List 65 | -- ^ List all benchmarks. 66 | | Version 67 | -- ^ Print the version. 68 | | Help 69 | -- ^ Print help 70 | | DefaultMode 71 | -- ^ Default Benchmark mode 72 | deriving (Eq, Read, Show, Typeable, Data, Generic) 73 | 74 | data DisplayMode = 75 | Condensed 76 | | StatsTable 77 | deriving (Eq, Read, Show, Typeable, Data, Generic) 78 | 79 | -- | Top-level benchmarking configuration. 80 | data Config = Config { 81 | confInterval :: Maybe Double 82 | -- ^ Confidence interval for bootstrap estimation (greater than 83 | -- 0, less than 1). 84 | , forceGC :: Bool 85 | -- ^ /Obsolete, unused/. This option used to force garbage 86 | -- collection between every benchmark run, but it no longer has 87 | -- an effect (we now unconditionally force garbage collection). 88 | -- This option remains solely for backwards API compatibility. 89 | , timeLimit :: Maybe Double 90 | -- ^ Number of seconds to run a single benchmark. In practice, execution 91 | -- time may exceed this limit to honor minimum number of samples or 92 | -- minimum duration of each sample. Increased time limit allows us to 93 | -- take more samples. Use 0 for a single sample benchmark. 94 | , minSamples :: Maybe Int 95 | -- ^ Minimum number of samples to be taken. 96 | , minDuration :: MilliSeconds 97 | -- ^ Minimum duration of each sample, increased duration allows us to 98 | -- perform more iterations in each sample. To enforce a single iteration 99 | -- in a sample use duration 0. 100 | , includeFirstIter :: Bool 101 | -- ^ Discard the very first iteration of a benchmark. The first iteration 102 | -- includes the potentially extra cost of one time evaluations 103 | -- introducing large variance. 104 | , quickMode :: Bool 105 | -- ^ Quickly measure and report raw measurements. 106 | , measureOnly :: Maybe FilePath 107 | -- ^ Just measure the given benchmark and place the raw output in this 108 | -- file, do not analyse and generate a report. 109 | , measureWith :: Maybe FilePath 110 | -- ^ Specify the path of the benchmarking program to use (this program 111 | -- itself) for measuring the benchmarks in a separate process. 112 | , resamples :: Int 113 | -- ^ Number of resamples to perform when bootstrapping. 114 | , regressions :: [([String], String)] 115 | -- ^ Regressions to perform. 116 | , rawDataFile :: Maybe FilePath 117 | -- ^ File to write binary measurement and analysis data to. If 118 | -- not specified, this will be a temporary file. 119 | , reportFile :: Maybe FilePath 120 | -- ^ File to write report output to, with template expanded. 121 | , csvFile :: Maybe FilePath 122 | -- ^ File to write CSV summary to. 123 | , csvRawFile :: Maybe FilePath 124 | -- ^ File to write CSV measurements to. 125 | , jsonFile :: Maybe FilePath 126 | -- ^ File to write JSON-formatted results to. 127 | , junitFile :: Maybe FilePath 128 | -- ^ File to write JUnit-compatible XML results to. 129 | , verbosity :: Verbosity 130 | -- ^ Verbosity level to use when running and analysing 131 | -- benchmarks. 132 | , template :: FilePath 133 | -- ^ Template file to use if writing a report. 134 | , iters :: Maybe Int64 135 | -- ^ Number of iterations 136 | , match :: MatchType 137 | -- ^ Type of matching to use, if any 138 | , mode :: Mode 139 | -- ^ Mode of operation 140 | , displayMode :: DisplayMode 141 | } deriving (Eq, Read, Show, Typeable, Data, Generic) 142 | 143 | defaultMinDuration :: MilliSeconds 144 | defaultMinDuration = MilliSeconds 30 145 | 146 | -- | Default benchmarking configuration. 147 | defaultConfig :: Config 148 | defaultConfig = Config 149 | { confInterval = Nothing 150 | , forceGC = True 151 | , timeLimit = Nothing 152 | , minSamples = Nothing 153 | , minDuration = defaultMinDuration 154 | , includeFirstIter = False 155 | , quickMode = False 156 | , measureOnly = Nothing 157 | , measureWith = Nothing 158 | , resamples = 1000 159 | , regressions = [] 160 | , rawDataFile = Nothing 161 | , reportFile = Nothing 162 | , csvFile = Nothing 163 | , csvRawFile = Nothing 164 | , jsonFile = Nothing 165 | , junitFile = Nothing 166 | , verbosity = Normal 167 | , template = "default" 168 | , iters = Nothing 169 | , match = Prefix 170 | , mode = DefaultMode 171 | , displayMode = StatsTable 172 | } 173 | 174 | -- | Create a benchmark selector function that can tell if a name given on the 175 | -- command line matches a defined benchmark. 176 | makeSelector :: MatchType 177 | -> [String] 178 | -- ^ Command line arguments. 179 | -> (String -> Bool) 180 | makeSelector matchKind args = 181 | case matchKind of 182 | Exact -> \b -> null args || any (== b) args 183 | Prefix -> \b -> null args || any (`isPrefixOf` b) args 184 | Pattern -> \b -> null args || any (`isInfixOf` b) args 185 | IPattern -> \b -> null args || any (`isInfixOf` map toLower b) (map (map toLower) args) 186 | 187 | parseWith :: Config 188 | -- ^ Default configuration to use 189 | -> [String] 190 | -- ^ Program Argument 191 | -> (Config, [String]) 192 | parseWith start argv = 193 | case getOpt Permute opts argv of 194 | (o,n,[] ) -> (foldl' (flip id) start o, n) 195 | (_,_,errs) -> optionError (concat errs ++ usageInfo header opts) 196 | 197 | opts :: [OptDescr (Config -> Config)] 198 | opts = 199 | [ Option "I" ["ci"] (ReqArg setCI "CI") "Confidence interval" 200 | , Option "G" ["no-gc"] (NoArg setNoGC) "Do not collect garbage between iterations" 201 | , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") $ 202 | "Min seconds for each benchmark run, default is " 203 | ++ show defaultTimeLimitNormal ++ " in normal mode, " 204 | ++ show defaultTimeLimitQuick ++ " in quick mode" 205 | , Option "" ["min-samples"] (ReqArg setMinSamples "COUNT") $ 206 | "Min no. of samples for each benchmark, default is " 207 | ++ show defaultMinSamplesNormal ++ " in normal mode, " 208 | ++ show defaultMinSamplesQuick ++ " in quick mode" 209 | , Option "" ["min-duration"] (ReqArg setMinDuration "MILLISECS") $ 210 | "Min duration for each sample, default is " 211 | ++ show defaultMinDuration ++ ", when 0 stops after first iteration" 212 | , Option "" ["include-first-iter"] (NoArg setIncludeFirst) "Do not discard the measurement of the first iteration" 213 | , Option "q" ["quick"] (NoArg setQuickMode) "Perform a quick measurement and report results without statistical analysis" 214 | , Option "" ["measure-only"] (fileArg setMeasureOnly) "Just measure the benchmark and place the raw data in the given file" 215 | , Option "" ["measure-with"] (fileArg setMeasureProg) "Perform measurements in a separate process using this program." 216 | , Option "" ["resamples"] (ReqArg setResamples "COUNT") "Number of boostrap resamples to perform" 217 | , Option "" ["regress"] (ReqArg setRegressions "RESP:PRED..") "Regressions to perform" 218 | , Option "" ["raw"] (fileArg setRaw) "File to write raw data to" 219 | , Option "o" ["output"] (fileArg setOutput) "File to write report to" 220 | , Option "" ["csvraw"] (fileArg setCSVRaw) "File to write CSV measurements to" 221 | , Option "" ["csv"] (fileArg setCSV) "File to write CSV summary to" 222 | , Option "" ["json"] (fileArg setJSON) "File to write JSON summary to" 223 | , Option "" ["junit"] (fileArg setJUnit) "File to write JUnit summary to" 224 | , Option "v" ["verbosity"] (ReqArg setVerbosity "LEVEL") "Verbosity level" 225 | , Option "t" ["template"] (fileArg setTemplate) "Template to use for report" 226 | , Option "n" ["iters"] (ReqArg setIters "ITERS") "Run benchmarks, don't analyse" 227 | , Option "m" ["match"] (ReqArg setMatch "MATCH") $ 228 | "Benchmark match style: prefix (default), exact, pattern (substring), " 229 | ++ "or ipattern (case insensitive)" 230 | , Option "l" ["list"] (NoArg $ setMode List) "List benchmarks" 231 | , Option "" ["version"] (NoArg $ setMode Version) "Show version info" 232 | , Option "s" ["small"] (NoArg $ setDisplayMode Condensed) "Set benchmark display to the minimum useful information" 233 | , Option "h" ["help"] (NoArg $ setMode Help) "Show help" 234 | ] 235 | where 236 | fileArg f = ReqArg f "FILE" 237 | setCI s v = v { confInterval = Just $ range 0.001 0.999 s } 238 | setNoGC v = v { forceGC = False } 239 | setTimeLimit s v = v { timeLimit = Just $ range 0.0 86400 s } 240 | setMinSamples n v = v { minSamples = Just $ read n } 241 | setMinDuration ms v = v { minDuration = MilliSeconds $ read ms } 242 | setIncludeFirst v = v { includeFirstIter = True } 243 | setQuickMode v = v { quickMode = True } 244 | setMeasureOnly f v = v { measureOnly = Just f } 245 | setMeasureProg f v = v { measureWith = Just f } 246 | setResamples s v = v { resamples = range 1 1000000 s } 247 | setRegressions s v = v { regressions = regressParams s : regressions v } 248 | setRaw f v = v { rawDataFile = Just f } 249 | setOutput f v = v { reportFile = Just f } 250 | setCSV f v = v { csvFile = Just f } 251 | setCSVRaw f v = v { csvRawFile = Just f } 252 | setJSON f v = v { jsonFile = Just f } 253 | setJUnit f v = v { junitFile = Just f } 254 | setVerbosity s v = v { verbosity = toEnum (range 0 2 s) } 255 | setTemplate f v = v { template = f } 256 | setIters s v = v { iters = Just $ read s } 257 | setMatch s v = 258 | let m = case map toLower s of 259 | "pfx" -> Prefix 260 | "prefix" -> Prefix 261 | "exact" -> Exact 262 | "pattern" -> Pattern 263 | "ipattern" -> IPattern 264 | _ -> optionError ("unknown match type: " ++ s) 265 | in v { match = m } 266 | setMode m v = v { mode = m } 267 | setDisplayMode m v = v { displayMode = m } 268 | 269 | -- FIXME 270 | optionError :: String -> a 271 | optionError s = error s 272 | 273 | range :: (Show a, Read a, Ord a) => a -> a -> String -> a 274 | range lo hi s = do 275 | case reads s of 276 | [(i, "")] 277 | | i >= lo && i <= hi -> i 278 | | otherwise -> optionError $ show i ++ " is outside range " ++ show (lo,hi) 279 | _ -> optionError $ show s ++ " is not a number" 280 | 281 | {- 282 | Regression metrics (for use with --regress): 283 | time wall-clock time 284 | cpuTime CPU time 285 | cycles CPU cycles 286 | iters loop iterations 287 | allocated (+RTS -T) bytes allocated 288 | numGcs (+RTS -T) number of garbage collections 289 | bytesCopied (+RTS -T) number of bytes copied during GC 290 | mutatorWallSeconds (+RTS -T) wall-clock time for mutator threads 291 | mutatorCpuSeconds (+RTS -T) CPU time spent running mutator threads 292 | gcWallSeconds (+RTS -T) wall-clock time spent doing GC 293 | gcCpuSeconds (+RTS -T) CPU time spent doing GC 294 | Benchmark self: FINISH 295 | 296 | -- We sort not by name, but by likely frequency of use. 297 | regressionHelp :: Chunk Doc 298 | regressionHelp = 299 | fmap (text "Regression metrics (for use with --regress):" .$.) $ 300 | tabulate [(text n,text d) | (n,(_,d)) <- map f measureKeys] 301 | where f k = (k, measureAccessors M.! k) 302 | -} 303 | 304 | describe :: String 305 | describe = usageInfo header opts 306 | 307 | header :: String 308 | header = "Microbenchmark suite - " ++ versionInfo 309 | 310 | -- | A string describing the version of this benchmark (really, the 311 | -- version of gauge that was used to build it). 312 | versionInfo :: String 313 | versionInfo = "built with gauge " ++ showVersion version 314 | 315 | regressParams :: String -> ([String], String) 316 | regressParams m 317 | | null r = optionError "no responder specified" 318 | | null ps = optionError "no predictors specified" 319 | | otherwise = 320 | let ret = (words . map repl . drop 1 $ ps, tidy r) 321 | in either optionError (const ret) $ uncurry validateAccessors ret 322 | where 323 | repl ',' = ' ' 324 | repl c = c 325 | tidy = reverse . dropWhile isSpace . reverse . dropWhile isSpace 326 | (r,ps) = break (==':') m 327 | 328 | -------------------------------------------------------------------------------- /Gauge/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | -- | 4 | -- Module : Gauge.Monad 5 | -- Copyright : (c) 2009 Neil Brown 6 | -- 7 | -- License : BSD-style 8 | -- Maintainer : bos@serpentine.com 9 | -- Stability : experimental 10 | -- Portability : GHC 11 | -- 12 | -- The environment in which most gauge code executes. 13 | module Gauge.Monad 14 | ( Gauge 15 | , Crit (..) 16 | , askCrit 17 | , askConfig 18 | , gaugeIO 19 | , withConfig 20 | , finallyGauge 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Exception 25 | import Control.Monad (ap) 26 | import Data.IORef (IORef, newIORef) 27 | import Gauge.Main.Options (Config) 28 | import Gauge.Measurement (initializeTime) 29 | import System.Random.MWC (GenIO) 30 | import Prelude -- Silence redundant import warnings 31 | 32 | data Crit = Crit 33 | { config :: !Config 34 | , gen :: !(IORef (Maybe GenIO)) 35 | } 36 | 37 | -- | 'Gauge' is essentially a reader monad to make the benchmark configuration 38 | -- available throughout the code. 39 | newtype Gauge a = Gauge { runGauge :: Crit -> IO a } 40 | 41 | instance Functor Gauge where 42 | fmap f a = Gauge $ \r -> f <$> runGauge a r 43 | instance Applicative Gauge where 44 | pure = Gauge . const . pure 45 | (<*>) = ap 46 | instance Monad Gauge where 47 | return = pure 48 | ma >>= mb = Gauge $ \r -> runGauge ma r >>= \a -> runGauge (mb a) r 49 | 50 | -- | Retrieve the configuration from the 'Gauge' monad. 51 | askConfig :: Gauge Config 52 | askConfig = Gauge (pure . config) 53 | 54 | askCrit :: Gauge Crit 55 | askCrit = Gauge pure 56 | 57 | -- | Lift an IO action into the 'Gauge' monad. 58 | gaugeIO :: IO a -> Gauge a 59 | gaugeIO = Gauge . const 60 | 61 | finallyGauge :: Gauge a -> Gauge b -> Gauge a 62 | finallyGauge f g = Gauge $ \crit -> do 63 | finally (runGauge f crit) (runGauge g crit) 64 | 65 | -- | Run a 'Gauge' action with the given 'Config'. 66 | withConfig :: Config -> Gauge a -> IO a 67 | withConfig cfg act = do 68 | initializeTime 69 | g <- newIORef Nothing 70 | runGauge act (Crit cfg g) 71 | -------------------------------------------------------------------------------- /Gauge/Optional.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | -- | 5 | -- Module : Gauge.Optional 6 | -- Copyright : (c) 2017-2018 Vincent Hanquez 7 | -- 8 | -- A sum-type free Maybe where the value Nothing is 9 | -- represented by a special value in the original 10 | -- domain supported 11 | -- 12 | -- The OptionalTag class is where the special value 13 | -- is defined 14 | -- 15 | {-# LANGUAGE DeriveGeneric #-} 16 | module Gauge.Optional 17 | ( Optional 18 | , toOptional 19 | , unOptional 20 | , OptionalTag(..) 21 | , isOmitted 22 | , omitted 23 | , toMaybe 24 | , fromMaybe 25 | , map 26 | , both 27 | ) where 28 | 29 | import Prelude hiding (map) 30 | import Data.Int 31 | import Data.Word 32 | import Data.Data 33 | import GHC.Generics 34 | import Basement.Compat.CallStack 35 | 36 | -- | A type representing a sum-type free Maybe a 37 | -- where a specific tag represent Nothing 38 | newtype Optional a = Optional { unOptional :: a } 39 | deriving (Eq, Show, Read, Typeable, Data, Generic) 40 | 41 | class OptionalTag a where 42 | optionalTag :: a 43 | isOptionalTag :: a -> Bool 44 | 45 | instance OptionalTag Int64 where 46 | optionalTag = minBound 47 | isOptionalTag = (==) optionalTag 48 | instance OptionalTag Word64 where 49 | optionalTag = maxBound 50 | isOptionalTag = (==) optionalTag 51 | instance OptionalTag Double where 52 | optionalTag = -1/0 53 | isOptionalTag d = isInfinite d || isNaN d 54 | 55 | -- | Create an optional value from a 56 | toOptional :: (HasCallStack, OptionalTag a) => String -> a -> Optional a 57 | toOptional ty v 58 | | isOptionalTag v = error ("Creating an optional valid value for " ++ ty ++ " using the optional tag") 59 | | otherwise = Optional v 60 | {-# INLINE toOptional #-} 61 | 62 | omitted :: OptionalTag a => Optional a 63 | omitted = Optional optionalTag 64 | {-# INLINE omitted #-} 65 | 66 | isOmitted :: OptionalTag a => Optional a -> Bool 67 | isOmitted (Optional v) 68 | | isOptionalTag v = True 69 | | otherwise = False 70 | 71 | toMaybe :: OptionalTag a => Optional a -> Maybe a 72 | toMaybe (Optional v) | isOptionalTag v = Nothing 73 | | otherwise = Just v 74 | {-# INLINE toMaybe #-} 75 | 76 | fromMaybe :: (HasCallStack, OptionalTag a) => Maybe a -> Optional a 77 | fromMaybe Nothing = Optional optionalTag 78 | fromMaybe (Just v) 79 | | isOptionalTag v = error "fromMaybe: creating an optional value using the optional tag" 80 | | otherwise = Optional v 81 | {-# INLINE fromMaybe #-} 82 | 83 | map :: OptionalTag a => (a -> a) -> Optional a -> Optional a 84 | map f o@(Optional v) | isOptionalTag v = o 85 | | otherwise = Optional (f v) 86 | {-# INLINE map #-} 87 | 88 | both :: (HasCallStack, OptionalTag a) => (a -> a -> a) -> Optional a -> Optional a -> Optional a 89 | both f o1 o2 90 | | isOmitted o1 = o2 91 | | isOmitted o2 = o1 92 | | isOptionalTag r = error "both: creating an optional value using the optional tag" 93 | | otherwise = Optional r 94 | where r = f (unOptional o1) (unOptional o2) 95 | -------------------------------------------------------------------------------- /Gauge/Source/GC.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Gauge.Source.GC 3 | -- Copyright : (c) 2017 Vincent Hanquez 4 | -- 5 | -- Metrics gathering related to the GHC RTS / GC 6 | -- 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | module Gauge.Source.GC 10 | ( Metrics(..) 11 | , supported 12 | , withMetrics 13 | ) where 14 | 15 | import Control.Applicative 16 | import Data.Word 17 | import Data.IORef (readIORef, newIORef, IORef) 18 | import Gauge.Time 19 | import System.IO.Unsafe (unsafePerformIO) 20 | import Gauge.Optional (omitted, toOptional, Optional, OptionalTag) 21 | 22 | #if MIN_VERSION_base(4,10,0) 23 | import qualified GHC.Stats as GHC (RTSStats(..), getRTSStatsEnabled, getRTSStats) 24 | #else 25 | import qualified Control.Exception as Exn 26 | import qualified GHC.Stats as GHC (GCStats(..), getGCStats) 27 | import Data.Int 28 | #endif 29 | 30 | import Prelude -- Silence redundant import warnings 31 | 32 | #if MIN_VERSION_base(4,10,0) 33 | newtype AbsMetrics = AbsMetrics GHC.RTSStats 34 | #else 35 | newtype AbsMetrics = AbsMetrics GHC.GCStats 36 | #endif 37 | 38 | -- | Check if RTS/GC metrics gathering is enabled or not 39 | supported :: Bool 40 | supported = unsafePerformIO (readIORef supportedVar) 41 | {-# NOINLINE supported #-} 42 | 43 | supportedVar :: IORef Bool 44 | supportedVar = unsafePerformIO $ do 45 | #if __GHCJS__ 46 | let b = False 47 | #elif MIN_VERSION_base(4,10,0) 48 | b <- GHC.getRTSStatsEnabled 49 | #else 50 | b <- (const True <$> GHC.getGCStats) `Exn.catch` \(_ :: Exn.SomeException) -> pure False 51 | #endif 52 | newIORef b 53 | {-# NOINLINE supportedVar #-} 54 | 55 | getMetrics :: IO AbsMetrics 56 | getMetrics = AbsMetrics <$> 57 | #if MIN_VERSION_base(4,10,0) 58 | GHC.getRTSStats 59 | #else 60 | GHC.getGCStats 61 | #endif 62 | 63 | -- | Differential metrics related the RTS/GC 64 | data Metrics = Metrics 65 | { allocated :: {-# UNPACK #-} !(Optional Word64) -- ^ number of bytes allocated 66 | , numGCs :: {-# UNPACK #-} !Word64 -- ^ number of GCs 67 | , copied :: {-# UNPACK #-} !(Optional Word64) -- ^ number of bytes copied 68 | , mutWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator wall time measurement 69 | , mutCpuSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator cpu time measurement 70 | , gcWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ gc wall time measurement 71 | , gcCpuSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ gc cpu time measurement 72 | } deriving (Show, Eq) 73 | 74 | diffMetrics :: AbsMetrics -> AbsMetrics -> Metrics 75 | diffMetrics (AbsMetrics end) (AbsMetrics start) = 76 | #if MIN_VERSION_base(4,10,0) 77 | Metrics { allocated = diff (-*?) GHC.allocated_bytes 78 | , numGCs = diff (-*) (fromIntegral . GHC.gcs) 79 | , copied = diff (-*?) GHC.copied_bytes 80 | , mutWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_elapsed_ns) 81 | , mutCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns) 82 | , gcWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_elapsed_ns) 83 | , gcCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_cpu_ns) 84 | } 85 | where 86 | diff op f = f end `op` f start 87 | (-*) :: (Ord a, Num a) => a -> a -> a 88 | (-*) a b 89 | | a >= b = a - b 90 | | otherwise = (-1) 91 | 92 | (-*?) :: (OptionalTag a, Ord a, Num a) => a -> a -> Optional a 93 | (-*?) a b 94 | | a >= b = toOptional "gc metric" (a - b) 95 | | otherwise = omitted 96 | #else 97 | Metrics { allocated = diff (-*?) GHC.bytesAllocated 98 | , numGCs = diff (-*) GHC.numGcs 99 | , copied = diff (-*?) GHC.bytesCopied 100 | , mutWallSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorWallSeconds 101 | , mutCpuSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorCpuSeconds 102 | , gcWallSeconds = doubleToNanoSeconds $ diff (-) GHC.gcWallSeconds 103 | , gcCpuSeconds = doubleToNanoSeconds $ diff (-) GHC.gcCpuSeconds 104 | } 105 | where 106 | diff op f = f end `op` f start 107 | 108 | (-*) :: Int64 -> Int64 -> Word64 109 | (-*) a b 110 | | a >= b = fromIntegral (a - b) 111 | | otherwise = -1 112 | 113 | (-*?) :: Int64 -> Int64 -> Optional Word64 114 | (-*?) a b 115 | | a >= b = toOptional "gc metrics" $ fromIntegral (a - b) 116 | | otherwise = omitted 117 | #endif 118 | 119 | -- | Return RTS/GC metrics differential between a call to `f` 120 | withMetrics :: IO a -- ^ function to measure 121 | -> IO (a, Maybe Metrics) 122 | withMetrics f 123 | | supported = do 124 | start <- getMetrics 125 | a <- f 126 | end <- getMetrics 127 | pure (a, Just $ diffMetrics end start) 128 | | otherwise = f >>= \a -> pure (a, Nothing) 129 | -------------------------------------------------------------------------------- /Gauge/Source/RUsage.hsc: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Gauge.Source.RUsage 3 | -- Copyright : (c) 2017 Vincent Hanquez 4 | -- 5 | -- A bindings to POSIX getrusage() 6 | -- 7 | 8 | {-# LANGUAGE PatternSynonyms #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE BangPatterns #-} 11 | module Gauge.Source.RUsage 12 | ( Who 13 | , pattern Self 14 | , pattern Children 15 | , RUsage(..) 16 | , TimeVal(..) 17 | , get 18 | , with 19 | , supported 20 | ) where 21 | 22 | #ifndef mingw32_HOST_OS 23 | #define SUPPORT_RUSAGE 24 | #endif 25 | 26 | #ifdef SUPPORT_RUSAGE 27 | 28 | import Control.Applicative 29 | import Foreign.C.Error (throwErrnoIfMinus1_) 30 | import Foreign.Storable 31 | import Foreign.Ptr 32 | import Foreign.Marshal.Alloc 33 | 34 | #include 35 | #include 36 | 37 | #else 38 | 39 | #endif 40 | 41 | import Gauge.Time (MicroSeconds(..)) 42 | import Foreign.C.Types 43 | import Data.Word 44 | import Prelude -- Silence redundant import warnings 45 | 46 | {- struct rusage : 47 | struct timeval ru_utime; /* user CPU time used */ 48 | struct timeval ru_stime; /* system CPU time used */ 49 | long ru_maxrss; /* maximum resident set size */ 50 | long ru_ixrss; /* integral shared memory size */ 51 | long ru_idrss; /* integral unshared data size */ 52 | long ru_isrss; /* integral unshared stack size */ 53 | long ru_minflt; /* page reclaims (soft page faults) */ 54 | long ru_majflt; /* page faults (hard page faults) */ 55 | long ru_nswap; /* swaps */ 56 | long ru_inblock; /* block input operations */ 57 | long ru_oublock; /* block output operations */ 58 | long ru_msgsnd; /* IPC messages sent */ 59 | long ru_msgrcv; /* IPC messages received */ 60 | long ru_nsignals; /* signals received */ 61 | long ru_nvcsw; /* voluntary context switches */ 62 | long ru_nivcsw; /* involuntary context switches */ 63 | -} 64 | 65 | data RUsage = RUsage 66 | { userCpuTime :: {-# UNPACK #-} !TimeVal 67 | , systemCpuTime :: {-# UNPACK #-} !TimeVal 68 | , maxResidentSetSize :: {-# UNPACK #-} !Word64 69 | , iSharedMemorySize :: {-# UNPACK #-} !Word64 70 | , iUnsharedDataSize :: {-# UNPACK #-} !Word64 71 | , iUnsharedStackSize :: {-# UNPACK #-} !Word64 72 | , minorFault :: {-# UNPACK #-} !Word64 73 | , majorFault :: {-# UNPACK #-} !Word64 74 | , nSwap :: {-# UNPACK #-} !Word64 75 | , inBlock :: {-# UNPACK #-} !Word64 76 | , outBlock :: {-# UNPACK #-} !Word64 77 | , msgSend :: {-# UNPACK #-} !Word64 78 | , msgRecv :: {-# UNPACK #-} !Word64 79 | , nSignals :: {-# UNPACK #-} !Word64 80 | , nVoluntaryContextSwitch :: {-# UNPACK #-} !Word64 81 | , nInvoluntaryContextSwitch :: {-# UNPACK #-} !Word64 82 | } deriving (Show, Eq) 83 | 84 | newtype TimeVal = TimeVal MicroSeconds 85 | deriving (Show, Eq) 86 | 87 | #ifdef SUPPORT_RUSAGE 88 | 89 | instance Storable RUsage where 90 | alignment _ = 8 91 | sizeOf _ = sizeRUsage 92 | peek p = RUsage <$> (#peek struct rusage, ru_utime) p 93 | <*> (#peek struct rusage, ru_stime) p 94 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_maxrss ) p) ) 95 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_ixrss ) p) ) 96 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_idrss ) p) ) 97 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_isrss ) p) ) 98 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_minflt ) p) ) 99 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_majflt ) p) ) 100 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_nswap ) p) ) 101 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_inblock ) p) ) 102 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_oublock ) p) ) 103 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_msgsnd ) p) ) 104 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_msgrcv ) p) ) 105 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_nsignals) p) ) 106 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_nvcsw ) p) ) 107 | <*> (clongToW64 <$> ( (#peek struct rusage, ru_nivcsw ) p) ) 108 | where 109 | 110 | poke p (RUsage utime stime maxrss ixrss idrss isrss minflt majflt nswap 111 | inblock oublock msgsnd msgrcv nsignals nvcsw nivcsw) = do 112 | (#poke struct rusage, ru_utime) p utime 113 | (#poke struct rusage, ru_stime) p stime 114 | (#poke struct rusage, ru_maxrss) p (w64ToCLong maxrss) 115 | (#poke struct rusage, ru_ixrss) p (w64ToCLong ixrss) 116 | (#poke struct rusage, ru_idrss) p (w64ToCLong idrss) 117 | (#poke struct rusage, ru_isrss) p (w64ToCLong isrss) 118 | (#poke struct rusage, ru_minflt) p (w64ToCLong minflt) 119 | (#poke struct rusage, ru_majflt) p (w64ToCLong majflt) 120 | (#poke struct rusage, ru_nswap) p (w64ToCLong nswap) 121 | (#poke struct rusage, ru_inblock) p (w64ToCLong inblock) 122 | (#poke struct rusage, ru_oublock) p (w64ToCLong oublock) 123 | (#poke struct rusage, ru_msgsnd) p (w64ToCLong msgsnd) 124 | (#poke struct rusage, ru_msgrcv) p (w64ToCLong msgrcv) 125 | (#poke struct rusage, ru_nsignals) p (w64ToCLong nsignals) 126 | (#poke struct rusage, ru_nvcsw) p (w64ToCLong nvcsw) 127 | (#poke struct rusage, ru_nivcsw) p (w64ToCLong nivcsw) 128 | 129 | instance Storable TimeVal where 130 | alignment _ = 8 131 | sizeOf _ = #const sizeof(struct timeval) 132 | peek p = toTimeVal <$> (#peek struct timeval, tv_sec) p 133 | <*> (#peek struct timeval, tv_usec) p 134 | where toTimeVal !s !us = TimeVal $! MicroSeconds $! (clongToW64 s * secondsToMicroScale) + clongToW64 us 135 | poke p (TimeVal (MicroSeconds cus)) = do 136 | (#poke struct timeval, tv_sec) p (w64ToCLong s) 137 | (#poke struct timeval, tv_usec) p (w64ToCLong us) 138 | where (s, us) = cus `divMod` secondsToMicroScale 139 | 140 | secondsToMicroScale :: Word64 141 | secondsToMicroScale = 1000000 142 | 143 | w64ToCLong :: Word64 -> CLong 144 | w64ToCLong = fromIntegral 145 | 146 | clongToW64 :: CLong -> Word64 147 | clongToW64 = fromIntegral 148 | 149 | sizeRUsage :: Int 150 | sizeRUsage = #const sizeof(struct rusage) 151 | 152 | #if __GLASGOW_HASKELL__ >= 710 153 | pattern Self :: Who 154 | #endif 155 | pattern Self = (#const RUSAGE_SELF) :: Who 156 | 157 | #if __GLASGOW_HASKELL__ >= 710 158 | pattern Children :: Who 159 | #endif 160 | pattern Children = (#const RUSAGE_CHILDREN) :: Who 161 | 162 | type Who = CInt 163 | 164 | -- | Gather RUsage 165 | get :: Who -> IO RUsage 166 | get who = alloca $ \ptr -> do 167 | throwErrnoIfMinus1_ "getrusage" (binding_getrusage who ptr) 168 | peek ptr 169 | 170 | -- | call a function `f` gathering RUSage before and after the call. 171 | with :: Who -> IO a -> IO (a, RUsage, RUsage) 172 | with who f = allocaBytes (sizeRUsage * 2) $ \ptr -> do 173 | let ptr2 = ptr `plusPtr` sizeRUsage 174 | throwErrnoIfMinus1_ "getrusage" (binding_getrusage who ptr) 175 | a <- f 176 | throwErrnoIfMinus1_ "getrusage" (binding_getrusage who ptr2) 177 | (,,) <$> pure a <*> peek ptr <*> peek ptr2 178 | 179 | -- binding for: int getrusage(int who, struct rusage *usage); 180 | foreign import ccall unsafe "getrusage" 181 | binding_getrusage :: Who -> Ptr RUsage -> IO CInt 182 | 183 | -- | On operating system not supporting getrusage this will be False, otherwise True. 184 | supported :: Bool 185 | supported = True 186 | 187 | #else 188 | 189 | #if __GLASGOW_HASKELL__ >= 710 190 | pattern Self :: Who 191 | #endif 192 | pattern Self = 1 :: Who 193 | 194 | #if __GLASGOW_HASKELL__ >= 710 195 | pattern Children :: Who 196 | #endif 197 | pattern Children = 2 :: Who 198 | 199 | type Who = CInt 200 | 201 | get :: Who -> IO RUsage 202 | get _ = pure rusageEmpty 203 | 204 | with :: Who -> IO a -> IO (a, RUsage, RUsage) 205 | with _ f = (,,) <$> f <*> pure rusageEmpty <*> pure rusageEmpty 206 | 207 | rusageEmpty :: RUsage 208 | rusageEmpty = RUsage ms0 ms0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 209 | where ms0 = TimeVal $ MicroSeconds 0 210 | 211 | supported :: Bool 212 | supported = False 213 | 214 | #endif 215 | -------------------------------------------------------------------------------- /Gauge/Source/Time.hsc: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Gauge.Source.Time 3 | -- Copyright : (c) 2017 Vincent Hanquez 4 | -- 5 | -- Various system time gathering methods 6 | -- 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE BangPatterns #-} 9 | {-# LANGUAGE ForeignFunctionInterface #-} 10 | {-# LANGUAGE KindSignatures #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | module Gauge.Source.Time 14 | ( initialize 15 | , ClockTime(..) 16 | , CpuTime(..) 17 | , Cycles(..) 18 | , TimeRecord(..) 19 | , MeasurementType(..) 20 | , getCycles 21 | , getTime 22 | , getCPUTime 23 | , getMetrics 24 | , withMetrics 25 | ) where 26 | 27 | #include "gauge-time.h" 28 | 29 | import Control.Applicative 30 | import Data.Word (Word64) 31 | import Foreign.Ptr 32 | import Foreign.Storable 33 | import Foreign.Marshal.Alloc (alloca, allocaBytes) 34 | import Prelude -- Silence redundant import warnings 35 | 36 | #ifdef __GHCJS__ 37 | import Foreign.C 38 | #endif 39 | 40 | data MeasurementType = Differential | Absolute 41 | 42 | newtype ClockTime (ty :: MeasurementType) = ClockTime Word64 43 | deriving (Eq, Storable) 44 | newtype CpuTime (ty :: MeasurementType) = CpuTime Word64 45 | deriving (Eq, Storable) 46 | newtype Cycles (ty :: MeasurementType) = Cycles Word64 47 | deriving (Eq, Storable) 48 | 49 | data TimeRecord w = TimeRecord 50 | {-# UNPACK #-} !(ClockTime w) 51 | {-# UNPACK #-} !(CpuTime w) 52 | {-# UNPACK #-} !(Cycles w) 53 | 54 | instance Storable (TimeRecord w) where 55 | alignment _ = 8 56 | sizeOf _ = sizeTimeRecord 57 | peek p = TimeRecord <$> (#peek struct gauge_time, clock_nanosecs) p 58 | <*> (#peek struct gauge_time, cpu_nanosecs) p 59 | <*> (#peek struct gauge_time, rdtsc) p 60 | poke p (TimeRecord clock cpu rdtsc) = do 61 | (#poke struct gauge_time, clock_nanosecs) p clock 62 | (#poke struct gauge_time, cpu_nanosecs ) p cpu 63 | (#poke struct gauge_time, rdtsc ) p rdtsc 64 | 65 | sizeTimeRecord :: Int 66 | sizeTimeRecord = #const sizeof(struct gauge_time) 67 | 68 | getMetrics :: IO (TimeRecord 'Absolute) 69 | getMetrics = alloca $ \ptr -> getRecordPtr ptr >> peek ptr 70 | 71 | withMetrics :: IO a -> IO (a, TimeRecord 'Absolute, TimeRecord 'Absolute) 72 | withMetrics f = allocaBytes (sizeTimeRecord * 2) $ \ptr -> do 73 | let ptr2 = ptr `plusPtr` sizeTimeRecord 74 | getRecordPtr ptr 75 | a <- f 76 | getRecordPtr ptr2 77 | (,,) <$> pure a <*> peek ptr <*> peek ptr2 78 | 79 | #ifdef __GHCJS__ 80 | data CTimespec = MkCTimespec CTime CLong 81 | 82 | instance Storable CTimespec where 83 | sizeOf _ = 8 84 | alignment _ = 4 85 | peek p = do 86 | s <- peekByteOff p 0 87 | ns <- peekByteOff p 4 88 | return (MkCTimespec s ns) 89 | poke p (MkCTimespec s ns) = do 90 | pokeByteOff p 0 s 91 | pokeByteOff p 4 ns 92 | 93 | foreign import ccall unsafe "time.h clock_gettime" 94 | clock_gettime :: CInt -> Ptr CTimespec -> IO CInt 95 | 96 | -- | Get the current POSIX time from the system clock. 97 | getRecordPtr :: Ptr (TimeRecord 'Absolute) -> IO () 98 | getRecordPtr ptr = do 99 | MkCTimespec (CTime sec) (CLong nsec) <- 100 | alloca (\ptspec -> do 101 | throwErrnoIfMinus1_ "clock_gettime" $ 102 | clock_gettime 0 ptspec 103 | peek ptspec 104 | ) 105 | poke ptr (TimeRecord 106 | (ClockTime ((fromIntegral sec) * 1000000000 + fromIntegral nsec)) 107 | (CpuTime 0) 108 | (Cycles 0)) 109 | 110 | initialize :: IO () 111 | initialize = return () 112 | 113 | getCycles :: IO (Cycles 'Absolute) 114 | getCycles = error "GHCJS does not support measuring cycles" 115 | 116 | getTime :: IO Double 117 | getTime = do 118 | MkCTimespec (CTime sec) (CLong nsec) <- 119 | alloca (\ptspec -> do 120 | throwErrnoIfMinus1_ "clock_gettime" $ 121 | clock_gettime 0 ptspec 122 | peek ptspec 123 | ) 124 | return $ fromIntegral sec + (fromIntegral nsec / 1000000000) 125 | 126 | getCPUTime :: IO Double 127 | getCPUTime = error "GHCJS does not support measuring CPUTime" 128 | 129 | #else 130 | 131 | -- | Set up time measurement. 132 | foreign import ccall unsafe "gauge_inittime" initialize :: IO () 133 | 134 | -- | Read the CPU cycle counter. 135 | foreign import ccall unsafe "gauge_rdtsc" getCycles :: IO (Cycles 'Absolute) 136 | 137 | -- | Return the current wallclock time, in seconds since some 138 | -- arbitrary time. 139 | -- 140 | -- You /must/ call 'initializeTime' once before calling this function! 141 | foreign import ccall unsafe "gauge_gettime" getTime :: IO Double 142 | 143 | -- | Return the amount of elapsed CPU time, combining user and kernel 144 | -- (system) time into a single measure. 145 | foreign import ccall unsafe "gauge_getcputime" getCPUTime :: IO Double 146 | 147 | -- | Record clock, cpu and cycles in one structure 148 | foreign import ccall unsafe "gauge_record" getRecordPtr :: Ptr (TimeRecord 'Absolute) -> IO () 149 | #endif 150 | -------------------------------------------------------------------------------- /Gauge/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | module Gauge.Time 5 | ( MicroSeconds(..) 6 | , MilliSeconds(..) 7 | , NanoSeconds(..) 8 | , PicoSeconds100(..) 9 | -- * Convertion functions 10 | , microSecondsToDouble 11 | , milliSecondsToDouble 12 | , nanoSecondsToDouble 13 | , picosecondsToNanoSeconds 14 | , doubleToNanoSeconds 15 | , doubleToPicoseconds100 16 | ) where 17 | 18 | import Data.Typeable 19 | import Data.Data 20 | import Data.Word 21 | import Control.DeepSeq 22 | import GHC.Generics 23 | import Gauge.Optional (OptionalTag) 24 | 25 | -- | Represent a number of milliseconds. 26 | newtype MilliSeconds = MilliSeconds Word64 27 | deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) 28 | 29 | -- | Represent a number of microseconds 30 | newtype MicroSeconds = MicroSeconds Word64 31 | deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) 32 | 33 | -- | Represent a number of nanoseconds 34 | newtype NanoSeconds = NanoSeconds Word64 35 | deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) 36 | 37 | -- | Represent a number of hundreds of picoseconds 38 | newtype PicoSeconds100 = PicoSeconds100 Word64 39 | deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) 40 | 41 | ref_picoseconds100 :: Num a => a 42 | ref_picoseconds100 = 10000000000 43 | 44 | ref_nanoseconds :: Num a => a 45 | ref_nanoseconds = 1000000000 46 | 47 | ref_microseconds :: Num a => a 48 | ref_microseconds = 1000000 49 | 50 | ref_milliseconds :: Num a => a 51 | ref_milliseconds = 1000 52 | 53 | microSecondsToDouble :: MicroSeconds -> Double 54 | microSecondsToDouble (MicroSeconds w) = fromIntegral w / ref_microseconds 55 | 56 | milliSecondsToDouble :: MilliSeconds -> Double 57 | milliSecondsToDouble (MilliSeconds w) = fromIntegral w / ref_milliseconds 58 | 59 | nanoSecondsToDouble :: NanoSeconds -> Double 60 | nanoSecondsToDouble (NanoSeconds w) = fromIntegral w / ref_nanoseconds 61 | 62 | doubleToNanoSeconds :: Double -> NanoSeconds 63 | doubleToNanoSeconds w = NanoSeconds $ truncate (w * ref_nanoseconds) 64 | 65 | -- | Return the number of integral nanoseconds followed by the number of hundred of picoseconds (1 digit) 66 | picosecondsToNanoSeconds :: PicoSeconds100 -> (NanoSeconds, Word) 67 | picosecondsToNanoSeconds (PicoSeconds100 p) = (NanoSeconds ns, fromIntegral fragment) 68 | where (ns, fragment) = p `divMod` 10 69 | 70 | doubleToPicoseconds100 :: Double -> PicoSeconds100 71 | doubleToPicoseconds100 w = PicoSeconds100 $ round (w * ref_picoseconds100) 72 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2017-2018 Vincent Hanquez, Harendra Kumar 2 | Copyright (c) 2009-2010 Bryan O'Sullivan 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 18 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 19 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 20 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 21 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 22 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 23 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 25 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Gauge: a clone of criterion 2 | 3 | This is a clone of criterion with a code / dependencies on a diet. It works the same way as criterion 4 | for outputing to terminal benchmark data. 5 | 6 | ## features compared to criterion 7 | 8 | missing: 9 | 10 | * JSON export 11 | * HTML/javascript pages 12 | * Glob benchmark matching 13 | 14 | Added: 15 | 16 | * Small condensed output (`-s` or `--small`) 17 | * Raw measurements dumping (CSV) 18 | 19 | ## Future Feature Plan 20 | 21 | * Remove further dependencies 22 | * storing benchmarks data in CSV and JSON 23 | * Add a standalone program taking benchmark data files and rendering to html/javascript/graphs 24 | * Make the library more useful as a standalone library to gather benchmark numbers related to functions in a programatic way 25 | 26 | ## Small mode 27 | 28 | It's hard to compare many benchmarks with criterion, so gauge has a `--small` output: 29 | 30 | ``` 31 | identity mean 41.65 ns ( +- 2.246 ns ) 32 | slow mean 163.9 ns ( +- 9.683 ns ) 33 | ``` 34 | 35 | ## Direct dependencies removed compared to criterion 36 | 37 | Number of total dependencies (direct & indirect): 38 | 39 | * gauge: 12 dependencies 40 | * criterion: 63 dependencies 41 | 42 | Dependencies removed: 43 | 44 | * Glob 0.8.0 45 | * abstract-deque 0.3 46 | * abstract-par 0.3.3 47 | * aeson 1.1.2.0 48 | * ansi-terminal 0.6.3.1 49 | * ansi-wl-pprint 0.6.7.3 50 | * array 0.5.1.1 51 | * attoparsec 0.13.1.0 52 | * base-compat 0.9.3 53 | * base-orphans 0.6 54 | * binary 0.8.3.0 55 | * blaze-builder 0.4.0.2 56 | * bytestring 0.10.8.1 57 | * cassava 0.4.5.1 58 | * cereal 0.5.4.0 59 | * code-page 0.1.3 60 | * containers 0.5.7.1 61 | * directory 1.3.0.0 62 | * dlist 0.8.0.3 63 | * erf 2.0.0.0 64 | * exceptions 0.8.3 65 | * filepath 1.4.1.1 66 | * ghc-boot-th 8.0.2 67 | * hashable 1.2.6.1 68 | * integer-gmp 1.0.0.1 69 | * integer-logarithms 1.0.2 70 | * js-flot 0.8.3 71 | * js-jquery 3.2.1 72 | * math-functions 0.2.1.0 73 | * microstache 1.0.1.1 74 | * monad-par 0.3.4.8 75 | * monad-par-extras 0.3.3 76 | * mtl 2.2.1 77 | * mwc-random 0.13.6.0 78 | * optparse-applicative 0.13.2.0 79 | * parallel 3.2.1.1 80 | * parsec 3.1.11 81 | * pretty 1.1.3.3 82 | * process 1.4.3.0 83 | * random 1.1 84 | * scientific 0.3.5.2 85 | * statistics 0.14.0.2 86 | * stm 2.4.4.1 87 | * tagged 0.8.5 88 | * template-haskell 2.11.1.0 89 | * text 1.2.2.2 90 | * time 1.6.0.1 91 | * time-locale-compat 0.1.1.3 92 | * transformers-compat 0.5.1.4 93 | * unix 2.7.2.1 94 | * unordered-containers 0.2.8.0 95 | * uuid-types 1.0.3 96 | * vector-algorithms 0.7.0.1 97 | * vector-binary-instances 0.2.3.5 98 | * vector-th-unbox 0.2.1.6 99 | 100 | 101 | Criterion graph of dependencies: 102 | 103 | ![Criterion](/.README.imgs/criterion.png) 104 | 105 | Gauge graph of dependencies: 106 | 107 | ![Gauge](/.README.imgs/gauge.png) 108 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /benchs/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main where 3 | 4 | import Gauge 5 | import System.IO.Unsafe 6 | import Control.Applicative 7 | import Control.Concurrent 8 | import Control.Exception 9 | 10 | delayed :: (a -> b) -> a -> b 11 | delayed f a = unsafePerformIO $ do 12 | !b <- evaluate (f a) 13 | threadDelay 10000 14 | pure b 15 | {-# NOINLINE delayed #-} 16 | 17 | main = defaultMain 18 | [ bench "identity" $ nf (map (+ 1)) [1,2,3 :: Int] 19 | , bench "slow" $ nf (map (\i -> delayed (+ 1))) [1..10::Int] 20 | ] 21 | -------------------------------------------------------------------------------- /cbits/cycles.c: -------------------------------------------------------------------------------- 1 | #include "Rts.h" 2 | 3 | #if darwin_HOST_OS 4 | 5 | #include 6 | 7 | StgWord64 gauge_rdtsc(void) 8 | { 9 | return mach_absolute_time(); 10 | } 11 | 12 | #elif x86_64_HOST_ARCH || i386_HOST_ARCH 13 | 14 | StgWord64 gauge_rdtsc(void) 15 | { 16 | StgWord32 hi, lo; 17 | __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); 18 | return ((StgWord64) lo) | (((StgWord64) hi)<<32); 19 | } 20 | 21 | #elif linux_HOST_OS 22 | 23 | /* 24 | * This should work on all Linux. 25 | * 26 | * Technique by Austin Seipp found here: 27 | * 28 | * http://neocontra.blogspot.com/2013/05/user-mode-performance-counters-for.html 29 | */ 30 | 31 | #include 32 | #include 33 | #include 34 | 35 | static int fddev = -1; 36 | __attribute__((constructor)) 37 | static void 38 | init(void) 39 | { 40 | static struct perf_event_attr attr; 41 | attr.type = PERF_TYPE_HARDWARE; 42 | attr.config = PERF_COUNT_HW_CPU_CYCLES; 43 | fddev = syscall (__NR_perf_event_open, &attr, 0, -1, -1, 0); 44 | } 45 | 46 | __attribute__((destructor)) 47 | static void 48 | fini(void) 49 | { 50 | close(fddev); 51 | } 52 | 53 | StgWord64 54 | gauge_rdtsc (void) 55 | { 56 | StgWord64 result = 0; 57 | if (read (fddev, &result, sizeof(result)) < sizeof(result)) 58 | return 0; 59 | return result; 60 | } 61 | 62 | #else 63 | 64 | #error Unsupported OS/architecture/compiler! 65 | 66 | #endif 67 | -------------------------------------------------------------------------------- /cbits/cycles.h: -------------------------------------------------------------------------------- 1 | #ifndef CYCLES_H 2 | #define CYCLES_H 3 | 4 | #include 5 | #include "Rts.h" 6 | 7 | #if x86_64_HOST_ARCH || i386_HOST_ARCH 8 | 9 | static inline uint64_t instruction_rdtsc(void) 10 | { 11 | uint32_t lo, hi; 12 | __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); 13 | return ((uint64_t) lo) | (((uint64_t) hi) << 32); 14 | } 15 | 16 | #else 17 | 18 | static inline uint64_t instruction_rdtsc(void) 19 | { 20 | return 0; 21 | } 22 | 23 | #endif 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /cbits/gauge-time.h: -------------------------------------------------------------------------------- 1 | #ifndef GAUGE_TIME_H 2 | 3 | #include 4 | 5 | /* 24 bytes */ 6 | struct gauge_time { 7 | uint64_t clock_nanosecs; 8 | uint64_t cpu_nanosecs; 9 | uint64_t rdtsc; 10 | }; 11 | 12 | /* multiplicator to rescale from X to nanoseconds */ 13 | const uint64_t ref_nanosecond = 1; 14 | const uint64_t ref_100nanosecond = 100; 15 | const uint64_t ref_microsecond = 1000; 16 | const uint64_t ref_millisecond = 1000000; 17 | const uint64_t ref_second = 1000000000; 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /cbits/time-osx.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "gauge-time.h" 4 | #include "cycles.h" 5 | #include 6 | 7 | void gauge_inittime(void) {} 8 | 9 | void gauge_record(struct gauge_time *tr) 10 | { 11 | struct task_thread_times_info thread_info_data; 12 | mach_msg_type_number_t thread_info_count = TASK_THREAD_TIMES_INFO_COUNT; 13 | kern_return_t kr = task_info(mach_task_self(), TASK_THREAD_TIMES_INFO, 14 | (task_info_t) &thread_info_data, 15 | &thread_info_count); 16 | 17 | tr->clock_nanosecs = clock_gettime_nsec_np(CLOCK_UPTIME_RAW); 18 | 19 | tr->cpu_nanosecs = (((uint64_t) thread_info_data.user_time.seconds) * ref_second) + 20 | (((uint64_t) thread_info_data.user_time.microseconds) * ref_microsecond) + 21 | (((uint64_t) thread_info_data.system_time.seconds) * ref_second) + 22 | (((uint64_t) thread_info_data.system_time.microseconds) * ref_microsecond); 23 | tr->rdtsc = instruction_rdtsc(); 24 | } 25 | 26 | double gauge_gettime(void) 27 | { 28 | return clock_gettime_nsec_np(CLOCK_UPTIME_RAW) / 1e9; 29 | } 30 | 31 | static double to_double(time_value_t time) 32 | { 33 | return time.seconds + time.microseconds / 1e6; 34 | } 35 | 36 | double gauge_getcputime(void) 37 | { 38 | struct task_thread_times_info thread_info_data; 39 | mach_msg_type_number_t thread_info_count = TASK_THREAD_TIMES_INFO_COUNT; 40 | kern_return_t kr = task_info(mach_task_self(), 41 | TASK_THREAD_TIMES_INFO, 42 | (task_info_t) &thread_info_data, 43 | &thread_info_count); 44 | return (to_double(thread_info_data.user_time) + 45 | to_double(thread_info_data.system_time)); 46 | } 47 | -------------------------------------------------------------------------------- /cbits/time-posix.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include 5 | 6 | #include "gauge-time.h" 7 | 8 | // #define USE_PERF_EVENT 9 | 10 | #ifdef USE_PERF_EVENT 11 | #include 12 | #include 13 | #else 14 | #include 15 | #endif 16 | 17 | #ifdef USE_PERF_EVENT 18 | static int gauge_rdtsc_fddev = -1; 19 | #endif 20 | 21 | void gauge_inittime(void) 22 | { 23 | #ifdef USE_PERF_EVENT 24 | static struct perf_event_attr attr; 25 | attr.type = PERF_TYPE_HARDWARE; 26 | attr.config = PERF_COUNT_HW_CPU_CYCLES; 27 | gauge_rdtsc_fddev = syscall (__NR_perf_event_open, &attr, 0, -1, -1, 0); 28 | #endif 29 | } 30 | 31 | #define timespec_to_uint64(x) ( \ 32 | (( ((uint64_t ) (x).tv_sec) * ref_second)) + \ 33 | ((uint64_t) (x).tv_nsec) \ 34 | ) 35 | 36 | void gauge_record(struct gauge_time *tr) 37 | { 38 | struct timespec ts, ts2; 39 | uint64_t res = 0; 40 | 41 | clock_gettime(CLOCK_MONOTONIC, &ts); 42 | clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts2); 43 | 44 | tr->clock_nanosecs = timespec_to_uint64(ts); 45 | tr->cpu_nanosecs = timespec_to_uint64(ts2); 46 | #ifdef USE_PERF_EVENT 47 | tr->rdtsc = (read (gauge_rdtsc_fddev, &res, sizeof(res)) < sizeof(res)) ? 0 : res; 48 | #else 49 | tr->rdtsc = instruction_rdtsc(); 50 | #endif 51 | } 52 | 53 | double gauge_gettime(void) 54 | { 55 | struct timespec ts; 56 | 57 | clock_gettime(CLOCK_MONOTONIC, &ts); 58 | 59 | return ts.tv_sec + ts.tv_nsec * 1e-9; 60 | } 61 | 62 | 63 | double gauge_getcputime(void) 64 | { 65 | struct timespec ts; 66 | 67 | clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts); 68 | 69 | return ts.tv_sec + ts.tv_nsec * 1e-9; 70 | } 71 | -------------------------------------------------------------------------------- /cbits/time-windows.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Windows has the most amazingly cretinous time measurement APIs you 3 | * can possibly imagine. 4 | * 5 | * Our first possibility is GetSystemTimeAsFileTime, which updates at 6 | * roughly 60Hz, and is hence worthless - we'd have to run a 7 | * computation for tens or hundreds of seconds to get a trustworthy 8 | * number. 9 | * 10 | * Alternatively, we can use QueryPerformanceCounter, which has 11 | * undefined behaviour under almost all interesting circumstances 12 | * (e.g. multicore systems, CPU frequency changes). But at least it 13 | * increments reasonably often. 14 | */ 15 | 16 | #include 17 | 18 | #include "gauge-time.h" 19 | #include "cycles.h" 20 | 21 | static LARGE_INTEGER freq; 22 | static double freq_recip; 23 | static LARGE_INTEGER firstClock; 24 | 25 | void gauge_inittime(void) 26 | { 27 | if (freq_recip == 0) { 28 | QueryPerformanceFrequency(&freq); 29 | QueryPerformanceCounter(&firstClock); 30 | freq_recip = 1.0 / freq.QuadPart; 31 | } 32 | } 33 | 34 | double gauge_gettime(void) 35 | { 36 | LARGE_INTEGER li; 37 | 38 | QueryPerformanceCounter(&li); 39 | 40 | return ((double) (li.QuadPart - firstClock.QuadPart)) * freq_recip; 41 | } 42 | 43 | static ULONGLONG to_quad_100ns(FILETIME ft) 44 | { 45 | ULARGE_INTEGER li; 46 | li.LowPart = ft.dwLowDateTime; 47 | li.HighPart = ft.dwHighDateTime; 48 | return li.QuadPart; 49 | } 50 | 51 | double gauge_getcputime(void) 52 | { 53 | FILETIME creation, exit, kernel, user; 54 | ULONGLONG time; 55 | 56 | GetProcessTimes(GetCurrentProcess(), &creation, &exit, &kernel, &user); 57 | 58 | time = to_quad_100ns(user) + to_quad_100ns(kernel); 59 | return time / 1e7; 60 | } 61 | 62 | void gauge_record(struct gauge_time *tr) 63 | { 64 | LARGE_INTEGER li; 65 | FILETIME creation, exit, kernel, user; 66 | ULONGLONG time; 67 | 68 | QueryPerformanceCounter(&li); 69 | GetProcessTimes(GetCurrentProcess(), &creation, &exit, &kernel, &user); 70 | 71 | time = to_quad_100ns(user) + to_quad_100ns(kernel); 72 | 73 | tr->clock_nanosecs = (li.QuadPart / freq.QuadPart * ref_second) + 74 | ((li.QuadPart % freq.QuadPart) * ref_second) / freq.QuadPart; 75 | tr->cpu_nanosecs = time * ref_100nanosecond; 76 | tr->rdtsc = instruction_rdtsc(); 77 | } 78 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # next 2 | 3 | * Change `gauge_rdtsc` to return `mach_absolute_time` on macOS. This is a 4 | portable way of returning the number of CPU cycles that works on both Intel- 5 | and ARM-based Macs. 6 | 7 | * Change `gauge_gettime` to use `clock_gettime_nsec_np` instead of 8 | `mach_absolute_time` on macOS. While `mach_absolute_time` has nanosecond 9 | resolution on Intel-based Macs, this is not the case on ARM-based Macs, so 10 | the previous `mach_absolute_time`-based implementation would return incorrect 11 | timing results on Apple silicon. 12 | 13 | There are two minor consequences of this change: 14 | 15 | * Gauge now only supports macOS 10.02 or later, as that is 16 | the first version to have `clock_gettime_nsec_np`. As macOS 10.02 was 17 | released in 2002, this is unlikely to affect users, but please speak up if 18 | this is a problem for you. 19 | 20 | * As `clock_gettime_nsec_np` does not require any special initialization 21 | code, `gauge_inittime` is now a no-op on macOS. If you manually invoke 22 | the `getTime` function in your code, however, it is still important that 23 | you `initializeTime` beforehand, as this is still required for the Windows 24 | implementation to work correctly. 25 | 26 | # 0.2.5 27 | 28 | * Add GHCJS support (statistical analysis is not supported) 29 | * Fix issue with perRunEnv 30 | * Drop support for GHC 7.8 31 | 32 | # 0.2.4 33 | 34 | * `Enhancement`: Add `nfAppIO` and `whnfAppIO` functions, which take a function 35 | and its argument separately like `nf`/`whnf`, but whose function returns `IO` 36 | like `nfIO`/`whnfIO`. This is useful for benchmarking functions in which the 37 | bulk of the work is not bound by IO, but by pure computations that might 38 | otherwise be optimized away if the argument is known statically. 39 | 40 | * `Bug Fix`: Pass `-m exact` option to the child processes used to run 41 | benchmarks in an isolated manner. This avoids running a wrong benchmark due 42 | to the default prefix match. 43 | 44 | # 0.2.3 45 | 46 | * Add a new benchmark matching option "-m exact" to match the benchmark name 47 | exactly. 48 | 49 | # 0.2.2 50 | 51 | * Write data to CSV file in quick mode too. 52 | * Fix the CSV file header to match with the data rows for the `--csvraw` case. 53 | * Fix issue with GC metrics in 32 bits that would silently wrap and failure in optional machinery. 54 | * Simplify dependencies in tests using foudation checks. 55 | 56 | # 0.2.1 57 | 58 | * Inline math-functions & mwc-random: 59 | * Remove most functions, instances and types, that are unnecessary for gauge 60 | * Remove unsafe seeding with partial seed (unused in gauge anyway) 61 | * Remove vector-th-unbox dependency (transitively template-haskell, pretty, ghc-boot-th) 62 | * Remove time dependency 63 | * Re-add Gauge.Benchmark to Gauge.Main to keep the transition between criterion and gauge easy 64 | * Fix cycles reporting on linux, osx and windows 65 | * Add some extra callstack for reporting on partial function 66 | * Fix compilation with Semigroup => Monoid (compilation on 8.4). still unsupported 67 | * Add some color on terminal output 68 | 69 | # 0.2.0 70 | 71 | * `Usability`: Simplify and organize the documentation and user APIs. 72 | * `Functionality`: 73 | * Add measurement and reporting of more performance counters on 74 | Unices (collected via getrusage) for example page faults, user time, system 75 | time and rss are now available in verbose mode. 76 | * Re-enable CSV analysis with the same output format as criterion (`--csv`) 77 | * Add CSV measurement dumping with `--csvraw` 78 | * `Control`: Provide better control over measurement process with 79 | `--min-samples`, `--min-duration` and `--include-first-iter` flags. 80 | * `Speed:` Add `--quick` flag that provides results much faster (10x) without 81 | using statistical analysis. 82 | * Reliability: 83 | * Fix a bug in GC stats collection and reporting with GHC 8.2 that caused 84 | incorrect reporting of some GC stats. 85 | * Fix a bug in statistical regression that caused incorrect reporting of mean 86 | and other stats. 87 | * Improve reliability by isolating benchmarks from one another using the 88 | `--measure-with` flag. The results of one benchmark are no longer affected 89 | by other benchmarks because each benchmark runs in a separate process. 90 | * Introduce an optional value type `Optional` with an efficient runtime 91 | representation to replace the ad-hoc fromXXX functions and the untyped 92 | approach. 93 | * Modularity: 94 | * Introduce `--measure-only` flag that allows just measurement and no 95 | analysis or reporting. 96 | * Provide modular build, measurement code is cleanly separated from 97 | statistical analysis code. As a result a leaner version can now be built 98 | without analysis code (controlled by the `analysis` build flag). 99 | * Clean, refactor & rewrite source code 100 | * Remove code-page dependency 101 | 102 | # 0.1.3 103 | 104 | * Simplify monad handling, remove foundation as dependency 105 | 106 | # 0.1.2 107 | 108 | * condensed display with `--small` 109 | 110 | # 0.1.1 111 | 112 | * remove optparse-applicative 113 | 114 | # 0.1.0 115 | 116 | * remove bunch of dependencies 117 | * initial import of criterion-1.2.2.0 118 | -------------------------------------------------------------------------------- /gauge.cabal: -------------------------------------------------------------------------------- 1 | name: gauge 2 | version: 0.2.5 3 | synopsis: small framework for performance measurement and analysis 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Bryan O'Sullivan 7 | maintainer: Vincent Hanquez 8 | copyright: 2009-2016 Bryan O'Sullivan and others 9 | category: Development, Performance, Testing, Benchmarking 10 | homepage: https://github.com/vincenthz/hs-gauge 11 | bug-reports: https://github.com/vincenthz/hs-gauge/issues 12 | build-type: Simple 13 | cabal-version: >= 1.10 14 | extra-source-files: 15 | README.markdown 16 | changelog.md 17 | cbits/*.h 18 | tested-with: 19 | GHC==7.10.3, 20 | GHC==8.0.2, 21 | GHC==8.2.2, 22 | GHC==8.4.3, 23 | GHC==8.6.5, 24 | GHC==8.8.1 25 | 26 | description: 27 | This library provides a powerful but simple way to measure software 28 | performance. It provides both a framework for executing and 29 | analysing benchmarks and a set of driver functions that makes it 30 | easy to build and run benchmarks, and to analyse their results. 31 | 32 | flag analysis 33 | description: Build with statistical analysis support 34 | manual: True 35 | default: True 36 | 37 | library 38 | exposed-modules: 39 | Gauge 40 | Gauge.Main 41 | Gauge.Main.Options 42 | Gauge.Benchmark 43 | other-modules: 44 | Gauge.IO.Printf 45 | Gauge.Measurement 46 | Gauge.Monad 47 | Gauge.ListMap 48 | Gauge.Time 49 | Gauge.Optional 50 | Gauge.CSV 51 | Gauge.Format 52 | 53 | Gauge.Source.RUsage 54 | Gauge.Source.GC 55 | Gauge.Source.Time 56 | System.Random.MWC 57 | 58 | if flag(analysis) && !impl(ghcjs) 59 | exposed-modules: 60 | Gauge.Analysis 61 | other-modules: 62 | Statistics.Distribution 63 | Statistics.Distribution.Normal 64 | Statistics.Function 65 | Statistics.Internal 66 | Statistics.Math.RootFinding 67 | Statistics.Matrix 68 | Statistics.Matrix.Algorithms 69 | Statistics.Matrix.Mutable 70 | Statistics.Matrix.Types 71 | Statistics.Quantile 72 | Statistics.Regression 73 | Statistics.Resampling 74 | Statistics.Resampling.Bootstrap 75 | Statistics.Sample 76 | Statistics.Sample.Histogram 77 | Statistics.Sample.Internal 78 | Statistics.Sample.KernelDensity 79 | Statistics.Transform 80 | Statistics.Types 81 | Statistics.Types.Internal 82 | Numeric.MathFunctions.Comparison 83 | Numeric.MathFunctions.Constants 84 | Numeric.SpecFunctions 85 | Numeric.SpecFunctions.Internal 86 | Numeric.Sum 87 | 88 | 89 | hs-source-dirs: . statistics mwc-random math-functions 90 | 91 | include-Dirs: cbits 92 | c-sources: cbits/cycles.c 93 | if os(darwin) 94 | c-sources: cbits/time-osx.c 95 | else { 96 | if os(windows) 97 | c-sources: cbits/time-windows.c 98 | else 99 | c-sources: cbits/time-posix.c 100 | } 101 | 102 | other-modules: 103 | Paths_gauge 104 | 105 | if impl(ghc < 7.10) 106 | buildable: False 107 | 108 | build-depends: 109 | base >= 4.7 && < 5, 110 | basement >= 0.0.4, 111 | deepseq >= 1.1.0.0, 112 | vector >= 0.7.1, 113 | process, 114 | directory 115 | 116 | default-language: Haskell2010 117 | ghc-options: -O2 -Wall -funbox-strict-fields 118 | if flag(analysis) && !impl(ghcjs) 119 | cpp-options: -DHAVE_ANALYSIS 120 | 121 | test-suite sanity 122 | type: exitcode-stdio-1.0 123 | hs-source-dirs: tests 124 | main-is: Sanity.hs 125 | default-language: Haskell2010 126 | ghc-options: -O2 -Wall -rtsopts 127 | 128 | build-depends: 129 | base > 0 && < 1000, 130 | bytestring, 131 | gauge, 132 | basement, 133 | foundation 134 | 135 | test-suite cleanup 136 | type: exitcode-stdio-1.0 137 | hs-source-dirs: tests 138 | default-language: Haskell2010 139 | main-is: Cleanup.hs 140 | 141 | ghc-options: 142 | -Wall -threaded -O0 -rtsopts 143 | 144 | build-depends: 145 | base > 0 && < 1000, 146 | bytestring, 147 | gauge, 148 | deepseq, 149 | directory, 150 | foundation 151 | 152 | benchmark self 153 | type: exitcode-stdio-1.0 154 | hs-source-dirs: benchs 155 | default-language: Haskell2010 156 | main-is: Main.hs 157 | build-depends: 158 | base > 0 && < 1000, 159 | gauge 160 | 161 | source-repository head 162 | type: git 163 | location: https://github.com/vincenthz/hs-gauge 164 | -------------------------------------------------------------------------------- /math-functions/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009, 2010 Bryan O'Sullivan 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /math-functions/Numeric/MathFunctions/Comparison.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Numeric.MathFunctions.Comparison 3 | -- Copyright : (c) 2011 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bos@serpentine.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- Functions for approximate comparison of floating point numbers. 11 | -- 12 | -- Approximate floating point comparison, based on Bruce Dawson's 13 | -- \"Comparing floating point numbers\": 14 | -- 15 | module Numeric.MathFunctions.Comparison 16 | ( within 17 | ) where 18 | 19 | import Basement.Floating (doubleToWord) 20 | import Data.Word (Word64) 21 | 22 | -- | 23 | -- Measure distance between two @Double@s in ULPs (units of least 24 | -- precision). Note that it's different from @abs (ulpDelta a b)@ 25 | -- since it returns correct result even when 'ulpDelta' overflows. 26 | ulpDistance :: Double 27 | -> Double 28 | -> Word64 29 | ulpDistance a b = 30 | -- IEEE754 floats use most significant bit as sign bit (not 31 | -- 2-complement) and we need to rearrange representations of float 32 | -- number so that they could be compared lexicographically as 33 | -- Word64. 34 | let big = 0x8000000000000000 35 | order i | i < big = i + big 36 | | otherwise = maxBound - i 37 | ai = order ai0 38 | bi = order bi0 39 | d | ai > bi = ai - bi 40 | | otherwise = bi - ai 41 | in d 42 | where 43 | ai0 = doubleToWord a 44 | bi0 = doubleToWord b 45 | 46 | 47 | -- | Compare two 'Double' values for approximate equality, using 48 | -- Dawson's method. 49 | -- 50 | -- The required accuracy is specified in ULPs (units of least 51 | -- precision). If the two numbers differ by the given number of ULPs 52 | -- or less, this function returns @True@. 53 | within :: Int -- ^ Number of ULPs of accuracy desired. 54 | -> Double -> Double -> Bool 55 | within ulps a b 56 | | ulps < 0 = False 57 | | otherwise = ulpDistance a b <= fromIntegral ulps 58 | -------------------------------------------------------------------------------- /math-functions/Numeric/MathFunctions/Constants.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Numeric.MathFunctions.Constants 3 | -- Copyright : (c) 2009, 2011 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bos@serpentine.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- Constant values common to much numeric code. 11 | 12 | module Numeric.MathFunctions.Constants 13 | ( 14 | -- * IEE754 constants 15 | m_epsilon 16 | , m_huge 17 | , m_tiny 18 | , m_max_exp 19 | , m_pos_inf 20 | , m_neg_inf 21 | , m_NaN 22 | , m_max_log 23 | , m_min_log 24 | -- * Mathematical constants 25 | , m_1_sqrt_2 26 | , m_2_sqrt_pi 27 | , m_ln_sqrt_2_pi 28 | , m_sqrt_2 29 | , m_sqrt_2_pi 30 | , m_eulerMascheroni 31 | ) where 32 | 33 | ---------------------------------------------------------------- 34 | -- IEE754 constants 35 | ---------------------------------------------------------------- 36 | 37 | -- | Largest representable finite value. 38 | m_huge :: Double 39 | m_huge = 1.7976931348623157e308 40 | {-# INLINE m_huge #-} 41 | 42 | -- | The smallest representable positive normalized value. 43 | m_tiny :: Double 44 | m_tiny = 2.2250738585072014e-308 45 | {-# INLINE m_tiny #-} 46 | 47 | -- | The largest 'Int' /x/ such that 2**(/x/-1) is approximately 48 | -- representable as a 'Double'. 49 | m_max_exp :: Int 50 | m_max_exp = 1024 51 | 52 | -- | Positive infinity. 53 | m_pos_inf :: Double 54 | m_pos_inf = 1/0 55 | {-# INLINE m_pos_inf #-} 56 | 57 | -- | Negative infinity. 58 | m_neg_inf :: Double 59 | m_neg_inf = -1/0 60 | {-# INLINE m_neg_inf #-} 61 | 62 | -- | Not a number. 63 | m_NaN :: Double 64 | m_NaN = 0/0 65 | {-# INLINE m_NaN #-} 66 | 67 | -- | Maximum possible finite value of @log x@ 68 | m_max_log :: Double 69 | m_max_log = 709.782712893384 70 | {-# INLINE m_max_log #-} 71 | 72 | -- | Logarithm of smallest normalized double ('m_tiny') 73 | m_min_log :: Double 74 | m_min_log = -708.3964185322641 75 | {-# INLINE m_min_log #-} 76 | 77 | 78 | ---------------------------------------------------------------- 79 | -- Mathematical constants 80 | ---------------------------------------------------------------- 81 | 82 | -- | @sqrt 2@ 83 | m_sqrt_2 :: Double 84 | m_sqrt_2 = 1.4142135623730950488016887242096980785696718753769480731766 85 | {-# INLINE m_sqrt_2 #-} 86 | 87 | -- | @sqrt (2 * pi)@ 88 | m_sqrt_2_pi :: Double 89 | m_sqrt_2_pi = 2.5066282746310005024157652848110452530069867406099383166299 90 | {-# INLINE m_sqrt_2_pi #-} 91 | 92 | -- | @2 / sqrt pi@ 93 | m_2_sqrt_pi :: Double 94 | m_2_sqrt_pi = 1.1283791670955125738961589031215451716881012586579977136881 95 | {-# INLINE m_2_sqrt_pi #-} 96 | 97 | -- | @1 / sqrt 2@ 98 | m_1_sqrt_2 :: Double 99 | m_1_sqrt_2 = 0.7071067811865475244008443621048490392848359376884740365883 100 | {-# INLINE m_1_sqrt_2 #-} 101 | 102 | -- | The smallest 'Double' ε such that 1 + ε ≠ 1. 103 | m_epsilon :: Double 104 | m_epsilon = encodeFloat (signif+1) expo - 1.0 105 | where (signif,expo) = decodeFloat (1.0::Double) 106 | 107 | -- | @log(sqrt((2*pi))@ 108 | m_ln_sqrt_2_pi :: Double 109 | m_ln_sqrt_2_pi = 0.9189385332046727417803297364056176398613974736377834128171 110 | {-# INLINE m_ln_sqrt_2_pi #-} 111 | 112 | -- | Euler–Mascheroni constant (γ = 0.57721...) 113 | m_eulerMascheroni :: Double 114 | m_eulerMascheroni = 0.5772156649015328606065121 115 | {-# INLINE m_eulerMascheroni #-} 116 | -------------------------------------------------------------------------------- /math-functions/Numeric/SpecFunctions.hs: -------------------------------------------------------------------------------- 1 | module Numeric.SpecFunctions ( module X ) where 2 | 3 | import Numeric.SpecFunctions.Internal as X 4 | -------------------------------------------------------------------------------- /math-functions/Numeric/SpecFunctions/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, ForeignFunctionInterface #-} 2 | -- | 3 | -- Module : Numeric.SpecFunctions.Internal 4 | -- Copyright : (c) 2009, 2011, 2012 Bryan O'Sullivan 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : bos@serpentine.com 8 | -- Stability : experimental 9 | -- Portability : portable 10 | -- 11 | -- Internal module with implementation of special functions. 12 | module Numeric.SpecFunctions.Internal 13 | ( erf 14 | , erfc 15 | , invErf 16 | , invErfc 17 | , log2 18 | ) where 19 | 20 | import Data.Bits ((.&.), (.|.), shiftR) 21 | import Data.Word (Word64) 22 | import qualified Data.Vector.Unboxed as U 23 | 24 | import Numeric.MathFunctions.Constants 25 | 26 | ---------------------------------------------------------------- 27 | -- Error function 28 | ---------------------------------------------------------------- 29 | 30 | -- | Error function. 31 | -- 32 | -- \[ 33 | -- \operatorname{erf}(x) = \frac{2}{\sqrt{\pi}} \int_{0}^{x} \exp(-t^2) dt 34 | -- \] 35 | -- 36 | -- Function limits are: 37 | -- 38 | -- \[ 39 | -- \begin{aligned} 40 | -- &\operatorname{erf}(-\infty) &=& -1 \\ 41 | -- &\operatorname{erf}(0) &=& \phantom{-}\,0 \\ 42 | -- &\operatorname{erf}(+\infty) &=& \phantom{-}\,1 \\ 43 | -- \end{aligned} 44 | -- \] 45 | erf :: Double -> Double 46 | {-# INLINE erf #-} 47 | erf = c_erf 48 | 49 | -- | Complementary error function. 50 | -- 51 | -- \[ 52 | -- \operatorname{erfc}(x) = 1 - \operatorname{erf}(x) 53 | -- \] 54 | -- 55 | -- Function limits are: 56 | -- 57 | -- \[ 58 | -- \begin{aligned} 59 | -- &\operatorname{erf}(-\infty) &=&\, 2 \\ 60 | -- &\operatorname{erf}(0) &=&\, 1 \\ 61 | -- &\operatorname{erf}(+\infty) &=&\, 0 \\ 62 | -- \end{aligned} 63 | -- \] 64 | erfc :: Double -> Double 65 | {-# INLINE erfc #-} 66 | erfc = c_erfc 67 | 68 | foreign import ccall "erf" c_erf :: Double -> Double 69 | foreign import ccall "erfc" c_erfc :: Double -> Double 70 | 71 | 72 | -- | Inverse of 'erf'. 73 | invErf :: Double -- ^ /p/ ∈ [-1,1] 74 | -> Double 75 | invErf p = invErfc (1 - p) 76 | 77 | -- | Inverse of 'erfc'. 78 | invErfc :: Double -- ^ /p/ ∈ [0,2] 79 | -> Double 80 | invErfc p 81 | | p == 2 = m_neg_inf 82 | | p == 0 = m_pos_inf 83 | | p >0 && p < 2 = if p <= 1 then r else -r 84 | | otherwise = modErr $ "invErfc: p must be in [0,2] got " ++ show p 85 | where 86 | pp = if p <= 1 then p else 2 - p 87 | t = sqrt $ -2 * log( 0.5 * pp) 88 | -- Initial guess 89 | x0 = -0.70711 * ((2.30753 + t * 0.27061) / (1 + t * (0.99229 + t * 0.04481)) - t) 90 | r = loop 0 x0 91 | -- 92 | loop :: Int -> Double -> Double 93 | loop !j !x 94 | | j >= 2 = x 95 | | otherwise = let err = erfc x - pp 96 | x' = x + err / (1.12837916709551257 * exp(-x * x) - x * err) -- // Halley 97 | in loop (j+1) x' 98 | 99 | -- | /O(log n)/ Compute the logarithm in base 2 of the given value. 100 | log2 :: Int -> Int 101 | log2 v0 102 | | v0 <= 0 = modErr $ "log2: nonpositive input, got " ++ show v0 103 | | otherwise = go 5 0 v0 104 | where 105 | go !i !r !v | i == -1 = r 106 | | v .&. b i /= 0 = let si = U.unsafeIndex sv i 107 | in go (i-1) (r .|. si) (v `shiftR` si) 108 | | otherwise = go (i-1) r v 109 | b = U.unsafeIndex bv 110 | !bv = U.fromList [ 0x02, 0x0c, 0xf0, 0xff00 111 | , fromIntegral (0xffff0000 :: Word64) 112 | , fromIntegral (0xffffffff00000000 :: Word64)] 113 | !sv = U.fromList [1,2,4,8,16,32] 114 | 115 | modErr :: String -> a 116 | modErr msg = error $ "Numeric.SpecFunctions." ++ msg 117 | -------------------------------------------------------------------------------- /math-functions/Numeric/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, 3 | MultiParamTypeClasses, TypeFamilies #-} 4 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 5 | -- | 6 | -- Module : Numeric.Sum 7 | -- Copyright : (c) 2014 Bryan O'Sullivan 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : bos@serpentine.com 11 | -- Stability : experimental 12 | -- Portability : portable 13 | -- 14 | -- Functions for summing floating point numbers more accurately than 15 | -- the naive 'Prelude.sum' function and its counterparts in the 16 | -- @vector@ package and elsewhere. 17 | -- 18 | -- When used with floating point numbers, in the worst case, the 19 | -- 'Prelude.sum' function accumulates numeric error at a rate 20 | -- proportional to the number of values being summed. The algorithms 21 | -- in this module implement different methods of /compensated 22 | -- summation/, which reduce the accumulation of numeric error so that 23 | -- it either grows much more slowly than the number of inputs 24 | -- (e.g. logarithmically), or remains constant. 25 | module Numeric.Sum 26 | ( 27 | -- * Summation type class 28 | Summation(..) 29 | , sumVector 30 | , kbn 31 | ) where 32 | 33 | import Control.DeepSeq (NFData(..)) 34 | import Control.Monad 35 | import Data.Data (Typeable, Data) 36 | import Data.Vector.Generic (Vector(..), foldl') 37 | import qualified Data.Vector.Generic.Mutable as M 38 | 39 | import qualified Data.Foldable as F 40 | import qualified Data.Vector.Generic as G 41 | import qualified Data.Vector.Unboxed as U 42 | 43 | -- | A class for summation of floating point numbers. 44 | class Summation s where 45 | -- | The identity for summation. 46 | zero :: s 47 | 48 | -- | Add a value to a sum. 49 | add :: s -> Double -> s 50 | 51 | -- | Sum a collection of values. 52 | -- 53 | -- Example: 54 | -- @foo = 'sum' 'kbn' [1,2,3]@ 55 | sum :: (F.Foldable f) => (s -> Double) -> f Double -> Double 56 | sum f = f . F.foldl' add zero 57 | {-# INLINE sum #-} 58 | 59 | instance Summation Double where 60 | zero = 0 61 | add = (+) 62 | 63 | -- | Kahan-Babuška-Neumaier summation. This is a little more 64 | -- computationally costly than plain Kahan summation, but is /always/ 65 | -- at least as accurate. 66 | data KBNSum = KBNSum {-# UNPACK #-} !Double {-# UNPACK #-} !Double 67 | deriving (Eq, Show, Typeable, Data) 68 | 69 | newtype instance U.MVector s KBNSum = MV_KBNSum (U.MVector s (Double,Double)) 70 | newtype instance U.Vector KBNSum = V_KBNSum (U.Vector (Double,Double)) 71 | 72 | instance M.MVector U.MVector KBNSum where 73 | {-# INLINE basicLength #-} 74 | {-# INLINE basicUnsafeSlice #-} 75 | {-# INLINE basicOverlaps #-} 76 | {-# INLINE basicUnsafeNew #-} 77 | {-# INLINE basicUnsafeReplicate #-} 78 | {-# INLINE basicUnsafeRead #-} 79 | {-# INLINE basicUnsafeWrite #-} 80 | {-# INLINE basicClear #-} 81 | {-# INLINE basicSet #-} 82 | {-# INLINE basicUnsafeCopy #-} 83 | {-# INLINE basicUnsafeGrow #-} 84 | basicLength (MV_KBNSum v) = M.basicLength v 85 | basicUnsafeSlice i n (MV_KBNSum v) = MV_KBNSum $ M.basicUnsafeSlice i n v 86 | basicOverlaps (MV_KBNSum v1) (MV_KBNSum v2) = M.basicOverlaps v1 v2 87 | basicUnsafeNew n = MV_KBNSum `liftM` M.basicUnsafeNew n 88 | basicUnsafeReplicate n (KBNSum a b) = MV_KBNSum `liftM` M.basicUnsafeReplicate n (a,b) 89 | basicUnsafeRead (MV_KBNSum v) i = uncurry KBNSum `liftM` M.basicUnsafeRead v i 90 | basicUnsafeWrite (MV_KBNSum v) i (KBNSum a b) = M.basicUnsafeWrite v i (a,b) 91 | basicClear (MV_KBNSum v) = M.basicClear v 92 | basicSet (MV_KBNSum v) (KBNSum a b) = M.basicSet v (a,b) 93 | basicUnsafeCopy (MV_KBNSum v1) (MV_KBNSum v2) = M.basicUnsafeCopy v1 v2 94 | basicUnsafeMove (MV_KBNSum v1) (MV_KBNSum v2) = M.basicUnsafeMove v1 v2 95 | basicUnsafeGrow (MV_KBNSum v) n = MV_KBNSum `liftM` M.basicUnsafeGrow v n 96 | #if MIN_VERSION_vector(0,11,0) 97 | {-# INLINE basicInitialize #-} 98 | basicInitialize (MV_KBNSum v) = M.basicInitialize v 99 | #endif 100 | 101 | instance G.Vector U.Vector KBNSum where 102 | {-# INLINE basicUnsafeFreeze #-} 103 | {-# INLINE basicUnsafeThaw #-} 104 | {-# INLINE basicLength #-} 105 | {-# INLINE basicUnsafeSlice #-} 106 | {-# INLINE basicUnsafeIndexM #-} 107 | {-# INLINE elemseq #-} 108 | basicUnsafeFreeze (MV_KBNSum v) = V_KBNSum `liftM` G.basicUnsafeFreeze v 109 | basicUnsafeThaw (V_KBNSum v) = MV_KBNSum `liftM` G.basicUnsafeThaw v 110 | basicLength (V_KBNSum v) = G.basicLength v 111 | basicUnsafeSlice i n (V_KBNSum v) = V_KBNSum $ G.basicUnsafeSlice i n v 112 | basicUnsafeIndexM (V_KBNSum v) i = uncurry KBNSum `liftM` G.basicUnsafeIndexM v i 113 | basicUnsafeCopy (MV_KBNSum mv) (V_KBNSum v) = G.basicUnsafeCopy mv v 114 | elemseq _ = seq 115 | 116 | 117 | instance U.Unbox KBNSum 118 | 119 | instance Summation KBNSum where 120 | zero = KBNSum 0 0 121 | add = kbnAdd 122 | 123 | instance NFData KBNSum where 124 | rnf !_ = () 125 | 126 | kbnAdd :: KBNSum -> Double -> KBNSum 127 | kbnAdd (KBNSum sum c) x = KBNSum sum' c' 128 | where c' | abs sum >= abs x = c + ((sum - sum') + x) 129 | | otherwise = c + ((x - sum') + sum) 130 | sum' = sum + x 131 | 132 | -- | Return the result of a Kahan-Babuška-Neumaier sum. 133 | kbn :: KBNSum -> Double 134 | kbn (KBNSum sum c) = sum + c 135 | 136 | -- | /O(n)/ Sum a vector of values. 137 | sumVector :: (Vector v Double, Summation s) => 138 | (s -> Double) -> v Double -> Double 139 | sumVector f = f . foldl' add zero 140 | {-# INLINE sumVector #-} 141 | 142 | -- $usage 143 | -- 144 | -- Most of these summation algorithms are intended to be used via the 145 | -- 'Summation' typeclass interface. Explicit type annotations should 146 | -- not be necessary, as the use of a function such as 'kbn' or 'kb2' 147 | -- to extract the final sum out of a 'Summation' instance gives the 148 | -- compiler enough information to determine the precise type of 149 | -- summation algorithm to use. 150 | -- 151 | -- As an example, here is a (somewhat silly) function that manually 152 | -- computes the sum of elements in a list. 153 | -- 154 | -- @ 155 | -- sillySumList :: [Double] -> Double 156 | -- sillySumList = loop 'zero' 157 | -- where loop s [] = 'kbn' s 158 | -- loop s (x:xs) = 'seq' s' loop s' xs 159 | -- where s' = 'add' s x 160 | -- @ 161 | -- 162 | -- In most instances, you can simply use the much more general 'sum' 163 | -- function instead of writing a summation function by hand. 164 | -- 165 | -- @ 166 | -- -- Avoid ambiguity around which sum function we are using. 167 | -- import Prelude hiding (sum) 168 | -- -- 169 | -- betterSumList :: [Double] -> Double 170 | -- betterSumList xs = 'sum' 'kbn' xs 171 | -- @ 172 | 173 | -- Note well the use of 'seq' in the example above to force the 174 | -- evaluation of intermediate values. If you must write a summation 175 | -- function by hand, and you forget to evaluate the intermediate 176 | -- values, you are likely to incur a space leak. 177 | -- 178 | -- Here is an example of how to compute a prefix sum in which the 179 | -- intermediate values are as accurate as possible. 180 | -- 181 | -- @ 182 | -- prefixSum :: [Double] -> [Double] 183 | -- prefixSum xs = map 'kbn' . 'scanl' 'add' 'zero' $ xs 184 | -- @ 185 | 186 | -- $references 187 | -- 188 | -- * Kahan, W. (1965), Further remarks on reducing truncation 189 | -- errors. /Communications of the ACM/ 8(1):40. 190 | -- 191 | -- * Neumaier, A. (1974), Rundungsfehleranalyse einiger Verfahren zur 192 | -- Summation endlicher Summen. 193 | -- /Zeitschrift für Angewandte Mathematik und Mechanik/ 54:39–51. 194 | -- 195 | -- * Klein, A. (2006), A Generalized 196 | -- Kahan-Babuška-Summation-Algorithm. /Computing/ 76(3):279-293. 197 | -- 198 | -- * Higham, N.J. (1993), The accuracy of floating point 199 | -- summation. /SIAM Journal on Scientific Computing/ 14(4):783–799. 200 | -------------------------------------------------------------------------------- /mwc-random/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009, Bryan O'Sullivan 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /mwc-random/System/Random/MWC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts, 3 | Rank2Types, ScopedTypeVariables, TypeFamilies #-} 4 | -- | 5 | -- Module : System.Random.MWC 6 | -- Copyright : (c) 2009-2012 Bryan O'Sullivan 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : bos@serpentine.com 10 | -- Stability : experimental 11 | -- Portability : portable 12 | -- 13 | -- Pseudo-random number generation. This module contains code for 14 | -- generating high quality random numbers that follow a uniform 15 | -- distribution. 16 | -- 17 | -- For non-uniform distributions, see the 18 | -- 'System.Random.MWC.Distributions' module. 19 | -- 20 | -- The uniform PRNG uses Marsaglia's MWC256 (also known as MWC8222) 21 | -- multiply-with-carry generator, which has a period of 2^8222 and 22 | -- fares well in tests of randomness. It is also extremely fast, 23 | -- between 2 and 3 times faster than the Mersenne Twister. 24 | -- 25 | -- The generator state is stored in the 'Gen' data type. It can be 26 | -- created in several ways: 27 | -- 28 | -- 1. Using the 'withSystemRandom' call, which creates a random state. 29 | -- 30 | -- 2. Supply your own seed to 'initialize' function. 31 | -- 32 | -- 3. Finally, 'create' makes a generator from a fixed seed. 33 | -- Generators created in this way aren't really random. 34 | -- 35 | -- For repeatability, the state of the generator can be snapshotted 36 | -- and replayed using the 'save' and 'restore' functions. 37 | -- 38 | -- The simplest use is to generate a vector of uniformly distributed values: 39 | -- 40 | -- @ 41 | -- vs \<- 'withSystemRandom' . 'asGenST' $ \\gen -> 'uniformVector' gen 100 42 | -- @ 43 | -- 44 | -- These values can be of any type which is an instance of the class 45 | -- 'Variate'. 46 | -- 47 | -- To generate random values on demand, first 'create' a random number 48 | -- generator. 49 | -- 50 | -- @ 51 | -- gen <- 'create' 52 | -- @ 53 | -- 54 | -- Hold onto this generator and use it wherever random values are 55 | -- required (creating a new generator is expensive compared to 56 | -- generating a random number, so you don't want to throw them 57 | -- away). Get a random value using 'uniform' or 'uniformR': 58 | -- 59 | -- @ 60 | -- v <- 'uniform' gen 61 | -- @ 62 | -- 63 | -- @ 64 | -- v <- 'uniformR' (1, 52) gen 65 | -- @ 66 | module System.Random.MWC 67 | ( 68 | -- * Gen: Pseudo-Random Number Generators 69 | Gen 70 | , initialize 71 | , createSystemRandom 72 | , GenIO 73 | , splitGen 74 | 75 | -- * Variates: uniformly distributed values 76 | , Variate(..) 77 | , uniformVector 78 | 79 | ) where 80 | 81 | #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) 82 | #include "MachDeps.h" 83 | #endif 84 | 85 | import Control.Monad (liftM, replicateM) 86 | import Data.Bits ((.|.), shiftL, shiftR) 87 | import Data.Int (Int8, Int16, Int32, Int64) 88 | import Data.Vector.Generic (Vector) 89 | import Data.Word (Word8, Word16, Word32, Word64) 90 | #if !MIN_VERSION_base(4,8,0) 91 | import Data.Word (Word) 92 | #endif 93 | import Foreign.Marshal.Alloc (allocaBytes) 94 | import Foreign.Marshal.Array (peekArray) 95 | import qualified Data.Vector.Generic as G 96 | import qualified Data.Vector.Unboxed as I 97 | import qualified Data.Vector.Unboxed.Mutable as M 98 | #if defined(mingw32_HOST_OS) 99 | import Foreign.Ptr 100 | import Foreign.C.Types 101 | #else 102 | import System.IO (IOMode(..), hGetBuf, withBinaryFile) 103 | #endif 104 | 105 | import Basement.Monad (PrimMonad(..)) 106 | 107 | 108 | -- | The class of types for which we can generate uniformly 109 | -- distributed random variates. 110 | -- 111 | -- The uniform PRNG uses Marsaglia's MWC256 (also known as MWC8222) 112 | -- multiply-with-carry generator, which has a period of 2^8222 and 113 | -- fares well in tests of randomness. It is also extremely fast, 114 | -- between 2 and 3 times faster than the Mersenne Twister. 115 | -- 116 | -- /Note/: Marsaglia's PRNG is not known to be cryptographically 117 | -- secure, so you should not use it for cryptographic operations. 118 | class Variate a where 119 | -- | Generate a single uniformly distributed random variate. The 120 | -- range of values produced varies by type: 121 | -- 122 | -- * For fixed-width integral types, the type's entire range is 123 | -- used. 124 | -- 125 | -- * For floating point numbers, the range (0,1] is used. Zero is 126 | -- explicitly excluded, to allow variates to be used in 127 | -- statistical calculations that require non-zero values 128 | -- (e.g. uses of the 'log' function). 129 | -- 130 | -- To generate a 'Float' variate with a range of [0,1), subtract 131 | -- 2**(-33). To do the same with 'Double' variates, subtract 132 | -- 2**(-53). 133 | uniform :: Gen -> IO a 134 | -- | Generate single uniformly distributed random variable in a 135 | -- given range. 136 | -- 137 | -- * For integral types inclusive range is used. 138 | -- 139 | -- * For floating point numbers range (a,b] is used if one ignores 140 | -- rounding errors. 141 | uniformR :: (a,a) -> Gen -> IO a 142 | 143 | instance Variate Word32 where 144 | uniform = uniform1 fromIntegral 145 | uniformR a b = uniformRange a b 146 | {-# INLINE uniform #-} 147 | {-# INLINE uniformR #-} 148 | 149 | instance Variate Word64 where 150 | uniform = uniform2 wordsTo64Bit 151 | uniformR a b = uniformRange a b 152 | {-# INLINE uniform #-} 153 | {-# INLINE uniformR #-} 154 | 155 | instance Variate Int where 156 | #if WORD_SIZE_IN_BITS == 32 157 | uniform = uniform1 fromIntegral 158 | #elif WORD_SIZE_IN_BITS == 64 159 | uniform = uniform2 wordsTo64Bit 160 | #else 161 | #error "Word size is not 32 nor 64" 162 | #endif 163 | uniformR a b = uniformRange a b 164 | {-# INLINE uniform #-} 165 | {-# INLINE uniformR #-} 166 | 167 | instance Variate Word where 168 | #if WORD_SIZE_IN_BITS == 32 169 | uniform = uniform1 fromIntegral 170 | #elif WORD_SIZE_IN_BITS == 64 171 | uniform = uniform2 wordsTo64Bit 172 | #else 173 | #error "Word size is not 32 nor 64" 174 | #endif 175 | uniformR a b = uniformRange a b 176 | {-# INLINE uniform #-} 177 | {-# INLINE uniformR #-} 178 | 179 | wordsTo64Bit :: (Integral a) => Word32 -> Word32 -> a 180 | wordsTo64Bit x y = 181 | fromIntegral ((fromIntegral x `shiftL` 32) .|. fromIntegral y :: Word64) 182 | {-# INLINE wordsTo64Bit #-} 183 | 184 | -- | State of the pseudo-random number generator. It uses mutable 185 | -- state so same generator shouldn't be used from the different 186 | -- threads simultaneously. 187 | newtype Gen = Gen (M.MVector (PrimState IO) Word32) 188 | 189 | -- | A shorter name for PRNG state in the 'IO' monad. 190 | type GenIO = Gen 191 | 192 | ioff, coff :: Int 193 | ioff = 256 194 | coff = 257 195 | 196 | -- | Create a generator for variates using the given seed of 256 elements 197 | -- 198 | -- @gen' <- 'initialize' . 'fromSeed' =<< 'save'@ 199 | initialize :: I.Vector Word32 -> IO Gen 200 | initialize seed 201 | | fini /= 256 = error "mwc seed invalid size" 202 | | otherwise = do 203 | q <- M.unsafeNew 258 204 | fill q 205 | M.unsafeWrite q ioff 255 206 | M.unsafeWrite q coff 362436 207 | return (Gen q) 208 | where 209 | fini = G.length seed 210 | fill q = go 0 where 211 | go i | i == 256 = return () 212 | | otherwise = M.unsafeWrite q i (G.unsafeIndex seed i) >> go (i+1) 213 | {-# INLINE initialize #-} 214 | 215 | -- | Acquire seed from the system entropy source. On Unix machines, 216 | -- this will attempt to use @/dev/urandom@. On Windows, it will internally 217 | -- use @RtlGenRandom@. 218 | acquireSeedSystem :: IO [Word32] 219 | acquireSeedSystem = do 220 | #if !defined(mingw32_HOST_OS) 221 | -- Read 256 random Word32s from /dev/urandom 222 | let nbytes = 1024 223 | random = "/dev/urandom" 224 | allocaBytes nbytes $ \buf -> do 225 | nread <- withBinaryFile random ReadMode $ 226 | \h -> hGetBuf h buf nbytes 227 | peekArray (nread `div` 4) buf 228 | #else 229 | let nbytes = 1024 230 | -- Generate 256 random Word32s from RtlGenRandom 231 | allocaBytes nbytes $ \buf -> do 232 | ok <- c_RtlGenRandom buf (fromIntegral nbytes) 233 | if ok then return () else fail "Couldn't use RtlGenRandom" 234 | peekArray (nbytes `div` 4) buf 235 | 236 | -- Note: on 64-bit Windows, the 'stdcall' calling convention 237 | -- isn't supported, so we use 'ccall' instead. 238 | #if defined(i386_HOST_ARCH) 239 | # define WINDOWS_CCONV stdcall 240 | #elif defined(x86_64_HOST_ARCH) 241 | # define WINDOWS_CCONV ccall 242 | #else 243 | # error Unknown mingw32 architecture! 244 | #endif 245 | 246 | -- Note: On Windows, the typical convention would be to use 247 | -- the CryptoGenRandom API in order to generate random data. 248 | -- However, here we use 'SystemFunction036', AKA RtlGenRandom. 249 | -- 250 | -- This is a commonly used API for this purpose; one bonus is 251 | -- that it avoids having to bring in the CryptoAPI library, 252 | -- and completely sidesteps the initialization cost of CryptoAPI. 253 | -- 254 | -- While this function is technically "subject to change" that is 255 | -- extremely unlikely in practice: rand_s in the Microsoft CRT uses 256 | -- this, and they can't change it easily without also breaking 257 | -- backwards compatibility with e.g. statically linked applications. 258 | -- 259 | -- The name 'SystemFunction036' is the actual link-time name; the 260 | -- display name is just for giggles, I guess. 261 | -- 262 | -- See also: 263 | -- - http://blogs.msdn.com/b/michael_howard/archive/2005/01/14/353379.aspx 264 | -- - https://bugzilla.mozilla.org/show_bug.cgi?id=504270 265 | -- 266 | foreign import WINDOWS_CCONV unsafe "SystemFunction036" 267 | c_RtlGenRandom :: Ptr a -> CULong -> IO Bool 268 | #endif 269 | 270 | -- | Seed a PRNG with data from the system's fast source of pseudo-random 271 | -- numbers. 272 | createSystemRandom :: IO GenIO 273 | createSystemRandom = do 274 | seed <- acquireSeedSystem 275 | initialize (I.fromList seed) 276 | 277 | -- | Compute the next index into the state pool. This is simply 278 | -- addition modulo 256. 279 | nextIndex :: Integral a => a -> Int 280 | nextIndex i = fromIntegral j 281 | where j = fromIntegral (i+1) :: Word8 282 | {-# INLINE nextIndex #-} 283 | 284 | aa :: Word64 285 | aa = 1540315826 286 | {-# INLINE aa #-} 287 | 288 | data DoubleWord32 = DoubleWord32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 289 | 290 | uniformWord32 :: Gen -> IO Word32 291 | uniformWord32 (Gen q) = do 292 | i <- nextIndex `liftM` M.unsafeRead q ioff 293 | c <- fromIntegral `liftM` M.unsafeRead q coff 294 | qi <- fromIntegral `liftM` M.unsafeRead q i 295 | let t = aa * qi + c 296 | c' = fromIntegral (t `shiftR` 32) 297 | x = fromIntegral t + c' 298 | (DoubleWord32 x' c'') | x < c' = DoubleWord32 (x + 1) (c' + 1) 299 | | otherwise = DoubleWord32 x c' 300 | M.unsafeWrite q i x' 301 | M.unsafeWrite q ioff (fromIntegral i) 302 | M.unsafeWrite q coff (fromIntegral c'') 303 | return x' 304 | {-# INLINE uniformWord32 #-} 305 | 306 | uniform1 :: (Word32 -> a) -> Gen -> IO a 307 | uniform1 f gen = do 308 | i <- uniformWord32 gen 309 | return $! f i 310 | {-# INLINE uniform1 #-} 311 | 312 | uniform2 :: (Word32 -> Word32 -> a) -> Gen -> IO a 313 | uniform2 f (Gen q) = do 314 | i <- nextIndex `liftM` M.unsafeRead q ioff 315 | let j = nextIndex i 316 | c <- fromIntegral `liftM` M.unsafeRead q coff 317 | qi <- fromIntegral `liftM` M.unsafeRead q i 318 | qj <- fromIntegral `liftM` M.unsafeRead q j 319 | let t = aa * qi + c 320 | c' = fromIntegral (t `shiftR` 32) 321 | x = fromIntegral t + c' 322 | DoubleWord32 x' c'' | x < c' = DoubleWord32 (x + 1) (c' + 1) 323 | | otherwise = DoubleWord32 x c' 324 | u = aa * qj + fromIntegral c'' 325 | d' = fromIntegral (u `shiftR` 32) 326 | y = fromIntegral u + d' 327 | DoubleWord32 y' d'' | y < d' = DoubleWord32 (y + 1) (d' + 1) 328 | | otherwise = DoubleWord32 y d' 329 | M.unsafeWrite q i x' 330 | M.unsafeWrite q j y' 331 | M.unsafeWrite q ioff (fromIntegral j) 332 | M.unsafeWrite q coff (fromIntegral d'') 333 | return $! f x' y' 334 | {-# INLINE uniform2 #-} 335 | 336 | -- Type family for fixed size integrals. For signed data types it's 337 | -- its unsigned couterpart with same size and for unsigned data types 338 | -- it's same type 339 | type family Unsigned a :: * 340 | 341 | type instance Unsigned Int8 = Word8 342 | type instance Unsigned Int16 = Word16 343 | type instance Unsigned Int32 = Word32 344 | type instance Unsigned Int64 = Word64 345 | 346 | type instance Unsigned Word8 = Word8 347 | type instance Unsigned Word16 = Word16 348 | type instance Unsigned Word32 = Word32 349 | type instance Unsigned Word64 = Word64 350 | 351 | -- This is workaround for bug #25. 352 | -- 353 | -- GHC-7.6 has a bug (#8072) which results in calculation of wrong 354 | -- number of buckets in function `uniformRange'. Consequently uniformR 355 | -- generates values in wrong range. 356 | -- 357 | -- Bug only affects 32-bit systems and Int/Word data types. Word32 358 | -- works just fine. So we set Word32 as unsigned counterpart for Int 359 | -- and Word on 32-bit systems. It's done only for GHC-7.6 because 360 | -- other versions are unaffected by the bug and we expect that GHC may 361 | -- optimise code which uses Word better. 362 | #if (WORD_SIZE_IN_BITS < 64) && (__GLASGOW_HASKELL__ == 706) 363 | type instance Unsigned Int = Word32 364 | type instance Unsigned Word = Word32 365 | #else 366 | type instance Unsigned Int = Word 367 | type instance Unsigned Word = Word 368 | #endif 369 | 370 | 371 | -- Subtract two numbers under assumption that x>=y and store result in 372 | -- unsigned data type of same size 373 | sub :: (Integral a, Integral (Unsigned a)) => a -> a -> Unsigned a 374 | sub x y = fromIntegral x - fromIntegral y 375 | {-# INLINE sub #-} 376 | 377 | add :: (Integral a, Integral (Unsigned a)) => a -> Unsigned a -> a 378 | add m x = m + fromIntegral x 379 | {-# INLINE add #-} 380 | 381 | -- Generate uniformly distributed value in inclusive range. 382 | -- 383 | -- NOTE: This function must be fully applied. Otherwise it won't be 384 | -- inlined, which will cause a severe performance loss. 385 | -- 386 | -- > uniformR = uniformRange -- won't be inlined 387 | -- > uniformR a b = uniformRange a b -- will be inlined 388 | uniformRange :: ( Integral a, Bounded a, Variate a 389 | , Integral (Unsigned a), Bounded (Unsigned a), Variate (Unsigned a)) 390 | => (a,a) -> Gen -> IO a 391 | uniformRange (x1,x2) g 392 | | n == 0 = uniform g -- Abuse overflow in unsigned types 393 | | otherwise = loop 394 | where 395 | -- Allow ranges where x2 Gen -> Int -> IO (v a) 411 | uniformVector gen n = G.replicateM n (uniform gen) 412 | {-# INLINE uniformVector #-} 413 | 414 | -- | Split a generator into several that can run independently. 415 | splitGen :: Int -> GenIO -> IO [GenIO] 416 | splitGen n gen 417 | | n <= 0 = return [] 418 | | otherwise = 419 | fmap (gen:) . replicateM (n-1) $ 420 | initialize =<< uniformVector gen 256 421 | 422 | -- $references 423 | -- 424 | -- * Marsaglia, G. (2003) Seeds for random number generators. 425 | -- /Communications of the ACM/ 46(5):90–93. 426 | -- 427 | -- 428 | -- * Doornik, J.A. (2007) Conversion of high-period random numbers to 429 | -- floating point. 430 | -- /ACM Transactions on Modeling and Computer Simulation/ 17(1). 431 | -- 432 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 6fe771eb91c98411c32b04cdd782a37cb1da7bdb7b6f346f6d98808d73808888 ~*~ 2 | { resolver: ghc-8.8.1, packages: [ '.' ], extra-deps: [ "basement-0.0.11@sha256:af43e2e334e515b52ca309919b135c51b5e9411e6d4c68d0e8950d61eb5f25d1,5711", "vector-0.12.0.3@sha256:1422b0bcf4e7675116ca8d9f473bf239850c58c4518a56010e3bfebeac345ace,7171", "primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416", "foundation-0.0.25@sha256:e24936100ca6c1778d671994eb3f179cf18ca7c772cc831a2c8b380dcad445df,12036" ], flags: {} } 3 | 4 | -------------------------------------------------------------------------------- /statistics/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009, 2010 Bryan O'Sullivan 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /statistics/Statistics/Distribution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} 3 | -- | 4 | -- Module : Statistics.Distribution 5 | -- Copyright : (c) 2009 Bryan O'Sullivan 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : bos@serpentine.com 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- Type classes for probability distributions 13 | 14 | module Statistics.Distribution 15 | ( 16 | -- * Type classes 17 | Distribution(..) 18 | , ContDistr(..) 19 | ) where 20 | 21 | import Prelude hiding (sum) 22 | 23 | -- | Type class common to all distributions. Only c.d.f. could be 24 | -- defined for both discrete and continuous distributions. 25 | class Distribution d where 26 | -- | Cumulative distribution function. The probability that a 27 | -- random variable /X/ is less or equal than /x/, 28 | -- i.e. P(/X/≤/x/). Cumulative should be defined for 29 | -- infinities as well: 30 | -- 31 | -- > cumulative d +∞ = 1 32 | -- > cumulative d -∞ = 0 33 | cumulative :: d -> Double -> Double 34 | 35 | -- | One's complement of cumulative distibution: 36 | -- 37 | -- > complCumulative d x = 1 - cumulative d x 38 | -- 39 | -- It's useful when one is interested in P(/X/>/x/) and 40 | -- expression on the right side begin to lose precision. This 41 | -- function have default implementation but implementors are 42 | -- encouraged to provide more precise implementation. 43 | complCumulative :: d -> Double -> Double 44 | complCumulative d x = 1 - cumulative d x 45 | 46 | -- | Continuous probability distributuion. 47 | -- 48 | -- Minimal complete definition is 'quantile' and either 'density' or 49 | -- 'logDensity'. 50 | class Distribution d => ContDistr d where 51 | -- | Probability density function. Probability that random 52 | -- variable /X/ lies in the infinitesimal interval 53 | -- [/x/,/x+/δ/x/) equal to /density(x)/⋅δ/x/ 54 | density :: d -> Double -> Double 55 | density d = exp . logDensity d 56 | 57 | -- | Inverse of the cumulative distribution function. The value 58 | -- /x/ for which P(/X/≤/x/) = /p/. If probability is outside 59 | -- of [0,1] range function should call 'error' 60 | quantile :: d -> Double -> Double 61 | 62 | -- | 1-complement of @quantile@: 63 | -- 64 | -- > complQuantile x ≡ quantile (1 - x) 65 | complQuantile :: d -> Double -> Double 66 | complQuantile d x = quantile d (1 - x) 67 | 68 | -- | Natural logarithm of density. 69 | logDensity :: d -> Double -> Double 70 | logDensity d = log . density d 71 | -------------------------------------------------------------------------------- /statistics/Statistics/Distribution/Normal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 4 | -- | 5 | -- Module : Statistics.Distribution.Normal 6 | -- Copyright : (c) 2009 Bryan O'Sullivan 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : bos@serpentine.com 10 | -- Stability : experimental 11 | -- Portability : portable 12 | -- 13 | -- The normal distribution. This is a continuous probability 14 | -- distribution that describes data that cluster around a mean. 15 | 16 | module Statistics.Distribution.Normal 17 | ( NormalDistribution 18 | -- * Constructors 19 | -- , normalDistr 20 | --, normalDistrE 21 | , standard 22 | ) where 23 | 24 | import Data.Data (Data, Typeable) 25 | import GHC.Generics (Generic) 26 | import Numeric.MathFunctions.Constants (m_sqrt_2, m_sqrt_2_pi) 27 | import Numeric.SpecFunctions (erfc, invErfc) 28 | 29 | import qualified Statistics.Distribution as D 30 | import Statistics.Internal 31 | 32 | 33 | -- | The normal distribution. 34 | data NormalDistribution = ND { 35 | mean :: {-# UNPACK #-} !Double 36 | , stdDev :: {-# UNPACK #-} !Double 37 | , ndPdfDenom :: {-# UNPACK #-} !Double 38 | , ndCdfDenom :: {-# UNPACK #-} !Double 39 | } deriving (Eq, Typeable, Data, Generic) 40 | 41 | instance Show NormalDistribution where 42 | showsPrec i (ND m s _ _) = defaultShow2 "normalDistr" m s i 43 | instance Read NormalDistribution where 44 | readPrec = defaultReadPrecM2 "normalDistr" normalDistrE 45 | 46 | instance D.Distribution NormalDistribution where 47 | cumulative = cumulative 48 | complCumulative = complCumulative 49 | 50 | instance D.ContDistr NormalDistribution where 51 | logDensity = logDensity 52 | quantile = quantile 53 | complQuantile = complQuantile 54 | 55 | -- | Standard normal distribution with mean equal to 0 and variance equal to 1 56 | standard :: NormalDistribution 57 | standard = ND { mean = 0.0 58 | , stdDev = 1.0 59 | , ndPdfDenom = log m_sqrt_2_pi 60 | , ndCdfDenom = m_sqrt_2 61 | } 62 | 63 | -- | Create normal distribution from parameters. 64 | -- 65 | -- IMPORTANT: prior to 0.10 release second parameter was variance not 66 | -- standard deviation. 67 | normalDistrE :: Double -- ^ Mean of distribution 68 | -> Double -- ^ Standard deviation of distribution 69 | -> Maybe NormalDistribution 70 | normalDistrE m sd 71 | | sd > 0 = Just ND { mean = m 72 | , stdDev = sd 73 | , ndPdfDenom = log $ m_sqrt_2_pi * sd 74 | , ndCdfDenom = m_sqrt_2 * sd 75 | } 76 | | otherwise = Nothing 77 | 78 | logDensity :: NormalDistribution -> Double -> Double 79 | logDensity d x = (-xm * xm / (2 * sd * sd)) - ndPdfDenom d 80 | where xm = x - mean d 81 | sd = stdDev d 82 | 83 | cumulative :: NormalDistribution -> Double -> Double 84 | cumulative d x = erfc ((mean d - x) / ndCdfDenom d) / 2 85 | 86 | complCumulative :: NormalDistribution -> Double -> Double 87 | complCumulative d x = erfc ((x - mean d) / ndCdfDenom d) / 2 88 | 89 | quantile :: NormalDistribution -> Double -> Double 90 | quantile d p 91 | | p == 0 = -inf 92 | | p == 1 = inf 93 | | p == 0.5 = mean d 94 | | p > 0 && p < 1 = x * ndCdfDenom d + mean d 95 | | otherwise = 96 | error $ "Statistics.Distribution.Normal.quantile: p must be in [0,1] range. Got: "++show p 97 | where x = - invErfc (2 * p) 98 | inf = 1/0 99 | 100 | complQuantile :: NormalDistribution -> Double -> Double 101 | complQuantile d p 102 | | p == 0 = inf 103 | | p == 1 = -inf 104 | | p == 0.5 = mean d 105 | | p > 0 && p < 1 = x * ndCdfDenom d + mean d 106 | | otherwise = 107 | error $ "Statistics.Distribution.Normal.complQuantile: p must be in [0,1] range. Got: "++show p 108 | where x = invErfc (2 * p) 109 | inf = 1/0 110 | -------------------------------------------------------------------------------- /statistics/Statistics/Function.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, CPP, FlexibleContexts, Rank2Types #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | #if __GLASGOW_HASKELL__ >= 704 4 | {-# OPTIONS_GHC -fsimpl-tick-factor=200 #-} 5 | #endif 6 | 7 | -- | 8 | -- Module : Statistics.Function 9 | -- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : bos@serpentine.com 13 | -- Stability : experimental 14 | -- Portability : portable 15 | -- 16 | -- Useful functions. 17 | 18 | module Statistics.Function 19 | ( 20 | -- * Scanning 21 | minMax 22 | -- * Sorting 23 | , sort 24 | , inplaceSortIO 25 | -- * Indexing 26 | , indices 27 | -- * Bit twiddling 28 | , nextHighestPowerOfTwo 29 | -- * Comparison 30 | , within 31 | -- * Arithmetic 32 | , square 33 | -- * Vectors 34 | , unsafeModify 35 | -- * Combinators 36 | , for 37 | , rfor 38 | ) where 39 | 40 | #include "MachDeps.h" 41 | 42 | import Control.Applicative 43 | import Control.Monad.ST (ST) 44 | import Data.Bits ((.|.), shiftR) 45 | import qualified Data.Vector.Generic as G 46 | import qualified Data.Vector.Unboxed as U 47 | import qualified Data.Vector.Unboxed.Mutable as M 48 | import Numeric.MathFunctions.Comparison (within) 49 | import Basement.Monad 50 | import Prelude -- Silence redundant import warnings 51 | 52 | -- | Sort a vector. 53 | sort :: U.Vector Double -> U.Vector Double 54 | sort = G.modify inplaceSortST 55 | {-# NOINLINE sort #-} 56 | 57 | inplaceSortST :: M.MVector s Double 58 | -> ST s () 59 | inplaceSortST mvec = qsort 0 (M.length mvec-1) 60 | where 61 | qsort lo hi 62 | | lo >= hi = pure () 63 | | otherwise = do 64 | p <- partition lo hi 65 | qsort lo (pred p) 66 | qsort (p+1) hi 67 | pivotStrategy low high = do 68 | let mid = (low + high) `div` 2 69 | pivot <- M.unsafeRead mvec mid 70 | M.unsafeRead mvec high >>= M.unsafeWrite mvec mid 71 | M.unsafeWrite mvec high pivot 72 | pure pivot 73 | partition lo hi = do 74 | pivot <- pivotStrategy lo hi 75 | let go iOrig jOrig = do 76 | let fw k = do ak <- M.unsafeRead mvec k 77 | if compare ak pivot == LT 78 | then fw (k+1) 79 | else pure (k, ak) 80 | (i, ai) <- fw iOrig 81 | let bw k | k==i = pure (i, ai) 82 | | otherwise = do ak <- M.unsafeRead mvec k 83 | if compare ak pivot /= LT 84 | then bw (pred k) 85 | else pure (k, ak) 86 | (j, aj) <- bw jOrig 87 | if i < j 88 | then do 89 | M.unsafeWrite mvec i aj 90 | M.unsafeWrite mvec j ai 91 | go (i+1) (pred j) 92 | else do 93 | M.unsafeWrite mvec hi ai 94 | M.unsafeWrite mvec i pivot 95 | pure i 96 | go lo hi 97 | 98 | inplaceSortIO :: M.MVector (PrimState IO) Double 99 | -> IO () 100 | inplaceSortIO mvec = qsort 0 (M.length mvec-1) 101 | where 102 | qsort lo hi 103 | | lo >= hi = pure () 104 | | otherwise = do 105 | p <- partition lo hi 106 | qsort lo (pred p) 107 | qsort (p+1) hi 108 | pivotStrategy low high = do 109 | let mid = (low + high) `div` 2 110 | pivot <- M.unsafeRead mvec mid 111 | M.unsafeRead mvec high >>= M.unsafeWrite mvec mid 112 | M.unsafeWrite mvec high pivot 113 | pure pivot 114 | partition lo hi = do 115 | pivot <- pivotStrategy lo hi 116 | let go iOrig jOrig = do 117 | let fw k = do ak <- M.unsafeRead mvec k 118 | if compare ak pivot == LT 119 | then fw (k+1) 120 | else pure (k, ak) 121 | (i, ai) <- fw iOrig 122 | let bw k | k==i = pure (i, ai) 123 | | otherwise = do ak <- M.unsafeRead mvec k 124 | if compare ak pivot /= LT 125 | then bw (pred k) 126 | else pure (k, ak) 127 | (j, aj) <- bw jOrig 128 | if i < j 129 | then do 130 | M.unsafeWrite mvec i aj 131 | M.unsafeWrite mvec j ai 132 | go (i+1) (pred j) 133 | else do 134 | M.unsafeWrite mvec hi ai 135 | M.unsafeWrite mvec i pivot 136 | pure i 137 | go lo hi 138 | 139 | -- | Return the indices of a vector. 140 | indices :: (G.Vector v a, G.Vector v Int) => v a -> v Int 141 | indices a = G.enumFromTo 0 (G.length a - 1) 142 | {-# INLINE indices #-} 143 | 144 | data MM = MM {-# UNPACK #-} !Double {-# UNPACK #-} !Double 145 | 146 | -- | Compute the minimum and maximum of a vector in one pass. 147 | minMax :: (G.Vector v Double) => v Double -> (Double, Double) 148 | minMax = fini . G.foldl' go (MM (1/0) (-1/0)) 149 | where 150 | go (MM lo hi) k = MM (min lo k) (max hi k) 151 | fini (MM lo hi) = (lo, hi) 152 | {-# INLINE minMax #-} 153 | 154 | -- | Efficiently compute the next highest power of two for a 155 | -- non-negative integer. If the given value is already a power of 156 | -- two, it is returned unchanged. If negative, zero is returned. 157 | nextHighestPowerOfTwo :: Int -> Int 158 | nextHighestPowerOfTwo n 159 | #if WORD_SIZE_IN_BITS == 64 160 | = 1 + _i32 161 | #else 162 | = 1 + i16 163 | #endif 164 | where 165 | i0 = n - 1 166 | i1 = i0 .|. i0 `shiftR` 1 167 | i2 = i1 .|. i1 `shiftR` 2 168 | i4 = i2 .|. i2 `shiftR` 4 169 | i8 = i4 .|. i4 `shiftR` 8 170 | i16 = i8 .|. i8 `shiftR` 16 171 | _i32 = i16 .|. i16 `shiftR` 32 172 | -- It could be implemented as 173 | -- 174 | -- > nextHighestPowerOfTwo n = 1 + foldl' go (n-1) [1, 2, 4, 8, 16, 32] 175 | -- where go m i = m .|. m `shiftR` i 176 | -- 177 | -- But GHC do not inline foldl (probably because it's recursive) and 178 | -- as result function walks list of boxed ints. Hand rolled version 179 | -- uses unboxed arithmetic. 180 | 181 | -- | Multiply a number by itself. 182 | square :: Double -> Double 183 | square x = x * x 184 | 185 | -- | Simple for loop. Counts from /start/ to /end/-1. 186 | for :: Monad m => Int -> Int -> (Int -> m ()) -> m () 187 | for n0 !n f = loop n0 188 | where 189 | loop i | i == n = return () 190 | | otherwise = f i >> loop (i+1) 191 | {-# INLINE for #-} 192 | 193 | -- | Simple reverse-for loop. Counts from /start/-1 to /end/ (which 194 | -- must be less than /start/). 195 | rfor :: Monad m => Int -> Int -> (Int -> m ()) -> m () 196 | rfor n0 !n f = loop n0 197 | where 198 | loop i | i == n = return () 199 | | otherwise = let i' = i-1 in f i' >> loop i' 200 | {-# INLINE rfor #-} 201 | 202 | unsafeModify :: M.MVector s Double -> Int -> (Double -> Double) -> ST s () 203 | unsafeModify v i f = do 204 | k <- M.unsafeRead v i 205 | M.unsafeWrite v i (f k) 206 | {-# INLINE unsafeModify #-} 207 | -------------------------------------------------------------------------------- /statistics/Statistics/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Internal 3 | -- Copyright : (c) 2009 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bos@serpentine.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- 11 | module Statistics.Internal ( 12 | -- * Default definitions for Show 13 | defaultShow1 14 | , defaultShow2 15 | -- * Default definitions for Read 16 | , defaultReadPrecM1 17 | , defaultReadPrecM2 18 | -- * Reexports 19 | , Show(..) 20 | , Read(..) 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Monad 25 | import Text.Read 26 | 27 | 28 | 29 | ---------------------------------------------------------------- 30 | -- Default show implementations 31 | ---------------------------------------------------------------- 32 | 33 | defaultShow1 :: (Show a) => String -> a -> Int -> ShowS 34 | defaultShow1 con a n 35 | = showParen (n >= 11) 36 | ( showString con 37 | . showChar ' ' 38 | . showsPrec 11 a 39 | ) 40 | 41 | defaultShow2 :: (Show a, Show b) => String -> a -> b -> Int -> ShowS 42 | defaultShow2 con a b n 43 | = showParen (n >= 11) 44 | ( showString con 45 | . showChar ' ' 46 | . showsPrec 11 a 47 | . showChar ' ' 48 | . showsPrec 11 b 49 | ) 50 | 51 | ---------------------------------------------------------------- 52 | -- Default read implementations 53 | ---------------------------------------------------------------- 54 | 55 | defaultReadPrecM1 :: (Read a) => String -> (a -> Maybe r) -> ReadPrec r 56 | defaultReadPrecM1 con f = parens $ prec 10 $ do 57 | expect con 58 | a <- readPrec 59 | maybe empty return $ f a 60 | 61 | defaultReadPrecM2 :: (Read a, Read b) => String -> (a -> b -> Maybe r) -> ReadPrec r 62 | defaultReadPrecM2 con f = parens $ prec 10 $ do 63 | expect con 64 | a <- readPrec 65 | b <- readPrec 66 | maybe empty return $ f a b 67 | 68 | expect :: String -> ReadPrec () 69 | expect str = do 70 | Ident s <- lexP 71 | guard (s == str) 72 | -------------------------------------------------------------------------------- /statistics/Statistics/Math/RootFinding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} 2 | 3 | -- | 4 | -- Module : Statistics.Math.RootFinding 5 | -- Copyright : (c) 2011 Bryan O'Sullivan 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : bos@serpentine.com 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- Haskell functions for finding the roots of mathematical functions. 13 | 14 | module Statistics.Math.RootFinding 15 | ( Root(..) 16 | , fromRoot 17 | , ridders 18 | -- * References 19 | -- $references 20 | ) where 21 | 22 | import Control.Applicative 23 | import Control.Monad (MonadPlus(..), ap) 24 | import Data.Data (Data, Typeable) 25 | import GHC.Generics (Generic) 26 | import Numeric.MathFunctions.Comparison (within) 27 | import Prelude 28 | 29 | 30 | -- | The result of searching for a root of a mathematical function. 31 | data Root a = NotBracketed 32 | -- ^ The function does not have opposite signs when 33 | -- evaluated at the lower and upper bounds of the search. 34 | | SearchFailed 35 | -- ^ The search failed to converge to within the given 36 | -- error tolerance after the given number of iterations. 37 | | Root a 38 | -- ^ A root was successfully found. 39 | deriving (Eq, Read, Show, Typeable, Data, Generic) 40 | 41 | instance Functor Root where 42 | fmap _ NotBracketed = NotBracketed 43 | fmap _ SearchFailed = SearchFailed 44 | fmap f (Root a) = Root (f a) 45 | 46 | instance Monad Root where 47 | NotBracketed >>= _ = NotBracketed 48 | SearchFailed >>= _ = SearchFailed 49 | Root a >>= m = m a 50 | 51 | return = Root 52 | 53 | instance MonadPlus Root where 54 | mzero = SearchFailed 55 | 56 | r@(Root _) `mplus` _ = r 57 | _ `mplus` p = p 58 | 59 | instance Applicative Root where 60 | pure = Root 61 | (<*>) = ap 62 | 63 | instance Alternative Root where 64 | empty = SearchFailed 65 | 66 | r@(Root _) <|> _ = r 67 | _ <|> p = p 68 | 69 | -- | Returns either the result of a search for a root, or the default 70 | -- value if the search failed. 71 | fromRoot :: a -- ^ Default value. 72 | -> Root a -- ^ Result of search for a root. 73 | -> a 74 | fromRoot _ (Root a) = a 75 | fromRoot a _ = a 76 | 77 | 78 | -- | Use the method of Ridders to compute a root of a function. 79 | -- 80 | -- The function must have opposite signs when evaluated at the lower 81 | -- and upper bounds of the search (i.e. the root must be bracketed). 82 | ridders :: Double -- ^ Absolute error tolerance. 83 | -> (Double,Double) -- ^ Lower and upper bounds for the search. 84 | -> (Double -> Double) -- ^ Function to find the roots of. 85 | -> Root Double 86 | ridders tol (lo,hi) f 87 | | flo == 0 = Root lo 88 | | fhi == 0 = Root hi 89 | | flo*fhi > 0 = NotBracketed -- root is not bracketed 90 | | otherwise = go lo flo hi fhi 0 91 | where 92 | go !a !fa !b !fb !i 93 | -- Root is bracketed within 1 ulp. No improvement could be made 94 | | within 1 a b = Root a 95 | -- Root is found. Check that f(m) == 0 is nessesary to ensure 96 | -- that root is never passed to 'go' 97 | | fm == 0 = Root m 98 | | fn == 0 = Root n 99 | | d < tol = Root n 100 | -- Too many iterations performed. Fail 101 | | i >= (100 :: Int) = SearchFailed 102 | -- Ridder's approximation coincide with one of old 103 | -- bounds. Revert to bisection 104 | | n == a || n == b = case () of 105 | _| fm*fa < 0 -> go a fa m fm (i+1) 106 | | otherwise -> go m fm b fb (i+1) 107 | -- Proceed as usual 108 | | fn*fm < 0 = go n fn m fm (i+1) 109 | | fn*fa < 0 = go a fa n fn (i+1) 110 | | otherwise = go n fn b fb (i+1) 111 | where 112 | d = abs (b - a) 113 | dm = (b - a) * 0.5 114 | !m = a + dm 115 | !fm = f m 116 | !dn = signum (fb - fa) * dm * fm / sqrt(fm*fm - fa*fb) 117 | !n = m - signum dn * min (abs dn) (abs dm - 0.5 * tol) 118 | !fn = f n 119 | !flo = f lo 120 | !fhi = f hi 121 | 122 | 123 | -- $references 124 | -- 125 | -- * Ridders, C.F.J. (1979) A new algorithm for computing a single 126 | -- root of a real continuous function. 127 | -- /IEEE Transactions on Circuits and Systems/ 26:979–980. 128 | -------------------------------------------------------------------------------- /statistics/Statistics/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | -- | 3 | -- Module : Statistics.Matrix 4 | -- Copyright : 2011 Aleksey Khudyakov, 2014 Bryan O'Sullivan 5 | -- License : BSD3 6 | -- 7 | -- Basic matrix operations. 8 | -- 9 | -- There isn't a widely used matrix package for Haskell yet, so 10 | -- we implement the necessary minimum here. 11 | 12 | module Statistics.Matrix 13 | ( 14 | -- * Data types 15 | Matrix(..) 16 | , Vector 17 | -- * Conversion from/to lists/vectors 18 | , fromVector 19 | , dimension 20 | -- , center 21 | , multiplyV 22 | , transpose 23 | , norm 24 | , column 25 | -- , row 26 | , for 27 | , unsafeIndex 28 | ) where 29 | 30 | import Prelude hiding (exponent, map, sum) 31 | import qualified Data.Vector.Unboxed as U 32 | 33 | import Statistics.Function (for, square) 34 | import Statistics.Matrix.Types 35 | import Statistics.Sample.Internal (sum) 36 | 37 | 38 | ---------------------------------------------------------------- 39 | -- Conversion to/from vectors/lists 40 | ---------------------------------------------------------------- 41 | 42 | -- | Convert from a row-major vector. 43 | fromVector :: Int -- ^ Number of rows. 44 | -> Int -- ^ Number of columns. 45 | -> U.Vector Double -- ^ Flat list of values, in row-major order. 46 | -> Matrix 47 | fromVector r c v 48 | | r*c /= len = error "input size mismatch" 49 | | otherwise = Matrix r c 0 v 50 | where len = U.length v 51 | 52 | ---------------------------------------------------------------- 53 | -- Other 54 | ---------------------------------------------------------------- 55 | 56 | -- | Return the dimensions of this matrix, as a (row,column) pair. 57 | dimension :: Matrix -> (Int, Int) 58 | dimension (Matrix r c _ _) = (r, c) 59 | 60 | -- | Matrix-vector multiplication. 61 | multiplyV :: Matrix -> Vector -> Vector 62 | multiplyV m v 63 | | cols m == c = U.generate (rows m) (sum . U.zipWith (*) v . row m) 64 | | otherwise = error $ "matrix/vector unconformable " ++ show (cols m,c) 65 | where c = U.length v 66 | 67 | -- | Calculate the Euclidean norm of a vector. 68 | norm :: Vector -> Double 69 | norm = sqrt . sum . U.map square 70 | 71 | -- | Return the given column. 72 | column :: Matrix -> Int -> Vector 73 | column (Matrix r c _ v) i = U.backpermute v $ U.enumFromStepN i c r 74 | {-# INLINE column #-} 75 | 76 | -- | Return the given row. 77 | row :: Matrix -> Int -> Vector 78 | row (Matrix _ c _ v) i = U.slice (c*i) c v 79 | 80 | unsafeIndex :: Matrix 81 | -> Int -- ^ Row. 82 | -> Int -- ^ Column. 83 | -> Double 84 | unsafeIndex = unsafeBounds U.unsafeIndex 85 | 86 | -- | Given row and column numbers, calculate the offset into the flat 87 | -- row-major vector, without checking. 88 | unsafeBounds :: (Vector -> Int -> r) -> Matrix -> Int -> Int -> r 89 | unsafeBounds k (Matrix _ cs _ v) r c = k v $! r * cs + c 90 | {-# INLINE unsafeBounds #-} 91 | 92 | 93 | transpose :: Matrix -> Matrix 94 | transpose m@(Matrix r0 c0 e _) = Matrix c0 r0 e . U.generate (r0*c0) $ \i -> 95 | let (r,c) = i `quotRem` r0 96 | in unsafeIndex m c r 97 | -------------------------------------------------------------------------------- /statistics/Statistics/Matrix/Algorithms.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Matrix.Algorithms 3 | -- Copyright : 2014 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Useful matrix functions. 7 | 8 | module Statistics.Matrix.Algorithms 9 | ( qr 10 | ) where 11 | 12 | import Control.Applicative 13 | import Control.Monad.ST (ST, runST) 14 | import Statistics.Matrix (Matrix, column, dimension, for, norm) 15 | import qualified Statistics.Matrix.Mutable as M 16 | import Statistics.Sample.Internal (sum) 17 | import qualified Data.Vector.Unboxed as U 18 | import Prelude hiding (sum, replicate) 19 | 20 | -- | /O(r*c)/ Compute the QR decomposition of a matrix. 21 | -- The result returned is the matrices (/q/,/r/). 22 | qr :: Matrix -> (Matrix, Matrix) 23 | qr mat = runST $ do 24 | let (m,n) = dimension mat 25 | r <- M.replicate n n 0 26 | a <- M.thaw mat 27 | for 0 n $ \j -> do 28 | cn <- M.immutably a $ \aa -> norm (column aa j) 29 | M.unsafeWrite r j j cn 30 | for 0 m $ \i -> M.unsafeModify a i j (/ cn) 31 | for (j+1) n $ \jj -> do 32 | p <- innerProduct a j jj 33 | M.unsafeWrite r j jj p 34 | for 0 m $ \i -> do 35 | aij <- M.unsafeRead a i j 36 | M.unsafeModify a i jj $ subtract (p * aij) 37 | (,) <$> M.unsafeFreeze a <*> M.unsafeFreeze r 38 | 39 | innerProduct :: M.MMatrix s -> Int -> Int -> ST s Double 40 | innerProduct mmat j k = M.immutably mmat $ \mat -> 41 | sum $ U.zipWith (*) (column mat j) (column mat k) 42 | -------------------------------------------------------------------------------- /statistics/Statistics/Matrix/Mutable.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Matrix.Mutable 3 | -- Copyright : (c) 2014 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Basic mutable matrix operations. 7 | 8 | module Statistics.Matrix.Mutable 9 | ( MMatrix(..) 10 | , MVector 11 | , replicate 12 | , thaw 13 | , unsafeFreeze 14 | , unsafeRead 15 | , unsafeWrite 16 | , unsafeModify 17 | , immutably 18 | ) where 19 | 20 | import Control.Applicative 21 | import Control.DeepSeq (NFData(..)) 22 | import Control.Monad.ST (ST) 23 | import Statistics.Matrix.Types (Matrix(..), MMatrix(..), MVector) 24 | import qualified Data.Vector.Unboxed as U 25 | import qualified Data.Vector.Unboxed.Mutable as M 26 | import Prelude hiding (replicate) 27 | 28 | replicate :: Int -> Int -> Double -> ST s (MMatrix s) 29 | replicate r c k = MMatrix r c 0 <$> M.replicate (r*c) k 30 | 31 | thaw :: Matrix -> ST s (MMatrix s) 32 | thaw (Matrix r c e v) = MMatrix r c e <$> U.thaw v 33 | 34 | unsafeFreeze :: MMatrix s -> ST s Matrix 35 | unsafeFreeze (MMatrix r c e mv) = Matrix r c e <$> U.unsafeFreeze mv 36 | 37 | unsafeRead :: MMatrix s -> Int -> Int -> ST s Double 38 | unsafeRead mat r c = unsafeBounds mat r c M.unsafeRead 39 | {-# INLINE unsafeRead #-} 40 | 41 | unsafeWrite :: MMatrix s -> Int -> Int -> Double -> ST s () 42 | unsafeWrite mat row col k = unsafeBounds mat row col $ \v i -> 43 | M.unsafeWrite v i k 44 | {-# INLINE unsafeWrite #-} 45 | 46 | unsafeModify :: MMatrix s -> Int -> Int -> (Double -> Double) -> ST s () 47 | unsafeModify mat row col f = unsafeBounds mat row col $ \v i -> do 48 | k <- M.unsafeRead v i 49 | M.unsafeWrite v i (f k) 50 | {-# INLINE unsafeModify #-} 51 | 52 | -- | Given row and column numbers, calculate the offset into the flat 53 | -- row-major vector, without checking. 54 | unsafeBounds :: MMatrix s -> Int -> Int -> (MVector s -> Int -> r) -> r 55 | unsafeBounds (MMatrix _ cs _ mv) r c k = k mv $! r * cs + c 56 | {-# INLINE unsafeBounds #-} 57 | 58 | immutably :: NFData a => MMatrix s -> (Matrix -> a) -> ST s a 59 | immutably mmat f = do 60 | k <- f <$> unsafeFreeze mmat 61 | rnf k `seq` return k 62 | {-# INLINE immutably #-} 63 | -------------------------------------------------------------------------------- /statistics/Statistics/Matrix/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Matrix.Types 3 | -- Copyright : 2014 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Basic matrix operations. 7 | -- 8 | -- There isn't a widely used matrix package for Haskell yet, so 9 | -- we implement the necessary minimum here. 10 | 11 | module Statistics.Matrix.Types 12 | ( Vector 13 | , MVector 14 | , Matrix(..) 15 | , MMatrix(..) 16 | ) where 17 | 18 | import Data.Char (isSpace) 19 | import Numeric (showFFloat) 20 | import qualified Data.Vector.Unboxed as U 21 | import qualified Data.Vector.Unboxed.Mutable as M 22 | 23 | type Vector = U.Vector Double 24 | type MVector s = M.MVector s Double 25 | 26 | -- | Two-dimensional matrix, stored in row-major order. 27 | data Matrix = Matrix { 28 | rows :: {-# UNPACK #-} !Int -- ^ Rows of matrix. 29 | , cols :: {-# UNPACK #-} !Int -- ^ Columns of matrix. 30 | , exponent :: {-# UNPACK #-} !Int 31 | -- ^ In order to avoid overflows during matrix multiplication, a 32 | -- large exponent is stored separately. 33 | , _vector :: !Vector -- ^ Matrix data. 34 | } deriving (Eq) 35 | 36 | -- | Two-dimensional mutable matrix, stored in row-major order. 37 | data MMatrix s = MMatrix 38 | {-# UNPACK #-} !Int 39 | {-# UNPACK #-} !Int 40 | {-# UNPACK #-} !Int 41 | !(MVector s) 42 | 43 | -- The Show instance is useful only for debugging. 44 | instance Show Matrix where 45 | show = debug 46 | 47 | debug :: Matrix -> String 48 | debug (Matrix r c _ vs) = unlines $ zipWith (++) (hdr0 : repeat hdr) rrows 49 | where 50 | rrows = map (cleanEnd . unwords) . split $ zipWith (++) ldone tdone 51 | hdr0 = show (r,c) ++ " " 52 | hdr = replicate (length hdr0) ' ' 53 | pad plus k xs = replicate (k - length xs) ' ' `plus` xs 54 | ldone = map (pad (++) (longest lstr)) lstr 55 | tdone = map (pad (flip (++)) (longest tstr)) tstr 56 | (lstr, tstr) = unzip . map (break (=='.') . render) . U.toList $ vs 57 | longest = maximum . map length 58 | render k = reverse . dropWhile (=='.') . dropWhile (=='0') . reverse . 59 | showFFloat (Just 4) k $ "" 60 | split [] = [] 61 | split xs = i : split rest where (i, rest) = splitAt c xs 62 | cleanEnd = reverse . dropWhile isSpace . reverse 63 | -------------------------------------------------------------------------------- /statistics/Statistics/Quantile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- | 3 | -- Module : Statistics.Quantile 4 | -- Copyright : (c) 2009 Bryan O'Sullivan 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : bos@serpentine.com 8 | -- Stability : experimental 9 | -- Portability : portable 10 | -- 11 | -- Functions for approximating quantiles, i.e. points taken at regular 12 | -- intervals from the cumulative distribution function of a random 13 | -- variable. 14 | -- 15 | -- The number of quantiles is described below by the variable /q/, so 16 | -- with /q/=4, a 4-quantile (also known as a /quartile/) has 4 17 | -- intervals, and contains 5 points. The parameter /k/ describes the 18 | -- desired point, where 0 ≤ /k/ ≤ /q/. 19 | 20 | module Statistics.Quantile 21 | ( 22 | -- * Quantile estimation functions 23 | weightedAvg 24 | , Sorted(..) 25 | -- * References 26 | -- $references 27 | ) where 28 | 29 | import Data.Vector.Generic ((!)) 30 | import qualified Data.Vector as V 31 | import qualified Data.Vector.Generic as G 32 | import qualified Data.Vector.Unboxed as U 33 | 34 | newtype Sorted x = Sorted x 35 | 36 | -- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample, 37 | -- using the weighted average method. 38 | -- 39 | -- The following properties should hold: 40 | -- * the length of the input is greater than @0@ 41 | -- * the input does not contain @NaN@ 42 | -- * k ≥ 0 and k ≤ q 43 | -- 44 | -- otherwise an error will be thrown. 45 | weightedAvg :: G.Vector v Double => 46 | Int -- ^ /k/, the desired quantile. 47 | -> Int -- ^ /q/, the number of quantiles. 48 | -> Sorted (v Double) -- ^ /x/, the sample data. 49 | -> Double 50 | weightedAvg k q (Sorted x) 51 | | G.any isNaN x = modErr "weightedAvg" "Sample contains NaNs" 52 | | n == 0 = modErr "weightedAvg" "Sample is empty" 53 | | n == 1 = G.head x 54 | | q < 2 = modErr "weightedAvg" "At least 2 quantiles is needed" 55 | | k == q = G.maximum x 56 | | k >= 0 || k < q = xj + g * (xj1 - xj) 57 | | otherwise = modErr "weightedAvg" "Wrong quantile number" 58 | where 59 | j = floor idx 60 | idx = fromIntegral (n - 1) * fromIntegral k / fromIntegral q 61 | g = idx - fromIntegral j 62 | xj = x ! j 63 | xj1 = x ! (j+1) 64 | n = G.length x 65 | {-# SPECIALIZE weightedAvg :: Int -> Int -> Sorted (U.Vector Double) -> Double #-} 66 | {-# SPECIALIZE weightedAvg :: Int -> Int -> Sorted (V.Vector Double) -> Double #-} 67 | 68 | modErr :: String -> String -> a 69 | modErr f err = error $ "Statistics.Quantile." ++ f ++ ": " ++ err 70 | 71 | 72 | 73 | -- $references 74 | -- 75 | -- * Weisstein, E.W. Quantile. /MathWorld/. 76 | -- 77 | -- 78 | -- * Hyndman, R.J.; Fan, Y. (1996) Sample quantiles in statistical 79 | -- packages. /American Statistician/ 80 | -- 50(4):361–365. 81 | -------------------------------------------------------------------------------- /statistics/Statistics/Regression.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Regression 3 | -- Copyright : 2014 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Functions for regression analysis. 7 | 8 | module Statistics.Regression 9 | ( olsRegress 10 | , bootstrapRegress 11 | ) where 12 | 13 | import Control.Applicative 14 | import Control.Concurrent (forkIO) 15 | import Control.Concurrent.Chan (newChan, readChan, writeChan) 16 | import Control.DeepSeq (rnf) 17 | import Control.Monad (forM_, replicateM) 18 | import GHC.Conc (getNumCapabilities) 19 | import Statistics.Function as F 20 | import Statistics.Matrix 21 | import Statistics.Matrix.Algorithms (qr) 22 | import Statistics.Types (Estimate(..),ConfInt,CL,estimateFromInterval,significanceLevel) 23 | import Statistics.Sample (mean) 24 | import Statistics.Sample.Internal (sum) 25 | import System.Random.MWC (GenIO, uniformR, splitGen) 26 | import qualified Data.Vector as V 27 | import qualified Data.Vector.Generic as G 28 | import qualified Data.Vector.Unboxed as U 29 | import qualified Data.Vector.Unboxed.Mutable as M 30 | import Prelude hiding (pred, sum) 31 | 32 | -- | Perform an ordinary least-squares regression on a set of 33 | -- predictors, and calculate the goodness-of-fit of the regression. 34 | -- 35 | -- The returned pair consists of: 36 | -- 37 | -- * A vector of regression coefficients. This vector has /one more/ 38 | -- element than the list of predictors; the last element is the 39 | -- /y/-intercept value. 40 | -- 41 | -- * /R²/, the coefficient of determination (see 'rSquare' for 42 | -- details). 43 | olsRegress :: [Vector] 44 | -- ^ Non-empty list of predictor vectors. Must all have 45 | -- the same length. These will become the columns of 46 | -- the matrix /A/ solved by 'ols'. 47 | -> Vector 48 | -- ^ Responder vector. Must have the same length as the 49 | -- predictor vectors. 50 | -> (Vector, Double) 51 | olsRegress preds@(_:_) resps 52 | | any (/=n) ls = error $ "predictor vector length mismatch " ++ 53 | show lss 54 | | G.length resps /= n = error $ "responder/predictor length mismatch " ++ 55 | show (G.length resps, n) 56 | | otherwise = (coeffs, rSquare mxpreds resps coeffs) 57 | where 58 | coeffs = ols mxpreds resps 59 | mxpreds = transpose . 60 | fromVector (length lss + 1) n . 61 | G.concat $ preds ++ [G.replicate n 1] 62 | lss@(n:ls) = map G.length preds 63 | olsRegress _ _ = error "no predictors given" 64 | 65 | -- | Compute the ordinary least-squares solution to /A x = b/. 66 | ols :: Matrix -- ^ /A/ has at least as many rows as columns. 67 | -> Vector -- ^ /b/ has the same length as columns in /A/. 68 | -> Vector 69 | ols a b 70 | | rs < cs = error $ "fewer rows than columns " ++ show d 71 | | otherwise = solve r (transpose q `multiplyV` b) 72 | where 73 | d@(rs,cs) = dimension a 74 | (q,r) = qr a 75 | 76 | -- | Solve the equation /R x = b/. 77 | solve :: Matrix -- ^ /R/ is an upper-triangular square matrix. 78 | -> Vector -- ^ /b/ is of the same length as rows\/columns in /R/. 79 | -> Vector 80 | solve r b 81 | | n /= l = error $ "row/vector mismatch " ++ show (n,l) 82 | | otherwise = U.create $ do 83 | s <- U.thaw b 84 | rfor n 0 $ \i -> do 85 | si <- (/ unsafeIndex r i i) <$> M.unsafeRead s i 86 | M.unsafeWrite s i si 87 | for 0 i $ \j -> F.unsafeModify s j $ subtract (unsafeIndex r j i * si) 88 | return s 89 | where n = rows r 90 | l = U.length b 91 | 92 | -- | Compute /R²/, the coefficient of determination that 93 | -- indicates goodness-of-fit of a regression. 94 | -- 95 | -- This value will be 1 if the predictors fit perfectly, dropping to 0 96 | -- if they have no explanatory power. 97 | rSquare :: Matrix -- ^ Predictors (regressors). 98 | -> Vector -- ^ Responders. 99 | -> Vector -- ^ Regression coefficients. 100 | -> Double 101 | rSquare pred resp coeff = 1 - r / t 102 | where 103 | r = sum $ flip U.imap resp $ \i x -> square (x - p i) 104 | t = sum $ flip U.map resp $ \x -> square (x - mean resp) 105 | p i = sum . flip U.imap coeff $ \j -> (* unsafeIndex pred i j) 106 | 107 | -- | Bootstrap a regression function. Returns both the results of the 108 | -- regression and the requested confidence interval values. 109 | bootstrapRegress 110 | :: GenIO 111 | -> Int -- ^ Number of resamples to compute. 112 | -> CL Double -- ^ Confidence level. 113 | -> ([Vector] -> Vector -> (Vector, Double)) 114 | -- ^ Regression function. 115 | -> [Vector] -- ^ Predictor vectors. 116 | -> Vector -- ^ Responder vector. 117 | -> IO (V.Vector (Estimate ConfInt Double), Estimate ConfInt Double) 118 | bootstrapRegress gen0 numResamples cl rgrss preds0 resp0 119 | | numResamples < 1 = error $ "bootstrapRegress: number of resamples " ++ 120 | "must be positive" 121 | | otherwise = do 122 | caps <- getNumCapabilities 123 | gens <- splitGen caps gen0 124 | done <- newChan 125 | forM_ (zip gens (balance caps numResamples)) $ \(gen,count) -> forkIO $ do 126 | v <- V.replicateM count $ do 127 | let n = U.length resp0 128 | ixs <- U.replicateM n $ uniformR (0,n-1) gen 129 | let resp = U.backpermute resp0 ixs 130 | preds = map (flip U.backpermute ixs) preds0 131 | return $ rgrss preds resp 132 | rnf v `seq` writeChan done v 133 | (coeffsv, r2v) <- (G.unzip . V.concat) <$> replicateM caps (readChan done) 134 | let coeffs = flip G.imap (G.convert coeffss) $ \i x -> 135 | est x . U.generate numResamples $ \k -> (coeffsv G.! k) G.! i 136 | r2 = est r2s (G.convert r2v) 137 | (coeffss, r2s) = rgrss preds0 resp0 138 | est s v = estimateFromInterval s (w G.! lo, w G.! hi) cl 139 | where w = F.sort v 140 | bounded i = min (U.length w - 1) (max 0 i) 141 | lo = bounded $ round c 142 | hi = bounded $ truncate (n - c) 143 | n = fromIntegral numResamples 144 | c = n * (significanceLevel cl / 2) 145 | return (coeffs, r2) 146 | 147 | -- | Balance units of work across workers. 148 | balance :: Int -> Int -> [Int] 149 | balance numSlices numItems = zipWith (+) (replicate numSlices q) 150 | (replicate r 1 ++ repeat 0) 151 | where (q,r) = numItems `quotRem` numSlices 152 | -------------------------------------------------------------------------------- /statistics/Statistics/Resampling.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | -- | 9 | -- Module : Statistics.Resampling 10 | -- Copyright : (c) 2009, 2010 Bryan O'Sullivan 11 | -- License : BSD3 12 | -- 13 | -- Maintainer : bos@serpentine.com 14 | -- Stability : experimental 15 | -- Portability : portable 16 | -- 17 | -- Resampling statistics. 18 | 19 | module Statistics.Resampling 20 | ( 21 | -- * Data types 22 | Bootstrap(..) 23 | , Estimator(..) 24 | , resample 25 | -- * Jackknife 26 | , jackknife 27 | ) where 28 | 29 | import Control.Concurrent (forkIO, newChan, readChan, writeChan) 30 | import Control.Monad 31 | import Data.Data (Data, Typeable) 32 | import Data.Vector.Generic (unsafeFreeze) 33 | import qualified Data.Foldable as T 34 | import qualified Data.Traversable as T 35 | import qualified Data.Vector.Generic as G 36 | import qualified Data.Vector.Unboxed as U 37 | import qualified Data.Vector.Unboxed.Mutable as MU 38 | 39 | import GHC.Conc (numCapabilities) 40 | import GHC.Generics (Generic) 41 | import Numeric.Sum (Summation(..), kbn) 42 | import Statistics.Function (indices, inplaceSortIO) 43 | import Statistics.Sample (mean, stdDev, variance, varianceUnbiased) 44 | import Statistics.Types (Sample) 45 | import System.Random.MWC (Gen, GenIO, uniformR, splitGen) 46 | 47 | 48 | ---------------------------------------------------------------- 49 | -- Data types 50 | ---------------------------------------------------------------- 51 | 52 | data Bootstrap v a = Bootstrap 53 | { fullSample :: !a 54 | , resamples :: v a 55 | } 56 | deriving (Eq, Read, Show , Generic, Functor, T.Foldable, T.Traversable 57 | #if __GLASGOW_HASKELL__ >= 708 58 | , Typeable, Data 59 | #endif 60 | ) 61 | 62 | -- | An estimator of a property of a sample, such as its 'mean'. 63 | -- 64 | -- The use of an algebraic data type here allows functions such as 65 | -- 'jackknife' and 'bootstrapBCA' to use more efficient algorithms 66 | -- when possible. 67 | data Estimator = Mean 68 | | Variance 69 | | VarianceUnbiased 70 | | StdDev 71 | | Function (Sample -> Double) 72 | 73 | -- | Run an 'Estimator' over a sample. 74 | estimate :: Estimator -> Sample -> Double 75 | estimate Mean = mean 76 | estimate Variance = variance 77 | estimate VarianceUnbiased = varianceUnbiased 78 | estimate StdDev = stdDev 79 | estimate (Function est) = est 80 | 81 | 82 | ---------------------------------------------------------------- 83 | -- Resampling 84 | ---------------------------------------------------------------- 85 | 86 | -- | /O(e*r*s)/ Resample a data set repeatedly, with replacement, 87 | -- computing each estimate over the resampled data. 88 | -- 89 | -- This function is expensive; it has to do work proportional to 90 | -- /e*r*s/, where /e/ is the number of estimation functions, /r/ is 91 | -- the number of resamples to compute, and /s/ is the number of 92 | -- original samples. 93 | -- 94 | -- To improve performance, this function will make use of all 95 | -- available CPUs. At least with GHC 7.0, parallel performance seems 96 | -- best if the parallel garbage collector is disabled (RTS option 97 | -- @-qg@). 98 | resample :: GenIO 99 | -> [Estimator] -- ^ Estimation functions. 100 | -> Int -- ^ Number of resamples to compute. 101 | -> U.Vector Double -- ^ Original sample. 102 | -> IO [(Estimator, Bootstrap U.Vector Double)] 103 | resample gen ests numResamples samples = do 104 | let ixs = scanl (+) 0 $ 105 | zipWith (+) (replicate numCapabilities q) 106 | (replicate r 1 ++ repeat 0) 107 | where (q,r) = numResamples `quotRem` numCapabilities 108 | results <- mapM (const (MU.new numResamples)) ests 109 | done <- newChan 110 | gens <- splitGen numCapabilities gen 111 | forM_ (zip3 ixs (tail ixs) gens) $ \ (start,!end,gen') -> 112 | forkIO $ do 113 | let loop k ers | k >= end = writeChan done () 114 | | otherwise = do 115 | re <- resampleVector gen' samples 116 | forM_ ers $ \(est,arr) -> 117 | MU.write arr k . est $ re 118 | loop (k+1) ers 119 | loop start (zip ests' results) 120 | replicateM_ numCapabilities $ readChan done 121 | mapM_ inplaceSortIO results 122 | -- Build resamples 123 | res <- mapM unsafeFreeze results 124 | return $ zip ests 125 | $ zipWith Bootstrap [estimate e samples | e <- ests] 126 | res 127 | where 128 | ests' = map estimate ests 129 | 130 | -- | Create vector using resamples 131 | resampleVector :: G.Vector v a => Gen -> v a -> IO (v a) 132 | resampleVector gen v 133 | = G.replicateM n $ do i <- uniformR (0,n-1) gen 134 | return $! G.unsafeIndex v i 135 | where 136 | n = G.length v 137 | 138 | ---------------------------------------------------------------- 139 | -- Jackknife 140 | ---------------------------------------------------------------- 141 | 142 | -- | /O(n) or O(n^2)/ Compute a statistical estimate repeatedly over a 143 | -- sample, each time omitting a successive element. 144 | jackknife :: Estimator -> Sample -> U.Vector Double 145 | jackknife Mean sample = jackknifeMean sample 146 | jackknife Variance sample = jackknifeVariance sample 147 | jackknife VarianceUnbiased sample = jackknifeVarianceUnb sample 148 | jackknife StdDev sample = jackknifeStdDev sample 149 | jackknife (Function est) sample 150 | | G.length sample == 1 = singletonErr "jackknife" 151 | | otherwise = U.map f . indices $ sample 152 | where f i = est (dropAt i sample) 153 | 154 | -- | /O(n)/ Compute the jackknife mean of a sample. 155 | jackknifeMean :: Sample -> U.Vector Double 156 | jackknifeMean samp 157 | | len == 1 = singletonErr "jackknifeMean" 158 | | otherwise = G.map (/l) $ G.zipWith (+) (pfxSumL samp) (pfxSumR samp) 159 | where 160 | l = fromIntegral (len - 1) 161 | len = G.length samp 162 | 163 | -- | /O(n)/ Compute the jackknife variance of a sample with a 164 | -- correction factor @c@, so we can get either the regular or 165 | -- \"unbiased\" variance. 166 | jackknifeVariance_ :: Double -> Sample -> U.Vector Double 167 | jackknifeVariance_ c samp 168 | | len == 1 = singletonErr "jackknifeVariance" 169 | | otherwise = G.zipWith4 go als ars bls brs 170 | where 171 | als = pfxSumL . G.map goa $ samp 172 | ars = pfxSumR . G.map goa $ samp 173 | goa x = v * v where v = x - m 174 | bls = pfxSumL . G.map (subtract m) $ samp 175 | brs = pfxSumR . G.map (subtract m) $ samp 176 | m = mean samp 177 | n = fromIntegral len 178 | go al ar bl br = (al + ar - (b * b) / q) / (q - c) 179 | where b = bl + br 180 | q = n - 1 181 | len = G.length samp 182 | 183 | -- | /O(n)/ Compute the unbiased jackknife variance of a sample. 184 | jackknifeVarianceUnb :: Sample -> U.Vector Double 185 | jackknifeVarianceUnb = jackknifeVariance_ 1 186 | 187 | -- | /O(n)/ Compute the jackknife variance of a sample. 188 | jackknifeVariance :: Sample -> U.Vector Double 189 | jackknifeVariance = jackknifeVariance_ 0 190 | 191 | -- | /O(n)/ Compute the jackknife standard deviation of a sample. 192 | jackknifeStdDev :: Sample -> U.Vector Double 193 | jackknifeStdDev = G.map sqrt . jackknifeVarianceUnb 194 | 195 | pfxSumL :: U.Vector Double -> U.Vector Double 196 | pfxSumL = G.map kbn . G.scanl add zero 197 | 198 | pfxSumR :: U.Vector Double -> U.Vector Double 199 | pfxSumR = G.tail . G.map kbn . G.scanr (flip add) zero 200 | 201 | -- | Drop the /k/th element of a vector. 202 | dropAt :: U.Unbox e => Int -> U.Vector e -> U.Vector e 203 | dropAt n v = U.slice 0 n v U.++ U.slice (n+1) (U.length v - n - 1) v 204 | 205 | singletonErr :: String -> a 206 | singletonErr func = error $ 207 | "Statistics.Resampling." ++ func ++ ": singleton input" 208 | -------------------------------------------------------------------------------- /statistics/Statistics/Resampling/Bootstrap.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Resampling.Bootstrap 3 | -- Copyright : (c) 2009, 2011 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bos@serpentine.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- The bootstrap method for statistical inference. 11 | 12 | module Statistics.Resampling.Bootstrap 13 | ( bootstrapBCA 14 | -- * References 15 | -- $references 16 | ) where 17 | 18 | import Data.Vector.Generic ((!)) 19 | import qualified Data.Vector.Unboxed as U 20 | 21 | import Statistics.Distribution (cumulative, quantile) 22 | import Statistics.Distribution.Normal 23 | import Statistics.Resampling (Bootstrap(..), jackknife) 24 | import Statistics.Sample (mean) 25 | import Statistics.Types (Sample, CL, Estimate, ConfInt, estimateFromInterval, 26 | estimateFromErr, CL, significanceLevel) 27 | import qualified Statistics.Resampling as R 28 | 29 | 30 | data T = {-# UNPACK #-} !Double :< {-# UNPACK #-} !Double 31 | infixl 2 :< 32 | 33 | -- | Bias-corrected accelerated (BCA) bootstrap. This adjusts for both 34 | -- bias and skewness in the resampled distribution. 35 | -- 36 | -- BCA algorithm is described in ch. 5 of Davison, Hinkley "Confidence 37 | -- intervals" in section 5.3 "Percentile method" 38 | bootstrapBCA 39 | :: CL Double -- ^ Confidence level 40 | -> Sample -- ^ Full data sample 41 | -> [(R.Estimator, Bootstrap U.Vector Double)] 42 | -- ^ Estimates obtained from resampled data and estimator used for 43 | -- this. 44 | -> [Estimate ConfInt Double] 45 | bootstrapBCA confidenceLevel sample resampledData 46 | = map e resampledData 47 | where 48 | e (est, Bootstrap pt resample) 49 | | U.length sample == 1 || isInfinite bias = 50 | estimateFromErr pt (0,0) confidenceLevel 51 | | otherwise = 52 | estimateFromInterval pt (resample ! lo, resample ! hi) confidenceLevel 53 | where 54 | -- Quantile estimates for given CL 55 | lo = min (max (cumn a1) 0) (ni - 1) 56 | where a1 = bias + b1 / (1 - accel * b1) 57 | b1 = bias + z1 58 | hi = max (min (cumn a2) (ni - 1)) 0 59 | where a2 = bias + b2 / (1 - accel * b2) 60 | b2 = bias - z1 61 | -- Number of resamples 62 | ni = U.length resample 63 | n = fromIntegral ni 64 | -- Corrections 65 | z1 = quantile standard (significanceLevel confidenceLevel / 2) 66 | cumn = round . (*n) . cumulative standard 67 | bias = quantile standard (probN / n) 68 | where probN = fromIntegral . U.length . U.filter ( 81 | -------------------------------------------------------------------------------- /statistics/Statistics/Sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- | 3 | -- Module : Statistics.Sample 4 | -- Copyright : (c) 2008 Don Stewart, 2009 Bryan O'Sullivan 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : bos@serpentine.com 8 | -- Stability : experimental 9 | -- Portability : portable 10 | -- 11 | -- Commonly used sample statistics, also known as descriptive 12 | -- statistics. 13 | 14 | module Statistics.Sample 15 | ( 16 | -- * Statistics of location 17 | mean 18 | 19 | -- ** Two-pass functions (numerically robust) 20 | -- $robust 21 | , variance 22 | , varianceUnbiased 23 | , stdDev 24 | 25 | -- * References 26 | -- $references 27 | ) where 28 | 29 | import Statistics.Sample.Internal (robustSumVar, sum) 30 | import qualified Data.Vector as V 31 | import qualified Data.Vector.Generic as G 32 | import qualified Data.Vector.Unboxed as U 33 | 34 | -- Operator ^ will be overriden 35 | import Prelude hiding ((^), sum) 36 | 37 | -- | /O(n)/ Arithmetic mean. This uses Kahan-Babuška-Neumaier 38 | -- summation, so is more accurate than 'welfordMean' unless the input 39 | -- values are very large. 40 | mean :: (G.Vector v Double) => v Double -> Double 41 | mean xs = sum xs / fromIntegral (G.length xs) 42 | {-# SPECIALIZE mean :: U.Vector Double -> Double #-} 43 | {-# SPECIALIZE mean :: V.Vector Double -> Double #-} 44 | 45 | -- $variance 46 | -- 47 | -- The variance—and hence the standard deviation—of a 48 | -- sample of fewer than two elements are both defined to be zero. 49 | 50 | -- $robust 51 | -- 52 | -- These functions use the compensated summation algorithm of Chan et 53 | -- al. for numerical robustness, but require two passes over the 54 | -- sample data as a result. 55 | -- 56 | -- Because of the need for two passes, these functions are /not/ 57 | -- subject to stream fusion. 58 | 59 | -- | Maximum likelihood estimate of a sample's variance. Also known 60 | -- as the population variance, where the denominator is /n/. 61 | variance :: (G.Vector v Double) => v Double -> Double 62 | variance samp 63 | | n > 1 = robustSumVar (mean samp) samp / fromIntegral n 64 | | otherwise = 0 65 | where 66 | n = G.length samp 67 | {-# SPECIALIZE variance :: U.Vector Double -> Double #-} 68 | {-# SPECIALIZE variance :: V.Vector Double -> Double #-} 69 | 70 | 71 | -- | Unbiased estimate of a sample's variance. Also known as the 72 | -- sample variance, where the denominator is /n/-1. 73 | varianceUnbiased :: (G.Vector v Double) => v Double -> Double 74 | varianceUnbiased samp 75 | | n > 1 = robustSumVar (mean samp) samp / fromIntegral (n-1) 76 | | otherwise = 0 77 | where 78 | n = G.length samp 79 | {-# SPECIALIZE varianceUnbiased :: U.Vector Double -> Double #-} 80 | {-# SPECIALIZE varianceUnbiased :: V.Vector Double -> Double #-} 81 | 82 | -- | Standard deviation. This is simply the square root of the 83 | -- unbiased estimate of the variance. 84 | stdDev :: (G.Vector v Double) => v Double -> Double 85 | stdDev = sqrt . varianceUnbiased 86 | {-# SPECIALIZE stdDev :: U.Vector Double -> Double #-} 87 | {-# SPECIALIZE stdDev :: V.Vector Double -> Double #-} 88 | 89 | -- $cancellation 90 | -- 91 | -- The functions prefixed with the name @fast@ below perform a single 92 | -- pass over the sample data using Knuth's algorithm. They usually 93 | -- work well, but see below for caveats. These functions are subject 94 | -- to array fusion. 95 | -- 96 | -- /Note/: in cases where most sample data is close to the sample's 97 | -- mean, Knuth's algorithm gives inaccurate results due to 98 | -- catastrophic cancellation. 99 | 100 | -- $references 101 | -- 102 | -- * Chan, T. F.; Golub, G.H.; LeVeque, R.J. (1979) Updating formulae 103 | -- and a pairwise algorithm for computing sample 104 | -- variances. Technical Report STAN-CS-79-773, Department of 105 | -- Computer Science, Stanford 106 | -- University. 107 | -- 108 | -- * Knuth, D.E. (1998) The art of computer programming, volume 2: 109 | -- seminumerical algorithms, 3rd ed., p. 232. 110 | -- 111 | -- * Welford, B.P. (1962) Note on a method for calculating corrected 112 | -- sums of squares and products. /Technometrics/ 113 | -- 4(3):419–420. 114 | -- 115 | -- * West, D.H.D. (1979) Updating mean and variance estimates: an 116 | -- improved method. /Communications of the ACM/ 117 | -- 22(9):532–535. 118 | -------------------------------------------------------------------------------- /statistics/Statistics/Sample/Histogram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, BangPatterns #-} 2 | 3 | -- | 4 | -- Module : Statistics.Sample.Histogram 5 | -- Copyright : (c) 2011 Bryan O'Sullivan 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : bos@serpentine.com 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- Functions for computing histograms of sample data. 13 | 14 | module Statistics.Sample.Histogram 15 | ( 16 | -- * Building blocks 17 | histogram_ 18 | ) where 19 | 20 | import Numeric.MathFunctions.Constants (m_epsilon) 21 | import qualified Data.Vector.Generic as G 22 | import qualified Data.Vector.Generic.Mutable as GM 23 | 24 | -- | /O(n)/ Compute a histogram over a data set. 25 | -- 26 | -- Interval (bin) sizes are uniform, based on the supplied upper 27 | -- and lower bounds. 28 | histogram_ :: (Num b, RealFrac a, G.Vector v0 a, G.Vector v1 b) => 29 | Int 30 | -- ^ Number of bins. This value must be positive. A zero 31 | -- or negative value will cause an error. 32 | -> a 33 | -- ^ Lower bound on interval range. Sample data less than 34 | -- this will cause an error. 35 | -> a 36 | -- ^ Upper bound on interval range. This value must not be 37 | -- less than the lower bound. Sample data that falls above 38 | -- the upper bound will cause an error. 39 | -> v0 a 40 | -- ^ Sample data. 41 | -> v1 b 42 | histogram_ numBins lo hi xs0 = G.create (GM.replicate numBins 0 >>= bin xs0) 43 | where 44 | bin xs bins = go 0 45 | where 46 | go i | i >= len = return bins 47 | | otherwise = do 48 | let x = xs `G.unsafeIndex` i 49 | b = truncate $ (x - lo) / d 50 | write' bins b . (+1) =<< GM.read bins b 51 | go (i+1) 52 | write' bs b !e = GM.write bs b e 53 | len = G.length xs 54 | d = ((hi - lo) * (1 + realToFrac m_epsilon)) / fromIntegral numBins 55 | {-# INLINE histogram_ #-} 56 | 57 | -------------------------------------------------------------------------------- /statistics/Statistics/Sample/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | 4 | -- Module : Statistics.Sample.Internal 5 | -- Copyright : (c) 2013 Bryan O'Sullivan 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : bos@serpentine.com 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- Internal functions for computing over samples. 13 | module Statistics.Sample.Internal 14 | ( robustSumVar 15 | , sum 16 | ) where 17 | 18 | import Numeric.Sum (kbn, sumVector) 19 | import Prelude hiding (sum) 20 | import Statistics.Function (square) 21 | import qualified Data.Vector.Generic as G 22 | 23 | robustSumVar :: (G.Vector v Double) => Double -> v Double -> Double 24 | robustSumVar m = sum . G.map (square . subtract m) 25 | {-# INLINE robustSumVar #-} 26 | 27 | sum :: (G.Vector v Double) => v Double -> Double 28 | sum = sumVector kbn 29 | {-# INLINE sum #-} 30 | -------------------------------------------------------------------------------- /statistics/Statistics/Sample/KernelDensity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, FlexibleContexts, UnboxedTuples #-} 2 | -- | 3 | -- Module : Statistics.Sample.KernelDensity 4 | -- Copyright : (c) 2011 Bryan O'Sullivan 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : bos@serpentine.com 8 | -- Stability : experimental 9 | -- Portability : portable 10 | -- 11 | -- Kernel density estimation. This module provides a fast, robust, 12 | -- non-parametric way to estimate the probability density function of 13 | -- a sample. 14 | -- 15 | -- This estimator does not use the commonly employed \"Gaussian rule 16 | -- of thumb\". As a result, it outperforms many plug-in methods on 17 | -- multimodal samples with widely separated modes. 18 | 19 | module Statistics.Sample.KernelDensity 20 | ( 21 | -- * Estimation functions 22 | kde 23 | -- , kde_ 24 | -- * References 25 | -- $references 26 | ) where 27 | 28 | import Numeric.MathFunctions.Constants (m_sqrt_2_pi) 29 | import Prelude hiding (const, min, max, sum) 30 | import Statistics.Function (minMax, nextHighestPowerOfTwo) 31 | import Statistics.Math.RootFinding (fromRoot, ridders) 32 | import Statistics.Sample.Histogram (histogram_) 33 | import Statistics.Sample.Internal (sum) 34 | import Statistics.Transform (CD, dct, idct) 35 | import qualified Data.Vector.Generic as G 36 | import qualified Data.Vector.Unboxed as U 37 | import qualified Data.Vector as V 38 | 39 | 40 | -- | Gaussian kernel density estimator for one-dimensional data, using 41 | -- the method of Botev et al. 42 | -- 43 | -- The result is a pair of vectors, containing: 44 | -- 45 | -- * The coordinates of each mesh point. The mesh interval is chosen 46 | -- to be 20% larger than the range of the sample. (To specify the 47 | -- mesh interval, use 'kde_'.) 48 | -- 49 | -- * Density estimates at each mesh point. 50 | kde :: (G.Vector v CD, G.Vector v Double, G.Vector v Int) 51 | => Int 52 | -- ^ The number of mesh points to use in the uniform discretization 53 | -- of the interval @(min,max)@. If this value is not a power of 54 | -- two, then it is rounded up to the next power of two. 55 | -> v Double -> (v Double, v Double) 56 | kde n0 xs = kde_ n0 (lo - range / 10) (hi + range / 10) xs 57 | where 58 | (lo,hi) = minMax xs 59 | range | G.length xs <= 1 = 1 -- Unreasonable guess 60 | | lo == hi = 1 -- All elements are equal 61 | | otherwise = hi - lo 62 | {-# INLINABLE kde #-} 63 | {-# SPECIAlIZE kde :: Int -> U.Vector Double -> (U.Vector Double, U.Vector Double) #-} 64 | {-# SPECIAlIZE kde :: Int -> V.Vector Double -> (V.Vector Double, V.Vector Double) #-} 65 | 66 | 67 | -- | Gaussian kernel density estimator for one-dimensional data, using 68 | -- the method of Botev et al. 69 | -- 70 | -- The result is a pair of vectors, containing: 71 | -- 72 | -- * The coordinates of each mesh point. 73 | -- 74 | -- * Density estimates at each mesh point. 75 | kde_ :: (G.Vector v CD, G.Vector v Double, G.Vector v Int) 76 | => Int 77 | -- ^ The number of mesh points to use in the uniform discretization 78 | -- of the interval @(min,max)@. If this value is not a power of 79 | -- two, then it is rounded up to the next power of two. 80 | -> Double 81 | -- ^ Lower bound (@min@) of the mesh range. 82 | -> Double 83 | -- ^ Upper bound (@max@) of the mesh range. 84 | -> v Double 85 | -> (v Double, v Double) 86 | kde_ n0 min max xs 87 | | G.null xs = error "Statistics.KernelDensity.kde: empty sample" 88 | | n0 <= 1 = error "Statistics.KernelDensity.kde: invalid number of points" 89 | | otherwise = (mesh, density) 90 | where 91 | mesh = G.generate ni $ \z -> min + (d * fromIntegral z) 92 | where d = r / (n-1) 93 | density = G.map (/(2 * r)) . idct $ G.zipWith f a (G.enumFromTo 0 (n-1)) 94 | where f b z = b * exp (sqr z * sqr pi * t_star * (-0.5)) 95 | !n = fromIntegral ni 96 | !ni = nextHighestPowerOfTwo n0 97 | !r = max - min 98 | a = dct . G.map (/ sum h) $ h 99 | where h = G.map (/ len) $ histogram_ ni min max xs 100 | !len = fromIntegral (G.length xs) 101 | !t_star = fromRoot (0.28 * len ** (-0.4)) . ridders 1e-14 (0,0.1) $ \x -> 102 | x - (len * (2 * sqrt pi) * go 6 (f 7 x)) ** (-0.4) 103 | where 104 | f q t = 2 * pi ** (q*2) * sum (G.zipWith g iv a2v) 105 | where g i a2 = i ** q * a2 * exp ((-i) * sqr pi * t) 106 | a2v = G.map (sqr . (*0.5)) $ G.tail a 107 | iv = G.map sqr $ G.enumFromTo 1 (n-1) 108 | go s !h | s == 1 = h 109 | | otherwise = go (s-1) (f s time) 110 | where time = (2 * const * k0 / len / h) ** (2 / (3 + 2 * s)) 111 | const = (1 + 0.5 ** (s+0.5)) / 3 112 | k0 = U.product (G.enumFromThenTo 1 3 (2*s-1)) / m_sqrt_2_pi 113 | sqr x = x * x 114 | {-# INLINABLE kde_ #-} 115 | {-# SPECIAlIZE kde_ :: Int -> Double -> Double -> U.Vector Double -> (U.Vector Double, U.Vector Double) #-} 116 | {-# SPECIAlIZE kde_ :: Int -> Double -> Double -> V.Vector Double -> (V.Vector Double, V.Vector Double) #-} 117 | 118 | 119 | -- $references 120 | -- 121 | -- Botev. Z.I., Grotowski J.F., Kroese D.P. (2010). Kernel density 122 | -- estimation via diffusion. /Annals of Statistics/ 123 | -- 38(5):2916–2957. 124 | -------------------------------------------------------------------------------- /statistics/Statistics/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, FlexibleContexts #-} 2 | -- | 3 | -- Module : Statistics.Transform 4 | -- Copyright : (c) 2011 Bryan O'Sullivan 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : bos@serpentine.com 8 | -- Stability : experimental 9 | -- Portability : portable 10 | -- 11 | -- Fourier-related transformations of mathematical functions. 12 | -- 13 | -- These functions are written for simplicity and correctness, not 14 | -- speed. If you need a fast FFT implementation for your application, 15 | -- you should strongly consider using a library of FFTW bindings 16 | -- instead. 17 | 18 | module Statistics.Transform 19 | ( 20 | -- * Type synonyms 21 | CD 22 | -- * Discrete cosine transform 23 | , dct 24 | , idct 25 | ) where 26 | 27 | import Control.Monad (when) 28 | import Control.Monad.ST (ST) 29 | import Data.Bits (shiftL, shiftR) 30 | import Data.Complex (Complex(..), conjugate, realPart) 31 | import Numeric.SpecFunctions (log2) 32 | import qualified Data.Vector.Generic as G 33 | import qualified Data.Vector.Generic.Mutable as M 34 | import qualified Data.Vector.Unboxed as U 35 | import qualified Data.Vector as V 36 | 37 | type CD = Complex Double 38 | 39 | -- | Discrete cosine transform (DCT-II). 40 | dct :: (G.Vector v CD, G.Vector v Double, G.Vector v Int) => v Double -> v Double 41 | dct = dctWorker . G.map (:+0) 42 | {-# INLINABLE dct #-} 43 | {-# SPECIAlIZE dct :: U.Vector Double -> U.Vector Double #-} 44 | {-# SPECIAlIZE dct :: V.Vector Double -> V.Vector Double #-} 45 | 46 | dctWorker :: (G.Vector v CD, G.Vector v Double, G.Vector v Int) => v CD -> v Double 47 | {-# INLINE dctWorker #-} 48 | dctWorker xs 49 | -- length 1 is special cased because shuffle algorithms fail for it. 50 | | G.length xs == 1 = G.map ((2*) . realPart) xs 51 | | vectorOK xs = G.map realPart $ G.zipWith (*) weights (fft interleaved) 52 | | otherwise = error "Statistics.Transform.dct: bad vector length" 53 | where 54 | interleaved = G.backpermute xs $ G.enumFromThenTo 0 2 (len-2) G.++ 55 | G.enumFromThenTo (len-1) (len-3) 1 56 | weights = G.cons 2 . G.generate (len-1) $ \x -> 57 | 2 * exp ((0:+(-1))*fi (x+1)*pi/(2*n)) 58 | where n = fi len 59 | len = G.length xs 60 | 61 | 62 | 63 | -- | Inverse discrete cosine transform (DCT-III). It's inverse of 64 | -- 'dct' only up to scale parameter: 65 | -- 66 | -- > (idct . dct) x = (* length x) 67 | idct :: (G.Vector v CD, G.Vector v Double) => v Double -> v Double 68 | idct = idctWorker . G.map (:+0) 69 | {-# INLINABLE idct #-} 70 | {-# SPECIAlIZE idct :: U.Vector Double -> U.Vector Double #-} 71 | {-# SPECIAlIZE idct :: V.Vector Double -> V.Vector Double #-} 72 | 73 | idctWorker :: (G.Vector v CD, G.Vector v Double) => v CD -> v Double 74 | {-# INLINE idctWorker #-} 75 | idctWorker xs 76 | | vectorOK xs = G.generate len interleave 77 | | otherwise = error "Statistics.Transform.dct: bad vector length" 78 | where 79 | interleave z | even z = vals `G.unsafeIndex` halve z 80 | | otherwise = vals `G.unsafeIndex` (len - halve z - 1) 81 | vals = G.map realPart . ifft $ G.zipWith (*) weights xs 82 | weights 83 | = G.cons n 84 | $ G.generate (len - 1) $ \x -> 2 * n * exp ((0:+1) * fi (x+1) * pi/(2*n)) 85 | where n = fi len 86 | len = G.length xs 87 | 88 | 89 | 90 | -- | Inverse fast Fourier transform. 91 | ifft :: G.Vector v CD => v CD -> v CD 92 | ifft xs 93 | | vectorOK xs = G.map ((/fi (G.length xs)) . conjugate) . fft . G.map conjugate $ xs 94 | | otherwise = error "Statistics.Transform.ifft: bad vector length" 95 | {-# INLINABLE ifft #-} 96 | {-# SPECIAlIZE ifft :: U.Vector CD -> U.Vector CD #-} 97 | {-# SPECIAlIZE ifft :: V.Vector CD -> V.Vector CD #-} 98 | 99 | -- | Radix-2 decimation-in-time fast Fourier transform. 100 | fft :: G.Vector v CD => v CD -> v CD 101 | fft v | vectorOK v = G.create $ do mv <- G.thaw v 102 | mfft mv 103 | return mv 104 | | otherwise = error "Statistics.Transform.fft: bad vector length" 105 | {-# INLINABLE fft #-} 106 | {-# SPECIAlIZE fft :: U.Vector CD -> U.Vector CD #-} 107 | {-# SPECIAlIZE fft :: V.Vector CD -> V.Vector CD #-} 108 | 109 | -- Vector length must be power of two. It's not checked 110 | mfft :: (M.MVector v CD) => v s CD -> ST s () 111 | {-# INLINE mfft #-} 112 | mfft vec = bitReverse 0 0 113 | where 114 | bitReverse i j | i == len-1 = stage 0 1 115 | | otherwise = do 116 | when (i < j) $ M.swap vec i j 117 | let inner k l | k <= l = inner (k `shiftR` 1) (l-k) 118 | | otherwise = bitReverse (i+1) (l+k) 119 | inner (len `shiftR` 1) j 120 | stage l !l1 | l == m = return () 121 | | otherwise = do 122 | let !l2 = l1 `shiftL` 1 123 | !e = -6.283185307179586/fromIntegral l2 124 | flight j !a | j == l1 = stage (l+1) l2 125 | | otherwise = do 126 | let butterfly i | i >= len = flight (j+1) (a+e) 127 | | otherwise = do 128 | let i1 = i + l1 129 | xi1 :+ yi1 <- M.read vec i1 130 | let !c = cos a 131 | !s = sin a 132 | d = (c*xi1 - s*yi1) :+ (s*xi1 + c*yi1) 133 | ci <- M.read vec i 134 | M.write vec i1 (ci - d) 135 | M.write vec i (ci + d) 136 | butterfly (i+l2) 137 | butterfly j 138 | flight 0 0 139 | len = M.length vec 140 | m = log2 len 141 | 142 | 143 | ---------------------------------------------------------------- 144 | -- Helpers 145 | ---------------------------------------------------------------- 146 | 147 | fi :: Int -> CD 148 | fi = fromIntegral 149 | 150 | halve :: Int -> Int 151 | halve = (`shiftR` 1) 152 | 153 | vectorOK :: G.Vector v a => v a -> Bool 154 | {-# INLINE vectorOK #-} 155 | vectorOK v = (1 `shiftL` log2 n) == n where n = G.length v 156 | -------------------------------------------------------------------------------- /statistics/Statistics/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 7 | -- | 8 | -- Module : Statistics.Types 9 | -- Copyright : (c) 2009 Bryan O'Sullivan 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : bos@serpentine.com 13 | -- Stability : experimental 14 | -- Portability : portable 15 | -- 16 | -- Data types common used in statistics 17 | module Statistics.Types 18 | ( 19 | -- * Confidence level 20 | CL 21 | -- ** Accessors 22 | , confidenceLevel 23 | , significanceLevel 24 | -- ** Constructors 25 | , mkCL 26 | -- ** Constants and conversion to nσ 27 | , cl95 28 | -- * Estimates and upper/lower limits 29 | , Estimate(..) 30 | -- , NormalErr(..) 31 | , ConfInt(..) 32 | -- ** Constructors 33 | -- , estimateNormErr 34 | , estimateFromInterval 35 | , estimateFromErr 36 | -- ** Accessors 37 | , confidenceInterval 38 | , Scale(..) 39 | -- * Other 40 | , Sample 41 | ) where 42 | 43 | import Control.DeepSeq (NFData(..)) 44 | import Data.Data (Data,Typeable) 45 | import Data.Maybe (fromMaybe) 46 | import GHC.Generics (Generic) 47 | 48 | #if __GLASGOW_HASKELL__ == 704 49 | import qualified Data.Vector.Generic 50 | import qualified Data.Vector.Generic.Mutable 51 | #endif 52 | 53 | import Statistics.Internal 54 | import Statistics.Types.Internal 55 | 56 | 57 | ---------------------------------------------------------------- 58 | -- Data type for confidence level 59 | ---------------------------------------------------------------- 60 | 61 | -- | 62 | -- Confidence level. In context of confidence intervals it's 63 | -- probability of said interval covering true value of measured 64 | -- value. In context of statistical tests it's @1-α@ where α is 65 | -- significance of test. 66 | -- 67 | -- Since confidence level are usually close to 1 they are stored as 68 | -- @1-CL@ internally. There are two smart constructors for @CL@: 69 | -- 'mkCL' and 'mkCLFromSignificance' (and corresponding variant 70 | -- returning @Maybe@). First creates @CL@ from confidence level and 71 | -- second from @1 - CL@ or significance level. 72 | -- 73 | -- >>> cl95 74 | -- mkCLFromSignificance 0.05 75 | -- 76 | -- Prior to 0.14 confidence levels were passed to function as plain 77 | -- @Doubles@. Use 'mkCL' to convert them to @CL@. 78 | newtype CL a = CL a 79 | deriving (Eq, Typeable, Data, Generic) 80 | 81 | instance Show a => Show (CL a) where 82 | showsPrec n (CL p) = defaultShow1 "mkCLFromSignificance" p n 83 | instance (Num a, Ord a, Read a) => Read (CL a) where 84 | readPrec = defaultReadPrecM1 "mkCLFromSignificance" mkCLFromSignificanceE 85 | 86 | instance NFData a => NFData (CL a) where 87 | rnf (CL a) = rnf a 88 | 89 | -- | 90 | -- >>> cl95 > cl90 91 | -- True 92 | instance Ord a => Ord (CL a) where 93 | CL a < CL b = a > b 94 | CL a <= CL b = a >= b 95 | CL a > CL b = a < b 96 | CL a >= CL b = a <= b 97 | max (CL a) (CL b) = CL (min a b) 98 | min (CL a) (CL b) = CL (max a b) 99 | 100 | 101 | -- | Create confidence level from probability β or probability 102 | -- confidence interval contain true value of estimate. Will throw 103 | -- exception if parameter is out of [0,1] range 104 | -- 105 | -- >>> mkCL 0.95 -- same as cl95 106 | -- mkCLFromSignificance 0.05 107 | mkCL :: (Ord a, Num a) => a -> CL a 108 | mkCL 109 | = fromMaybe (error "Statistics.Types.mkCL: probability is out if [0,1] range") 110 | . mkCLE 111 | 112 | -- | Same as 'mkCL' but returns @Nothing@ instead of error if 113 | -- parameter is out of [0,1] range 114 | -- 115 | -- >>> mkCLE 0.95 -- same as cl95 116 | -- Just (mkCLFromSignificance 0.05) 117 | mkCLE :: (Ord a, Num a) => a -> Maybe (CL a) 118 | mkCLE p 119 | | p >= 0 && p <= 1 = Just $ CL (1 - p) 120 | | otherwise = Nothing 121 | 122 | -- | Same as 'mkCLFromSignificance' but returns @Nothing@ instead of error if 123 | -- parameter is out of [0,1] range 124 | -- 125 | -- >>> mkCLFromSignificanceE 0.05 -- same as cl95 126 | -- Just (mkCLFromSignificance 0.05) 127 | mkCLFromSignificanceE :: (Ord a, Num a) => a -> Maybe (CL a) 128 | mkCLFromSignificanceE p 129 | | p >= 0 && p <= 1 = Just $ CL p 130 | | otherwise = Nothing 131 | 132 | -- | Get confidence level. This function is subject to rounding 133 | -- errors. If @1 - CL@ is needed use 'significanceLevel' instead 134 | confidenceLevel :: (Num a) => CL a -> a 135 | confidenceLevel (CL p) = 1 - p 136 | 137 | -- | Get significance level. 138 | significanceLevel :: CL a -> a 139 | significanceLevel (CL p) = p 140 | 141 | 142 | 143 | -- | 95% confidence level 144 | cl95 :: Fractional a => CL a 145 | cl95 = CL 0.05 146 | 147 | ---------------------------------------------------------------- 148 | -- Data type for p-value 149 | ---------------------------------------------------------------- 150 | 151 | -- | Newtype wrapper for p-value. 152 | newtype PValue a = PValue a 153 | deriving (Eq, Ord, Typeable, Data, Generic) 154 | 155 | instance Show a => Show (PValue a) where 156 | showsPrec n (PValue p) = defaultShow1 "mkPValue" p n 157 | instance (Num a, Ord a, Read a) => Read (PValue a) where 158 | readPrec = defaultReadPrecM1 "mkPValue" mkPValueE 159 | 160 | instance NFData a => NFData (PValue a) where 161 | rnf (PValue a) = rnf a 162 | 163 | 164 | -- | Construct PValue. Returns @Nothing@ if argument is out of [0,1] range. 165 | mkPValueE :: (Ord a, Num a) => a -> Maybe (PValue a) 166 | mkPValueE p 167 | | p >= 0 && p <= 1 = Just $ PValue p 168 | | otherwise = Nothing 169 | 170 | ---------------------------------------------------------------- 171 | -- Point estimates 172 | ---------------------------------------------------------------- 173 | 174 | -- | 175 | -- A point estimate and its confidence interval. It's parametrized by 176 | -- both error type @e@ and value type @a@. This module provides two 177 | -- types of error: 'NormalErr' for normally distributed errors and 178 | -- 'ConfInt' for error with normal distribution. See their 179 | -- documentation for more details. 180 | -- 181 | -- For example @144 ± 5@ (assuming normality) could be expressed as 182 | -- 183 | -- > Estimate { estPoint = 144 184 | -- > , estError = NormalErr 5 185 | -- > } 186 | -- 187 | -- Or if we want to express @144 + 6 - 4@ at CL95 we could write: 188 | -- 189 | -- > Estimate { estPoint = 144 190 | -- > , estError = ConfInt 191 | -- > { confIntLDX = 4 192 | -- > , confIntUDX = 6 193 | -- > , confIntCL = cl95 194 | -- > } 195 | -- 196 | -- Prior to statistics 0.14 @Estimate@ data type used following definition: 197 | -- 198 | -- > data Estimate = Estimate { 199 | -- > estPoint :: {-# UNPACK #-} !Double 200 | -- > , estLowerBound :: {-# UNPACK #-} !Double 201 | -- > , estUpperBound :: {-# UNPACK #-} !Double 202 | -- > , estConfidenceLevel :: {-# UNPACK #-} !Double 203 | -- > } 204 | -- 205 | -- Now type @Estimate ConfInt Double@ should be used instead. Function 206 | -- 'estimateFromInterval' allow to easily construct estimate from same inputs. 207 | data Estimate e a = Estimate 208 | { estPoint :: !a 209 | -- ^ Point estimate. 210 | , estError :: !(e a) 211 | -- ^ Confidence interval for estimate. 212 | } deriving (Eq, Read, Show, Generic 213 | #if __GLASGOW_HASKELL__ >= 708 214 | , Typeable, Data 215 | #endif 216 | ) 217 | 218 | instance (NFData (e a), NFData a) => NFData (Estimate e a) where 219 | rnf (Estimate x dx) = rnf x `seq` rnf dx 220 | 221 | 222 | -- | Confidence interval. It assumes that confidence interval forms 223 | -- single interval and isn't set of disjoint intervals. 224 | data ConfInt a = ConfInt 225 | { confIntLDX :: !a 226 | -- ^ Lower error estimate, or distance between point estimate and 227 | -- lower bound of confidence interval. 228 | , confIntUDX :: !a 229 | -- ^ Upper error estimate, or distance between point estimate and 230 | -- upper bound of confidence interval. 231 | , confIntCL :: !(CL Double) 232 | -- ^ Confidence level corresponding to given confidence interval. 233 | } 234 | deriving (Read, Show, Eq, Typeable, Data, Generic) 235 | 236 | instance NFData a => NFData (ConfInt a) where 237 | rnf (ConfInt x y _) = rnf x `seq` rnf y 238 | 239 | 240 | 241 | ---------------------------------------- 242 | -- Constructors 243 | 244 | -- | Create estimate with asymmetric error. 245 | estimateFromErr 246 | :: a -- ^ Central estimate 247 | -> (a,a) -- ^ Lower and upper errors. Both should be 248 | -- positive but it's not checked. 249 | -> CL Double -- ^ Confidence level for interval 250 | -> Estimate ConfInt a 251 | estimateFromErr x (ldx,udx) cl = Estimate x (ConfInt ldx udx cl) 252 | 253 | -- | Create estimate with asymmetric error. 254 | estimateFromInterval 255 | :: Num a 256 | => a -- ^ Point estimate. Should lie within 257 | -- interval but it's not checked. 258 | -> (a,a) -- ^ Lower and upper bounds of interval 259 | -> CL Double -- ^ Confidence level for interval 260 | -> Estimate ConfInt a 261 | estimateFromInterval x (lx,ux) cl 262 | = Estimate x (ConfInt (x-lx) (ux-x) cl) 263 | 264 | 265 | ---------------------------------------- 266 | -- Accessors 267 | 268 | -- | Get confidence interval 269 | confidenceInterval :: Num a => Estimate ConfInt a -> (a,a) 270 | confidenceInterval (Estimate x (ConfInt ldx udx _)) 271 | = (x - ldx, x + udx) 272 | 273 | 274 | -- | Data types which could be multiplied by constant. 275 | class Scale e where 276 | scale :: (Ord a, Num a) => a -> e a -> e a 277 | 278 | instance Scale ConfInt where 279 | scale a (ConfInt l u cl) | a >= 0 = ConfInt (a*l) (a*u) cl 280 | | otherwise = ConfInt (-a*u) (-a*l) cl 281 | 282 | instance Scale e => Scale (Estimate e) where 283 | scale a (Estimate x dx) = Estimate (a*x) (scale a dx) 284 | 285 | -------------------------------------------------------------------------------- /statistics/Statistics/Types/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Statistics.Types.Internal 3 | -- Copyright : (c) 2009 Bryan O'Sullivan 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bos@serpentine.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- Types for working with statistics. 11 | module Statistics.Types.Internal where 12 | 13 | 14 | import qualified Data.Vector.Unboxed as U (Vector) 15 | 16 | -- | Sample data. 17 | type Sample = U.Vector Double 18 | 19 | -- | Sample with weights. First element of sample is data, second is weight 20 | --type WeightedSample = U.Vector (Double,Double) 21 | 22 | -- | Weights for affecting the importance of elements of a sample. 23 | --type Weights = U.Vector Double 24 | 25 | -------------------------------------------------------------------------------- /tests/Cleanup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | import Gauge.Benchmark(Benchmark, bench, nfIO) 8 | import Gauge.Main.Options (Config(..), Verbosity(Quiet)) 9 | import Control.Applicative 10 | import Control.DeepSeq (NFData(..)) 11 | import Control.Exception (Exception, try, throwIO) 12 | import Control.Monad (when) 13 | import Data.Typeable (Typeable) 14 | import System.Directory (doesFileExist, removeFile) 15 | import System.IO ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) 16 | , hClose, hFileSize, hSeek, openFile) 17 | import GHC.Exts (IsList(..)) 18 | import Foundation.Check 19 | import Foundation.Check.Main 20 | import qualified Gauge as C 21 | import Data.ByteString (ByteString) 22 | import qualified Data.ByteString as BS 23 | import Prelude 24 | 25 | instance NFData Handle where 26 | rnf !_ = () 27 | 28 | data CheckResult = ShouldThrow | WrongData deriving (Show, Typeable, Eq) 29 | 30 | instance Exception CheckResult 31 | 32 | type BenchmarkWithFile = 33 | String -> IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> Benchmark 34 | 35 | perRun :: BenchmarkWithFile 36 | perRun name alloc clean work = 37 | bench name $ C.perRunEnvWithCleanup alloc clean work 38 | 39 | perBatch :: BenchmarkWithFile 40 | perBatch name alloc clean work = 41 | bench name $ C.perBatchEnvWithCleanup (const alloc) (const clean) work 42 | 43 | envWithCleanup :: BenchmarkWithFile 44 | envWithCleanup name alloc clean work = 45 | C.envWithCleanup alloc clean $ bench name . nfIO . work 46 | 47 | testCleanup :: Bool -> String -> BenchmarkWithFile -> Test 48 | testCleanup shouldFail name withEnvClean = CheckPlan (fromList name) $ do 49 | existsBefore <- pick "file-exists" $ doesFileExist testFile 50 | 51 | validate "Temporary file not exists" $ existsBefore === False 52 | 53 | result <- runTest . withEnvClean name alloc clean $ \hnd -> do 54 | result <- hFileSize hnd >>= BS.hGet hnd . fromIntegral 55 | resetHandle hnd 56 | when (result /= testData) $ throwIO WrongData 57 | when shouldFail $ throwIO ShouldThrow 58 | 59 | validate "is-right" $ case result of 60 | Left WrongData -> False -- failTest "Incorrect result read from file" 61 | Left ShouldThrow -> True 62 | Right _ | shouldFail -> False -- failTest "Failed to throw exception" 63 | | otherwise -> True 64 | 65 | failure <- pick "cleanup" $ do 66 | existsAfter <- doesFileExist testFile 67 | if existsAfter 68 | then removeFile testFile >> pure True 69 | else pure False 70 | validate "Suceed to delete temporary file" $ failure === False 71 | where 72 | testFile :: String 73 | testFile = "tmp" 74 | 75 | testData :: ByteString 76 | testData = "blah" 77 | 78 | runTest :: Benchmark -> Check (Either CheckResult ()) 79 | runTest = pick "run-test" . try . C.defaultMainWith config . pure 80 | where 81 | config = C.defaultConfig { verbosity = Quiet , timeLimit = Just 1, iters = Just 1 } 82 | 83 | resetHandle :: Handle -> IO () 84 | resetHandle hnd = hSeek hnd AbsoluteSeek 0 85 | 86 | alloc :: IO Handle 87 | alloc = do 88 | hnd <- openFile testFile ReadWriteMode 89 | BS.hPut hnd testData 90 | resetHandle hnd 91 | return hnd 92 | 93 | clean :: Handle -> IO () 94 | clean hnd = do 95 | hClose hnd 96 | removeFile testFile 97 | 98 | testSuccess :: String -> BenchmarkWithFile -> Test 99 | testSuccess = testCleanup False 100 | 101 | testFailure :: String -> BenchmarkWithFile -> Test 102 | testFailure = testCleanup True 103 | 104 | main :: IO () 105 | main = defaultMain $ Group "cleanup" 106 | [ testSuccess "perRun Success" perRun 107 | , testFailure "perRun Failure" perRun 108 | , testSuccess "perBatch Success" perBatch 109 | , testFailure "perBatch Failure" perBatch 110 | , testSuccess "envWithCleanup Success" envWithCleanup 111 | , testFailure "envWithCleanup Failure" envWithCleanup 112 | ] 113 | -------------------------------------------------------------------------------- /tests/Sanity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import System.Timeout (timeout) 5 | import Data.Word 6 | import GHC.Exts (IsList(..)) 7 | 8 | import qualified Gauge as C 9 | import Gauge.Main.Options 10 | import Gauge.Benchmark (bench, bgroup, env, whnf) 11 | 12 | import Basement.Compat.Base ((<>)) 13 | import Foundation.Check 14 | import Foundation.Check.Main 15 | 16 | fib :: Int -> Int 17 | fib = sum . go 18 | where go 0 = [0] 19 | go 1 = [1] 20 | go n = go (n-1) ++ go (n-2) 21 | 22 | withSpecialMain :: Bool -> Bool -> [C.Benchmark] -> IO () 23 | withSpecialMain useVerbose useQuick = C.defaultMainWith cfg 24 | where 25 | cfg = defaultConfig 26 | { rawDataFile = Just "sanity.dat" 27 | , jsonFile = Just "sanity.json" 28 | , csvFile = Just "sanity.csv" 29 | , reportFile = Just "sanity.html" 30 | , junitFile = Just "sanity.junit" 31 | , verbosity = if useVerbose then Verbose else verbosity defaultConfig 32 | , quickMode = useQuick 33 | } 34 | 35 | sanity :: Bool -> Bool -> Check () 36 | sanity useVerbose useQuick = do 37 | let tooLong = 30 38 | wat <- pick "run-program" $ timeout (tooLong * 1000000) $ withSpecialMain useVerbose useQuick 39 | [ bgroup "fib" 40 | [ bench "fib 10" $ whnf fib 10 41 | , bench "fib 22" $ whnf fib 22 42 | ] 43 | , env (return (replicate 1024 0 :: [Word8])) $ \xs -> 44 | bgroup "length . filter" 45 | [ bench "string" $ whnf (length . filter (==0)) xs 46 | -- , env (return (B.pack xs)) $ \bs -> bench "uarray" $ whnf (B.length . B.filter (==0)) bs 47 | ] 48 | ] 49 | 50 | validate ("not killed for running longer than " <> fromList (show tooLong) <> " seconds") $ 51 | wat === Just () 52 | 53 | main :: IO () 54 | main = defaultMain $ Group "gauge-sanity" 55 | [ CheckPlan "normal" $ sanity False False 56 | , CheckPlan "verbose" $ sanity True False 57 | , CheckPlan "quick" $ sanity False True 58 | , CheckPlan "verbose-quick" $ sanity True True 59 | ] 60 | --------------------------------------------------------------------------------