module Data.Histogram.Generic (
Histogram
, module Data.Histogram.Bin
, histogram
, histogramUO
, HistIndex(..)
, histIndex
, readHistogram
, readFileHistogram
, bins
, histData
, underflows
, overflows
, outOfRange
, asList
, asVector
, map
, bmap
, mapData
, zip
, zipSafe
, convert
, convertBinning
, foldl
, bfoldl
, slice
, rebin
, rebinFold
, sliceAlongX
, sliceAlongY
, listSlicesAlongX
, listSlicesAlongY
, reduceX
, reduceY
, liftX
, liftY
) where
import Control.Applicative ((<$>),(<*>))
import Control.Arrow ((***), (&&&))
import Control.Monad (ap)
import Control.DeepSeq (NFData(..))
import qualified Data.Vector.Generic as G
import Data.Maybe (fromMaybe)
import Data.Typeable
import Data.Vector.Generic (Vector,(!))
import Text.Read
import Prelude hiding (map,zip,foldl)
import qualified Prelude (zip)
import Data.Histogram.Bin
import Data.Histogram.Bin.Read
data Histogram v bin a = Histogram bin (Maybe (a,a)) (v a)
deriving (Eq)
data HistIndex b
= Index Int
| Value (BinValue b)
deriving (Typeable)
histIndex :: Bin b => b -> HistIndex b -> Int
histIndex _ (Index i) = i
histIndex b (Value x) = toIndex b x
histogram :: (Vector v a, Bin bin) => bin -> v a -> Histogram v bin a
histogram b = histogramUO b Nothing
histogramUO :: (Vector v a, Bin bin) => bin -> Maybe (a,a) -> v a -> Histogram v bin a
histogramUO b uo v
| nBins b == G.length v = Histogram b uo v
| otherwise = error "Data.Histogram.Generic.histogramUO: number of bins and vector size doesn't match"
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 (fmap showT $ asList h)
where
showT (x,y) = show x ++ "\t" ++ show y
showUO (Just (u,o)) = "# Underflows = " ++ show u ++ "\n" ++
"# Overflows = " ++ show o ++ "\n"
showUO Nothing = "# Underflows = \n" ++
"# Overflows = \n"
instance Typeable1 v => Typeable2 (Histogram v) where
typeOf2 h = mkTyConApp (mkTyCon "Data.Histogram.Generic.Histogram") [typeOf1 (histData h)]
instance (NFData a, NFData bin) => NFData (Histogram v bin a) where
rnf (Histogram bin uo vec) =
rnf bin `seq` rnf uo `seq` seq vec ()
instance (Functor v) => Functor (Histogram v bin) where
fmap f (Histogram bin uo vec) = Histogram bin (fmap (f *** f) uo) (fmap f vec)
histHeader :: (Read bin, Read a, Bin bin, Vector v a) => ReadPrec (v a -> Histogram v bin a)
histHeader = do
keyword "Histogram"
u <- maybeValue "Underflows"
o <- maybeValue "Overflows"
bin <- readPrec
return $ Histogram bin ((,) `fmap` u `ap` o)
readHistogram :: (Read bin, Read a, Bin bin, Vector v a) => String -> Histogram v bin a
readHistogram str =
let (h,rest) = case readPrec_to_S histHeader 0 str of
[x] -> x
_ -> error "Cannot parse histogram header"
xs = fmap (unwords . tail) . filter (not . null) . fmap words . lines $ rest
in h (G.fromList $ fmap read xs)
readFileHistogram :: (Read bin, Read a, Bin bin, Vector v a) => FilePath -> IO (Histogram v bin a)
readFileHistogram fname = readHistogram `fmap` readFile fname
bins :: Histogram v bin a -> bin
bins (Histogram bin _ _) = bin
histData :: Histogram v bin a -> v a
histData (Histogram _ _ a) = a
underflows :: Histogram v bin a -> Maybe a
underflows (Histogram _ uo _) = fst <$> uo
overflows :: Histogram v bin a -> Maybe a
overflows (Histogram _ uo _) = snd <$> uo
outOfRange :: Histogram v bin a -> Maybe (a,a)
outOfRange (Histogram _ uo _) = uo
asList :: (Vector v a, Bin bin) => Histogram v bin a -> [(BinValue bin, a)]
asList (Histogram bin _ arr) =
Prelude.zip (fromIndex bin <$> [0..]) (G.toList arr)
asVector :: (Bin bin, Vector v a, Vector v (BinValue bin,a))
=> Histogram v bin a -> v (BinValue bin, a)
asVector (Histogram bin _ arr) =
G.generate (nBins bin) $ \i -> (fromIndex bin i, arr G.! i)
map :: (Vector v a, Vector v b) => (a -> b) -> Histogram v bin a -> Histogram v bin b
map f (Histogram bin uo a) =
Histogram bin (fmap (f *** f) uo) (G.map f a)
bmap :: (Vector v a, Vector v b, Bin bin)
=> (BinValue bin -> a -> b) -> Histogram v bin a -> Histogram v bin b
bmap f (Histogram bin _ vec) =
Histogram bin Nothing $ G.imap (f . fromIndex bin) vec
mapData :: (Vector v a, Vector u b, Bin bin)
=> (v a -> u b) -> Histogram v bin a -> Histogram u bin b
mapData f (Histogram bin _ v)
| G.length v /= G.length v' = error "Data.Histogram.Generic.Histogram.mapData: vector length changed"
| otherwise = Histogram bin Nothing v'
where v' = f v
zip :: (Bin bin, BinEq 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
zip f ha hb = fromMaybe (error msg) $ zipSafe f ha hb
where msg = "Data.Histogram.Generic.Histogram.histZip: bins are different"
zipSafe :: (Bin bin, BinEq 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)
zipSafe f (Histogram bin uo v) (Histogram bin' uo' v')
| binEq bin bin' = Just $ Histogram bin (f2 <$> uo <*> uo') (G.zipWith f v v')
| otherwise = Nothing
where
f2 (x,x') (y,y') = (f x y, f x' y')
convert :: (Vector v a, Vector w a)
=> Histogram v bin a -> Histogram w bin a
convert (Histogram bin uo vec) = Histogram bin uo (G.convert vec)
convertBinning :: (ConvertBin bin bin', Vector v a)
=> Histogram v bin a -> Histogram v bin' a
convertBinning (Histogram bin uo vec)
| nBins bin == nBins bin' = Histogram bin' uo vec
| otherwise = error "Data.Histogram.Generic.convertBinning: invalid ConvertBin instance"
where
bin' = convertBin bin
foldl :: (Bin bin, Vector v a) => (b -> a -> b) -> b -> Histogram v bin a -> b
foldl f x0 (Histogram _ _ vec) =
G.foldl' f x0 vec
bfoldl :: (Bin bin, Vector v a) => (b -> BinValue bin -> a -> b) -> b -> Histogram v bin a -> b
bfoldl f x0 (Histogram bin _ vec) =
G.ifoldl' (\acc -> f acc . fromIndex bin) x0 vec
slice :: (SliceableBin bin, Vector v a)
=> HistIndex bin
-> HistIndex bin
-> Histogram v bin a
-> Histogram v bin a
slice a b (Histogram bin _ v) =
Histogram (sliceBin i j bin) Nothing (G.slice i (j i + 1) v)
where
i = max 0 $ histIndex bin a
j = min n $ histIndex bin b
n = nBins bin 1
rebin :: (MergeableBin bin, Vector v a)
=> CutDirection
-> Int
-> (a -> a -> a)
-> Histogram v bin a
-> Histogram v bin a
rebin dir k f = rebinWorker dir k (G.foldl1' f)
rebinFold :: (MergeableBin bin, Vector v a, Vector v b)
=> CutDirection
-> Int
-> (b -> a -> b)
-> b
-> Histogram v bin a
-> Histogram v bin b
rebinFold dir k f x0 = rebinWorker dir k (G.foldl' f x0)
rebinWorker :: (MergeableBin bin, Vector v a, Vector v b)
=> CutDirection
-> Int
-> (v a -> b)
-> Histogram v bin a
-> Histogram v bin b
rebinWorker dir k f (Histogram bin _ vec)
| G.length vec' /= nBins bin' = error "Data.Histogram.Generic.rebin: wrong MergeableBin instance"
| otherwise = Histogram bin' Nothing vec'
where
bin' = mergeBins dir k bin
vec' = G.generate n $ \i -> f (G.slice (off + i*k) k vec)
n = G.length vec `div` k
off = case dir of CutLower -> G.length vec n * k
CutHigher -> 0
sliceAlongX :: (Vector v a, Bin bX, Bin bY)
=> Histogram v (Bin2D bX bY) a
-> HistIndex bY
-> Histogram v bX a
sliceAlongX (Histogram (Bin2D bX bY) _ arr) y
| iy >= 0 && iy < ny = Histogram bX Nothing $ G.slice (nx * iy) nx arr
| otherwise = error "Data.Histogram.Generic.Histogram.sliceXatIx: bad index"
where
nx = nBins bX
ny = nBins bY
iy = histIndex bY y
sliceAlongY :: (Vector v a, Bin bX, Bin bY)
=> Histogram v (Bin2D bX bY) a
-> HistIndex bX
-> Histogram v bY a
sliceAlongY (Histogram (Bin2D bX bY) _ arr) x
| ix >= 0 && ix < nx = Histogram bY Nothing $ G.generate ny (\iy -> arr ! (iy*nx + ix))
| otherwise = error "Data.Histogram.Generic.Histogram.sliceXatIx: bad index"
where
nx = nBins bX
ny = nBins bY
ix = histIndex bX x
listSlicesAlongX :: (Vector v a, Bin bX, Bin bY)
=> Histogram v (Bin2D bX bY) a
-> [(BinValue bY, Histogram v bX a)]
listSlicesAlongX h@(Histogram (Bin2D _ bY) _ _) =
fmap (fromIndex bY &&& sliceAlongX h . Index) [0 .. nBins bY 1]
listSlicesAlongY :: (Vector v a, Bin bX, Bin bY)
=> Histogram v (Bin2D bX bY) a
-> [(BinValue bX, Histogram v bY a)]
listSlicesAlongY h@(Histogram (Bin2D bX _) _ _) =
fmap (fromIndex bX &&& sliceAlongY h . Index) [0 .. nBins bX 1]
reduceX :: (Vector v a, Vector v b, Bin bX, Bin bY)
=> (Histogram v bX a -> b)
-> Histogram v (Bin2D bX bY) a
-> Histogram v bY b
reduceX f h@(Histogram (Bin2D _ bY) _ _) =
Histogram bY Nothing $ G.generate (nBins bY) (f . sliceAlongX h . Index)
reduceY :: (Vector v a, Vector v b, Bin bX, Bin bY)
=> (Histogram v bY a -> b)
-> Histogram v (Bin2D bX bY) a
-> Histogram v bX b
reduceY f h@(Histogram (Bin2D bX _) _ _) =
Histogram bX Nothing $ G.generate (nBins bX) (f . sliceAlongY h . Index)
liftX :: (Bin bX, Bin bY, Bin bX', BinEq bX', Vector v a, Vector v b)
=> (Histogram v bX a -> Histogram v bX' b)
-> Histogram v (Bin2D bX bY) a
-> Histogram v (Bin2D bX' bY) b
liftX f hist@(Histogram (Bin2D _ by) _ _) =
case f . snd <$> listSlicesAlongX hist of
[] -> error "Data.Histogram.Generic.Histogram.liftX: zero size along Y"
hs -> Histogram
(Bin2D (bins (head hs)) by)
Nothing
(G.concat (histData <$> hs))
liftY :: (Bin bX, Bin bY, Bin bY', BinEq bY', Vector v a, Vector v b, Vector v Int)
=> (Histogram v bY a -> Histogram v bY' b)
-> Histogram v (Bin2D bX bY ) a
-> Histogram v (Bin2D bX bY') b
liftY f hist@(Histogram (Bin2D bx _) _ _) =
case f . snd <$> listSlicesAlongY hist of
[] -> error "Data.Histogram.Generic.Histogram.liftY: zero size along X"
hs -> make hs
where
make hs = Histogram (Bin2D bx by') Nothing
$ G.backpermute (G.concat (histData <$> hs)) (G.generate (nx*ny) join)
where
by' = bins (head hs)
nx = nBins bx
ny = nBins by'
join i = let (a,b) = i `quotRem` nx
in a + b * ny