module Data.Histogram.Generic (
Histogram
, module Data.Histogram.Bin
, histogram
, histogramUO
, readHistogram
, readFileHistogram
, bins
, histData
, underflows
, overflows
, outOfRange
, asList
, asVector
, sliceX
, sliceY
, histMap
, histMapBin
, histZip
) where
import Control.Applicative ((<$>),(<*>))
import Control.Arrow ((***))
import Control.Monad (ap, forM_)
import Control.Monad.ST (runST)
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Vector.Generic as G
import Data.Vector.Generic (Vector)
import Text.Read
import Data.Histogram.Bin
import Data.Histogram.Parse
data Histogram v bin a = Histogram bin (Maybe (a,a)) (v a)
deriving Eq
histogram :: (Vector v a, Bin bin) => bin -> v a -> Histogram v bin a
histogram b v | nBins b == G.length v = Histogram b Nothing v
| otherwise = error "histogram: number of bins and vector size doesn't match"
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 "histogram: 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 $ map 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"
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 = map (unwords . tail) . filter (not . null) . map words . lines $ rest
in h (G.fromList $ map 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) = map (fromIndex bin) [0..] `zip` G.toList arr
asVector :: (Bin bin, Vector v a, Vector v (BinValue bin), Vector v (BinValue bin,a))
=> Histogram v bin a -> v (BinValue bin, a)
asVector (Histogram bin _ arr) = G.zip (G.generate (nBins bin) (fromIndex bin) ) arr
histMap :: (Vector v a, Vector v b) => (a -> b) -> Histogram v bin a -> Histogram v bin b
histMap f (Histogram bin uo a) = Histogram bin (fmap (f *** f) uo) (G.map f a)
histMapBin :: (Bin bin, Bin bin') => (bin -> bin') -> Histogram v bin a -> Histogram v bin' a
histMapBin f (Histogram bin uo a)
| nBins bin == nBins bin' = Histogram (f bin) uo a
| otherwise = error "Number of bins doesn't match"
where
bin' = bin
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
histZip f (Histogram bin uo v) (Histogram bin' uo' v')
| bin /= bin' = error "histZip: bins are different"
| otherwise = Histogram bin (f2 <$> uo <*> uo') (G.zipWith f v v')
where
f2 (x,x') (y,y') = (f x y, f x' y')
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 .. ny1]
where
(nx, ny) = nBins2D b
mkSlice i = ( fromIndex (binY b) i
, Histogram (binX b) Nothing (G.slice nx (nx*i) a) )
sliceX :: (Vector v a, Bin bX, Bin bY) => Histogram v (Bin2D bX bY) a -> [(BinValue bX, Histogram v bY a)]
sliceX (Histogram b _ a) = map mkSlice [0 .. nx1]
where
(nx, ny) = nBins2D b
mkSlice i = ( fromIndex (binX b) i
, Histogram (binY b) Nothing (mkArray i))
mkArray x = runST $ do arr <- M.new ny
forM_ [0 .. ny1] $ \y -> M.write arr y (a G.! (y*nx + x))
G.unsafeFreeze arr