diff --git a/Data/Histogram/Bin.hs b/Data/Histogram/Bin.hs --- a/Data/Histogram/Bin.hs +++ b/Data/Histogram/Bin.hs @@ -72,8 +72,8 @@ -- Type classes ---------------------------------------------------------------- --- | This type represent some abstract data binning algorithms. --- It maps some value to integer indices. +-- | This type represent some abstract data binning algorithms. Such +-- algorithm maps sets of values to integer indices. -- -- Following invariant is expected to hold: -- @@ -81,11 +81,11 @@ class Bin b where -- | Type of value to bin type BinValue b - -- | Convert from value to index. No bound checking - -- performed. Function must not fail for any input. + -- | Convert from value to index. Function must not fail for any + -- input and should produce out of range indices for invalid 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 + -- 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 @@ -143,6 +143,10 @@ ---------------------------------------------------------------- -- | Simple binning algorithm which map continous range of bins onto -- indices. Each number correcsponds to different bin +-- +-- 1. Lower bound (inclusive) +-- +-- 2. Upper bound (inclusive) data BinI = BinI {-# UNPACK #-} !Int -- Lower bound (inclusive) {-# UNPACK #-} !Int -- Upper bound (inclusive) @@ -190,6 +194,12 @@ ---------------------------------------------------------------- -- | Integer bins with size which differ from 1. +-- +-- 1. Low bound +-- +-- 2. Bin size +-- +-- 3. Number of bins data BinInt = BinInt {-# UNPACK #-} !Int -- Low bound {-# UNPACK #-} !Int -- Bin size @@ -281,6 +291,12 @@ -- -- Note that due to GHC bug #2271 this toIndex is really slow (20x -- slowdown with respect to BinD) and use of BinD is recommended +-- +-- 1. Lower bound +-- +-- 2. Size of bin +-- +-- 3. Number of bins data BinF f = BinF {-# UNPACK #-} !f -- Lower bound {-# UNPACK #-} !f -- Size of bin {-# UNPACK #-} !Int -- Number of bins @@ -355,6 +371,12 @@ ---------------------------------------------------------------- -- | Floaintg point bins with equal sizes. If you work with Doubles -- this data type should be used instead of BinF. +-- +-- 1. Lower bound +-- +-- 2. Size of bin +-- +-- 3. Number of bins data BinD = BinD {-# UNPACK #-} !Double -- Lower bound {-# UNPACK #-} !Double -- Size of bin {-# UNPACK #-} !Int -- Number of bins @@ -432,6 +454,14 @@ -- Log-scale bin ---------------------------------------------------------------- -- | Logarithmic scale bins. +-- +-- 1. Lower bound +-- +-- 2. Upper bound +-- +-- 2. Increment ratio +-- +-- 3. Number of bins data LogBinD = LogBinD Double -- Low border Double -- Hi border diff --git a/Data/Histogram/Fill.hs b/Data/Histogram/Fill.hs --- a/Data/Histogram/Fill.hs +++ b/Data/Histogram/Fill.hs @@ -6,12 +6,10 @@ -- Maintainer : Alexey Khudyakov -- Stability : experimental -- --- Module with algorithms for histogram filling. This is pure wrapper --- around stateful histograms. +-- Stateful and pure (still stateful under the hood) accumulators. -- -module Data.Histogram.Fill ( -- * Histogram builders API +module Data.Histogram.Fill ( -- * Builder type class HistBuilder(..) - , FillableData(..) , (<<-) , (<<-|) , (< (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. +-- | Type class for stateful accumulators. In this module they are +-- called builders. Every builder is parametrized by two +-- types. First one is type of values which are fed to accumulator +-- and second one is type of values which could be extracted from +-- it. +-- +-- Every instance of 'HBuilder' should be instance of 'Functor' too +-- and satisfy 'fmap' == 'modifyOut'. class HistBuilder h where - -- | Convert output of histogram - 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 + -- | Apply function to output of histogram. + modifyOut :: (b -> b') -> h a b -> h a b' + -- | Change input of builder by applying function to it. + modifyIn :: (a' -> a) -> h a b -> h a' b + -- | Put all values in container into builder + fromContainer :: F.Foldable f => h a b -> h (f 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 --- | Modify input of builder +-- | Modify input of builder (<<-) :: HistBuilder h => h a b -> (a' -> a) -> h a' b (<<-) = flip modifyIn {-# INLINE (<<-) #-} -- | 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 +(<<-|) :: (HistBuilder h, F.Foldable f) => h a b -> (a' -> f a) -> h a' b +h <<-| f = fromContainer h <<- f {-# INLINE (<<-|) #-} -- | Add cut for input @@ -114,20 +116,84 @@ infixr 4 -<< +-- $examples +-- +-- All examples will make use of operators to create builders. It's +-- possible to avoid their use but operators offer clear notation and +-- compose nicely in pipeline. Also note that data flows from right to +-- left as with '.' operator. +-- +-- First example just counts ints in in [0..4] inclusive range. +-- 'fillBuilder' is used to put all values into accumulator. +-- +-- > ghci> let h = forceInt -<< mkSimple (BinI 0 4) +-- > ghci> fillBuilder h [0,0,0,1,1,2,3,4,4,4] +-- > # Histogram +-- > # Underflows = 0 +-- > # Overflows = 0 +-- > # BinI +-- > # Low = 0 +-- > # High = 4 +-- > 0 3 +-- > 1 2 +-- > 2 1 +-- > 3 1 +-- > 4 3 +-- +-- More involved example only accept even numbers. Filtering could be +-- achieved with either 'addCut' or '< forceInt -<< mkSimple (BinI 0 4) < (,) <$> +-- > (forceInt -<< mkSimple (BinI 0 4) < (forceInt -<< mkSimple (BinI 0 4) < joinHBuilder [ +-- > forceInt -<< mkSimple (BinI 0 4) < , forceInt -<< mkSimple (BinI 0 4) < ] +-- +-- If one wants to collect result from many histograms he can take an +-- advantage of 'Monoid' instance of 'HBuilder'. Example below +-- concatenates string outputs of individual histograms. +-- +-- > mconcat [ +-- > show . forceInt -<< mkSimple (BinI 0 4) < , show . forceInt -<< mkSimple (BinI 0 4) < ] + + ---------------------------------------------------------------- --- ST based builder +-- Monadic builder ---------------------------------------------------------------- --- | Stateful histogram builder. +-- | Stateful histogram builder. There is no direct way to construct +-- such builder. Only way to do it is to create 'HBuilder' and use +-- 'toHBuilderST' or 'toHBuilderIO'. +-- +-- It's useful when result should be extracted many times from the +-- same accumulator. data HBuilderM m a b = HBuilderM { hbInput :: a -> m () , hbOutput :: m b } 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 } + modifyIn f h = h { hbInput = hbInput h . f } + addCut f h = h { hbInput = \x -> when (f x) (hbInput h x) } + fromContainer h = h { hbInput = F.mapM_ (hbInput h) } + modifyOut f h = h { hbOutput = f `liftM` hbOutput h } instance PrimMonad m => Functor (HBuilderM m a) where fmap = modifyOut @@ -140,8 +206,17 @@ b <- hbOutput g return (a b) } - --- | Put one value into histogram + +instance (PrimMonad m, Monoid b) => Monoid (HBuilderM m a b) where + mempty = HBuilderM { hbInput = \_ -> return () + , hbOutput = return mempty + } + mappend h1 h2 = mappend <$> h1 <*> h2 + mconcat = fmap mconcat . joinHBuilderM + {-# INLINE mempty #-} + {-# INLINE mconcat #-} + +-- | Put one item into histogram feedOne :: PrimMonad m => HBuilderM m a b -> a -> m () feedOne = hbInput {-# INLINE feedOne #-} @@ -152,106 +227,112 @@ freezeHBuilderM = hbOutput {-# INLINE freezeHBuilderM #-} --- | Join list of builders into one builder -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 +-- | Join histogram builders in container +joinHBuilderM :: (F.Traversable f, PrimMonad m) => f (HBuilderM m a b) -> HBuilderM m a (f b) +joinHBuilderM hs = HBuilderM { hbInput = \x -> F.mapM_ (flip hbInput x) hs + , hbOutput = F.mapM hbOutput hs } {-# INLINE joinHBuilderM #-} --- | Join list of builders into one builders -joinHBuilderMonoidM :: (PrimMonad m, Monoid b) => [HBuilderM m a b] -> HBuilderM m a b -joinHBuilderMonoidM = fmap mconcat . joinHBuilderM -{-# INLINE joinHBuilderMonoidM #-} - -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 +-- | Apply functions to builder +treeHBuilderM :: (PrimMonad m, F.Traversable f) => f (HBuilderM m a b -> HBuilderM m a' b') -> HBuilderM m a b -> HBuilderM m a' (f b') +treeHBuilderM fs h = joinHBuilderM $ fmap ($ 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 ---------------------------------------------------------------- -- | Stateless histogram builder -newtype HBuilder a b = HBuilder { toHBuilderST :: (forall s . ST s (HBuilderM (ST s) a b)) - -- ^ Convert builder to stateful builder in 'ST' monad +newtype HBuilder a b = HBuilder { toHBuilderST :: (forall s . ST s (HBuilderM (ST s) a b)) + -- ^ Convert builder to stateful builder in ST monad } -- | Convert builder to builder in IO monad toHBuilderIO :: HBuilder a b -> IO (HBuilderM IO a b) -toHBuilderIO (HBuilder h) = do +toHBuilderIO (HBuilder h) = do builder <- stToIO h - return (HBuilderM - (stToIO . hbInput builder) + return (HBuilderM + (stToIO . hbInput builder) (stToIO $ hbOutput builder)) {-# INLINE toHBuilderIO #-} - + instance HistBuilder (HBuilder) where - modifyIn f (HBuilder h) = HBuilder (modifyIn f <$> h) - addCut f (HBuilder h) = HBuilder (addCut f <$> h) - modifyWith (HBuilder h) = HBuilder (modifyWith <$> h) - modifyOut f (HBuilder h) = HBuilder (modifyOut f <$> h) + modifyIn f (HBuilder h) = HBuilder (modifyIn f <$> h) + addCut f (HBuilder h) = HBuilder (addCut f <$> h) + fromContainer (HBuilder h) = HBuilder (fromContainer <$> 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 + (HBuilder f) <*> (HBuilder g) = HBuilder $ liftM2 (<*>) f g +instance Monoid b => Monoid (HBuilder a b) where + mempty = HBuilder (return mempty) + mappend h g = mappend <$> h <*> g + mconcat = fmap mconcat . joinHBuilder + {-# INLINE mempty #-} + {-# INLINE mconcat #-} --- | Join list of builders -joinHBuilder :: [HBuilder a b] -> HBuilder a [b] -joinHBuilder hs = HBuilder (joinHBuilderM <$> mapM toHBuilderST hs) +-- | Join hitogram builders in container. +joinHBuilder :: F.Traversable f => f (HBuilder a b) -> HBuilder a (f b) +joinHBuilder hs = HBuilder (joinHBuilderM <$> F.mapM toHBuilderST hs) {-# INLINE joinHBuilder #-} --- | Join list of builders -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 +-- | Apply function to builder +treeHBuilder :: F.Traversable f => f (HBuilder a b -> HBuilder a' b') -> HBuilder a b -> HBuilder a' (f b') +treeHBuilder fs h = joinHBuilder $ fmap ($ 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 #-} ---------------------------------------------------------------- -- Constructors ---------------------------------------------------------------- +-- | Create builder. Bin content will be incremented by 1 for each +-- item put into histogram mkSimple :: (Bin bin, Unbox val, Num val ) => bin -> HBuilder (BinValue bin) (Histogram bin val) -mkSimple bin = +mkSimple bin = HBuilder $ do acc <- newMHistogram 0 bin - return $ HBuilderM { hbInput = fillOne acc - , hbOutput = freezeHist acc - } + return HBuilderM { hbInput = fillOne acc + , hbOutput = freezeHist acc + } {-# INLINE mkSimple #-} +-- | Create builder. Bin content will incremented by weight supplied +-- for each item put into histogram 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 - } + return HBuilderM { hbInput = fillOneW acc + , hbOutput = freezeHist acc + } {-# INLINE mkWeighted #-} +-- | Create builder. New value wil be mappended to current content of +-- a bin for each item put into histogram 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 - } + return HBuilderM { hbInput = fillMonoid acc + , hbOutput = freezeHist acc + } {-# INLINE mkMonoidal #-} + +-- | Create histogram builder which just does ordinary pure fold. It +-- is intended for use when some fold should be performed together +-- with histogram filling +mkFolder :: b -> (a -> b -> b) -> HBuilder a b +mkFolder a f = HBuilder $ do ref <- newSTRef a + return HBuilderM { hbInput = \x -> modifySTRef ref (f x) + , hbOutput = readSTRef ref + } +{-# INLINE mkFolder #-} + -- mkMonoidalAcc :: (Bin bin, Unbox val, StatMonoid val a -- ) => bin -> HBuilder (BinValue bin,a) (Histogram bin val) -- mkMonoidalAcc bin = HBuilder $ do acc <- newMHistogram mempty bin @@ -264,22 +345,57 @@ -- Actual filling of histograms ---------------------------------------------------------------- -fillBuilder :: HBuilder a b -> [a] -> b -fillBuilder hb xs = +-- | Fill histogram builder. +fillBuilder :: F.Foldable f => HBuilder a b -> f a -> b +fillBuilder hb xs = runST $ do h <- toHBuilderST hb - mapM_ (feedOne h) xs + F.mapM_ (feedOne h) xs freezeHBuilderM h ---------------------------------------------------------------- --- | Function used to restrict type of histrogram. +-- $auxillary +-- +-- In some cases builder constructors do not constrain output type +-- enough. Output type is still parametric in value type of histogram. +-- Functions below are just 'id' function with more restrictive +-- signature. +-- +-- In example below 'forceInt' used to fix type of histogram to +-- 'Histogram BinI Int'. Without it compiler cannot infer type of +-- intermediate histogram. +-- +-- > show . forceInt -<< mkSimple (BinI 1 10) + forceInt :: Histogram bin Int -> Histogram bin Int forceInt = id --- | Function used to restrict type of histrogram. forceDouble :: Histogram bin Double -> Histogram bin Double forceDouble = id --- | Function used to restrict type of histrogram. forceFloat :: Histogram bin Float -> Histogram bin Float forceFloat = id + +---------------------------------------------------------------- +-- | Join list of builders into one builders +joinHBuilderMonoidM :: (PrimMonad m, Monoid b) => [HBuilderM m a b] -> HBuilderM m a b +joinHBuilderMonoidM = mconcat +{-# INLINE joinHBuilderMonoidM #-} +{-# DEPRECATED joinHBuilderMonoidM "Use mconcat instead. Will be removed in 0.5" #-} + +-- | Join list of builders +joinHBuilderMonoid :: Monoid b => [HBuilder a b] -> HBuilder a b +joinHBuilderMonoid = mconcat +{-# INLINE joinHBuilderMonoid #-} +{-# DEPRECATED joinHBuilderMonoid "Use mconcat instead. Will be removed in 0.5" #-} + +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 #-} +{-# DEPRECATED treeHBuilderMonoidM "Will be removed in 0.5" #-} + +treeHBuilderMonoid :: Monoid b' => [HBuilder a b -> HBuilder a' b'] -> HBuilder a b -> HBuilder a' b' +treeHBuilderMonoid fs h = joinHBuilderMonoid $ map ($ h) fs +{-# INLINE treeHBuilderMonoid #-} +{-# DEPRECATED treeHBuilderMonoid "Will be removed in 0.5" #-} diff --git a/histogram-fill.cabal b/histogram-fill.cabal --- a/histogram-fill.cabal +++ b/histogram-fill.cabal @@ -1,5 +1,5 @@ Name: histogram-fill -Version: 0.3.1 +Version: 0.4 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE