mealy 0.2.0 → 0.3.0
raw patch · 3 files changed
+68/−222 lines, 3 filesdep −foldsdep −matrixdep −numhask-array
Dependencies removed: folds, matrix, numhask-array
Files
- mealy.cabal +1/−4
- src/Data/Mealy.hs +66/−217
- src/Data/Mealy/Quantiles.hs +1/−1
mealy.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mealy-version: 0.2.0+version: 0.3.0 license: BSD-3-Clause copyright: Tony Day (c) 2013 - 2022 maintainer: tonyday567@gmail.com@@ -44,11 +44,8 @@ , adjunctions ^>=4.4 , base >=4.13 && <5 , containers ^>=0.6.2- , folds ^>=0.7.6- , matrix ^>=0.3.6 , mwc-probability ^>=2.3.1 , numhask ^>=0.10- , numhask-array ^>=0.10 , optics-core ^>=0.4 , primitive ^>=0.7.2 , profunctors ^>=5.6.2
src/Data/Mealy.hs view
@@ -1,14 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}@@ -27,6 +24,7 @@ module Data.Mealy ( -- * Types Mealy (..),+ dipure, pattern M, scan, fold,@@ -48,43 +46,30 @@ beta1, alpha1, reg1,- beta,- alpha,- reg, asum, aconst,+ last,+ maybeLast, delay1, delay,- depState,- Model1 (..),- zeroModel1,- depModel1, -- * median Medianer (..), onlineL1,- onlineL1', maL1,- absmaL1,+ window, ) where import Control.Category import Control.Exception-import Data.Fold hiding (M)-import Data.Functor.Rep import Data.List (scanl')-import qualified Data.Matrix as M import Data.Profunctor import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Text (Text) import Data.Typeable (Typeable)-import GHC.TypeLits-import qualified NumHask.Array.Fixed as F-import NumHask.Array.Shape (HasShape)-import NumHask.Prelude hiding (L1, asum, fold, id, (.))-import Optics.Core+import NumHask.Prelude hiding (L1, asum, fold, id, last, (.)) -- $setup --@@ -128,23 +113,57 @@ -- -- > M id (+) id ----- where the first id is the initial injection to a contravariant position, and the second id is the covriant extraction.+-- where the first id is the initial injection to a contravariant position, and the second id is the covariant extraction. -- -- __inject__ kicks off state on the initial element of the Foldable, but is otherwise be independent of __step__. -- -- > scan (M e s i) (x : xs) = e <$> scanl' s (i x) xs-newtype Mealy a b = Mealy {l1 :: L1 a b}- deriving (Profunctor, Category) via L1- deriving (Functor, Applicative) via L1 a+data Mealy a b = forall c. Mealy (a -> c) (c -> a -> c) (c -> b) --- | Pattern for a 'Mealy'.+-- | Strict Pair+data Pair' a b = Pair' !a !b deriving (Eq, Ord, Show, Read)++instance (Semigroup a, Semigroup b) => Semigroup (Pair' a b) where+ Pair' a b <> Pair' c d = Pair' (a <> c) (b <> d)+ {-# INLINE (<>) #-}++instance (Monoid a, Monoid b) => Monoid (Pair' a b) where+ mempty = Pair' mempty mempty++instance Functor (Mealy a) where+ fmap f (Mealy z h k) = Mealy z h (f . k)++instance Applicative (Mealy a) where+ pure x = Mealy (const ()) (\() _ -> ()) (\() -> x)+ Mealy zf hf kf <*> Mealy za ha ka =+ Mealy+ (\a -> Pair' (zf a) (za a))+ (\(Pair' x y) a -> Pair' (hf x a) (ha y a))+ (\(Pair' x y) -> kf x (ka y))++instance Category Mealy where+ id = Mealy id (\_ a -> a) id+ Mealy z h k . Mealy z' h' k' = Mealy z'' h'' (\(Pair' b _) -> k b)+ where+ z'' a = Pair' (z (k' b)) b where b = z' a+ h'' (Pair' c d) a = Pair' (h c (k' d')) d' where d' = h' d a++instance Profunctor Mealy where+ dimap f g (Mealy z h k) = Mealy (z . f) (\a -> h a . f) (g . k)+ lmap f (Mealy z h k) = Mealy (z . f) (\a -> h a . f) k+ rmap g (Mealy z h k) = Mealy z h (g . k)++-- | Convenience pattern for a 'Mealy'. -- -- @M extract step inject@ pattern M :: (a -> c) -> (c -> a -> c) -> (c -> b) -> Mealy a b-pattern M i s e = Mealy (L1 e s i)+pattern M i s e = Mealy i s e {-# COMPLETE M #-} +dipure :: (a -> a -> a) -> Mealy a a+dipure f = M id f id+ -- | Fold a list through a 'Mealy'. -- -- > cosieve == fold@@ -288,7 +307,8 @@ -- 0.7978347126677433 corrGauss :: (ExpField a) => a -> Mealy (a, a) a corrGauss r =- (\cov' stdx stdy -> cov' / (stdx * stdy)) <$> cov (ma r)+ (\cov' stdx stdy -> cov' / (stdx * stdy))+ <$> cov (ma r) <*> lmap fst (std r) <*> lmap snd (std r) {-# INLINEABLE corrGauss #-}@@ -301,7 +321,8 @@ -- > corr (ma r) (std r) == corrGauss r corr :: (ExpField a) => Mealy a a -> Mealy a a -> Mealy (a, a) a corr central deviation =- (\cov' stdx stdy -> cov' / (stdx * stdy)) <$> cov central+ (\cov' stdx stdy -> cov' / (stdx * stdy))+ <$> cov central <*> lmap fst deviation <*> lmap snd deviation {-# INLINEABLE corr #-}@@ -322,7 +343,8 @@ -- 0.999747321294513 beta1 :: (ExpField a) => Mealy a a -> Mealy (a, a) a beta1 m =- (\xy x' y' x2 -> (xy - x' * y') / (x2 - x' * x')) <$> lmap (uncurry (*)) m+ (\xy x' y' x2 -> (xy - x' * y') / (x2 - x' * x'))+ <$> lmap (uncurry (*)) m <*> lmap fst m <*> lmap snd m <*> lmap (\(x, _) -> x * x) m@@ -351,91 +373,6 @@ reg1 :: (ExpField a) => Mealy a a -> Mealy (a, a) (a, a) reg1 m = (,) <$> alpha1 m <*> beta1 m -data RegressionState (n :: Nat) a = RegressionState- { _xx :: F.Array '[n, n] a,- _x :: F.Array '[n] a,- _xy :: F.Array '[n] a,- _y :: a- }- deriving (Functor)---- | multiple regression------ \[--- \begin{align}--- {\hat {{\mathbf {B}}}}=({\mathbf {X}}^{{{\rm {T}}}}{\mathbf {X}})^{{ -1}}{\mathbf {X}}^{{{\rm {T}}}}{\mathbf {Y}}--- \end{align}--- \]------ \[--- \begin{align}--- {\mathbf {X}}={\begin{bmatrix}{\mathbf {x}}_{1}^{{{\rm {T}}}}\\{\mathbf {x}}_{2}^{{{\rm {T}}}}\\\vdots \\{\mathbf {x}}_{n}^{{{\rm {T}}}}\end{bmatrix}}={\begin{bmatrix}x_{{1,1}}&\cdots &x_{{1,k}}\\x_{{2,1}}&\cdots &x_{{2,k}}\\\vdots &\ddots &\vdots \\x_{{n,1}}&\cdots &x_{{n,k}}\end{bmatrix}}--- \end{align}--- \]------ > let ys = zipWith3 (\x y z -> 0.1 * x + 0.5 * y + 1 * z) xs0 xs1 xs2--- > let zs = zip (zipWith (\x y -> fromList [x,y] :: F.Array '[2] Double) xs1 xs2) ys--- > fold (beta 0.99) zs--- [0.4982692361226971, 1.038192474255091]-beta :: (Field a, KnownNat n, Fractional a, Eq a) => a -> Mealy (F.Array '[n] a, a) (F.Array '[n] a)-beta r = M inject step extract- where- -- extract :: Averager (RegressionState n a) a -> (F.Array '[n] a)- extract (A (RegressionState xx x xy y) c) =- (\a b -> inverse a `F.mult` b)- ((one / c) .* (xx - F.expand (*) x x))- ((xy - (y .* x)) *. (one / c))- step x (xs, y) = rsOnline r x (inject (xs, y))- -- inject :: (F.Array '[n] a, a) -> Averager (RegressionState n a) a- inject (xs, y) =- A (RegressionState (F.expand (*) xs xs) xs (y .* xs) y) one-{-# INLINEABLE beta #-}--toMatrix :: (KnownNat n, KnownNat m) => F.Array [m, n] a -> M.Matrix a-toMatrix a = M.matrix m n (index a . (\(i, j) -> [i, j]))- where- (m : n : _) = F.shape a--fromMatrix :: (KnownNat n, KnownNat m) => M.Matrix a -> F.Array [m, n] a-fromMatrix = fromList . M.toList--data MatrixException = MatrixException- deriving (Show)--instance Exception MatrixException---- | The inverse of a square matrix.-inverse :: (KnownNat n, Fractional a, Eq a) => F.Array [n, n] a -> F.Array [n, n] a-inverse = either (const $ throw MatrixException) fromMatrix . M.inverse . toMatrix--rsOnline :: (Field a, KnownNat n) => a -> Averager (RegressionState n a) a -> Averager (RegressionState n a) a -> Averager (RegressionState n a) a-rsOnline r (A (RegressionState xx x xy y) c) (A (RegressionState xx' x' xy' y') c') =- A (RegressionState (liftR2 d xx xx') (liftR2 d x x') (liftR2 d xy xy') (d y y')) (d c c')- where- d s s' = r * s + s'---- | alpha in a multiple regression-alpha :: (ExpField a, KnownNat n, Fractional a, Eq a) => a -> Mealy (F.Array '[n] a, a) a-alpha r = (\xs b y -> y - sum (liftR2 (*) b xs)) <$> lmap fst (arrayify $ ma r) <*> beta r <*> lmap snd (ma r)-{-# INLINEABLE alpha #-}--arrayify :: (HasShape s) => Mealy a b -> Mealy (F.Array s a) (F.Array s b)-arrayify (M sExtract sStep sInject) = M extract step inject- where- extract = fmap sExtract- step = liftR2 sStep- inject = fmap sInject---- | multiple regression------ > let ys = zipWith3 (\x y z -> 0.1 * x + 0.5 * y + 1 * z) xs0 xs1 xs2--- > let zs = zip (zipWith (\x y -> fromList [x,y] :: F.Array '[2] Double) xs1 xs2) ys--- > fold (reg 0.99) zs--- ([0.4982692361226971, 1.038192474255091],2.087160803386695e-3)-reg :: (ExpField a, KnownNat n, Fractional a, Eq a) => a -> Mealy (F.Array '[n] a, a) (F.Array '[n] a, a)-reg r = (,) <$> beta r <*> alpha r-{-# INLINEABLE reg #-}- -- | accumulated sum asum :: (Additive a) => Mealy a a asum = M id (+) id@@ -444,6 +381,14 @@ aconst :: b -> Mealy a b aconst b = M (const ()) (\_ _ -> ()) (const b) +-- | most recent value+last :: Mealy a a+last = M id (\_ a -> a) id++-- | most recent value if it exists, previous value otherwise.+maybeLast :: a -> Mealy (Maybe a) a+maybeLast def = M (fromMaybe def) fromMaybe id+ -- | delay input values by 1 delay1 :: a -> Mealy a a delay1 x0 = M (x0,) (\(_, x) a -> (x, a)) fst@@ -476,89 +421,6 @@ step Seq.Empty _ = throw (MealyError "empty seq") step (_ Seq.:<| xs) a = xs Seq.|> a --- | Add a state dependency to a series.------ Typical regression analytics tend to assume that moments of a distributional assumption are unconditional with respect to prior instantiations of the stochastics being studied.------ For time series analytics, a major preoccupation is estimation of the current moments given what has happened in the past.------ IID:------ \[--- \begin{align}--- x_{t+1} & = alpha_t^x + s_{t+1}\\--- s_{t+1} & = alpha_t^s * N(0,1)--- \end{align}--- \]------ Example: including a linear dependency on moving average history:------ \[--- \begin{align}--- x_{t+1} & = (alpha_t^x + beta_t^{x->x} * ma_t^x) + s_{t+1}\\--- s_{t+1} & = alpha_t^s * N(0,1)--- \end{align}--- \]------ >>> let xs' = scan (depState (\a m -> a + 0.1 * m) (ma 0.99)) xs0--- >>> let ma' = scan ((ma (1 - 0.01)) >>> delay [0]) xs'--- >>> let xsb = fold (beta1 (ma (1 - 0.001))) $ drop 1 $ zip ma' xs'--- >>> -- beta measurement if beta of ma was, in reality, zero.--- >>> let xsb0 = fold (beta1 (ma (1 - 0.001))) $ drop 1 $ zip ma' xs0--- >>> xsb - xsb0--- 0.10000000000000009-depState :: (a -> b -> a) -> Mealy a b -> Mealy a a-depState f (M sInject sStep sExtract) = M inject step extract- where- inject a = (a, sInject a)- step (_, x) a = let a' = f a (sExtract x) in (a', sStep x a')- extract (a, _) = a---- | a linear model of state dependencies for the first two moments------ \[--- \begin{align}--- x_{t+1} & = (alpha_t^x + beta_t^{x->x} * ma_t^x + beta_t^{s->x} * std_t^x) + s_{t+1}\\--- s_{t+1} & = (alpha_t^s + beta_t^{x->s} * ma_t^x + beta_t^{s->s} * std_t^x) * N(0,1)--- \end{align}--- \]-data Model1 = Model1- { alphaX :: Double,- alphaS :: Double,- betaMa2X :: Double,- betaMa2S :: Double,- betaStd2X :: Double,- betaStd2S :: Double- }- deriving (Eq, Show, Generic)---- | zeroised Model1-zeroModel1 :: Model1-zeroModel1 = Model1 0 0 0 0 0 0---- | Apply a model1 relationship using a single decay factor.------ >>> :set -XOverloadedLabels--- >>> import Optics.Core--- >>> fold (depModel1 0.01 (zeroModel1 & #betaMa2X .~ 0.1)) xs0--- -0.4591515493154126-depModel1 :: Double -> Model1 -> Mealy Double Double-depModel1 r m1 =- depState fX st- where- st = (,) <$> ma (1 - r) <*> std (1 - r)- fX a (m, s) =- a- * ( (1 + m1 ^. #alphaS)- + (m1 ^. #betaMa2S) * m- + (m1 ^. #betaStd2S) * (s - 1)- )- + m1 ^. #alphaX- + (m1 ^. #betaMa2X)- * m- + (m1 ^. #betaStd2X)- * (s - 1)- -- | A rough Median. -- The average absolute value of the stat is used to callibrate estimate drift towards the median data Medianer a b = Medianer@@ -568,9 +430,9 @@ } -- | onlineL1' takes a function and turns it into a `Mealy` where the step is an incremental update of an (isomorphic) median statistic.-onlineL1' ::- (Ord b, Field b, Signed b) => b -> b -> (a -> b) -> (b -> b) -> Mealy a (b, b)-onlineL1' i d f g = M inject step extract+onlineL1 ::+ (Ord b, Field b, Signed b) => b -> b -> (a -> b) -> (b -> b) -> Mealy a b+onlineL1 i d f g = snd <$> M inject step extract where inject a = let s = abs (f a) in Medianer s one (i * s) step (Medianer s c m) a =@@ -588,21 +450,8 @@ | f a > m = one | f a < m = negate one | otherwise = zero-{-# INLINEABLE onlineL1' #-}---- | onlineL1 takes a function and turns it into a `Control.Foldl.Fold` where the step is an incremental update of an (isomorphic) median statistic.-onlineL1 :: (Ord b, Field b, Signed b) => b -> b -> (a -> b) -> (b -> b) -> Mealy a b-onlineL1 i d f g = snd <$> onlineL1' i d f g {-# INLINEABLE onlineL1 #-} --- $setup------ >>> import qualified Control.Foldl as L--- >>> let n = 100--- >>> let inc = 0.1--- >>> let d = 0--- >>> let r = 0.9- -- | moving median -- > L.fold (maL1 inc d r) [1..n] -- 93.92822312742108@@ -610,7 +459,7 @@ maL1 i d r = onlineL1 i d id (* r) {-# INLINEABLE maL1 #-} --- | moving absolute deviation-absmaL1 :: (Ord a, Field a, Signed a) => a -> a -> a -> Mealy a a-absmaL1 i d r = fst <$> onlineL1' i d id (* r)-{-# INLINEABLE absmaL1 #-}+-- | a window of a's+window :: Int -> Mealy a [a]+window n = M Seq.singleton (\xs x -> Seq.take n (x Seq.<| xs)) (reverse . toList)+{-# INLINEABLE window #-}
src/Data/Mealy/Quantiles.hs view
@@ -67,7 +67,7 @@ onlineCompress otd@(OnlineTDigest t _ _) | Data.TDigest.Tree.Internal.size t > relMaxSize * compression && Data.TDigest.Tree.Internal.size t > absMaxSize =- onlineForceCompress otd+ onlineForceCompress otd | otherwise = otd where compression = 25