diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,20 @@ Changelog ========= +Version 0.1.3.0 +--------------- + +*August 15, 2018* + + + +* `Default` instance for `SiftCondition` and `EMDOpts`, as a useful + alternative to `defaultEO` and `defaultSC` for those who prefer it. +* `Binary` instances for `EMD`, `HHT`, and related data types. These are + based on `Binary` instance for `v a`, so the user must bring the orphan + instance of their choice into scope. Not sure if this is the best way to + do this. + Version 0.1.2.1 --------------- diff --git a/emd.cabal b/emd.cabal --- a/emd.cabal +++ b/emd.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: eba3e48d66b797a1e9b109e1bb2cc296003754c5adda30419efb80cfee7a1d66 +-- hash: 8146e6229308d428ec6ca649537a3ddf860fe609d1d2de6ea2aff6536e75ae9e name: emd -version: 0.1.2.1 +version: 0.1.3.0 synopsis: Empirical Mode Decomposition and Hilbert-Huang Transform description: Please see the README on GitHub at category: Math @@ -41,7 +41,9 @@ ghc-options: -Wall -Wredundant-constraints -Wcompat build-depends: base >=4.10 && <5 + , binary , containers + , data-default-class , finite-typelits , ghc-typelits-knownnat , ghc-typelits-natnormalise diff --git a/src/Numeric/EMD.hs b/src/Numeric/EMD.hs --- a/src/Numeric/EMD.hs +++ b/src/Numeric/EMD.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -51,12 +52,15 @@ import Control.Monad import Control.Monad.IO.Class +import Data.Default.Class import Data.Finite import Data.Functor.Identity +import GHC.Generics (Generic) import GHC.TypeNats import Numeric.EMD.Internal.Extrema import Numeric.EMD.Internal.Spline import Text.Printf +import qualified Data.Binary as Bi import qualified Data.Map as M import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Sized as SVG @@ -66,18 +70,21 @@ , eoSplineEnd :: SplineEnd a -- ^ end conditions for envelope splines , eoBoundaryHandler :: Maybe BoundaryHandler -- ^ process for handling boundary } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) data BoundaryHandler -- | Clamp envelope at end points (Matlab implementation) = BHClamp -- | Extend boundaries symmetrically | BHSymmetric - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) -- -- | Extend boundaries assuming global periodicity -- -- | BHPeriodic +instance Bi.Binary BoundaryHandler +instance Bi.Binary a => Bi.Binary (EMDOpts a) + -- | Default 'EMDOpts' defaultEO :: Fractional a => EMDOpts a defaultEO = EO { eoSiftCondition = defaultSC @@ -85,7 +92,22 @@ , eoBoundaryHandler = Just BHSymmetric } +instance Fractional a => Default (EMDOpts a) where + def = defaultEO + -- | Stop conditions for sifting process +-- +-- Data type is lazy in its fields, so this infinite data type: +-- +-- @ +-- nTimes n = SCTimes n `SCOr` nTimes (n + 1) +-- @ +-- +-- will be treated identically as: +-- +-- @ +-- nTimes = SCTimes +-- @ data SiftCondition a -- | Stop using standard SD method = SCStdDev !a @@ -95,11 +117,15 @@ | SCOr (SiftCondition a) (SiftCondition a) -- | Stop when both conditions are met | SCAnd (SiftCondition a) (SiftCondition a) - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) +instance Bi.Binary a => Bi.Binary (SiftCondition a) +instance Fractional a => Default (SiftCondition a) where + def = defaultSC + -- | Default 'SiftCondition' defaultSC :: Fractional a => SiftCondition a -defaultSC = SCStdDev 0.3 `SCOr` SCTimes 100 -- R package uses SCTimes 20, Matlab uses no limit +defaultSC = SCStdDev 0.3 `SCOr` SCTimes 50 -- R package uses SCTimes 20, Matlab uses no limit -- defaultSC = SCStdDev 0.3 -- | 'True' if stop @@ -128,7 +154,15 @@ data EMD v n a = EMD { emdIMFs :: ![SVG.Vector v n a] , emdResidual :: !(SVG.Vector v n a) } - deriving Show + deriving (Show, Generic, Eq, Ord) + +instance (VG.Vector v a, KnownNat n, Bi.Binary (v a)) => Bi.Binary (EMD v n a) where + put EMD{..} = Bi.put (SVG.fromSized <$> emdIMFs) + *> Bi.put (SVG.fromSized emdResidual) + get = do + Just emdIMFs <- traverse SVG.toSized <$> Bi.get + Just emdResidual <- SVG.toSized <$> Bi.get + pure EMD{..} -- | EMD decomposition of a given time series with a given sifting stop -- condition. diff --git a/src/Numeric/EMD/Internal/Spline.hs b/src/Numeric/EMD/Internal/Spline.hs --- a/src/Numeric/EMD/Internal/Spline.hs +++ b/src/Numeric/EMD/Internal/Spline.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -33,9 +34,11 @@ import Data.Maybe import Data.Proxy import Data.Type.Equality +import GHC.Generics (Generic) import GHC.TypeLits.Compare import GHC.TypeNats import Numeric.EMD.Internal.Tridiagonal +import qualified Data.Binary as Bi import qualified Data.Map as M import qualified Data.Vector.Sized as SV @@ -51,7 +54,9 @@ -- -- @since 0.1.2.0 | SEClamped a a - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance Bi.Binary a => Bi.Binary (SplineEnd a) data SplineCoef a = SC { _scAlpha :: !a -- ^ a , _scBeta :: !a -- ^ b diff --git a/src/Numeric/HHT.hs b/src/Numeric/HHT.hs --- a/src/Numeric/HHT.hs +++ b/src/Numeric/HHT.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -43,8 +44,10 @@ import Data.List import Data.Proxy import Data.Semigroup +import GHC.Generics (Generic) import GHC.TypeNats import Numeric.EMD +import qualified Data.Binary as Bi import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Vector.Generic as VG @@ -58,14 +61,25 @@ -- | IMF HHT instantaneous frequency as a time series (between 0 and 1) , hlFreqs :: !(SVG.Vector v n a) } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) +instance (VG.Vector v a, KnownNat n, Bi.Binary (v a)) => Bi.Binary (HHTLine v n a) where + put HHTLine{..} = Bi.put (SVG.fromSized hlMags ) + *> Bi.put (SVG.fromSized hlFreqs) + get = do + Just hlMags <- SVG.toSized <$> Bi.get + Just hlFreqs <- SVG.toSized <$> Bi.get + pure HHTLine{..} + -- | A Hilbert-Huang Transform. An @'HHT' v n a@ is a Hilbert-Huang -- transform of an @n@-item time series of items of type @a@ represented -- using vector @v@. -- -- Create using 'hht' or 'hhtEmd'. newtype HHT v n a = HHT { hhtLines :: [HHTLine v n a] } + deriving (Show, Eq, Ord, Generic) + +instance (VG.Vector v a, KnownNat n, Bi.Binary (v a)) => Bi.Binary (HHT v n a) -- | Directly compute the Hilbert-Huang transform of a given time series. -- Essentially is a composition of 'hhtEmd' and 'emd'. See 'hhtEmd' for