histogram-fill 0.2.0 → 0.3
raw patch · 8 files changed
+697/−597 lines, 8 filesdep +primitive
Dependencies added: primitive
Files
- Data/Histogram.hs +7/−1
- Data/Histogram/Bin.hs +354/−287
- Data/Histogram/Bin/Extra.hs +135/−38
- Data/Histogram/Fill.hs +149/−236
- Data/Histogram/Generic.hs +21/−6
- Data/Histogram/Parse.hs +2/−2
- Data/Histogram/ST.hs +27/−23
- histogram-fill.cabal +2/−4
Data/Histogram.hs view
@@ -37,6 +37,7 @@ , histMap , histMapBin , histZip+ , histZipSafe ) where import qualified Data.Vector.Unboxed as U@@ -125,12 +126,17 @@ histMapBin :: (Bin bin, Bin bin') => (bin -> bin') -> Histogram bin a -> Histogram bin' a histMapBin = H.histMapBin --- | Zip two histograms together. Bins of histograms must be equal+-- | Zip two histograms elementwise. Bins of histograms must be equal -- otherwise error will be called. histZip :: (Bin bin, Eq bin, Unbox a, Unbox b, Unbox c) => (a -> b -> c) -> Histogram bin a -> Histogram bin b -> Histogram bin c histZip = H.histZip +-- | Zip two histogram elementwise. If bins are not equal return `Nothing`+histZipSafe :: (Bin bin, Eq bin, Unbox a, Unbox b, Unbox c) =>+ (a -> b -> c) -> Histogram bin a -> Histogram bin b -> Maybe (Histogram bin c)+histZipSafe = H.histZipSafe+ -- | Slice 2D histogram along Y axis. This function is fast because it does not require reallocations. sliceY :: (Unbox a, Bin bX, Bin bY) => Histogram (Bin2D bX bY) a -> [(BinValue bY, Histogram bX a)] sliceY = H.sliceY
Data/Histogram/Bin.hs view
@@ -1,174 +1,200 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- Requred for Bin2D conversions+{-# LANGUAGE OverlappingInstances #-} -- | -- Module : Data.Histogram.Bin -- Copyright : Copyright (c) 2009, Alexey Khudyakov <alexey.skladnoy@gmail.com> -- License : BSD3 -- Maintainer : Alexey Khudyakov <alexey.skladnoy@gmail.com> -- Stability : experimental--- +-- -- Binning algorithms. This is mapping from set of interest to integer--- indices and approximate reverse. +-- indices and approximate reverse. module Data.Histogram.Bin ( -- * Type classes Bin(..) , Bin1D(..)- , Indexable(..)- , Indexable2D(..)+ , UniformBin1D(..)+ , VariableBin1D(..)+ , ConvertBin(..) -- * Bin types -- ** Integer bins , BinI(..) , binI0 -- ** Integer bins with non-1 size- , BinInt+ , BinInt(..) , binInt- -- ** Indexed bins - , BinIx(BinIx,unBinIx)- , binIx+ -- ** Enum based bin+ , BinEnum(..)+ , binEnum+ , binEnumFull -- ** Floating point bins , BinF , binF , binFn- , binI2binF+ , binFstep , scaleBinF- -- *** Specialized for Double + -- *** Specialized for Double , BinD , binD , binDn- , binI2binD+ , binDstep , scaleBinD -- ** Log scale point- , LogBinD + , LogBinD , logBinD -- ** 2D bins , Bin2D(..) , (><) , nBins2D , toIndex2D- , binX- , binY , fmapBinX , fmapBinY- -- ** 2D indexed bins- , BinIx2D (unBinIx2D)- , binIx2D ) where -import Control.Monad+import Control.Monad (liftM, liftM2, liftM3)+import GHC.Float (double2Int)++import qualified Data.Vector.Generic as G+import Data.Vector.Generic (Vector)+import Data.Typeable (Typeable)+import Text.Read (Read(..))+ import Data.Histogram.Parse-import Text.Read (Read(..)) -import GHC.Float (double2Int)++ ------------------------------------------------------------------- | Abstract binning algorithm. It provides way to map some values--- onto continous range of integer values starting from zero. --- --- Following invariant is expected to hold: --- --- > toIndex . fromIndex == id--- --- Reverse is not nessearily true. +-- Type classes+----------------------------------------------------------------++-- | This type represent some abstract data binning algorithms.+-- It maps some value to integer indices.+--+-- Following invariant is expected to hold:+--+-- > toIndex . fromIndex == id class Bin b where- -- | Type of value to bin- type BinValue b- -- | Convert from value to index. No bound checking performed- toIndex :: b -> BinValue b -> Int- -- | Convert from index to value. - fromIndex :: b -> Int -> BinValue b - -- | Check whether value in range.- inRange :: b -> BinValue b -> Bool- -- | Total number of bins- nBins :: b -> Int+ -- | Type of value to bin+ type BinValue b+ -- | Convert from value to index. No bound checking+ -- performed. Function must not fail for any input.+ toIndex :: b -> BinValue b -> Int+ -- | Convert from index to value. Returned value should correspond+ -- to "center" of bin. Definition of center is left for definition+ -- of instance. Funtion may fail for invalid indices but+ -- encouraged not to do so.+ fromIndex :: b -> Int -> BinValue b+ -- | Check whether value in range. Values which lay in range must+ -- produce valid indices and conversely value which produce+ -- valid index must be in range.+ inRange :: b -> BinValue b -> Bool+ -- | Total number of bins+ nBins :: b -> Int -----------------------------------------------------------------+ -- | One dimensional binning algorithm. It means that bin values have--- some inherent ordering. For example all binning algorithms for real--- numbers could be members or this type class whereas binning--- algorithms for R^2 could not. +-- some inherent ordering. For example all binning algorithms for+-- real numbers could be members or this type class whereas binning+-- algorithms for R^2 could not. class Bin b => Bin1D b where- -- | List of center of bins in ascending order.- binsList :: b -> [BinValue b]- -- | List of bins in ascending order.- binsListRange :: b -> [(BinValue b, BinValue b)]+ -- | Minimal accepted value of histogram+ lowerLimit :: b -> BinValue b+ -- | Maximal accepted value of histogram+ upperLimit :: b -> BinValue b+ -- | List of center of bins in ascending order. Default+ -- implementation is:+ --+ -- > binsList b = G.generate (nBins b) (fromIndex b)+ binsList :: Vector v (BinValue b) => b -> v (BinValue b)+ binsList b = G.generate (nBins b) (fromIndex b)+ -- | List of bins in ascending order. First element of tuple is+ -- lower bound second is upper bound of bin+ binsListRange :: Vector v (BinValue b, BinValue b) => b -> v (BinValue b, BinValue b)+ {-# INLINE binsList #-} -------------------------------------------------------------------- | Indexable is value which could be converted to and from Int--- without information loss.------ Always true------ > deindex . index = id------ Only if Int is in range------ > index . deindex = id-class Indexable a where- -- | Convert value to index- index :: a -> Int - -- | Convert index to value- deindex :: Int -> a -instance Indexable Int where- index = id- deindex = id+-- | 1D binning algorithms with variable bin size+class Bin1D b => VariableBin1D b where+ -- | Size of n'th bin.+ binSizeN :: b -> Int -> BinValue b -------------------------------------------------------------------- | This type class is same as Indexable but for 2D values.-class Indexable2D a where- -- | Convert value to index- index2D :: a -> (Int,Int)- -- | Convert index to value- deindex2D :: (Int,Int) -> a -instance (Indexable a, Indexable b) => Indexable2D (a,b) where- index2D (x,y) = (index x, index y)- deindex2D (i,j) = (deindex i, deindex j)+-- | 1D binning algorithms with constant size bins. Constant sized+-- bins could be thought as specialization of variable-sized bins+-- therefore a superclass constraint.+class VariableBin1D b => UniformBin1D b where+ -- | Size of bin. Default implementation just uses 0 bin.+ binSize :: b -> BinValue b+ binSize b = binSizeN b 0 ++-- | Class for conversion between binning algorithms+class (Bin b, Bin b') => ConvertBin b b' where+ -- | Convert bins+ convertBin :: b -> b'+ ---------------------------------------------------------------- -- Integer bin ---------------------------------------------------------------- -- | Simple binning algorithm which map continous range of bins onto -- indices. Each number correcsponds to different bin-data BinI = BinI {-# UNPACK #-} !Int {-# UNPACK #-} !Int- deriving Eq+data BinI = BinI+ {-# UNPACK #-} !Int -- ^ Lower bound (inclusive)+ {-# UNPACK #-} !Int -- ^ Upper bound (inclusive)+ deriving (Eq,Typeable) -- | Construct BinI with n bins. Indexing starts from 0 binI0 :: Int -> BinI binI0 n = BinI 0 (n-1) instance Bin BinI where- type BinValue BinI = Int- toIndex !(BinI base _) !x = x - base- {-# INLINE toIndex #-}- fromIndex !(BinI base _) !x = x + base- inRange !(BinI x y) i = i>=x && i<=y- {-# INLINE inRange #-}- nBins !(BinI x y) = y - x + 1+ type BinValue BinI = Int+ toIndex !(BinI base _) !x = x - base+ fromIndex !(BinI base _) !x = x + base+ inRange !(BinI x y) i = i>=x && i<=y+ nBins !(BinI x y) = y - x + 1+ {-# INLINE toIndex #-}+ {-# INLINE inRange #-} instance Bin1D BinI where- binsList (BinI lo hi) = [lo .. hi]- binsListRange b = zip (binsList b) (binsList b)+ lowerLimit (BinI i _) = i+ upperLimit (BinI _ i) = i+ binsList b@(BinI lo _) = G.enumFromN lo (nBins b)+ binsListRange b@(BinI lo _) = G.generate (nBins b) (\i -> let n = lo+i in (n,n))+ {-# INLINE binsList #-}+ {-# INLINE binsListRange #-} +instance VariableBin1D BinI where+ binSizeN _ _ = 1++instance UniformBin1D BinI where+ binSize _ = 1+ instance Show BinI where- show (BinI lo hi) = unlines [ "# BinI"- , "# Low = " ++ show lo- , "# High = " ++ show hi- ]+ show (BinI lo hi) = unlines [ "# BinI"+ , "# Low = " ++ show lo+ , "# High = " ++ show hi+ ] instance Read BinI where- readPrec = keyword "BinI" >> liftM2 BinI (value "Low") (value "High")+ readPrec = keyword "BinI" >> liftM2 BinI (value "Low") (value "High") ++ ---------------------------------------------------------------- -- Another form of Integer bin ---------------------------------------------------------------- -- | Integer bins with size which differ from 1.-data BinInt = BinInt - {-# UNPACK #-} !Int -- Low bound- {-# UNPACK #-} !Int -- Bin size- {-# UNPACK #-} !Int -- Number of bins- deriving Eq+data BinInt = BinInt+ {-# UNPACK #-} !Int -- ^ Low bound+ {-# UNPACK #-} !Int -- ^ Bin size+ {-# UNPACK #-} !Int -- ^ Number of bins+ deriving (Eq,Typeable) -- | Construct BinInt. binInt :: Int -- ^ Lower bound@@ -177,71 +203,91 @@ -> BinInt binInt lo n hi = BinInt lo n nb where- nb = (hi-lo) `div` n + nb = (hi-lo) `div` n instance Bin BinInt where- type BinValue BinInt = Int- toIndex !(BinInt base sz _) !x = (x - base) `div` sz- {-# INLINE toIndex #-}- fromIndex !(BinInt base sz _) !x = x * sz + base- inRange !(BinInt base sz n) i = i>=base && i<(base+n*sz)- {-# INLINE inRange #-}- nBins !(BinInt _ _ n) = n+ type BinValue BinInt = Int+ toIndex !(BinInt base sz _) !x = (x - base) `div` sz+ fromIndex !(BinInt base sz _) !x = x * sz + base+ inRange !(BinInt base sz n) i = i>=base && i<(base+n*sz)+ nBins !(BinInt _ _ n) = n+ {-# INLINE toIndex #-}+ {-# INLINE inRange #-} +instance Bin1D BinInt where+ lowerLimit (BinInt base _ _) = base+ upperLimit (BinInt base sz n) = base + sz * n - 1+ binsListRange b@(BinInt _ sz n) = G.generate n (\i -> let x = fromIndex b i in (x,x + sz - 1))++instance VariableBin1D BinInt where+ binSizeN (BinInt _ sz _) _ = sz++instance UniformBin1D BinInt where+ binSize (BinInt _ sz _) = sz+ instance Show BinInt where- show (BinInt base sz n) = - unlines [ "# BinInt"- , "# Base = " ++ show base- , "# Step = " ++ show sz- , "# Bins = " ++ show n- ]+ show (BinInt base sz n) =+ unlines [ "# BinInt"+ , "# Base = " ++ show base+ , "# Step = " ++ show sz+ , "# Bins = " ++ show n+ ] instance Read BinInt where- readPrec = keyword "BinInt" >> liftM3 BinInt (value "Base") (value "Step") (value "Bins")+ readPrec = keyword "BinInt" >> liftM3 BinInt (value "Base") (value "Step") (value "Bins") + ------------------------------------------------------------------- Bins for indexables+-- Enumeration bin ---------------------------------------------------------------- --- | Binning for indexable values-newtype BinIx i = BinIx { unBinIx :: BinI }- deriving Eq+-- | Bin for types which are instnaces of Enum type class+newtype BinEnum a = BinEnum BinI+ deriving (Eq,Typeable) --- | Construct indexed bin-binIx :: Indexable i => i -> i -> BinIx i-binIx lo hi = BinIx $ BinI (index lo) (index hi)+-- | Create enum based bin+binEnum :: Enum a => a -> a -> BinEnum a+binEnum a b = BinEnum $ BinI (fromEnum a) (fromEnum b) -instance Indexable i => Bin (BinIx i) where- type BinValue (BinIx i) = i- toIndex (BinIx b) x = toIndex b (index x)- fromIndex (BinIx b) i = deindex (fromIndex b i)- inRange (BinIx b) x = inRange b (index x)- nBins (BinIx b) = nBins b+-- | Use full range of data+binEnumFull :: (Enum a, Bounded a) => BinEnum a+binEnumFull = binEnum minBound maxBound -instance Indexable i => Bin1D (BinIx i) where- binsList (BinIx b) = map deindex (binsList b)- binsListRange b = let bins = binsList b in zip bins bins+instance Enum a => Bin (BinEnum a) where+ type BinValue (BinEnum a) = a+ toIndex (BinEnum b) = toIndex b . fromEnum+ fromIndex (BinEnum b) = toEnum . fromIndex b+ inRange (BinEnum b) = inRange b . fromEnum+ nBins (BinEnum b) = nBins b -instance (Show i, Indexable i) => Show (BinIx i) where- show (BinIx (BinI lo hi)) = unlines [ "# BinIx"- , "# Low = " ++ show (deindex lo :: i)- , "# High = " ++ show (deindex hi :: i)- ]-instance (Read i, Indexable i) => Read (BinIx i) where- readPrec = keyword "BinIx" >> liftM2 binIx (value "Low") (value "High")+instance Enum a => Bin1D (BinEnum a) where+ lowerLimit (BinEnum b) = toEnum $ lowerLimit b+ upperLimit (BinEnum b) = toEnum $ upperLimit b+ binsListRange b = G.generate (nBins b) (\n -> let x = fromIndex b n in (x,x))+ {-# INLINE binsListRange #-} +instance Show (BinEnum a) where+ show (BinEnum b) = "# BinEnum\n" ++ show b+instance Read (BinEnum a) where+ readPrec = keyword "BinEnum" >> liftM BinEnum readPrec+++ ---------------------------------------------------------------- -- Floating point bin ----------------------------------------------------------------+ -- | Floaintg point bins with equal sizes.-data BinF f where- BinF :: RealFrac f => !f -> !f -> !Int -> BinF f +--+-- Note that due to GHC bug #2271 this toIndex is really slow (20x+-- slowdown with respect to BinD) and use of BinD is recommended+data BinF f = BinF {-# UNPACK #-} !f -- ^ Lower bound+ {-# UNPACK #-} !f -- ^ Size of bin+ {-# UNPACK #-} !Int -- ^ Number of bins+ deriving (Eq,Typeable) -instance Eq f => Eq (BinF f) where- (BinF lo hi n) == (BinF lo' hi' n') = lo == lo' && hi == hi' && n == n'- -- | Create bins.-binF :: RealFrac f => +binF :: RealFrac f => f -- ^ Lower bound of range -> Int -- ^ Number of bins -> f -- ^ Upper bound of range@@ -253,58 +299,67 @@ f -- ^ Begin of range -> f -- ^ Size of step -> f -- ^ Approximation of end of range- -> BinF f + -> BinF f binFn from step to = BinF from step (round $ (to - from) / step) --- | Convert BinI to BinF-binI2binF :: RealFrac f => BinI -> BinF f-binI2binF b@(BinI i _) = BinF (fromIntegral i) 1 (nBins b)+-- | Create bins+binFstep :: RealFrac f =>+ f -- ^ Begin of range+ -> f -- ^ Size of step+ -> Int -- ^ Number of bins+ -> BinF f+binFstep = BinF -- | 'scaleBinF a b' scales BinF using linear transform 'a+b*x' scaleBinF :: RealFrac f => f -> f -> BinF f -> BinF f-scaleBinF a b (BinF base step n) +scaleBinF a b (BinF base step n) | b > 0 = BinF (a + b*base) (b*step) n | otherwise = error $ "scaleBinF: b must be positive (b = "++show b++")" -instance Bin (BinF f) where- type BinValue (BinF f) = f - toIndex !(BinF from step _) !x = floor $ (x-from) / step- {-# INLINE toIndex #-}- fromIndex !(BinF from step _) !i = (step/2) + (fromIntegral i * step) + from - inRange !(BinF from step n) x = x > from && x < from + step*fromIntegral n- {-# INLINE inRange #-}- nBins !(BinF _ _ n) = n+instance RealFrac f => Bin (BinF f) where+ type BinValue (BinF f) = f+ toIndex !(BinF from step _) !x = floor $ (x-from) / step+ fromIndex !(BinF from step _) !i = (step/2) + (fromIntegral i * step) + from+ inRange !(BinF from step n) x = x > from && x < from + step*fromIntegral n+ nBins !(BinF _ _ n) = n+ {-# INLINE toIndex #-}+ {-# INLINE inRange #-} -instance Bin1D (BinF f) where- binsList b@(BinF _ _ n) = map (fromIndex b) [0..n-1]- binsListRange b@(BinF _ step _) = map toPair (binsList b)- where- toPair x = (x - step/2, x + step/2)+instance RealFrac f => Bin1D (BinF f) where+ lowerLimit (BinF from _ _) = from+ upperLimit (BinF from step n) = from + step * fromIntegral n+ binsListRange !b@(BinF _ step n) = G.generate n toPair+ where+ toPair k = (x - step/2, x + step/2) where x = fromIndex b k+ {-# INLINE binsListRange #-} +instance RealFrac f => VariableBin1D (BinF f) where+ binSizeN (BinF _ step _) _ = step++instance RealFrac f => UniformBin1D (BinF f) where+ binSize (BinF _ step _) = step+ instance Show f => Show (BinF f) where- show (BinF base step n) = unlines [ "# BinF"- , "# Base = " ++ show base- , "# Step = " ++ show step- , "# N = " ++ show n- ]+ show (BinF base step n) = unlines [ "# BinF"+ , "# Base = " ++ show base+ , "# Step = " ++ show step+ , "# N = " ++ show n+ ] instance (Read f, RealFrac f) => Read (BinF f) where- readPrec = do- keyword "BinF"- base <- value "Base"- step <- value "Step"- n <- value "N"- return $ BinF base step n+ readPrec = keyword "BinF" >> liftM3 BinF (value "Base") (value "Step") (value "N") ++ ---------------------------------------------------------------- -- Floating point bin /Specialized for Double ---------------------------------------------------------------- -- | Floaintg point bins with equal sizes. If you work with Doubles -- this data type should be used instead of BinF.-data BinD = BinD {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Int+data BinD = BinD {-# UNPACK #-} !Double -- ^ Lower bound+ {-# UNPACK #-} !Double -- ^ Size of bin+ {-# UNPACK #-} !Int -- ^ Number of bins+ deriving (Eq,Typeable) -instance Eq BinD where- (BinD lo hi n) == (BinD lo' hi' n') = lo == lo' && hi == hi' && n == n'- -- | Create bins. binD :: Double -- ^ Lower bound of range -> Int -- ^ Number of bins@@ -319,13 +374,16 @@ -> BinD binDn from step to = BinD from step (round $ (to - from) / step) --- | Convert BinI to BinF-binI2binD :: BinI -> BinD-binI2binD b@(BinI i _) = BinD (fromIntegral i) 1 (nBins b)+-- | Create bins+binDstep :: Double -- ^ Begin of range+ -> Double -- ^ Size of step+ -> Int -- ^ Number of bins+ -> BinD+binDstep = BinD -- | 'scaleBinF a b' scales BinF using linear transform 'a+b*x' scaleBinD :: Double -> Double -> BinD -> BinD-scaleBinD a b (BinD base step n) +scaleBinD a b (BinD base step n) | b > 0 = BinD (a + b*base) (b*step) n | otherwise = error $ "scaleBinF: b must be positive (b = "++show b++")" @@ -336,102 +394,119 @@ {-# INLINE floorD #-} instance Bin BinD where- type BinValue BinD = Double- toIndex !(BinD from step _) !x = floorD $ (x-from) / step- {-# INLINE toIndex #-}- fromIndex !(BinD from step _) !i = (step/2) + (fromIntegral i * step) + from - inRange !(BinD from step n) x = x > from && x < from + step*fromIntegral n- {-# INLINE inRange #-}- nBins !(BinD _ _ n) = n+ type BinValue BinD = Double+ toIndex !(BinD from step _) !x = floorD $ (x-from) / step+ fromIndex !(BinD from step _) !i = (step/2) + (fromIntegral i * step) + from+ inRange !(BinD from step n) x = x > from && x < from + step*fromIntegral n+ nBins !(BinD _ _ n) = n+ {-# INLINE toIndex #-}+ {-# INLINE inRange #-} instance Bin1D BinD where- binsList b@(BinD _ _ n) = map (fromIndex b) [0..n-1]- binsListRange b@(BinD _ step _) = map toPair (binsList b)- where- toPair x = (x - step/2, x + step/2)+ lowerLimit (BinD from _ _) = from+ upperLimit (BinD from step n) = from + step * fromIntegral n+ binsListRange b@(BinD _ step n) = G.generate n toPair+ where+ toPair k = (x - step/2, x + step/2) where x = fromIndex b k+ {-# INLINE binsListRange #-} ++instance VariableBin1D BinD where+ binSizeN (BinD _ step _) _ = step++instance UniformBin1D BinD where+ binSize (BinD _ step _) = step+ instance Show BinD where- show (BinD base step n) = unlines [ "# BinD"- , "# Base = " ++ show base- , "# Step = " ++ show step- , "# N = " ++ show n- ]+ show (BinD base step n) = unlines [ "# BinD"+ , "# Base = " ++ show base+ , "# Step = " ++ show step+ , "# N = " ++ show n+ ] instance Read BinD where- readPrec = do- keyword "BinD"- base <- value "Base"- step <- value "Step"- n <- value "N"- return $ BinD base step n+ readPrec = keyword "BinD" >> liftM3 BinD (value "Base") (value "Step") (value "N") + ---------------------------------------------------------------- -- Log-scale bin ---------------------------------------------------------------- -- | Logarithmic scale bins. data LogBinD = LogBinD- Double -- Low border- Double -- Hi border- Double -- Increment ratio- Int -- Number of bins- deriving Eq+ Double -- ^ Low border+ Double -- ^ Hi border+ Double -- ^ Increment ratio+ Int -- ^ Number of bins+ deriving (Eq,Typeable) --- | Create log-scale bins. +-- | Create log-scale bins. logBinD :: Double -> Int -> Double -> LogBinD logBinD lo n hi = LogBinD lo hi ((hi/lo) ** (1 / fromIntegral n)) n instance Bin LogBinD where- type BinValue LogBinD = Double- toIndex !(LogBinD base _ step _) !x = floorD $ logBase step (x / base)- {-# INLINE toIndex #-}- fromIndex !(LogBinD base _ step _) !i = base * step ^ i- inRange !(LogBinD lo hi _ _) x = x >= lo && x < hi- {-# INLINE inRange #-}- nBins !(LogBinD _ _ _ n) = n+ type BinValue LogBinD = Double+ toIndex !(LogBinD base _ step _) !x = floorD $ logBase step (x / base)+ fromIndex !(LogBinD base _ step _) !i | i >= 0 = base * step ** (fromIntegral i + 0.5)+ | otherwise = -1 / 0+ inRange !(LogBinD lo hi _ _) x = x >= lo && x < hi+ nBins !(LogBinD _ _ _ n) = n+ {-# INLINE toIndex #-}+ {-# INLINE inRange #-} +instance Bin1D LogBinD where+ lowerLimit (LogBinD lo _ _ _) = lo+ upperLimit (LogBinD _ hi _ _) = hi+ binsListRange (LogBinD base _ step n) = G.unfoldrN n next base+ where+ next x = let x' = x * step in Just ((x,x'), x')+ {-# INLINE binsListRange #-}++instance VariableBin1D LogBinD where+ binSizeN (LogBinD base _ step _) n = let x = base * step ^ n in x*step - x+ instance Show LogBinD where- show (LogBinD lo hi step n) = - unlines [ "# LogBinD"- , "# Lo = " ++ show lo- , "# Hi = " ++ show hi- , "# Step = " ++ show step- , "# N = " ++ show n- ]+ show (LogBinD lo hi _ n) =+ unlines [ "# LogBinD"+ , "# Lo = " ++ show lo+ , "# N = " ++ show n+ , "# Hi = " ++ show hi+ ]+instance Read LogBinD where+ readPrec = do+ keyword "LogBinD"+ liftM3 logBinD (value "Lo") (value "N") (value "Hi") + ---------------------------------------------------------------- -- 2D bin ---------------------------------------------------------------- --- | 2D bins. binX is binning along X axis and binY is one along Y axis. -data Bin2D binX binY = Bin2D !binX !binY- deriving Eq+-- | 2D bins. binX is binning along X axis and binY is one along Y axis.+data Bin2D binX binY = Bin2D { binX :: !binX -- ^ Binning algorithm for X axis+ , binY :: !binY -- ^ Binning algorithm for Y axis+ }+ deriving (Eq,Typeable) -- | Alias for 'Bin2D'. (><) :: binX -> binY -> Bin2D binX binY (><) = Bin2D --- | Get binning algorithm along X axis-binX :: Bin2D bx by -> bx-binX !(Bin2D bx _) = bx---- | Get binning algorithm along Y axis-binY :: Bin2D bx by -> by-binY !(Bin2D _ by) = by- instance (Bin binX, Bin binY) => Bin (Bin2D binX binY) where- type BinValue (Bin2D binX binY) = (BinValue binX, BinValue binY)- toIndex b@(Bin2D bx by) (x,y) - | inRange b (x,y) = toIndex bx x + (toIndex by y)*(fromIntegral $ nBins bx)- | otherwise = maxBound- {-# INLINE toIndex #-}- fromIndex b@(Bin2D bx by) i = let (ix,iy) = toIndex2D b i- in (fromIndex bx ix, fromIndex by iy)- inRange (Bin2D bx by) (x,y) = inRange bx x && inRange by y- {-# INLINE inRange #-}- nBins (Bin2D bx by) = (nBins bx) * (nBins by)+ type BinValue (Bin2D binX binY) = (BinValue binX, BinValue binY)+ toIndex !(Bin2D bx by) !(x,y)+ | inRange bx x = toIndex bx x + toIndex by y * nBins bx+ | otherwise = maxBound+ fromIndex b@(Bin2D bx by) i = let (ix,iy) = toIndex2D b i+ in (fromIndex bx ix, fromIndex by iy)+ inRange (Bin2D bx by) !(x,y) = inRange bx x && inRange by y+ nBins (Bin2D bx by) = nBins bx * nBins by+ {-# INLINE toIndex #-}+ {-# INLINE inRange #-} +-- | Convert index into pair of indices for X and Y axes toIndex2D :: (Bin binX, Bin binY) => Bin2D binX binY -> Int -> (Int,Int)-toIndex2D b i = let (iy,ix) = divMod i (nBins $ binX b) in (ix,iy)+toIndex2D !b !i = let (iy,ix) = divMod i (nBins $ binX b) in (ix,iy)+{-# INLINE toIndex2D #-} -- | 2-dimensional size of binning algorithm nBins2D :: (Bin bx, Bin by) => Bin2D bx by -> (Int,Int)@@ -440,10 +515,10 @@ -- | Apply function to X binning algorithm. If new binning algorithm -- have different number of bins will fail. fmapBinX :: (Bin bx, Bin bx') => (bx -> bx') -> Bin2D bx by -> Bin2D bx' by-fmapBinX f (Bin2D bx by) +fmapBinX f (Bin2D bx by) | nBins bx' /= nBins bx = error "fmapBinX: new binnig algorithm has different number of bins" | otherwise = Bin2D bx' by- where + where bx' = f bx -- | Apply function to Y binning algorithm. If new binning algorithm@@ -452,53 +527,45 @@ fmapBinY f (Bin2D bx by) | nBins by' /= nBins by = error "fmapBinY: new binnig algorithm has different number of bins" | otherwise = Bin2D bx by'- where + where by' = f by instance (Show b1, Show b2) => Show (Bin2D b1 b2) where- show (Bin2D b1 b2) = concat [ "# Bin2D\n"- , "# X\n"- , show b1- , "# Y\n"- , show b2- ]+ show (Bin2D b1 b2) = concat [ "# Bin2D\n"+ , "# X\n"+ , show b1+ , "# Y\n"+ , show b2+ ] instance (Read b1, Read b2) => Read (Bin2D b1 b2) where- readPrec = do- keyword "Bin2D"- keyword "X"- b1 <- readPrec- keyword "Y"- b2 <- readPrec- return $ Bin2D b1 b2-+ readPrec = do+ keyword "Bin2D"+ keyword "X"+ b1 <- readPrec+ keyword "Y"+ b2 <- readPrec+ return $ Bin2D b1 b2 ------------------------------------------------------------------- Indexed 2D bins+-- Bin conversion ------------------------------------------------------------------- | Binning for 2D indexable value-newtype BinIx2D i = BinIx2D {unBinIx2D :: (Bin2D BinI BinI) } --- | Construct indexed bin-binIx2D :: Indexable2D i => i -> i -> BinIx2D i-binIx2D lo hi = let (ix,iy) = index2D lo- (jx,jy) = index2D hi- in BinIx2D $ BinI ix jx >< BinI iy jy+-- BinI,BinInt -> BinF+instance RealFrac f => ConvertBin BinI (BinF f) where+ convertBin b = BinF (fromIntegral (lowerLimit b) - 0.5) 1 (nBins b)+instance RealFrac f => ConvertBin BinInt (BinF f) where+ convertBin b = BinF (fromIntegral (lowerLimit b) - 0.5) (fromIntegral $ binSize b) (nBins b) -instance Indexable2D i => Bin (BinIx2D i) where- type BinValue (BinIx2D i) = i- toIndex (BinIx2D b) x = toIndex b (index2D x)- fromIndex (BinIx2D b) i = deindex2D $ fromIndex b i- inRange (BinIx2D b) x = inRange b (index2D x)- nBins (BinIx2D b) = nBins b+-- BinI,BinInt -> BinD+instance ConvertBin BinI BinD where+ convertBin b = BinD (fromIntegral (lowerLimit b) - 0.5) 1 (nBins b)+instance ConvertBin BinInt BinD where+ convertBin b = BinD (fromIntegral (lowerLimit b) - 0.5) (fromIntegral $ binSize b) (nBins b) -instance (Show i, Indexable2D i) => Show (BinIx2D i) where- show (BinIx2D b) = unlines [ "# BinIx2D"- , "# Low = " ++ show (deindex2D (fromIndex b 0 ) :: i)- , "# High = " ++ show (deindex2D (fromIndex b (nBins b - 1)) :: i)- ]-instance (Read i, Indexable2D i) => Read (BinIx2D i) where- readPrec = do- keyword "BinIx2D"- l <- value "Low"- h <- value "High"- return $ binIx2D l h+-- Bin2D -> Bin2D+instance (ConvertBin bx bx', Bin by) => ConvertBin (Bin2D bx by) (Bin2D bx' by) where+ convertBin = fmapBinX convertBin+instance (ConvertBin by by', Bin bx) => ConvertBin (Bin2D bx by) (Bin2D bx by') where+ convertBin = fmapBinY convertBin+instance (ConvertBin bx bx', ConvertBin by by') => ConvertBin (Bin2D bx by) (Bin2D bx' by') where+ convertBin (Bin2D bx by) = Bin2D (convertBin bx) (convertBin by)
Data/Histogram/Bin/Extra.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Histogram.Bin -- Copyright : Copyright (c) 2010, Alexey Khudyakov <alexey.skladnoy@gmail.com>@@ -10,67 +12,162 @@ -- -- Extra binning algorithms -module Data.Histogram.Bin.Extra ( BinPermute(permutedBin, permuteTo, permuteFrom)+module Data.Histogram.Bin.Extra ( Enum2D(..)+ , BinEnum2D+ , binEnum2D+ , BinPermute(permutedBin, permuteTo, permuteFrom)+ , permuteByTable , permuteBin ) where import Control.Applicative-import Control.Monad (forM_)+import Control.Monad -- (forM_,liftM2)++import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as M-import Data.Vector.Unboxed ((!))+import Data.Vector.Generic ((!)) import Text.Read import Data.Histogram.Bin import Data.Histogram.Parse --- | Direct permutation of indices. -data BinPermute b = BinPermute { permutedBin :: b- , permuteTo :: U.Vector Int- , permuteFrom :: U.Vector Int+----------------------------------------------------------------++-- | Type class very similar to 'Enum' but elements of type are+-- enumerated on 2-dimensional grid+class Enum2D a where+ -- | Convert value to index+ fromEnum2D :: a -> (Int,Int)+ -- | Convert index to value+ toEnum2D :: (Int,Int) -> a++instance (Enum a, Enum b) => Enum2D (a,b) where+ fromEnum2D (x,y) = (fromEnum x, fromEnum y)+ toEnum2D (i,j) = (toEnum i, toEnum j)++++----------------------------------------------------------------+-- 2D enumaration bin+----------------------------------------------------------------++-- | Binning for 2D enumerations+newtype BinEnum2D i = BinEnum2D (Bin2D BinI BinI)++-- | Construct indexed bin+binEnum2D :: Enum2D i => i -> i -> BinEnum2D i+binEnum2D lo hi = let (ix,iy) = fromEnum2D lo+ (jx,jy) = fromEnum2D hi+ in BinEnum2D $ BinI ix jx >< BinI iy jy++instance Enum2D i => Bin (BinEnum2D i) where+ type BinValue (BinEnum2D i) = i+ toIndex !(BinEnum2D b) !x = toIndex b (fromEnum2D x)+ fromIndex !(BinEnum2D b) !i = toEnum2D (fromIndex b i)+ inRange !(BinEnum2D b) !x = inRange b (fromEnum2D x)+ nBins !(BinEnum2D b) = nBins b++instance (Show i, Enum2D i) => Show (BinEnum2D i) where+ show (BinEnum2D b) = unlines [ "# BinEnum2D"+ , "# Low = " ++ show (toEnum2D (fromIndex b 0 ) :: i)+ , "# High = " ++ show (toEnum2D (fromIndex b (nBins b - 1)) :: i)+ ]+instance (Read i, Enum2D i) => Read (BinEnum2D i) where+ readPrec = do+ keyword "BinEnum2D"+ liftM2 binEnum2D (value "Low") (value "High")+++----------------------------------------------------------------+-- Permutation+----------------------------------------------------------------++-- | Direct permutation of indices.+data BinPermute b = BinPermute { permutedBin :: b -- ^ Original bin+ , permuteTo :: U.Vector Int -- ^ Maps original bin's indices to new indices+ , permuteFrom :: U.Vector Int -- ^ Inverse of pervious table }+ instance Bin b => Bin (BinPermute b) where- type BinValue (BinPermute b) = BinValue b- toIndex (BinPermute b to _) x = to ! toIndex b x- fromIndex (BinPermute b _ from) i = fromIndex b (from ! i)- inRange (BinPermute b _ _) x = inRange b x- nBins (BinPermute b _ _) = nBins b+ type BinValue (BinPermute b) = BinValue b+ toIndex (BinPermute b to _) !x = to ! toIndex b x+ fromIndex (BinPermute b _ from) !i = fromIndex b (from ! i)+ inRange (BinPermute b _ _) x = inRange b x+ nBins = nBins . permutedBin +instance (Bin1D b) => Bin1D (BinPermute b) where+ lowerLimit = lowerLimit . permutedBin+ upperLimit = upperLimit . permutedBin+ binsList (BinPermute b _ a) = res+ where+ res = G.generate (nBins b) fun+ arr = binsList b `asTypeOf` res+ fun i = arr ! (a ! i)+ binsListRange (BinPermute b _ a) = res+ where+ res = G.generate (nBins b) fun+ arr = binsListRange b `asTypeOf` res+ fun i = arr ! (a ! i)+ {-# INLINE binsList #-}+ {-# INLINE binsListRange #-}++instance VariableBin1D b => VariableBin1D (BinPermute b) where+ binSizeN b i = binSizeN (permutedBin b) (permuteFrom b ! i)+ +instance UniformBin1D b => UniformBin1D (BinPermute b) where+ binSize = binSize . permutedBin+ + instance Show b => Show (BinPermute b) where- show (BinPermute b to _) = unlines [ "# BinPermute"- , "# Permutation = " ++ show (U.toList to)- ] ++ show b+ show (BinPermute b to _) = unlines [ "# BinPermute"+ , "# Permutation = " ++ show (U.toList to)+ ] ++ show b instance Read BinI => Read (BinPermute BinI) where- readPrec = do keyword "BinPermute"- to <- U.fromList <$> value "Permutation"- from <- case checkPermutation (invertPermutation to) of- Just v -> return v- Nothing -> fail "Invalid permutation"- b <- readPrec - return $ BinPermute b to from+ readPrec = do keyword "BinPermute"+ to <- U.fromList <$> value "Permutation"+ b <- readPrec+ from <- case checkPermutationTable b (invertPermutationTable to) of+ Just v -> return v+ Nothing -> fail "Invalid permutation"+ return $ BinPermute b to from + -- Check whether this viable permutation-checkPermutation :: U.Vector Int -> Maybe (U.Vector Int)-checkPermutation v | U.any bad v = Nothing- | otherwise = Just v- where- n = U.length v- bad i = i < 0 || i >= n+checkPermutationTable :: Bin b => b -> U.Vector Int -> Maybe (U.Vector Int)+checkPermutationTable b v = do+ let n = U.length v+ good i = i >= 0 && i < n+ guard $ nBins b == n+ guard $ U.all good v+ return v --- Calculate inverse permutation -invertPermutation :: U.Vector Int -> U.Vector Int-invertPermutation v = U.create $ do a <- M.newWith n (-1)- forM_ [0..n-1] (writeInvert a)- return a++-- Calculate inverse permutation+invertPermutationTable :: U.Vector Int -> U.Vector Int+invertPermutationTable v = U.create $ do a <- M.newWith n (-1)+ forM_ [0..n-1] (writeInvert a)+ return a where n = U.length v writeInvert a i | j >= 0 && j < n = M.write a j i | otherwise = return ()- where j = v ! i+ where j = v ! i ++-- | Constuct bin permutation from table+permuteByTable :: Bin b => b -> U.Vector Int -> Maybe (BinPermute b)+permuteByTable b tbl = BinPermute b <$>+ checkPermutationTable b tbl <*>+ checkPermutationTable b (invertPermutationTable tbl)++ -- | Constuct bin permutation from function.-permuteBin :: Bin b => (Int -> Int) -> b -> Maybe (BinPermute b)-permuteBin f b = BinPermute b <$> checkPermutation to <*> checkPermutation (invertPermutation to)+permuteBin :: Bin b => b -> (Int -> Int) -> Maybe (BinPermute b)+permuteBin b f = BinPermute b <$>+ checkPermutationTable b to <*>+ checkPermutationTable b (invertPermutationTable to) where to = U.map f $ U.enumFromN 0 (nBins b)+
Data/Histogram/Fill.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-} -- | -- Module : Data.Histogram.Fill -- Copyright : Copyright (c) 2009, Alexey Khudyakov <alexey.skladnoy@gmail.com>@@ -11,59 +9,47 @@ -- Module with algorithms for histogram filling. This is pure wrapper -- around stateful histograms. ---module Data.Histogram.Fill ( -- * Type classes+module Data.Histogram.Fill ( -- * Histogram builders API HistBuilder(..)+ , FillableData(..)+ , (<<-)+ , (<<-|)+ , (<<?)+ , (-<<) -- * Histogram builders -- ** Stateful- , HBuilderST+ , HBuilderM , feedOne- , freezeHBuilderST- , joinHBuilderST- , joinHBuilderSTList- , treeHBuilderST- -- ** IO based- , HBuilderIO- , feedOneIO- , freezeHBuilderIO- , joinHBuilderIO- , joinHBuilderIOList- , treeHBuilderIO+ , freezeHBuilderM+ , joinHBuilderM+ , joinHBuilderMonoidM+ , treeHBuilderM+ , treeHBuilderMonoidM -- ** Stateless , HBuilder , joinHBuilder- , joinHBuilderList+ , joinHBuilderMonoid , treeHBuilder- -- ** Conversion between builders- , toBuilderST- , toBuilderIO- , builderSTtoIO- -- * Fill histograms- , fillBuilder- -- * Histogram constructors+ , treeHBuilderMonoid+ -- * Histogram constructors , module Data.Histogram.Bin- -- ** Fixed weigth histograms- , mkHist1- , mkHist- , mkHistMaybe- -- ** Weighted histograms- , mkHistWgh1- , mkHistWgh- , mkHistWghMaybe- -- ** Histograms with monoidal bins- , mkHistMonoid1- , mkHistMonoid- , mkHistMonoidMaybe- -- * Auxillary functions+ , mkSimple+ , mkWeighted+ , mkMonoidal+ -- * Fill histograms+ , fillBuilder+ -- * Auxillary functions , forceInt , forceDouble , forceFloat ) where -import Control.Applicative ((<$>))-import Control.Monad (when)+import Control.Applicative+import Control.Monad (when,liftM,liftM2) import Control.Monad.ST +import Control.Monad.Primitive -import Data.Monoid (Monoid, mempty)+import Data.Monoid (Monoid(..)) import Data.Vector.Unboxed (Unbox) import Data.Histogram@@ -74,266 +60,193 @@ -- Type class ---------------------------------------------------------------- +-- | Data type which could be put into histogram.+class FillableData d where+ -- | Lift putter function to lift putter function to use data type.+ fillData :: PrimMonad m => (a -> m ()) -> d a -> m ()++instance FillableData Maybe where+ fillData f (Just x) = f x+ fillData _ Nothing = return ()+instance FillableData [] where+ fillData = mapM_+ -- | Histogram builder typeclass. Instance of this class contain -- instructions how to build histograms. class HistBuilder h where- -- | Convert input type of histogram from a to a'- modifyIn :: (a' -> a) -> h a b -> h a' b- -- | Make input function accept value only if it's Just a.- modifyMaybe :: h a b -> h (Maybe a) b- -- | Add cut to histogram. Only put value histogram if condition is true.- addCut :: (a -> Bool) -> h a b -> h a b -- | Convert output of histogram- modifyOut :: (b -> b') -> h a b -> h a b'+ modifyOut :: (b -> b') -> h a b -> h a b'+ -- | Convert input type of histogram from a to a'+ modifyIn :: (a' -> a) -> h a b -> h a' b+ -- | Make input function accept value only + modifyWith :: FillableData d => h a b -> h (d a) b+ -- | Add cut to histogram. Value would be putted into histogram only if condition is true.+ addCut :: (a -> Bool) -> h a b -> h a b -------------------------------------------------------------------- ST based builder----------------------------------------------------------------- --- | Stateful histogram builder.-data HBuilderST s a b = HBuilderST { hbInput :: a -> ST s ()- , hbOutput :: ST s b- }+-- | Modify input of builder +(<<-) :: HistBuilder h => h a b -> (a' -> a) -> h a' b+(<<-) = flip modifyIn+{-# INLINE (<<-) #-} -instance HistBuilder (HBuilderST s) where- modifyIn f h = h { hbInput = hbInput h . f }- addCut f h = h { hbInput = \x -> when (f x) (hbInput h x) }- modifyMaybe h = h { hbInput = modified } - where modified (Just x) = hbInput h x- modified Nothing = return ()- modifyOut f h = h { hbOutput = f `fmap` hbOutput h }+-- | Modify input of builder to use composite input+(<<-|) :: (HistBuilder h, FillableData d) => h a b -> (a' -> d a) -> h a' b+h <<-| f = modifyWith h <<- f+{-# INLINE (<<-|) #-} -instance Functor (HBuilderST s a) where- fmap = modifyOut+-- | Add cut for input+(<<?) :: HistBuilder h => h a b -> (a -> Bool) -> h a b+(<<?) = flip addCut+{-# INLINE (<<?) #-} --- | Put one value into histogram-feedOne :: HBuilderST s a b -> a -> ST s ()-feedOne = hbInput+-- | Modify output of histogram. In fact it's same as '<$>' but have opposite fixity+(-<<) :: HistBuilder h => (b -> b') -> h a b -> h a b'+(-<<) = modifyOut+{-# INLINE (-<<) #-} --- | Create stateful histogram from instructions. Histograms could--- be filled either in the ST monad or with createHistograms-freezeHBuilderST :: HBuilderST s a b -> ST s b-freezeHBuilderST = hbOutput+-- Fixity of operator+infixl 5 <<-+infixl 5 <<-|+infixl 5 <<?+infixr 4 -<< --- | Join list of builders into one builder-joinHBuilderST :: [HBuilderST s a b] -> HBuilderST s a [b]-joinHBuilderST hs = HBuilderST { hbInput = \x -> mapM_ (flip hbInput x) hs- , hbOutput = mapM hbOutput hs- }---- | Join list of builders into one builders-joinHBuilderSTList :: [HBuilderST s a [b]] -> HBuilderST s a [b]-joinHBuilderSTList = fmap concat . joinHBuilderST--treeHBuilderST :: [HBuilderST s a b -> HBuilderST s a' b'] -> HBuilderST s a b -> HBuilderST s a' [b']-treeHBuilderST fs h = joinHBuilderST $ map ($ h) fs- ------------------------------------------------------------------- IO based+-- ST based builder ---------------------------------------------------------------- -- | Stateful histogram builder.-data HBuilderIO a b = HBuilderIO { hbInputIO :: a -> IO ()- , hbOutputIO :: IO b+data HBuilderM m a b = HBuilderM { hbInput :: a -> m ()+ , hbOutput :: m b } -instance HistBuilder (HBuilderIO) where- modifyIn f h = h { hbInputIO = hbInputIO h . f }- addCut f h = h { hbInputIO = \x -> when (f x) (hbInputIO h x) }- modifyMaybe h = h { hbInputIO = modified } - where modified (Just x) = hbInputIO h x- modified Nothing = return ()- modifyOut f h = h { hbOutputIO = f `fmap` hbOutputIO h }+instance PrimMonad m => HistBuilder (HBuilderM m) where+ modifyIn f h = h { hbInput = hbInput h . f }+ addCut f h = h { hbInput = \x -> when (f x) (hbInput h x) }+ modifyWith h = h { hbInput = fillData (hbInput h) } + modifyOut f h = h { hbOutput = f `liftM` hbOutput h } -instance Functor (HBuilderIO a) where+instance PrimMonad m => Functor (HBuilderM m a) where fmap = modifyOut-+instance PrimMonad m => Applicative (HBuilderM m a) where+ pure x = HBuilderM { hbInput = const $ return ()+ , hbOutput = return x+ }+ f <*> g = HBuilderM { hbInput = \a -> hbInput f a >> hbInput g a+ , hbOutput = do a <- hbOutput f+ b <- hbOutput g+ return (a b)+ }+ -- | Put one value into histogram-feedOneIO :: HBuilderIO a b -> a -> IO ()-feedOneIO = hbInputIO+feedOne :: PrimMonad m => HBuilderM m a b -> a -> m ()+feedOne = hbInput+{-# INLINE feedOne #-} -- | Create stateful histogram from instructions. Histograms could -- be filled either in the ST monad or with createHistograms-freezeHBuilderIO :: HBuilderIO a b -> IO b-freezeHBuilderIO = hbOutputIO+freezeHBuilderM :: PrimMonad m => HBuilderM m a b -> m b+freezeHBuilderM = hbOutput+{-# INLINE freezeHBuilderM #-} -- | Join list of builders into one builder-joinHBuilderIO :: [HBuilderIO a b] -> HBuilderIO a [b]-joinHBuilderIO hs = HBuilderIO { hbInputIO = \x -> mapM_ (flip hbInputIO x) hs- , hbOutputIO = mapM hbOutputIO hs- }+joinHBuilderM :: PrimMonad m => [HBuilderM m a b] -> HBuilderM m a [b]+joinHBuilderM hs = HBuilderM { hbInput = \x -> mapM_ (flip hbInput x) hs+ , hbOutput = mapM hbOutput hs+ }+{-# INLINE joinHBuilderM #-} -- | Join list of builders into one builders-joinHBuilderIOList :: [HBuilderIO a [b]] -> HBuilderIO a [b]-joinHBuilderIOList = fmap concat . joinHBuilderIO+joinHBuilderMonoidM :: (PrimMonad m, Monoid b) => [HBuilderM m a b] -> HBuilderM m a b+joinHBuilderMonoidM = fmap mconcat . joinHBuilderM+{-# INLINE joinHBuilderMonoidM #-} -treeHBuilderIO :: [HBuilderIO a b -> HBuilderIO a' b'] -> HBuilderIO a b -> HBuilderIO a' [b']-treeHBuilderIO fs h = joinHBuilderIO $ map ($ h) fs+treeHBuilderM :: PrimMonad m => [HBuilderM m a b -> HBuilderM m a' b'] -> HBuilderM m a b -> HBuilderM m a' [b']+treeHBuilderM fs h = joinHBuilderM $ map ($ h) fs+{-# INLINE treeHBuilderM #-} +treeHBuilderMonoidM :: (PrimMonad m, Monoid b') => + [HBuilderM m a b -> HBuilderM m a' b'] -> HBuilderM m a b -> HBuilderM m a' b'+treeHBuilderMonoidM fs h = joinHBuilderMonoidM $ map ($ h) fs+{-# INLINE treeHBuilderMonoidM #-}++ ---------------------------------------------------------------- -- Stateless ---------------------------------------------------------------- -- | Stateless histogram builder-newtype HBuilder a b = HBuilder { toBuilderST :: (forall s . ST s (HBuilderST s a b)) }+newtype HBuilder a b = HBuilder { toBuilderM :: (forall s . ST s (HBuilderM (ST s) a b)) } instance HistBuilder (HBuilder) where modifyIn f (HBuilder h) = HBuilder (modifyIn f <$> h) addCut f (HBuilder h) = HBuilder (addCut f <$> h)- modifyMaybe (HBuilder h) = HBuilder (modifyMaybe <$> h)+ modifyWith (HBuilder h) = HBuilder (modifyWith <$> h) modifyOut f (HBuilder h) = HBuilder (modifyOut f <$> h) instance Functor (HBuilder a) where fmap = modifyOut+instance Applicative (HBuilder a) where+ pure x = HBuilder (return $ pure x)+ (HBuilder f) <*> (HBuilder g) = HBuilder $ liftM2 (<*>) f g -- | Join list of builders joinHBuilder :: [HBuilder a b] -> HBuilder a [b]-joinHBuilder hs = HBuilder (joinHBuilderST <$> mapM toBuilderST hs)+joinHBuilder hs = HBuilder (joinHBuilderM <$> mapM toBuilderM hs)+{-# INLINE joinHBuilder #-} -- | Join list of builders-joinHBuilderList :: [HBuilder a [b]] -> HBuilder a [b]-joinHBuilderList = modifyOut concat . joinHBuilder+joinHBuilderMonoid :: Monoid b => [HBuilder a b] -> HBuilder a b+joinHBuilderMonoid = modifyOut mconcat . joinHBuilder+{-# INLINE joinHBuilderMonoid #-} treeHBuilder :: [HBuilder a b -> HBuilder a' b'] -> HBuilder a b -> HBuilder a' [b'] treeHBuilder fs h = joinHBuilder $ map ($ h) fs+{-# INLINE treeHBuilder #-} +treeHBuilderMonoid :: Monoid b' => [HBuilder a b -> HBuilder a' b'] -> HBuilder a b -> HBuilder a' b'+treeHBuilderMonoid fs h = joinHBuilderMonoid $ map ($ h) fs+{-# INLINE treeHBuilderMonoid #-}++ ------------------------------------------------------------------- Conversions+-- Constructors ---------------------------------------------------------------- --- | Convert ST base builder to IO based one-builderSTtoIO :: HBuilderST RealWorld a b -> HBuilderIO a b-builderSTtoIO (HBuilderST i o) = HBuilderIO (stToIO . i) (stToIO o)+mkSimple :: (Bin bin, Unbox val, Num val+ ) => bin -> HBuilder (BinValue bin) (Histogram bin val)+mkSimple bin = + HBuilder $ do acc <- newMHistogram 0 bin+ return $ HBuilderM { hbInput = fillOne acc+ , hbOutput = freezeHist acc+ }+{-# INLINE mkSimple #-} --- | Convert stateless builder to IO based one-toBuilderIO :: HBuilder a b -> IO (HBuilderIO a b)-toBuilderIO h = builderSTtoIO `fmap` stToIO (toBuilderST h)+mkWeighted :: (Bin bin, Unbox val, Num val+ ) => bin -> HBuilder (BinValue bin,val) (Histogram bin val)+mkWeighted bin = HBuilder $ do acc <- newMHistogram 0 bin+ return $ HBuilderM { hbInput = fillOneW acc+ , hbOutput = freezeHist acc+ }+{-# INLINE mkWeighted #-} +mkMonoidal :: (Bin bin, Unbox val, Monoid val+ ) => bin -> HBuilder (BinValue bin,val) (Histogram bin val)+mkMonoidal bin = HBuilder $ do acc <- newMHistogram mempty bin+ return $ HBuilderM { hbInput = fillMonoid acc+ , hbOutput = freezeHist acc+ }+{-# INLINE mkMonoidal #-}+ ---------------------------------------------------------------- -- Actual filling of histograms ---------------------------------------------------------------- fillBuilder :: HBuilder a b -> [a] -> b fillBuilder hb xs = - runST $ do h <- toBuilderST hb+ runST $ do h <- toBuilderM hb mapM_ (feedOne h) xs- freezeHBuilderST h- -------------------------------------------------------------------- Histogram constructors--------------------------------------------------------------------- | Create histogram builder which take single item as input. Each--- item has weight 1.-mkHist1 :: (Bin bin, Unbox val, Num val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function - -> (a -> BinValue bin) -- ^ Input function- -> HBuilder a b-mkHist1 bin out inp = HBuilder $ do- acc <- newMHistogram 0 bin- return $ HBuilderST { hbInput = fillOne acc . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram builder which take many items as input. Each--- item has weight 1.-mkHist :: (Bin bin, Unbox val, Num val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> [BinValue bin]) -- ^ Input function - -> HBuilder a b-mkHist bin out inp = HBuilder $ do- acc <- newMHistogram 0 bin- return $ HBuilderST { hbInput = mapM_ (fillOne acc) . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram builder which at most one item as input. Each--- item has weight 1. -mkHistMaybe :: (Bin bin, Unbox val, Num val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> Maybe (BinValue bin)) -- ^ Input function - -> HBuilder a b-mkHistMaybe bin out inp = HBuilder $ do- acc <- newMHistogram 0 bin- return $ HBuilderST { hbInput = maybe (return ()) (fillOne acc) . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram with weighted bin. Takes one item at time. -mkHistWgh1 :: (Bin bin, Unbox val, Num val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> (BinValue bin, val)) -- ^ Input function- -> HBuilder a b-mkHistWgh1 bin out inp = HBuilder $ do- acc <- newMHistogram 0 bin- return $ HBuilderST { hbInput = fillOneW acc . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram with weighted bin. Takes many items at time.-mkHistWgh :: (Bin bin, Unbox val, Num val) => - bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> [(BinValue bin, val)]) -- ^ Input function- -> HBuilder a b-mkHistWgh bin out inp = HBuilder $ do- acc <- newMHistogram 0 bin- return $ HBuilderST { hbInput = mapM_ (fillOneW acc) . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram with weighted bin. Takes many items at time.-mkHistWghMaybe :: (Bin bin, Unbox val, Num val) => - bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> Maybe (BinValue bin, val)) -- ^ Input function- -> HBuilder a b-mkHistWghMaybe bin out inp = HBuilder $ do- acc <- newMHistogram 0 bin- return $ HBuilderST { hbInput = maybe (return ()) (fillOneW acc) . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram with monoidal bins-mkHistMonoid1 :: (Bin bin, Unbox val, Monoid val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> (BinValue bin, val)) -- ^ Input function- -> HBuilder a b-mkHistMonoid1 bin out inp = HBuilder $ do- acc <- newMHistogram mempty bin- return $ HBuilderST { hbInput = fillMonoid acc . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram with monoidal bins. Takes many items at time.-mkHistMonoid :: (Bin bin, Unbox val, Monoid val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> [(BinValue bin, val)]) -- ^ Input function- -> HBuilder a b-mkHistMonoid bin out inp = HBuilder $ do- acc <- newMHistogram mempty bin- return $ HBuilderST { hbInput = mapM_ (fillMonoid acc) . inp- , hbOutput = fmap out (freezeHist acc)- }---- | Create histogram with monoidal bins-mkHistMonoidMaybe :: (Bin bin, Unbox val, Monoid val) =>- bin -- ^ Bin information- -> (Histogram bin val -> b) -- ^ Output function- -> (a -> Maybe (BinValue bin, val)) -- ^ Input function- -> HBuilder a b-mkHistMonoidMaybe bin out inp = HBuilder $ do- acc <- newMHistogram mempty bin- return $ HBuilderST { hbInput = maybe (return ()) (fillMonoid acc) . inp- , hbOutput = fmap out (freezeHist acc)- }+ freezeHBuilderM h ----------------------------------------------------------------
Data/Histogram/Generic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Histogram -- Copyright : Copyright (c) 2009, Alexey Khudyakov <alexey.skladnoy@gmail.com>@@ -32,6 +32,7 @@ , histMap , histMapBin , histZip+ , histZipSafe ) where import Control.Applicative ((<$>),(<*>))@@ -40,7 +41,8 @@ import Control.Monad.ST (runST) import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic as G+import Data.Typeable (Typeable1(..), Typeable2(..), mkTyConApp, mkTyCon) import Data.Vector.Generic (Vector) import Text.Read @@ -54,7 +56,7 @@ -- | Immutable histogram. Histogram consists of binning algorithm, -- optional number of under and overflows, and data. data Histogram v bin a = Histogram bin (Maybe (a,a)) (v a)- deriving Eq+ deriving (Eq) -- | Create histogram from binning algorithm and vector with -- data. Overflows are set to Nothing. @@ -79,7 +81,7 @@ instance (Show a, Show (BinValue bin), Show bin, Bin bin, Vector v a) => Show (Histogram v bin a) where show h@(Histogram bin uo _) = "# Histogram\n" ++ showUO uo ++ show bin ++- (unlines $ map showT $ asList h)+ unlines (map showT $ asList h) where showT (x,y) = show x ++ "\t" ++ show y showUO (Just (u,o)) = "# Underflows = " ++ show u ++ "\n" ++@@ -87,6 +89,9 @@ showUO Nothing = "# Underflows = \n" ++ "# Overflows = \n" +instance Typeable1 v => Typeable2 (Histogram v) where+ typeOf2 h = mkTyConApp (mkTyCon "Data.Histogram.Generic.Histogram") [typeOf1 (histData h)]+ -- Parse histogram header histHeader :: (Read bin, Read a, Bin bin, Vector v a) => ReadPrec (v a -> Histogram v bin a) histHeader = do@@ -161,7 +166,7 @@ where bin' = bin --- | Zip two histograms together. Bins of histograms must be equal+-- | Zip two histograms elementwise. Bins of histograms must be equal -- otherwise error will be called. histZip :: (Bin bin, Eq bin, Vector v a, Vector v b, Vector v c) => (a -> b -> c) -> Histogram v bin a -> Histogram v bin b -> Histogram v bin c@@ -170,7 +175,17 @@ | otherwise = Histogram bin (f2 <$> uo <*> uo') (G.zipWith f v v') where f2 (x,x') (y,y') = (f x y, f x' y')- ++-- | Zip two histogram elementwise. If bins are not equal return `Nothing`+histZipSafe :: (Bin bin, Eq bin, Vector v a, Vector v b, Vector v c) =>+ (a -> b -> c) -> Histogram v bin a -> Histogram v bin b -> Maybe (Histogram v bin c)+histZipSafe f (Histogram bin uo v) (Histogram bin' uo' v')+ | bin /= bin' = Nothing+ | otherwise = Just $ Histogram bin (f2 <$> uo <*> uo') (G.zipWith f v v')+ where+ f2 (x,x') (y,y') = (f x y, f x' y')++ -- | Slice 2D histogram along Y axis. This function is fast because it does not require reallocations. sliceY :: (Vector v a, Bin bX, Bin bY) => Histogram v (Bin2D bX bY) a -> [(BinValue bY, Histogram v bX a)] sliceY (Histogram b _ a) = map mkSlice [0 .. ny-1]
Data/Histogram/Parse.hs view
@@ -36,8 +36,8 @@ -- Return optional value maybeValue :: Read a => String -> ReadPrec (Maybe a)-maybeValue str = do lift $ key str >> eq- (lift $ ws >> eol >> return Nothing) <++ (Just `fmap` getVal)+maybeValue str = do lift (key str >> eq)+ lift (ws >> eol >> return Nothing) <++ (Just `fmap` getVal) -- Keyword keyword :: String -> ReadPrec ()
Data/Histogram/ST.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE Rank2Types #-} -- | -- Module : Data.Histogram.ST -- Copyright : Copyright (c) 2009, Alexey Khudyakov <alexey.skladnoy@gmail.com>@@ -16,11 +14,11 @@ , fillOne , fillOneW , fillMonoid+ , unsafeFreezeHist , freezeHist ) where --import Control.Monad.ST+import Control.Monad.Primitive import Data.Monoid import qualified Data.Vector.Unboxed as U@@ -34,16 +32,11 @@ ---------------------------------------------------------------- -- | Mutable histogram.-data MHistogram s bin a where- MHistogram :: (Bin bin, MU.Unbox a) => - bin -- Binning- -> MU.MVector s a -- Over/underflows- -> MU.MVector s a -- Data- -> MHistogram s bin a+data MHistogram s bin a = MHistogram bin (MU.MVector s a) (MU.MVector s a) -- | Create new mutable histogram. All bins are set to zero element as -- passed to function.-newMHistogram :: (Bin bin, U.Unbox a) => a -> bin -> ST s (MHistogram s bin a)+newMHistogram :: (PrimMonad m, Bin bin, U.Unbox a) => a -> bin -> m (MHistogram (PrimState m) bin a) newMHistogram zero bin = do uo <- MU.newWith 2 zero a <- MU.newWith (nBins bin) zero@@ -51,8 +44,8 @@ {-# INLINE newMHistogram #-} -- | Put one value into histogram-fillOne :: Num a => MHistogram s bin a -> BinValue bin -> ST s ()-fillOne (MHistogram bin uo arr) x+fillOne :: (PrimMonad m, Num a, U.Unbox a, Bin bin) => MHistogram (PrimState m) bin a -> BinValue bin -> m ()+fillOne (MHistogram bin uo arr) !x | i < 0 = MU.unsafeWrite uo 0 . (+1) =<< MU.unsafeRead uo 0 | i >= MU.length arr = MU.unsafeWrite uo 1 . (+1) =<< MU.unsafeRead uo 1 | otherwise = MU.unsafeWrite arr i . (+1) =<< MU.unsafeRead arr i@@ -61,8 +54,8 @@ {-# INLINE fillOne #-} -- | Put one value into histogram with weight-fillOneW :: Num a => MHistogram s bin a -> (BinValue bin, a) -> ST s ()-fillOneW (MHistogram bin uo arr) (x,w)+fillOneW :: (PrimMonad m, Num a, U.Unbox a, Bin bin) => MHistogram (PrimState m) bin a -> (BinValue bin, a) -> m ()+fillOneW (MHistogram bin uo arr) !(x,w) | i < 0 = MU.unsafeWrite uo 0 . (+w) =<< MU.unsafeRead uo 0 | i >= MU.length arr = MU.unsafeWrite uo 1 . (+w) =<< MU.unsafeRead uo 1 | otherwise = MU.unsafeWrite arr i . (+w) =<< MU.unsafeRead arr i@@ -71,17 +64,28 @@ {-# INLINE fillOneW #-} -- | Put one monoidal element-fillMonoid :: Monoid a => MHistogram s bin a -> (BinValue bin, a) -> ST s ()-fillMonoid (MHistogram bin uo arr) (x,m)- | i < 0 = MU.unsafeWrite uo 1 . (flip mappend m) =<< MU.unsafeRead uo 0- | i >= MU.length arr = MU.unsafeWrite uo 1 . (flip mappend m) =<< MU.unsafeRead uo 1- | otherwise = MU.unsafeWrite arr i . (flip mappend m) =<< MU.unsafeRead arr i+fillMonoid :: (PrimMonad m, Monoid a, U.Unbox a, Bin bin) => MHistogram (PrimState m) bin a -> (BinValue bin, a) -> m ()+fillMonoid (MHistogram bin uo arr) !(x,m)+ | i < 0 = MU.unsafeWrite uo 1 . flip mappend m =<< MU.unsafeRead uo 0+ | i >= MU.length arr = MU.unsafeWrite uo 1 . flip mappend m =<< MU.unsafeRead uo 1+ | otherwise = MU.unsafeWrite arr i . flip mappend m =<< MU.unsafeRead arr i where i = toIndex bin x-{-# fillMonoid #-}+{-# INLINE fillMonoid #-} --- | Create immutable histogram from mutable one. This operation involve copying.-freezeHist :: MHistogram s bin a -> ST s (Histogram bin a)++-- | Create immutable histogram from mutable one. This operation is+-- unsafe! Accumulator mustn't be used after that+unsafeFreezeHist :: (PrimMonad m, U.Unbox a, Bin bin) => MHistogram (PrimState m) bin a -> m (Histogram bin a)+unsafeFreezeHist (MHistogram bin uo arr) = do+ u <- MU.unsafeRead uo 0+ o <- MU.unsafeRead uo 1+ a <- G.unsafeFreeze arr+ return $ histogramUO bin (Just (u,o)) a+{-# INLINE unsafeFreezeHist #-} ++-- | Create immutable histogram from mutable one.+freezeHist :: (PrimMonad m, U.Unbox a, Bin bin) => MHistogram (PrimState m) bin a -> m (Histogram bin a) freezeHist (MHistogram bin uo arr) = do u <- MU.unsafeRead uo 0 o <- MU.unsafeRead uo 1
histogram-fill.cabal view
@@ -1,5 +1,5 @@ Name: histogram-fill-Version: 0.2.0+Version: 0.3 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE@@ -12,15 +12,13 @@ Description: This is library for histograms filling. Its aim to provide convenient way to create and fill histograms. - .- This is very much work in progress so expect API breakage in future relesases. source-repository head type: hg location: http://bitbucket.org/Shimuuar/histogram-fill Library- Build-Depends: base >=3 && <5, vector+ Build-Depends: base >=3 && <5, primitive, vector Exposed-modules: Data.Histogram Data.Histogram.Generic Data.Histogram.Fill