packages feed

multipass (empty) → 0.1

raw patch · 29 files changed

+1533/−0 lines, 29 filesdep +basedep +binarydep +containerssetup-changed

Dependencies added: base, binary, containers, ghc-prim, hashable, keys, math-functions, newtype, unordered-containers

Files

+ Data/Pass.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Pass+-- Copyright   :  (C) 2012 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (GADTs, Rank2Types)+--+----------------------------------------------------------------------------+module Data.Pass+  (+  -- * Evaluation+    Eval(..), (@@)+  , Naive(..), (@@@)++  -- * Single pass calculations+  , Pass(..)+  , Passable(..)++  -- ** Embedding single pass calculations+  , Step(..)++  -- * Multipass calculations+  , Calc(..)+  , Calculation(..)++  -- * Input conditioning+  , Prep(..)++  -- * L-Estimators+  , L(..)+  , (@#)+  , breakdown+  , iqm -- interquantile mean+  , idm -- interdecile mean++  -- ** Quantile estimators+  , Estimator(..)+  , By(..)++  -- ** Robust statistics based on L-estimators+  , Robust(..)+  , median+  , tercile, t1, t2+  , quartile, q1, q2, q3+  , quintile, qu1, qu2, qu3, qu4+  , percentile+  , permille++  -- ** Acceleration for non-robust L-estimators+  , Accelerated(..)++  -- * Implementation Details+  , Thrist(..)+  , thrist+  , Trans(..)++  -- ** Classes required for user-defined calculation types+  , Call(..)+  , Named(..)+  , Accelerant(..)+  ) where++import Data.Pass.Calc+import Data.Pass.Accelerant+import Data.Pass.Accelerated+import Data.Pass.Calculation+import Data.Pass.Call+import Data.Pass.Class+import Data.Pass.Eval+import Data.Pass.Eval.Naive+import Data.Pass.Named+import Data.Pass.Prep+import Data.Pass.Thrist+import Data.Pass.Trans+import Data.Pass.Type+import Data.Pass.Step+import Data.Pass.L+import Data.Pass.L.By+import Data.Pass.L.Estimator+import Data.Pass.Robust
+ Data/Pass/Accelerant.hs view
@@ -0,0 +1,24 @@+module Data.Pass.Accelerant+  ( Accelerant(..)+  ) where++import Data.Pass.Type+import Data.Pass.L+import Data.Pass.Robust++-- provide hooks to allow the user to accelerate non-robust L-estimators+class Accelerant k where+  meanPass :: Pass k Double Double+  meanPass = robust LMean++  totalPass :: Pass k Double Double+  totalPass = robust LTotal++  largestPass :: Pass k Double Double+  largestPass = robust $ NthLargest 0++  smallestPass :: Pass k Double Double+  smallestPass = robust $ NthSmallest 0++  midrangePass :: Pass k Double Double+  midrangePass = largestPass - smallestPass
+ Data/Pass/Accelerated.hs view
@@ -0,0 +1,53 @@+module Data.Pass.Accelerated+  ( Accelerated(..)+  ) where++import Data.Pass.Type+import Data.Pass.Calc+import Data.Pass.L+import Data.Pass.Fun+import Data.Pass.Thrist+import Data.Pass.Robust+import Data.Pass.Accelerant++class Accelerated k where+  mean :: k Double Double+  total :: k Double Double+  largest :: k Double Double+  smallest :: k Double Double+  midrange :: k Double Double++instance Accelerated L where+  mean = robust LMean+  total = robust LTotal+  largest = robust (NthLargest 0)+  smallest = robust (NthSmallest 0)+  midrange = robust ((-1) :* NthSmallest 0 :+ NthLargest 0)++instance Accelerated k => Accelerated (Fun k) where+  mean = Fun mean+  total = Fun total+  largest = Fun largest+  smallest = Fun smallest+  midrange = Fun midrange++instance Accelerated k => Accelerated (Thrist k) where+  mean = mean :- Nil+  total = total :- Nil+  largest = largest :- Nil+  smallest = smallest :- Nil+  midrange = midrange :- Nil++instance Accelerant k => Accelerated (Calc k) where+  mean  = meanPass :& Stop+  total = totalPass :& Stop+  largest = largestPass :& Stop+  smallest = smallestPass :& Stop+  midrange = midrangePass :& Stop++instance Accelerant k => Accelerated (Pass k) where+  mean = meanPass+  total = totalPass+  largest = largestPass+  smallest = smallestPass+  midrange = midrangePass
+ Data/Pass/Calc.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+module Data.Pass.Calc+  ( Calc(..)+  ) where++import Control.Category+import Control.Applicative+import Prelude hiding (id,(.))+import Data.Pass.Call+import Data.Pass.Eval+import Data.Pass.Eval.Naive+import Data.Pass.L.By+import Data.Pass.Prep+import Data.Pass.Thrist+import Data.Pass.Type+import Data.Pass.Trans+import Data.List (sortBy)+import Data.Function (on)++data Calc k a b where+  Stop :: b -> Calc k a b+  (:&) :: Pass k a b -> (b -> Calc k a c) -> Calc k a c+  Rank :: Ord b => Thrist k a b -> ([Int] -> Calc k a c) -> Calc k a c++infixl 1 :&++instance By (Calc k) where+  by (x :& f) r = by x r :& \b -> f b `by` r+  by (Rank m f) r = Rank m $ \b -> f b `by` r+  by x _ = x++instance Functor (Calc k a) where+  fmap f (Stop b) = Stop (f b)+  fmap f (Rank m k) = Rank m (fmap f . k)+  fmap f (fb :& kba) = fb :& fmap f . kba++instance Applicative (Calc k a) where+  pure = Stop+  Stop f      <*> Stop a      = Stop (f a)+  Stop f      <*> (fb :& kba) = fb :& fmap f . kba+  Stop f      <*> Rank fb kba = Rank fb $ fmap f . kba+  (fg :& kgf) <*> Rank fb kba = fg :& \g -> Rank fb $ \b -> kgf g <*> kba b+  (fg :& kgf) <*> Stop a      = fg :& fmap ($a) . kgf+  (fg :& kgf) <*> (fb :& kba) = liftA2 (,) fg fb :& \(g,b) -> kgf g <*> kba b+  Rank fg kgf <*> (fb :& kba) = fb :& \b -> Rank fg $ \g -> kgf g <*> kba b+  Rank fg kgf <*> Stop a      = Rank fg $ fmap ($a) . kgf+  Rank fg kgf <*> Rank fb kba = Rank fg $ \g -> Rank fb $ \b -> kgf g <*> kba b+  _ *> b = b+  a <* _ = a++instance Monad (Calc k a) where+  return = Stop+  Stop a      >>= f = f a+  (fb :& kba) >>= f = fb :& (>>= f) . kba+  Rank fb kba >>= f = Rank fb $ (>>= f) . kba+  (>>) = (*>)++instance Prep Calc where+  prep _ (Stop b)   = Stop b+  prep t (c :& k)   = prep t c :& prep t . k+  prep t (Rank c k) = Rank (prep t c) (prep t . k)++#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ < 704+instance Show (Calc k a b) where+  showsPrec _ _ = showString "<calc>"+instance Eq (Calc k a b) where+  _ == _ = False+#endif+#endif++instance Num b => Num (Calc k a b) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  (*) = liftA2 (*)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance Fractional b => Fractional (Calc k a b) where+  (/) = liftA2 (/)+  recip = fmap recip+  fromRational = pure . fromRational++instance Floating b => Floating (Calc k a b) where+  pi = pure pi+  exp = fmap exp+  sqrt = fmap sqrt+  log = fmap log+  (**) = liftA2 (**)+  logBase = liftA2 logBase+  sin = fmap sin+  tan = fmap tan+  cos = fmap cos+  asin = fmap asin+  atan = fmap atan+  acos = fmap acos+  sinh = fmap sinh+  tanh = fmap tanh+  cosh = fmap cosh+  asinh = fmap asinh+  acosh = fmap acosh+  atanh = fmap atanh++instance Trans Calc where+  trans t = trans t :& Stop++instance Call k => Naive (Calc k) where+  naive (Stop b) _ _    = b+  naive (i :& k) n xs   = naive (k $ naive i n xs) n xs+  naive (Rank m k) n xs = naive (k $ map fst $ sortBy (on compare (call m . snd)) $ zip [0..] xs) n xs++instance Call k => Eval (Calc k) where+  eval (Stop b) _ _    = b+  eval (i :& k) n xs   = eval (k (eval i n xs)) n xs+  eval (Rank m k) n xs = eval (k $ map fst $ sortBy (on compare $ call m . snd) $ zip [0..] xs) n xs
+ Data/Pass/Calculation.hs view
@@ -0,0 +1,28 @@+module Data.Pass.Calculation+  ( Calculation(..)+  ) where++import Data.Binary+import Data.Monoid+import Data.Typeable+import Data.Pass.Calc+import Data.Pass.Class+import Data.Pass.Eval+import Data.Pass.Fun+import Data.Pass.Thrist+import Data.Pass.Type++class Calculation t where+  calc :: (Eval k, Typeable b, Binary b, Monoid b) => t k a b -> Calc k a b++instance Calculation Fun where+  calc = calc . pass++instance Calculation Thrist where+  calc = calc . pass++instance Calculation Pass where+  calc p = p :& Stop++instance Calculation Calc where+  calc = id
+ Data/Pass/Call.hs view
@@ -0,0 +1,8 @@+module Data.Pass.Call+  ( Call(..)+  ) where++import Data.Pass.Named++class Named k => Call k where+  call :: k a b -> a -> b
+ Data/Pass/Class.hs view
@@ -0,0 +1,24 @@+module Data.Pass.Class+  ( Passable(..)+  ) where++import Data.Binary+import Data.Monoid+import Data.Typeable+import Data.Pass.Type+import Data.Pass.Eval+import Data.Pass.Fun+import Data.Pass.Thrist+import Data.Pass.Trans++class Passable t where+  pass :: (Eval k, Typeable b, Binary b, Monoid b) => t k a b -> Pass k a b++instance Passable Fun where+  pass (Fun k) = trans k++instance Passable Thrist where+  pass = Pass id++instance Passable Pass where+  pass = id
+ Data/Pass/Env.hs view
@@ -0,0 +1,53 @@+module Data.Pass.Env+  ( Env+  , empty+  , lookup+  , insert+  , cons+  ) where++import Control.Applicative hiding (empty)+import Data.Binary+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import Data.Monoid (Monoid(..))+import Data.Typeable+import GHC.Prim (Any)+import Prelude hiding (lookup)+import Unsafe.Coerce+import Data.Pass.Call+import Data.Pass.Key+import Data.Pass.Named+import Data.Pass.Thrist++newtype Id a = Id { getId :: a }++instance Functor Id where+  fmap f (Id a) = Id (f a)++instance Applicative Id where+  pure = Id+  Id a <*> Id b = Id (a b)++mapWithKey :: (k -> a -> b) -> HashMap k a -> HashMap k b+mapWithKey f m = getId (HashMap.traverseWithKey (\k a -> Id (f k a)) m)++newtype Env k a = Env (HashMap (Key k a) Any)++data Fake = Any deriving Show++instance Named k => Show (Env k a) where+  showsPrec d (Env m) = showParen (d > 10) $+    showString "Env " . showsPrec 10 (Any <$ m)++empty :: Env k a+empty = Env HashMap.empty++lookup :: (Call k, Typeable b, Binary b, Monoid b) => Thrist k a b -> Env k a -> Maybe b+lookup k (Env m) = unsafeCoerce <$> HashMap.lookup (Key k) m++insert :: (Call k, Typeable b, Binary b, Monoid b) => Thrist k a b -> b -> Env k a -> Env k a+insert k v (Env m) = Env $ HashMap.insert (Key k) (unsafeCoerce v) m++cons :: Call k => a -> Env k a -> Env k a+cons a (Env m) = Env $ mapWithKey (\(Key k) old -> unsafeCoerce $ call k a `mappend` unsafeCoerce old) m
+ Data/Pass/Eval.hs view
@@ -0,0 +1,15 @@+module Data.Pass.Eval+  ( Eval(..)+  , (@@)+  ) where++import Data.Foldable++infixl 0 @@++class Eval k where+  -- | Run a calculation+  eval :: k a b -> Int -> [a] -> b++(@@) :: (Eval k, Foldable f) => k a b -> f a -> b+k @@ as = eval k (length xs) xs where xs = toList as
+ Data/Pass/Eval/Naive.hs view
@@ -0,0 +1,14 @@+module Data.Pass.Eval.Naive+  ( Naive(..)+  , (@@@)+  ) where++import Data.Foldable++infixl 0 @@@++class Naive k where+  naive :: k a b -> Int -> [a] -> b++(@@@) :: (Naive k, Foldable f) => k a b -> f a -> b+k @@@ as = naive k (length xs) xs where xs = toList as
+ Data/Pass/Fun.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+module Data.Pass.Fun+  ( Fun(..)+  ) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++import Data.Hashable+import Data.Typeable+import Data.Pass.Named+import Data.Pass.Call+import Data.Pass.Trans+import Data.Pass.L.By+import Data.Pass.Eval+import Data.Pass.Eval.Naive++newtype Fun k a b = Fun { unFun :: k a b }++instance Trans Fun where+  trans = Fun++instance Named k => Show (Fun k a b) where+  showsPrec = showsFun++instance Typeable2 k => Typeable2 (Fun k) where+  typeOf2 (_ :: Fun k a b) = mkTyConApp funTyCon [typeOf2 (undefined :: k a b)]++funTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+funTyCon = mkTyCon3 "pass" "Data.Pass.Fun" "Fun"+#else+funTyCon = mkTyCon "Data.Pass.Fun.Fun"+#endif+{-# NOINLINE funTyCon #-}++instance Named k => Named (Fun k) where+  showsFun d (Fun f) = showParen (d > 10) $ showString "Fun " . showsFun 10 f+  hashFunWithSalt i (Fun k) = hashFunWithSalt i k+  equalFun (Fun f) (Fun g) = equalFun f g+  putFun (Fun f) = putFun f++instance Call k => Call (Fun k) where+  call (Fun k) = call k++instance Named k => Eq (Fun k a b) where+  (==) = equalFun++instance Named k => Hashable (Fun k a b) where+  hashWithSalt = hashFunWithSalt++instance Naive k => Naive (Fun k) where+  naive (Fun k) = naive k++instance Eval k => Eval (Fun k) where+  eval (Fun k) = eval k++instance By k => By (Fun k) where+  by (Fun k) r = Fun (by k r)
+ Data/Pass/Key.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ScopedTypeVariables, GADTs #-}+module Data.Pass.Key+  ( Key(..)+  ) where++import Prelude hiding (lookup)+import Data.Binary+import Data.Typeable+import Data.Hashable+import Data.Monoid+import Data.Pass.Thrist+import Data.Pass.Named++data Key k a where+  Key :: (Typeable b, Binary b, Monoid b) => Thrist k a b -> Key k a++instance Named k => Eq (Key k a) where+  Key (x :: Thrist k a b) == Key (y :: Thrist k a c) = equalFun x y && typeOf (undefined :: b) == typeOf (undefined :: c)++instance Named k => Hashable (Key k a) where+  hashWithSalt s (Key (tkab :: Thrist k a b)) = s `hashFunWithSalt` tkab `hashWithSalt` typeOf (undefined :: b)++instance Named k => Show (Key k a) where+  showsPrec d (Key t) = showParen (d > 10) $ showString "Key " . showsFun 10 t
+ Data/Pass/L.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE GADTs, DeriveDataTypeable, PatternGuards, Rank2Types, BangPatterns #-}++module Data.Pass.L+  ( L(..)+  , getL+  , callL+  , ordL+  , eqL+  , selectM+  , breakdown+  , (@#)+  ) where++import Control.Monad (liftM, liftM2)+import Data.Typeable+import Data.Hashable+import Data.Pass.Named+import Data.IntMap (IntMap)+import Data.Key (foldrWithKey)+import Data.List (sort)+import qualified Data.IntMap as IM+import Data.Pass.L.Estimator+import Data.Pass.Eval+import Data.Pass.Eval.Naive+import Data.Pass.L.By+import Data.Pass.Util (clamp)+import Data.Binary++-- | An L-Estimator represents a linear combination of order statistics+data L a b where+  LTotal       :: (Num a, Ord a) => L a a+  LMean        :: (Fractional a, Ord a) => L a a+  LScale       :: (Fractional a, Ord a) => L a a+  NthLargest   :: (Num a, Ord a) => Int -> L a a+  NthSmallest  :: (Num a, Ord a) => Int -> L a a+  QuantileBy   :: (Fractional a, Ord a) => Estimator -> Rational -> L a a+  Winsorized   :: (Fractional b, Ord b) => Rational -> L a b -> L a b+  Trimmed      :: (Fractional b, Ord b) => Rational -> L a b -> L a b+  Jackknifed   :: (Fractional b, Ord b) => L a b -> L a b+  (:*)         :: Fractional b => Rational -> L a b -> L a b+  (:+)         :: Num b => L a b -> L a b -> L a b+  deriving Typeable++instance By L where+  QuantileBy _ q `by` r = QuantileBy r q+  Trimmed p f    `by` r = Trimmed p (by f r)+  Winsorized p f `by` r = Winsorized p (by f r)+  Jackknifed f   `by` r = Jackknifed (by f r)+  (n :* f)       `by` r = n :* by f r+  (f :+ g)       `by` r = by f r :+ by g r+  f              `by` _ = f++infixl 7 :*+infixl 6 :+++instance Named L where+  showsFun _ LTotal           = showString "LTotal"+  showsFun _ LMean            = showString "LMean"+  showsFun _ LScale           = showString "LScale"+  showsFun d (QuantileBy e q) = showParen (d > 10) $ showString "QuantileBy " . showsPrec 10 e . showChar ' ' . showsPrec 10 q+  showsFun d (Winsorized p f) = showParen (d > 10) $ showString "Winsorized " . showsPrec 10 p . showChar ' ' . showsFun 10 f+  showsFun d (Trimmed p f)    = showParen (d > 10) $ showString "Trimmed "    . showsPrec 10 p . showChar ' ' . showsFun 10 f+  showsFun d (Jackknifed f)   = showParen (d > 10) $ showString "Jackknifed "                                 . showsFun 10 f+  showsFun d (NthLargest n)   = showParen (d > 10) $ showString "NthLargest "  . showsPrec 10 n+  showsFun d (NthSmallest n)  = showParen (d > 10) $ showString "NthSmallest " . showsPrec 10 n+  showsFun d (x :* y)         = showParen (d > 7) $ showsPrec 8 x . showString " :* " . showsPrec 7 y+  showsFun d (x :+ y)         = showParen (d > 6) $ showsPrec 7 x . showString " :+ " . showsPrec 6 y++  hashFunWithSalt n LTotal           = 0 `hashWithSalt` n+  hashFunWithSalt n LMean            = 1 `hashWithSalt` n+  hashFunWithSalt n LScale           = 2 `hashWithSalt` n+  hashFunWithSalt n (QuantileBy e q) = 4 `hashWithSalt` n  `hashWithSalt` e `hashWithSalt` q+  hashFunWithSalt n (Winsorized p f) = 5 `hashWithSalt` n  `hashWithSalt` p `hashFunWithSalt` f+  hashFunWithSalt n (Trimmed p f)    = 6 `hashWithSalt` n  `hashWithSalt` p `hashFunWithSalt` f+  hashFunWithSalt n (Jackknifed f)   = 7 `hashWithSalt` n                  `hashFunWithSalt` f+  hashFunWithSalt n (NthLargest m)   = 8 `hashWithSalt` n  `hashWithSalt` m+  hashFunWithSalt n (NthSmallest m)  = 9 `hashWithSalt` n  `hashWithSalt` m+  hashFunWithSalt n (x :* y)         = 10 `hashWithSalt` n `hashWithSalt` x `hashFunWithSalt` y+  hashFunWithSalt n (x :+ y)         = 11 `hashWithSalt` n `hashFunWithSalt` x `hashFunWithSalt` y++  equalFun LTotal LTotal = True+  equalFun LMean  LMean  = True+  equalFun LScale LScale = True+  equalFun (QuantileBy e p) (QuantileBy f q) = e == f && p == q+  equalFun (Winsorized p f) (Winsorized q g) = p == q && equalFun f g+  equalFun (Trimmed p f) (Trimmed q g)       = p == q && equalFun f g+  equalFun (Jackknifed f) (Jackknifed g)     = equalFun f g+  equalFun (NthLargest n)  (NthLargest m)    = n == m+  equalFun (NthSmallest n) (NthSmallest m)   = n == m+  equalFun (a :+ b) (c :+ d)                 = equalFun a c && equalFun b d+  equalFun (a :* b) (c :* d)                 = typeOf a == typeOf c && cast a == Just c && equalFun b d+  equalFun _ _ = False++  putFun LTotal           = put (0 :: Word8)+  putFun LMean            = put (1 :: Word8)+  putFun LScale           = put (2 :: Word8)+  putFun (QuantileBy e r) = put (4 :: Word8) >> put e >> put r+  putFun (Winsorized p f) = put (5 :: Word8) >> put p >> putFun f+  putFun (Trimmed p f)    = put (6 :: Word8) >> put p >> putFun f+  putFun (Jackknifed f)   = put (7 :: Word8) >> putFun f+  putFun (NthLargest n)   = put (8 :: Word8) >> put n+  putFun (NthSmallest n)  = put (9 :: Word8) >> put n+  putFun (x :* y)         = put (10 :: Word8) >> put x >> putFun y+  putFun (x :+ y)         = put (11 :: Word8) >> putFun x >> putFun y++getL :: (Fractional a, Ord a) => Get (L a a)+getL = do+  i <- get :: Get Word8+  case i of+    0 -> return LTotal+    1 -> return LMean+    2 -> return LScale+    4 -> liftM2 QuantileBy get get+    5 -> liftM2 Winsorized get getL+    6 -> liftM2 Trimmed get getL+    7 -> liftM Jackknifed getL+    8 -> liftM NthLargest get+    9 -> liftM NthSmallest get+    10 -> liftM2 (:*) get getL+    11 -> liftM2 (:+) getL getL+    _  -> error "getL: Unknown L-estimator"++instance Show (L a b) where+  showsPrec = showsFun++instance Hashable (L a b) where+  hashWithSalt = hashFunWithSalt++instance Eq (L a b) where+  (==) = equalFun++-- | A common measure of how robust an L estimator is in the presence of outliers.+breakdown :: (Num b, Eq b) => L a b -> Int+breakdown f+  | IM.null m = 50+  | otherwise = fst (IM.findMin m) `min` (100 - fst (IM.findMax m))+  where m = IM.filter (/= 0) $ callL f 101++infixl 0 @#++-- | @f \@# n@ Return a list of the coefficients that would be used by an L-Estimator for an input of length @n@+(@#) :: Num a => L a a -> Int -> [a]+f @# n = [ IM.findWithDefault 0 k fn | k <- [0..n-1] ]+  where fn = callL f n++callL :: L a b -> Int -> IntMap b+callL LTotal n = IM.fromList [ (i,1) | i <- [0..n-1]]+callL LMean n = IM.fromList [ (i, oon) | i <- [0..n-1]]+  where oon = recip (fromIntegral n)+callL LScale n = IM.fromList [ (i - 1, scale * (2 * fromIntegral i - 1 - r)) | i <- [1..n]]+  where r = fromIntegral n+        scale = 1 / (r *(r-1))+callL (QuantileBy f p) n = case estimateBy f p n of+  Estimate h qp -> case properFraction h of+    (w, 0) -> IM.singleton (clamp n (w - 1)) 1+    _      -> qp+callL (Winsorized p g) n = case properFraction (fromIntegral n * p) of+  (w, 0) -> IM.fromAscListWith (+) [ (w `max` min (n - 1 - w) k, v) | (k,v) <- IM.toAscList (callL g n) ]+  (w, f) | w' <- w + 1 -> IM.fromListWith (+) $ do+     (k,v) <- IM.toList (callL g n)+     [ (w  `max` min (n - 1 - w ) k, v * fromRational (1 - f)),+       (w' `max` min (n - 1 - w') k, v * fromRational f)]+callL (Trimmed p g) n = case properFraction (fromIntegral n * p) of+  (w, 0)               -> IM.fromDistinctAscList [ (k + w, v) | (k, v) <- IM.toAscList $ callL g (n - w*2)]+  (w, f) | w' <- w + 1 -> IM.fromListWith (+) $ [ (k + w, fromRational (1 - f) * v) | (k,v) <- IM.toList $ callL g (n - w*2)] +++                                                [ (k + w', fromRational f  * v)     | (k,v) <- IM.toList $ callL g (n - w'*2)]+callL (Jackknifed g) n = IM.fromAscListWith (+) $ do+  let n' = fromIntegral n+  (k, v) <- IM.toAscList $ callL g (n - 1)+  let k' = fromIntegral k + 1+  [(k, (n' - k') * v / n'), (k + 1, k' * v / n')]+callL (NthLargest m) n  = IM.singleton (clamp n (n - m - 1)) 1+callL (NthSmallest m) n = IM.singleton (clamp n m) 1+callL (x :+ y) n = IM.unionWith (+) (callL x n) (callL y n)+callL (s :* y) n = fmap (r *) (callL y n) where r = fromRational s++instance Naive L where+  naive m n xs = ordL m $ foldrWithKey step 0 $ sort $ eqL m xs where+    coefs = callL m n+    step = ordL m $ \g v x -> IM.findWithDefault 0 g coefs * v + x++instance Eval L where+  -- eval m n xs = ordL m $ callL m n `selectM` eqL m xs+  eval = naive -- faster for now++-- perform a hedged quickselect using the keys for the sparse+selectM :: (Num a, Ord a) => IntMap a -> [a] -> a+selectM = go 0 where+  go !_ !_ [] = 0+  go !b !m (x:xs) = i + j + k+    where (lo,n, hi) = partitionAndCount (<x) xs+          (lm,mm,hm) = IM.splitLookup (b+n) m+          i = if IM.null lm then 0 else go b lm lo+          j = maybe 0 (x*) mm+          k = if IM.null hm then 0 else go (b+n+1) hm hi++-- NB: unstable, reverses the sub-lists each time+partitionAndCount :: (a -> Bool) -> [a] -> ([a],Int,[a])+partitionAndCount f = go [] 0 [] where+  go !ts !n !fs [] = (ts,n,fs)+  go !ts !n !fs (x:xs)+   | f x = go (x:ts) (n + 1) fs xs+   | otherwise = go ts n (x:fs) xs++eqL :: L a b -> p a -> p b+eqL LTotal a = a+eqL LMean a = a+eqL LScale a = a+eqL (NthLargest _) a = a+eqL (NthSmallest _) a = a+eqL (QuantileBy _ _) a = a+eqL (Winsorized _ x) a = eqL x a+eqL (Jackknifed x) a = eqL x a+eqL (Trimmed _ x) a = eqL x a+eqL (x :+ _) a = eqL x a+eqL (_ :* x) a = eqL x a++ordL :: L a b -> ((Ord b, Num b) => r) -> r+ordL LTotal a = a+ordL LMean a = a+ordL LScale a = a+ordL (NthLargest _) a = a+ordL (NthSmallest _) a = a+ordL (QuantileBy _ _) a = a+ordL (Winsorized _ x) a = ordL x a+ordL (Trimmed _ x) a = ordL x a+ordL (Jackknifed x) a = ordL x a+ordL (x :+ _) a = ordL x a+ordL (_ :* x) a = ordL x a
+ Data/Pass/L/By.hs view
@@ -0,0 +1,7 @@+module Data.Pass.L.By+  (By(..)) where++import Data.Pass.L.Estimator++class By k where+  by :: k a b -> Estimator -> k a b
+ Data/Pass/L/Estimator.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}+module Data.Pass.L.Estimator+  ( Estimator(..)+  , Estimate(..)+  , estimateBy+  ) where++import Data.Ratio+import Data.Binary+import Data.Data+import qualified Data.IntMap as IM+import Data.IntMap (IntMap)+import Data.Pass.Util (clamp)+import Data.Hashable+import Data.Pass.Util.Beta (Beta(Beta))+import qualified Data.Pass.Util.Beta as Beta++-- | Techniques used to smooth the nearest values when calculating quantile functions. R2 is used by default, and the numbering convention follows the +-- use in the R programming language, as far as it goes.+data Estimator+  = R1  -- ^ Inverse of the empirical distribution function+  | R2  -- ^ .. with averaging at discontinuities (default)+  | R3  -- ^ The observation numbered closest to Np. NB: does not yield a proper median+  | R4  -- ^ Linear interpolation of the empirical distribution function. NB: does not yield a proper median.+  | R5  -- ^ .. with knots midway through the steps as used in hydrology. This is the simplest continuous estimator that yields a correct median+  | R6  -- ^ Linear interpolation of the expectations of the order statistics for the uniform distribution on [0,1]+  | R7  -- ^ Linear interpolation of the modes for the order statistics for the uniform distribution on [0,1]+  | R8  -- ^ Linear interpolation of the approximate medans for order statistics.+  | R9  -- ^ The resulting quantile estimates are approximately unbiased for the expected order statistics if x is normally distributed.+  | R10 -- ^ When rounding h, this yields the order statistic with the least expected square deviation relative to p.+  | HD  -- ^ The Harrell-Davis quantile estimator based on bootstrapped order statistics+  deriving (Eq,Ord,Enum,Bounded,Data,Typeable,Show,Read)++instance Binary Estimator where+  put e = put (fromIntegral (fromEnum e) :: Word8)+  get = do+    i <- get :: Get Word8+    return $ toEnum (fromIntegral i)++instance Hashable Estimator where+  hashWithSalt n e = n `hashWithSalt` fromEnum e++data Estimate r = Estimate {-# UNPACK #-} !Rational (IntMap r)+  deriving Show++continuousEstimator ::+  Fractional r =>+  (Rational -> (Rational, Rational)) ->+  (Rational -> Rational -> Rational) ->+  Rational -> Int -> Estimate r+continuousEstimator bds f p n = Estimate h $+  if p < lo then IM.singleton 0 1+  else if p >= hi then IM.singleton (n - 1) 1+  else case properFraction h of+    (w,frac) | frac' <- fromRational frac -> IM.fromList [(w - 1, frac'), (w, 1 - frac')]+  where+    r = fromIntegral n+    h = f p r+    (lo, hi) = bds r++estimateBy :: Fractional r => Estimator -> Rational -> Int -> Estimate r+estimateBy HD = \q n -> Estimate (1%2) $ let+    n' = fromIntegral n+    np1 = n' + 1+    q' = fromRational q+    d = Beta (q'*np1) (np1*(1-q'))+  in if q == 0 then IM.singleton 0 1+  else if q == 1 then IM.singleton (n - 1) 1+  else IM.fromListWith (+)+    [ (i, realToFrac $ Beta.cumulative d ((fromIntegral i + 1) / n') - Beta.cumulative d (fromIntegral i / n'))+    | i <- [0 .. n-1]+    ]+estimateBy R1  = \p n -> let np = fromIntegral n * p in Estimate (np + 1%2) $ IM.singleton (clamp n (ceiling np - 1)) 1+estimateBy R2  = \p n -> let np = fromIntegral n * p in Estimate (np + 1%2) $+  if p == 0      then IM.singleton 0       1+  else if p == 1 then IM.singleton (n - 1) 1+  else IM.fromListWith (+) [(clamp n (ceiling np - 1), 0.5), (clamp n (floor np), 0.5)]+estimateBy R3  = \p n -> let np = fromIntegral n * p in Estimate np $ IM.singleton (clamp n (round np - 1)) 1+estimateBy R4  = continuousEstimator (\n -> (recip n, 1)) (*)+estimateBy R5  = continuousEstimator (\n -> let tn = 2 * n in (recip tn, (tn - 1) / tn)) $ \p n -> p*n + 0.5+estimateBy R6  = continuousEstimator (\n -> (recip (n + 1), n / (n + 1))) $ \p n -> p*(n+1)+estimateBy R7  = continuousEstimator (\_ -> (0, 1)) $ \p n -> p*(n-1) + 1+estimateBy R8  = continuousEstimator (\n -> (2/3 / (n + 1/3), (n - 1/3)/(n + 1/3))) $ \p n -> p*(n + 1/3) + 1/3+estimateBy R9  = continuousEstimator (\n -> (0.625 / (n + 0.25), (n - 0.375)/(n + 0.25))) $ \p n -> p*(n + 0.25) + 0.375+estimateBy R10 = continuousEstimator (\n -> (1.5 / (n + 2), (n + 0.5)/(n + 2))) $ \p n -> p*(n + 2) - 0.5
+ Data/Pass/Monoid/Ord.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Pass.Monoid.Ord+  ( Min(..), getMin+  , Max(..), getMax+  ) where++import Control.Monad (liftM)+import Data.Monoid+import Data.Typeable+import Data.Binary++data Min a = Min a | NoMin deriving Typeable++getMin :: Num a => Min a -> a+getMin (Min a) = a+getMin NoMin = 0++instance Ord a => Monoid (Min a) where+  mempty = NoMin+  NoMin `mappend` y = y+  x `mappend` NoMin = x+  Min x `mappend` Min y = Min (min x y)++instance Binary a => Binary (Min a) where+  put NoMin = put (0 :: Word8)+  put (Min a) = put (1 :: Word8) >> put a+  get = do+    i <- get :: Get Word8+    case i of+      0 -> return NoMin+      1 -> liftM Min get+      _ -> error "get: unknown constructor"++getMax :: Num a => Max a -> a+getMax (Max a) = a+getMax NoMax = 0++data Max a = Max a | NoMax deriving Typeable++instance Binary a => Binary (Max a) where+  put NoMax = put (0 :: Word8)+  put (Max a) = put (1 :: Word8) >> put a+  get = do+    i <- get :: Get Word8+    case i of+      0 -> return NoMax+      1 -> liftM Max get+      _ -> error "get: unknown constructor"++instance Ord a => Monoid (Max a) where+  mempty = NoMax+  NoMax `mappend` y = y+  x `mappend` NoMax = x+  Max x `mappend` Max y = Max (max x y)
+ Data/Pass/Named.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Pass.Named+  ( Named(..)+  ) where++import Data.Binary+import Data.Binary.Put+import Data.Typeable+import Data.Hashable++infixl 0 `hashFunWithSalt`++class Typeable2 k => Named k where+  showsFun :: Int -> k a b -> String -> String++  putFun :: k a b -> Put+  putFun xs = put $ showsFun 0 xs ""++  hashFunWithSalt :: Int -> k a b -> Int+  hashFunWithSalt n xs = n `hashWithSalt` runPut (putFun xs)++  equalFun :: k a b -> k c d -> Bool+  equalFun xs ys = runPut (putFun xs) == runPut (putFun ys)
+ Data/Pass/Prep.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE GADTs #-}+module Data.Pass.Prep+  ( Prep(..)+  ) where++import Data.Pass.Thrist++infixr 5 `prep`++class Prep t where+  prep :: k a b -> t k b c -> t k a c++instance Prep Thrist where+  prep x Nil       = x :- Nil+  prep x (y :- ys) = y :- prep x ys
+ Data/Pass/Robust.hs view
@@ -0,0 +1,114 @@+module Data.Pass.Robust+  ( Robust(..)+  , median+  , iqm+  , idm+  , tercile, t1, t2+  , quartile, q1, q2, q3+  , quintile, qu1, qu2, qu3, qu4+  , percentile+  , permille+  ) where++import Data.Pass.Type+import Data.Pass.Calc+import Data.Pass.Fun+import Data.Pass.Thrist+import Data.Pass.L+import Data.Pass.L.Estimator++-- | embedding for L-estimators+class Robust l where+  robust :: L a b -> l a b++  winsorized :: (Fractional b, Ord b) => Rational -> L a b -> l a b+  winsorized p f = robust $ Winsorized p f++  trimmed :: (Fractional b, Ord b) => Rational -> L a b -> l a b+  trimmed p f = robust $ Trimmed p f++  jackknifed :: (Fractional b, Ord b) => L a b -> l a b+  jackknifed f = robust $ Jackknifed f++  lscale :: (Fractional a, Ord a) => l a a+  lscale = robust LScale++  quantile :: (Fractional a, Ord a) => Rational -> l a a+  quantile p = robust $ QuantileBy R2 p++  midhinge :: (Fractional a, Ord a) => l a a+  midhinge = robust $ 0.5 :* (q1 :+ q3)++  -- | Tukey's trimean+  trimean :: (Fractional a, Ord a) => l a a+  trimean = robust $ 0.25 :* (q1 :+ 2 :* q2 :+ q3)++  -- | interquartile range+  iqr :: (Fractional a, Ord a) => l a a+  iqr = robust $ ((-1) :* q1) :+ q3++  idr :: (Fractional a, Ord a) => l a a+  idr = robust $ ((-1) :* quantile 0.1) :+ quantile 0.9++-- | interquartile mean+iqm :: (Robust l, Fractional a, Ord a) => l a a+iqm = trimmed 0.25 LMean++idm :: (Robust l, Fractional a, Ord a) => l a a+idm = trimmed 0.1 LMean++median :: (Robust l, Fractional a, Ord a) => l a a+median = quantile 0.5++tercile :: (Robust l, Fractional a, Ord a) => Rational -> l a a+tercile n = quantile (n/3)++-- | terciles 1 and 2+t1, t2 :: (Robust l, Fractional a, Ord a) => l a a+t1 = tercile 1+t2 = tercile 2++quartile :: (Robust l, Fractional a, Ord a) => Rational -> l a a+quartile n = quantile (n/4)++-- | quantiles, with breakdown points 25%, 50%, and 25% respectively+q1, q2, q3 :: (Robust l, Fractional a, Ord a) => l a a+q1 = quantile 0.25+q2 = median+q3 = quantile 0.75++quintile :: (Robust l, Fractional a, Ord a) => Rational -> l a a+quintile n = quantile (n/5)++-- | quintiles 1 through 4+qu1, qu2, qu3, qu4 :: (Robust l, Fractional a, Ord a) => l a a+qu1 = quintile 1+qu2 = quintile 2+qu3 = quintile 3+qu4 = quintile 4++percentile :: (Robust l, Fractional a, Ord a) => Rational -> l a a+percentile n = quantile (n/100)++permille :: (Robust l, Fractional a, Ord a) => Rational -> l a a+permille n = quantile (n/1000)++instance Robust L where+  robust = id++instance Robust l => Robust (Fun l) where+  robust = Fun . robust++newtype Flip f a b = Flip { flop :: f b a }++instance Robust (Pass k) where+  robust l = L id (flop (eqL l (Flip l))) (eqL l Nil)+  midhinge = (q1 + q3) / 2+  trimean  = (q1 + 2 * q2 + q3) / 4+  iqr      = q3 - q1++instance Robust (Calc k) where+  robust l = robust l :& Stop+  midhinge = midhinge :& Stop+  trimean  = trimean :& Stop+  iqr      = iqr :& Stop
+ Data/Pass/Step.hs view
@@ -0,0 +1,16 @@+module Data.Pass.Step+  ( Step(..)+  ) where++import Data.Pass.Type+import Data.Pass.Calc+import Data.Pass.Prep++class Prep t => Step t where+  step :: Pass k a b -> t k a b++instance Step Pass where+  step = id++instance Step Calc where+  step k = k :& Stop
+ Data/Pass/Thrist.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE CPP, GADTs, Rank2Types, ScopedTypeVariables #-}+module Data.Pass.Thrist+  ( Thrist(..)+  , thrist+  , fromThrist+  ) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++import Control.Category+import Data.Hashable+import Data.Typeable+import Data.Binary+import Prelude hiding (id,(.))+import Data.Pass.Call+import Data.Pass.Named+import Data.Pass.Trans+import Data.Pass.L.By++infixr 5 :-++data Thrist k a b where+  Nil :: Thrist k a a+  (:-) :: k b c -> Thrist k a b -> Thrist k a c++instance Named k => Show (Thrist k a b) where+  showsPrec d xs = showsFun d xs++instance Trans Thrist where+  trans k = k :- Nil++instance Category (Thrist k) where+  id = Nil+  Nil . x = x+  (f :- xs) . ys = f :- (xs . ys)++thrist :: k a b -> Thrist k a b+thrist k = k :- Nil+{-# INLINE thrist #-}++instance Named k => Named (Thrist k) where+  showsFun d (x :- xs) = showParen (d > 5) $ showsFun 6 x . showString " :- " . showsFun 5 xs+  showsFun _ Nil = showString "Nil"++  hashFunWithSalt k Nil = k+  hashFunWithSalt k (f :- xs) = k `hashFunWithSalt` f `hashWithSalt` xs++  equalFun Nil Nil = True+  equalFun (a :- as) (b :- bs) = equalFun a b && equalFun as bs+  equalFun _ _ = False++  putFun Nil = put (0 :: Word8)+  putFun (x :- xs) = do+    put (1 :: Word8)+    putFun x+    putFun xs++instance Call k => Call (Thrist k) where+  call Nil = id+  call (f :- xs) = call f . call xs++instance By k => By (Thrist k) where+  by Nil _ = Nil+  by (x :- xs) r = by x r :- by xs r++fromThrist :: forall k a b c. Call k => (forall d e. k d e -> c) -> Thrist k a b -> [c]+fromThrist f = go where+  go :: Thrist k f g -> [c]+  go Nil = []+  go (x :- xs) = f x : go xs+{-# INLINE fromThrist #-}++instance Named k => Eq (Thrist k a b) where+  (==) = equalFun++instance Named k => Hashable (Thrist k a b) where+  hashWithSalt = hashFunWithSalt++instance Typeable2 k => Typeable2 (Thrist k) where+  typeOf2 (_ :: Thrist k a b) = mkTyConApp thristTyCon [typeOf2 (undefined :: k a b)]++thristTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+thristTyCon = mkTyCon3 "pass" "Data.Pass.Thrist" "Thrist"+#else+thristTyCon = mkTyCon "Data.Pass.Thrist.Thrist"+#endif+{-# NOINLINE thristTyCon #-}
+ Data/Pass/Trans.hs view
@@ -0,0 +1,11 @@+module Data.Pass.Trans+  ( Trans(..)+  ) where++import Data.Typeable+import Data.Monoid+import Data.Binary+-- import Data.Pass.Eval++class Trans t where+  trans :: (Binary b, Monoid b, Typeable b) => k a b -> t k a b
+ Data/Pass/Type.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-}+module Data.Pass.Type+  ( Pass(..)+  , env+  ) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++import Control.Category+import Control.Applicative hiding (empty)+import Data.Binary+import Data.Monoid+import Data.Foldable+import Data.Typeable+import Data.List (sort)+import Data.Key (foldrWithKey)+import qualified Data.IntMap as IntMap+import Prelude hiding (id,(.),foldr,lookup)++import Data.Pass.Call+import Data.Pass.Eval+import Data.Pass.Eval.Naive+import qualified Data.Pass.Env as Env+import Data.Pass.Env (Env)+import Data.Pass.Prep+import Data.Pass.Thrist+import Data.Pass.Trans+import Data.Pass.L+import Data.Pass.L.By++data Pass k a b where+  Pass :: (Typeable m, Binary m, Monoid m) => (m -> o) -> Thrist k i m -> Pass k i o+  L    :: (n -> o) -> L n n -> Thrist k i n -> Pass k i o+  Ap   :: (b -> c) -> Pass k i (a -> b) -> Pass k i a -> Pass k i c+  Pure :: a -> Pass k i a++instance By (Pass k) where+  by (Ap k mf ma) r = Ap k (by mf r) (by ma r)+  by (L k m i) r = L k (by m r) i+  by x _ = x++instance Trans Pass where+  trans t = Pass id (trans t)++instance Functor (Pass k a) where+  fmap f (L k m i)    = L (f . k) m i+  fmap f (Pass k v)   = Pass (f . k) v+  fmap f (Pure a)     = Pure (f a)+  fmap f (Ap k mf ma) = Ap   (f . k) mf ma++instance Applicative (Pass k a) where+  pure          = Pure+  Pure f <*> xs = fmap f xs+  fs <*> Pure x = fmap ($x) fs+  fs <*> xs     = Ap id fs xs++instance Typeable2 k => Typeable2 (Pass k) where+  typeOf2 (_ :: Pass k a b) = mkTyConApp calcTyCon [typeOf2 (undefined :: k a b)]++calcTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+calcTyCon = mkTyCon3 "pass" "Data.Pass.Type" "Pass"+#else+calcTyCon = mkTyCon "Data.Pass.Type.Pass"+#endif+{-# NOINLINE calcTyCon #-}++instance Prep Pass where+  prep f (Pass k g)   = Pass k (prep f g)+  prep f (L k m i)  = L k m (prep f i)+  prep f (Ap k mf ma) = Ap k (prep f mf) (prep f ma)+  prep _ (Pure a)     = Pure a++#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ < 704+instance Show (Pass k a b) where+  showsPrec _ _ = showString "<pass>"+instance Eq (Pass k a b) where+  _ == _ = False+#endif+#endif++instance Num b => Num (Pass k a b) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  negate = fmap negate+  (*) = liftA2 (*)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance Fractional b => Fractional (Pass k a b) where+  (/) = liftA2 (/)+  recip = fmap recip+  fromRational = pure . fromRational++instance Floating b => Floating (Pass k a b) where+  pi = pure pi+  exp = fmap exp+  sqrt = fmap sqrt+  log = fmap log+  (**) = liftA2 (**)+  logBase = liftA2 logBase+  sin = fmap sin+  tan = fmap tan+  cos = fmap cos+  asin = fmap asin+  atan = fmap atan+  acos = fmap acos+  sinh = fmap sinh+  tanh = fmap tanh+  cosh = fmap cosh+  asinh = fmap asinh+  acosh = fmap acosh+  atanh = fmap atanh++instance Call k => Naive (Pass k) where+  naive (Pure b)     _ _  = b+  naive (Ap k mf mx) n xs = k $ naive mf n xs $ naive mx n xs+  naive (Pass k t)   _ xs = k $ foldMap (call t) xs+  naive (L k m i)    n xs = k $ ordL m $ foldrWithKey step 0 stats+    where+      step g v x = ordL m $ IntMap.findWithDefault 0 g coefs * v + x+      stats = ordL m $ sort $ call i <$> xs+      coefs = callL m n++env :: Call k => Pass k a b -> Env k a+env = envWith Env.empty++envWith :: Call k => Env k a -> Pass k a c -> Env k a+envWith acc (Ap _ l r) = envWith (envWith acc l) r+envWith acc (Pass _ t) = Env.insert t mempty acc+envWith acc _ = acc++instance Call k => Eval (Pass k) where+  eval f n xs = evalWith (foldr Env.cons (env f) xs) f n xs++evalWith :: Call k => Env k a -> Pass k a c -> Int -> [a] -> c+evalWith _ (Pure a)   _ _  = a+evalWith g (Ap k l r) n xs = k $ evalWith g l n xs $ evalWith g r n xs+evalWith _ (L k m i)  n xs = k $ eval m n $ map (call i) xs+evalWith g (Pass k t) _ _  = k $ case Env.lookup t g of+  Nothing -> error "evalWith: missing thrist"+  Just v  -> v
+ Data/Pass/Util.hs view
@@ -0,0 +1,10 @@+module Data.Pass.Util+  ( clamp+  ) where++clamp :: Int -> Int -> Int+clamp n k+  | k <= 0    = 0+  | k >= n    = n - 1+  | otherwise = k+{-# INLINE clamp #-}
+ Data/Pass/Util/Beta.hs view
@@ -0,0 +1,46 @@+module Data.Pass.Util.Beta+  ( Beta(..)+  , cumulative+  , density+  , quantile+  ) where++import Numeric.SpecFunctions+import Numeric.MathFunctions.Constants (m_NaN)++data Beta = Beta {-# UNPACK #-} !Double {-# UNPACK #-} !Double+  deriving (Eq,Read,Show)++cumulative :: Beta -> Double -> Double+cumulative (Beta a b) x+  | x <= 0 = 0+  | otherwise = incompleteBeta a b x+{-# INLINE cumulative #-}++-- invert a monotone function+invertMono :: (Double -> Double) -> Double -> Double -> Double -> Double+invertMono f l0 h0 b = go l0 h0 where+  go l h+    | h - l < epsilon = m+    | otherwise = case compare (f m) b of+      LT -> go m h+      EQ -> m+      GT -> go l m+    where m = l + (h-l)/2+          epsilon = 1e-12+{-# INLINE invertMono #-}++density :: Beta -> Double -> Double+density (Beta a b) x+  | a <= 0 || b <= 0 = m_NaN+  | x <= 0 = 0+  | x >= 1 = 0+  | otherwise = exp $ (a-1)*log x + (b-1)*log (1-x) - logBeta a b+{-# INLINE density #-}++quantile :: Beta -> Double -> Double+quantile d p+  | p < 0 = error $ "probability must be positive. Got " ++ show p+  | p > 1 = error $ "probability must be less than 1. Got " ++ show p+  | otherwise = invertMono (cumulative d) 0 1 p+{-# INLINE quantile #-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2012 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Pass.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE GADTs, DeriveDataTypeable, StandaloneDeriving, ExtendedDefaultRules, GeneralizedNewtypeDeriving #-}++import Control.Applicative+import Control.Category+import Control.Newtype+import Control.Monad (liftM)+import Data.Binary+import Data.Foldable+import Data.Hashable+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Monoid+import Data.Typeable+import Data.Pass+import Data.Pass.Monoid.Ord+import Prelude hiding (id,(.))++-- example calculation type+data Test a b where+  Total    :: Num a => Test a (Sum a)+  Count    :: Test a (Sum Int)+  Square   :: Num a => Test a a+  Minus    :: Double -> Test Double Double+  Abs      :: Num a => Test a a+  Smallest :: Num a => Test a (Min a)+  Largest  :: Num a => Test a (Max a)+  deriving Typeable++deriving instance Typeable1 Sum -- :(+deriving instance Binary a => Binary (Sum a)++count :: (Step t, Num b) => t Test a b+count = step $ fromIntegral . getSum <$> trans Count++sumSq :: Step t => t Test Double Double+sumSq = step $ Square `prep` total++-- | @E[X^2] - E[X]^2@+var :: Step t => t Test Double Double+var = step $ sumSq / count - mean ^ 2++stddev :: Step t => t Test Double Double+stddev = step $ sqrt var++-- > absDev median -- median absolute deviation+-- > absDev mean   -- mean absolute deviation+absdev :: Pass Test Double Double -> Calc Test Double Double+absdev mu = mu :& \m -> Minus m `prep` Abs `prep` step mu++-- median absolute deviation+mad :: Calc Test Double Double+mad = absdev median++instance Named Test where+  showsFun _ Total     = showString "Total"+  showsFun _ Count     = showString "Count"+  showsFun _ Square    = showString "Square"+  showsFun d (Minus n) = showParen (d > 10) $ showString "Minus " . showsPrec 10 n+  showsFun _ Abs       = showString "Abs"+  showsFun _ Largest   = showString "Largest"+  showsFun _ Smallest  = showString "Smallest"++instance Call Test where+  call Total a = Sum a+  call Count _ = Sum 1+  call Square a = a * a+  call (Minus n) a = a - n+  call Abs a = abs a+  call Largest a = Max a+  call Smallest a = Min a++instance Accelerant Test where+  meanPass  = total / count+  totalPass = getSum <$> trans Total+  largestPass = getMax <$> trans Largest+  smallestPass = getMin <$> trans Smallest++infixl 0 @!++(@!) :: Calc Test a b -> [a] -> b+(@!) = (@@)
+ multipass.cabal view
@@ -0,0 +1,71 @@+name:          multipass+category:      Control+version:       0.1+license:       BSD3+cabal-version: >= 1.6+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/multipass/+copyright:     Copyright (C) 2012 Edward A. Kmett+synopsis:      Folding data with multiple named passes+description:   Folding data with multiple named passes+build-type:    Simple++extra-source-files: examples/Pass.hs++source-repository head+  type: git+  location: git://github.com/ekmett/multipass.git++library+  other-extensions:+    CPP+    GADTs+    Rank2Types+    BangPatterns+    PatternGuards+    ScopedTypeVariables++  build-depends:+    ghc-prim,+    base                 == 4.*,+    binary               == 0.5.*,+    containers           >= 0.4 && < 0.6,+    hashable             == 1.1.*,+    keys                 == 3.0.*,+    math-functions       == 0.1.*,+    newtype              == 0.2.*,+    unordered-containers >= 0.2.1 && < 0.3++  exposed-modules:+    Data.Pass+    Data.Pass.Accelerant+    Data.Pass.Accelerated+    Data.Pass.Calc+    Data.Pass.Calculation+    Data.Pass.Call+    Data.Pass.Class+    Data.Pass.Env+    Data.Pass.Eval+    Data.Pass.Eval.Naive+    Data.Pass.Fun+    Data.Pass.Key+    Data.Pass.L+    Data.Pass.L.By+    Data.Pass.L.Estimator+    Data.Pass.Named+    Data.Pass.Prep+    Data.Pass.Robust+    Data.Pass.Step+    Data.Pass.Thrist+    Data.Pass.Trans+    Data.Pass.Type+    Data.Pass.Monoid.Ord++  other-modules:+    Data.Pass.Util+    Data.Pass.Util.Beta++  ghc-options: -Wall