module Data.Histogram (
Histogram(..)
, module Data.Histogram.Bin
, mapHist
, histBin
, histData
, underflows
, overflows
, outOfRange
, readHistogram
, asList
, asPairVector
, asVectorPairs
, sliceY
, sliceX
) where
import Control.Arrow ((***))
import Control.Monad (ap)
import Data.Array.Vector
import Text.Read
import Text.ParserCombinators.ReadPrec (readPrec_to_S)
import Data.Histogram.Bin
import Data.Histogram.Parse
data Histogram bin a where
Histogram :: (Bin bin, UA a) =>
bin
-> Maybe (a,a)
-> UArr a
-> Histogram bin a
instance (Show a, Show (BinValue bin), Show bin) => Show (Histogram 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, UA a) => ReadPrec (UArr a -> Histogram 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, UA a) => String -> Histogram bin a
readHistogram str =
let [(h,rest)] = readPrec_to_S histHeader 0 str
xs = map last . filter (not . null) . map words . lines $ rest
in h (toU $ map read xs)
mapHist :: UA b => (a -> b) -> Histogram bin a -> Histogram bin b
mapHist f (Histogram bin uo a) = Histogram bin (fmap (f *** f) uo) (mapU f a)
histBin :: Histogram bin a -> bin
histBin (Histogram bin _ _) = bin
histData :: Histogram bin a -> UArr a
histData (Histogram _ _ a) = a
underflows :: Histogram bin a -> Maybe a
underflows (Histogram _ uo _) = fmap fst uo
overflows :: Histogram bin a -> Maybe a
overflows (Histogram _ uo _) = fmap snd uo
outOfRange :: Histogram bin a -> Maybe (a,a)
outOfRange (Histogram _ uo _) = uo
asList :: Histogram bin a -> [(BinValue bin, a)]
asList (Histogram bin _ arr) = map (fromIndex bin) [0..] `zip` fromU arr
asPairVector :: UA (BinValue bin) => Histogram bin a -> (UArr (BinValue bin), UArr a)
asPairVector (Histogram bin _ a) = (toU $ map (fromIndex bin) [0 .. nBins bin], a)
asVectorPairs :: UA (BinValue bin) => Histogram bin a -> UArr ((BinValue bin) :*: a)
asVectorPairs h@(Histogram _ _ _) = uncurry zipU . asPairVector $ h
sliceY :: (Bin bX, Bin bY) => Histogram (Bin2D bX bY) a -> [(BinValue bY, Histogram bX a)]
sliceY (Histogram b@(Bin2D bX _) _ a) = map mkHist $ init [0, nBins bX .. nBins b]
where
mkHist i = ( snd $ fromIndex b i
, Histogram bX Nothing (sliceU a i (nBins bX)) )
sliceX :: (Bin bX, Bin bY) => Histogram (Bin2D bX bY) a -> [(BinValue bX, Histogram bY a)]
sliceX (Histogram b@(Bin2D bX bY) _ a) = map mkHist $ init [0 .. nx]
where
nx = nBins bX
n = nBins b
mkHist i = ( fst $ fromIndex b i
, Histogram bY Nothing (toU $ map (indexU a) [i,i+nx .. n1]) )