mealy 0.3.0 → 0.4.0
raw patch · 2 files changed
+86/−10 lines, 2 filesdep +numhask-arraydep ~text
Dependencies added: numhask-array
Dependency ranges changed: text
Files
- mealy.cabal +4/−3
- src/Data/Mealy.hs +82/−7
mealy.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mealy-version: 0.3.0+version: 0.4.0 license: BSD-3-Clause copyright: Tony Day (c) 2013 - 2022 maintainer: tonyday567@gmail.com@@ -21,7 +21,7 @@ category: folding build-type: Simple-tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.4 || ==9.4.2 source-repository head type: git@@ -46,10 +46,11 @@ , containers ^>=0.6.2 , mwc-probability ^>=2.3.1 , numhask ^>=0.10+ , numhask-array ^>=0.10.1 , optics-core ^>=0.4 , primitive ^>=0.7.2 , profunctors ^>=5.6.2 , tdigest ^>=0.2.1- , text ^>=1.2.4+ , text >=1.2.4 && < 2.1 , vector ^>=0.12.3 , vector-algorithms ^>=0.8.0
src/Data/Mealy.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}@@ -46,29 +47,35 @@ beta1, alpha1, reg1,+ beta,+ alpha,+ reg, asum, aconst, last, maybeLast, delay1, delay,+ window, -- * median Medianer (..), onlineL1, maL1,- window, ) where import Control.Category import Control.Exception+import Data.Functor.Rep import Data.List (scanl') 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 NumHask.Array as F import NumHask.Prelude hiding (L1, asum, fold, id, last, (.)) -- $setup@@ -117,7 +124,7 @@ -- -- __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+-- > scan (M i s e) (x : xs) = e <$> scanl' s (i x) xs data Mealy a b = forall c. Mealy (a -> c) (c -> a -> c) (c -> b) -- | Strict Pair@@ -373,6 +380,74 @@ 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 :: (ExpField a, KnownNat n, 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 -> recip 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 #-}++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, 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, 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@@ -421,6 +496,11 @@ step Seq.Empty _ = throw (MealyError "empty seq") step (_ Seq.:<| xs) a = xs Seq.|> a +-- | a moving window of a's, most recent at the front of the sequence+window :: Int -> Mealy a (Seq.Seq a)+window n = M Seq.singleton (\xs x -> Seq.take n (x Seq.<| xs)) id+{-# INLINEABLE window #-}+ -- | A rough Median. -- The average absolute value of the stat is used to callibrate estimate drift towards the median data Medianer a b = Medianer@@ -458,8 +538,3 @@ maL1 :: (Ord a, Field a, Signed a) => a -> a -> a -> Mealy a a maL1 i d r = onlineL1 i d id (* r) {-# INLINEABLE maL1 #-}---- | 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 #-}