module Data.Histogram.Bin (
Bin(..)
, Bin1D(..)
, Indexable(..)
, Indexable2D(..)
, BinI(..)
, binI0
, BinInt
, binInt
, BinIx(BinIx,unBinIx)
, binIx
, BinF
, binF
, binFn
, binI2binF
, scaleBinF
, BinD
, binD
, binDn
, binI2binD
, scaleBinD
, LogBinD
, logBinD
, Bin2D(..)
, (><)
, nBins2D
, toIndex2D
, binX
, binY
, fmapBinX
, fmapBinY
, BinIx2D (unBinIx2D)
, binIx2D
) where
import Control.Monad
import Data.Histogram.Parse
import Text.Read (Read(..))
import GHC.Float (double2Int)
class Bin b where
type BinValue b
toIndex :: b -> BinValue b -> Int
fromIndex :: b -> Int -> BinValue b
inRange :: b -> BinValue b -> Bool
nBins :: b -> Int
class Bin b => Bin1D b where
binsList :: b -> [BinValue b]
binsListRange :: b -> [(BinValue b, BinValue b)]
class Indexable a where
index :: a -> Int
deindex :: Int -> a
instance Indexable Int where
index = id
deindex = id
class Indexable2D a where
index2D :: a -> (Int,Int)
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)
data BinI = BinI !Int !Int
deriving Eq
binI0 :: Int -> BinI
binI0 n = BinI 0 (n1)
instance Bin BinI where
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
instance Bin1D BinI where
binsList (BinI lo hi) = [lo .. hi]
binsListRange b = zip (binsList b) (binsList b)
instance Show BinI where
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")
data BinInt = BinInt
!Int
!Int
!Int
deriving Eq
binInt :: Int
-> Int
-> Int
-> BinInt
binInt lo n hi = BinInt lo n nb
where
nb = (hilo) `div` n
instance Bin BinInt where
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
instance Show BinInt where
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")
newtype BinIx i = BinIx { unBinIx :: BinI }
deriving Eq
binIx :: Indexable i => i -> i -> BinIx i
binIx lo hi = BinIx $ BinI (index lo) (index hi)
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
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 (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")
data BinF f where
BinF :: RealFrac f => !f -> !f -> !Int -> BinF f
instance Eq f => Eq (BinF f) where
(BinF lo hi n) == (BinF lo' hi' n') = lo == lo' && hi == hi' && n == n'
binF :: RealFrac f =>
f
-> Int
-> f
-> BinF f
binF from n to = BinF from ((to from) / fromIntegral n) n
binFn :: RealFrac f =>
f
-> f
-> f
-> BinF f
binFn from step to = BinF from step (round $ (to from) / step)
binI2binF :: RealFrac f => BinI -> BinF f
binI2binF b@(BinI i _) = BinF (fromIntegral i) 1 (nBins b)
scaleBinF :: RealFrac f => f -> f -> BinF f -> BinF f
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 $ (xfrom) / 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
instance Bin1D (BinF f) where
binsList b@(BinF _ _ n) = map (fromIndex b) [0..n1]
binsListRange b@(BinF _ step _) = map toPair (binsList b)
where
toPair x = (x step/2, x + step/2)
instance Show f => Show (BinF f) where
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
data BinD = BinD !Double !Double !Int
instance Eq BinD where
(BinD lo hi n) == (BinD lo' hi' n') = lo == lo' && hi == hi' && n == n'
binD :: Double
-> Int
-> Double
-> BinD
binD from n to = BinD from ((to from) / fromIntegral n) n
binDn :: Double
-> Double
-> Double
-> BinD
binDn from step to = BinD from step (round $ (to from) / step)
binI2binD :: BinI -> BinD
binI2binD b@(BinI i _) = BinD (fromIntegral i) 1 (nBins b)
scaleBinD :: Double -> Double -> BinD -> BinD
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++")"
floorD :: Double -> Int
floorD x | x < 0 = double2Int x 1
| otherwise = double2Int x
instance Bin BinD where
type BinValue BinD = Double
toIndex !(BinD from step _) !x = floorD $ (xfrom) / 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
instance Bin1D BinD where
binsList b@(BinD _ _ n) = map (fromIndex b) [0..n1]
binsListRange b@(BinD _ step _) = map toPair (binsList b)
where
toPair x = (x step/2, x + step/2)
instance Show BinD where
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
data LogBinD = LogBinD
Double
Double
Double
Int
deriving Eq
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)
fromIndex !(LogBinD base _ step _) !i = base * step ^ i
inRange !(LogBinD lo hi _ _) x = x >= lo && x < hi
nBins !(LogBinD _ _ _ n) = n
instance Show LogBinD where
show (LogBinD lo hi step n) =
unlines [ "# LogBinD"
, "# Lo = " ++ show lo
, "# Hi = " ++ show hi
, "# Step = " ++ show step
, "# N = " ++ show n
]
data Bin2D binX binY = Bin2D !binX !binY
deriving Eq
(><) :: binX -> binY -> Bin2D binX binY
(><) = Bin2D
binX :: Bin2D bx by -> bx
binX !(Bin2D bx _) = bx
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
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)
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)
nBins2D :: (Bin bx, Bin by) => Bin2D bx by -> (Int,Int)
nBins2D (Bin2D bx by) = (nBins bx, nBins by)
fmapBinX :: (Bin bx, Bin bx') => (bx -> bx') -> Bin2D bx by -> 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
bx' = f bx
fmapBinY ::(Bin by, Bin by') => (by -> by') -> Bin2D bx by -> Bin2D bx by'
fmapBinY f (Bin2D bx by)
| nBins by' /= nBins by = error "fmapBinY: new binnig algorithm has different number of bins"
| otherwise = Bin2D bx by'
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
]
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
newtype BinIx2D i = BinIx2D {unBinIx2D :: (Bin2D BinI BinI) }
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
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
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