packages feed

tslib (empty) → 0.1.4

raw patch · 15 files changed

+1736/−0 lines, 15 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, containers, hspec, hybrid-vectors, lens, statistics, time, tslib, vector

Files

+ LICENSE view
@@ -0,0 +1,1 @@+All rights reserved
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog view
@@ -0,0 +1,9 @@+0.1.4+-----++* Fixing bug in tsResampleMoving.++0.1.3+-----++* Adding tsMapMaybe utility.
+ src/Data/TimeSeries.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}++module Data.TimeSeries (+  -- * Simple accessors+  tsLength,+  (!),+  tsRange,+  tsTraversed,+  tsTraversedWithIndex,+  toPairList,+  -- * Lookup at time+  TSLook(..),+  tsSearch,+  tsLookup,+  -- * Construction+  fromSortedPairList,+  fromUnsortedPairList,+  TSU.fromPeriodicData,+  -- * Lookup with interpolation+  TSInterpolate(..),+  interpolateAt,+  tsiExtend,+  tsiNoExtend,+  interpolateLinear,+  extendInterpolateLinear,+  tsGet,+  -- * Slicing+  tsSlice,+  TSU.tsSliceByCount,+  tsSplitAt,+  -- * Merging time series+  TSMerge(..),+  tsMerge,+  tsMergeWith,+  tsMergeEnhance,+  -- * Resampling time series+  tsResampleLocal,+  extendForward,+  extendBackward,+  tsResampleGlobal,+  tsResampleMoving,+  -- * Shifting time series in time+  tsOffsetGeneral,+  tsOffsetByPeriod,+  -- * Utilities+  tsMapMaybe+  ) where++import Control.Lens+import Data.Time (UTCTime)+import Data.TimeSeries.Class+import Data.TimeSeries.Periodic+import qualified Data.TimeSeries.UTime as TSU+import Data.UTime+import qualified Data.Vector.Generic as G++ut2utc :: Setting (->) s t UTime UTCTime -> s -> t+ut2utc s = over s fromUTime++ut2utcL :: [(UTime, a)] -> [(UTCTime, a)]+ut2utcL = ut2utc (mapped._1)++utc2ut :: Setting (->) s t UTCTime UTime -> s -> t+utc2ut s = over s toUTime++utc2utL :: [(UTCTime, a)] -> [(UTime, a)]+utc2utL = utc2ut (mapped._1)+++tsLength :: TSeries ts a => ts a -> Int+tsLength = TSU.tsLength+{-# INLINE tsLength #-}++(!) :: TSeries ts a => ts a -> Int -> (UTCTime, a)+(!) ts i = ut2utc _1 $ toVector ts G.! i+{-# INLINE (!) #-}++-- | Returns the first and last time stamp of a time series.+tsRange :: TSeries ts a => ts a -> Maybe (UTCTime, UTCTime)+tsRange = ut2utc (mapped.both) . TSU.tsRange++-- TODO(klao): Going through lists is probably inefficient! Check, and+-- go through streams it that's the case.++-- | Traversal of the values of a time series with access to the time stamp as index.+tsTraversed :: (TSeries ts a, TSeries ts b) => IndexedTraversal UTCTime (ts a) (ts b) a b+tsTraversed f ts = fromVector . G.fromListN (G.length v) <$> traverse g (G.toList v)+  where+    v = toVector ts+    g (t, x) = (t,) <$> indexed f (fromUTime t) x++-- | Traversal of ('UTCTime', @value@) pairs of a time series with+-- access to a positional index.+--+-- The user of this traversal should guarantee to not reorder the+-- events (ie. that the time stamps are modified in a monotonic way).+tsTraversedWithIndex :: (TSeries ts a, TSeries ts b)+                        => IndexedTraversal Int (ts a) (ts b) (UTCTime, a) (UTCTime, b)+tsTraversedWithIndex f ts+  = fromVector . G.fromListN (G.length v) . utc2utL <$> itraversed f (ut2utcL $ G.toList v)+  where+    v = toVector ts++-- | Construct a time series from a list of (time stamp, value) pairs+--+-- Precondition: the list /have to/ be sorted by time stamps.+fromSortedPairList :: TSeries ts a => [(UTCTime, a)] -> ts a+fromSortedPairList = TSU.fromSortedPairList . utc2utL++-- | Construct a time series from a list of (time stamp, value) pairs+--+-- The list is sorted by time stamps on construction.+fromUnsortedPairList :: TSeries ts a => [(UTCTime, a)] -> ts a+fromUnsortedPairList = TSU.fromUnsortedPairList . utc2utL++-- | Returns a list of (time stamp, value) pairs of a time series+-- sorted by time stamps.+toPairList :: TSeries ts a => ts a -> [(UTCTime, a)]+toPairList = ut2utcL . TSU.toPairList++--------------------------------------------------------------------------------+-- Lookup++data TSLook+  = AtOrAfter UTCTime+  | After UTCTime+  | AtOrBefore UTCTime+  | Before UTCTime+  deriving (Eq, Show)++-- | Returns the position in the time series corresponding to the+-- 'TSLook' parameter.+tsSearch :: TSeries ts a => ts a -> TSLook -> Int+tsSearch ts l = if before then i - 1 else i+  where+    (before, ut) = case l of+      AtOrAfter t    -> (False, toUTimeUp t)+      After t  -> (False, toUTimeUp' t)+      AtOrBefore t   -> (True, toUTimeUp' t)+      Before t -> (True, toUTimeUp t)+    i = TSU.tsSearch ts ut++-- | Returns the element of the time series corresponding to the+-- 'TSLook' parameter, or 'Nothing' if there is no suitable element.+--+-- Examples:+--+-- @tsLookup ts ('AtOrAfter' t)@ returns the /first/ element with the time+-- stamp not earlier than @t@.+--+-- @tsLookup ts ('StrictBefore' t)@ returns the /last/ element with+-- the time stamp strictly before @t@.+tsLookup :: TSeries ts a => ts a -> TSLook -> Maybe (UTCTime, a)+tsLookup ts l | i >= 0, i < tsLength ts  = Just (ts ! i)+              | otherwise  = Nothing+  where+    i = tsSearch ts l++--------------------------------------------------------------------------------+-- Slicing++-- | Returns the slice of the time series within the provided time interval.+--+-- The time interval is interpreted as half-open, ie. the element+-- corresponding to the start paramenter is included, but the one+-- corresponding to the end parameter is not. With this, using+-- 'AtOrAfter' and 'After' it is possible to synthesize both inclusive+-- and exclusive behavior at either end. Eg.:+--+-- @tsSlice ts (AtOrAfter t0) (After t1)@ returns series of all+-- elements with time stamp at least @t0@ and at most @t1@, both ends+-- included.+--+-- @tsSlice ts (After t0) (AtOrAfter t1)@ -- like before, but now both+-- @t0@ and @t1@ are excluded.+tsSlice :: TSeries ts a => ts a+        -> TSLook -- ^ start descriptor (inclusive)+        -> TSLook -- ^ end descriptor (exclusive)+        -> ts a+tsSlice ts lStart lEnd+  | start > end  = error "tsSlice: start position later than the end position"+  | otherwise  = fromVector $ G.slice start (end - start) $ toVector ts+  where+    start = max 0 $ tsSearch ts lStart+    end = max 0 $ tsSearch ts lEnd++-- | Split the time series into two parts at the position+-- corresponding to the 'TSLook' parameter.+--+-- The element that would have been returned by 'tsLookup' with the+-- same arguments is the first element of the second part.+tsSplitAt :: TSeries ts a => TSLook -> ts a -> (ts a, ts a)+tsSplitAt l ts = (before, after)+  where+    i = tsSearch ts l+    v = toVector ts+    (before, after) = G.splitAt i v & both %~ fromVector++--------------------------------------------------------------------------------+-- Interpolating++-- | Data type used to set up interpolation functions like+-- 'interpolateAt', 'tsMergeEnhance' and 'tsResampleLocal'.+data TSInterpolate a =+  TSInterpolate+  { tsiBefore  :: UTCTime -> (UTCTime, a) -> Maybe (UTCTime, a)+    -- ^ Function to interpolate for time stamps that are before the first item in the time series.+  , tsiAfter   :: UTCTime -> (UTCTime, a) -> Maybe (UTCTime, a)+    -- ^ Function to interpolate for time stamps that are after the last item in the time series.+  , tsiBetween :: UTCTime -> (UTCTime, a) -> (UTCTime, a) -> Maybe (UTCTime, a)+    -- ^ Function to interpolate for time stamps in the middle of the time series.+  }+  | TSInterpolateUT (TSU.TSInterpolate a)++tsi2ut :: TSInterpolate a -> TSU.TSInterpolate a+tsi2ut (TSInterpolateUT interp) = interp+tsi2ut (TSInterpolate before after between) = TSU.TSInterpolate before' after' between'+  where+    before' t = utc2ut (mapped._1) . before (fromUTime t) . ut2utc _1+    after' t = utc2ut (mapped._1) . after (fromUTime t) . ut2utc _1+    between' t (t0, a) = utc2ut (mapped._1) . between (fromUTime t) (fromUTime t0, a) . ut2utc _1++interpolateAt :: TSeries ts a => TSInterpolate a -- ^ Parameters to use during the interpolation.+              -> ts a                -- ^ Input time series to interpolate from.+              -> UTCTime             -- ^ Time stamp to interpolate at.+              -> Maybe (UTCTime, a)  -- ^ The result of interpolation.+interpolateAt inter ts = ut2utc (mapped._1) . TSU.interpolateAt (tsi2ut inter) ts . toUTime++-- | Defines trivial extending of a time series: uses the the same+-- value as the first/last item.+--+-- To be used as 'tsiBefore' or 'tsiAfter' field of a 'TSInterpolate'.+tsiExtend :: UTCTime -> (UTCTime, a) -> Maybe (UTCTime, a)+tsiExtend t (_, x) = Just (t, x)++-- | Defines non-extending time series.+--+-- To be used as 'tsiBefore' or 'tsiAfter' field of a 'TSInterpolate'.+tsiNoExtend :: UTCTime -> (UTCTime, a) -> Maybe (UTCTime, a)+tsiNoExtend = const $ const Nothing++-- | Linearly interpolates within time series; does not extend.+interpolateLinear :: Fractional a => TSInterpolate a+interpolateLinear = TSInterpolateUT TSU.interpolateLinear++-- | Linearly interpolates within time series; extends at the ends.+extendInterpolateLinear :: Fractional a => TSInterpolate a+extendInterpolateLinear = TSInterpolateUT TSU.extendInterpolateLinear++-- | Access any time stamp in the given time series, with linear+-- interpolation and trivial extension at the ends if needed.+tsGet :: (Fractional a, TSeries ts a) => ts a -> UTCTime -> a+tsGet ts = TSU.tsGet ts . toUTime++--------------------------------------------------------------------------------+-- Time series merging++-- | Structure describing a recipe for a generic merge.+data TSMerge a b c =+  TSMerge+  { tsmLeft  :: UTCTime -> a -> Maybe c+  , tsmRight :: UTCTime -> b -> Maybe c+  , tsmBoth  :: UTCTime -> a -> b -> Maybe c+  }++tsm2ut :: TSMerge a b c -> TSU.TSMerge a b c+tsm2ut (TSMerge mleft mright mboth) = TSU.TSMerge mleft' mright' mboth'+  where+    mleft' = mleft . fromUTime+    mright' = mright . fromUTime+    mboth' = mboth . fromUTime++-- | Generic (non-interpolating) merge.+--+-- Every time stamp considered independently from all the+-- other. Conversion or combination of values is made according to the+-- provided recipe, based on whether the value is present in one or+-- both time series.+tsMerge :: (TSeries ts a, TSeries ts b, TSeries ts c)+           => TSMerge a b c -> ts a -> ts b -> ts c+tsMerge = TSU.tsMerge . tsm2ut++-- | Simple (non-interpolating) merge, similar to zipWith.+--+-- Only the time stamps for which value is present in both series are+-- considered. Values are combined by the user-supplied function.+tsMergeWith :: (TSeries ts a, TSeries ts b, TSeries ts c)+           => (UTCTime -> a -> b -> c) -> ts a -> ts b -> ts c+tsMergeWith fboth = TSU.tsMergeWith (fboth . fromUTime)++-- | Merges two time series by extending/resampling them to match each other.+--+-- The two time series are extended/resampled with 'tsResampleLocal'+-- using the provided interpolators; and then merged with+-- 'tsMergeWith'.+tsMergeEnhance :: (TSeries ts a, TSeries ts b, TSeries ts c)+                  => (Bool, TSInterpolate a)+                  -> (Bool, TSInterpolate b)+                  -> (UTCTime -> a -> b -> c)+                  -> ts a -> ts b -> ts c+tsMergeEnhance aInterp bInterp fboth+  = TSU.tsMergeEnhance (over _2 tsi2ut aInterp) (over _2 tsi2ut bInterp) (fboth . fromUTime)++--------------------------------------------------------------------------------+-- Resampling++-- | Resample or extend a time series to have values at the provided time stamps.+--+-- Resampling is done by locally interpolating between the two+-- neighboring events (using the provided @interpolator@).+--+-- If the @extend?@ argument is @True@, the original time series is+-- extended; otherwise the result will have values only at the new+-- time stamps (and the elements of the original time series are+-- discarded if they don't appear in the provided time stamp+-- sequence).+tsResampleLocal :: TSeries ts a+                   => Bool             -- ^ extend?+                   -> TSInterpolate a  -- ^ interpolator+                   -> [UTCTime]        -- ^ time stamp sequence+                   -> ts a -> ts a+tsResampleLocal keepOriginal interp+  = TSU.tsResampleLocal keepOriginal (tsi2ut interp) . map toUTime++-- | Extend/resample a time series by copying values forward.+extendForward :: TSeries ts a => Bool -> [UTCTime] -> ts a -> ts a+extendForward keepOriginal = TSU.extendForward keepOriginal . map toUTime++-- | Extend/resample a time series by copying values backward.+extendBackward :: TSeries ts a => Bool -> [UTCTime] -> ts a -> ts a+extendBackward keepOriginal = TSU.extendBackward keepOriginal . map toUTime++-- | Resample a time series to have values at provided time stamps.+--+-- For every new time stamp a user supplied function is evaluated with+-- that time stamp and two sub-series: one containing every event+-- strictly before the time stamp, and one containing events at or+-- after the time stamp. The results are collected to create the+-- resulting time series.+tsResampleGlobal :: TSeries ts a+                    => (UTCTime -> ts a -> ts a -> Maybe (UTCTime, a))+                    -> [UTCTime]+                    -> ts a -> ts a+tsResampleGlobal sample = TSU.tsResampleGlobal sample' . map toUTime+  where+    sample' t tsl tsr = utc2ut (mapped._1) $ sample (fromUTime t) tsl tsr++-- | Resamples a time series by calculating aggregates over a moving+-- window of a given duration at the given time stamps.+--+-- If the time stamps for the window positions should be periodic too, you can use+-- @'psOver' ('tsRange' series)@ as the @times@ argument.+--+-- Note that each timestamp defines the end of a window, and the+-- timestamp is included in the window.+tsResampleMoving :: TSeries ts a+                  => (UTCTime -> ts a -> Maybe a)+                  -> Period      -- ^ window duration+                  -> [UTCTime]   -- ^ @times@: time stamps for the window ends (included in the window)+                  -> ts a -> ts a+tsResampleMoving sample p = TSU.tsResampleMoving (sample . fromUTime) p . map (TSU.justAfter . toUTime)++--------------------------------------------------------------------------------+-- Shift time series in time.++-- | Shift time series in time by applying the user provided function+-- to all the time stamps.+--+-- Prerequisite: the provided time-modifying function has to be monotone.+tsOffsetGeneral :: TSeries ts a+                   => (UTCTime -> UTCTime)+                   -> ts a -> ts a+tsOffsetGeneral f = tsTraversedWithIndex . _1 %~ f++tsOffsetByPeriod :: TSeries ts a+                    => Period+                    -> ts a -> ts a+tsOffsetByPeriod p = tsOffsetGeneral $ periodStep p++-- Utilities --++tsMapMaybe+  :: (TSeries ts a, TSeries ts b)+  => (a -> Maybe b)+  -> ts a+  -> ts b+tsMapMaybe f+  = fromSortedPairList . toListOf (folded . aside _Just) . map (_2 %~ f) . toPairList
+ src/Data/TimeSeries/Boxed.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Data.TimeSeries.Boxed (+  TSeries(..),+  ) where++import Control.Applicative+import Control.Lens+import Data.Foldable+import Data.Typeable (Typeable)+import Data.TimeSeries.Class hiding (TSeries)+import Data.UTime (UTime)+import qualified Data.TimeSeries.Class as TSC+import qualified Data.Vector as V+import qualified Data.Vector.Hybrid as H+import qualified Data.Vector.Storable as VS+import Prelude hiding (foldr)++-- | Boxed time series that can hold any kind of value.  The internal+-- representation is a parallel vector of 'UTime's and @a@s. The+-- vector of 'UTime's is storable 'VS.Vector' for efficiency and+-- interoperability reasons.+newtype TSeries a = TSeries (H.Vector VS.Vector V.Vector (UTime, a))+                    deriving (Eq, Show, Typeable)++type instance TSVector TSeries = H.Vector VS.Vector V.Vector+type instance TSTimes TSeries = VS.Vector+type instance TSValues TSeries  = V.Vector++instance TSC.TSeries TSeries a where+  toVector (TSeries v) = v+  fromVector = TSeries++  tsValues (TSeries v) = H.projectSnd v+  tsTimes (TSeries v) = H.projectFst v++  fromTimesValues ts vs = TSeries $ H.unsafeZip ts vs++instance Functor TSeries where+  fmap f ts = fromTimesValues times $ fmap f values+    where+      (times, values) = (tsTimes ts, tsValues ts)++instance Foldable TSeries where+  foldr f b = foldr f b . tsValues++instance Traversable TSeries where+  traverse f ts = fromTimesValues times <$> traverse f values+    where+      (times, values) = (tsTimes ts, tsValues ts)++--------------------------------------------------------------------------------+-- *WithIndex instances++instance TraversableWithIndex UTime TSeries where+  itraverse f (TSeries v) =+    fromVector . H.fromListN (H.length v) <$> traverse (itraverse f) (H.toList v)++instance FunctorWithIndex UTime TSeries++instance FoldableWithIndex UTime TSeries
+ src/Data/TimeSeries/Class.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Data.TimeSeries.Class (+  TSeries(..),+  TSTimes,+  TSVector,+  TSValues,+  ) where++import Data.Vector.Generic (Vector)+import Data.UTime (UTime)++----------------------------------------+-- The main type class++-- | The @hybrid-vector@ type backing the time series.+type family TSVector (ts :: * -> *) :: * -> *+-- | The @vector@ type backing the 'UTime's in the time series.+type family TSTimes (ts :: * -> *) :: * -> *+-- | The @vector@ type backing the values in the time series.+type family TSValues (ts :: * -> *) :: * -> *++-- | The time series type class, currently with two implementations:+-- Boxed and Unboxed (Storable).+--+-- The type variable @ts@ denotes the specific time series type and+-- @a@ denotes the stored values.+class (Vector (TSVector ts) (UTime, a),+       Vector (TSTimes ts) UTime,+       Vector (TSValues ts) a) => TSeries ts a where++  fromVector :: TSVector ts (UTime, a) -> ts a+  toVector :: ts a -> TSVector ts (UTime, a)++  tsTimes :: ts a -> TSTimes ts UTime+  tsValues :: ts a -> TSValues ts a++  -- | The two vectors are assumed to have the same length.  This is+  -- not checked!+  fromTimesValues :: TSTimes ts UTime -> TSValues ts a -> ts a
+ src/Data/TimeSeries/Periodic.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE BangPatterns #-}++module Data.TimeSeries.Periodic (+  Period(..),+  Weekdays(..),+  periodStep,+  periodStepBack,+  PeriodicSequence,+  periodicSequence,+  nth,+  psToList,+  psOver,+  -- * UTime API+  psToUTimeList,+  periodStepUTime,+  periodStepBackUTime,+  psOverUTime,+  ) where++import Control.Arrow (first, second)+import Control.Lens+import Data.Fixed (divMod')+import Data.Time+import Data.Set (Set)+import qualified Data.Set as S+import Data.UTime+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as V++data Period+  = PicoSeconds Integer+  | Seconds Int+  | Minutes Int+  | Hours Int+  | Days Int+  | Weeks Int+  | Workdays+  | Weekdays (Set Weekdays)+  | Months Int+  | Years Int+  deriving (Eq, Show, Read)++data Weekdays+  = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday+  deriving (Eq, Ord, Show, Read, Enum)++-- | Represents a sequence of time stamps repeating periodically from+-- a given start time.  The repeating period can be quite flexible,+-- see 'Period'.  To create values of this data type use the+-- 'periodicSequence' function.+data PeriodicSequence+  = PSecs !DiffTime !Integer !DiffTime      -- period, broken down starting time+  | PDays !Integer !Integer !DiffTime   -- period, broken down starting time+  | PCal !Integer !Int !Integer !Int !Int !DiffTime  -- period (years, months), starting time (gregorian (y,m,d), daytime)+  | PWeek !(Vector Int) !Integer !Int !DiffTime  -- period (set of week days), starting time (Monday of the start time, day's index in the set, daytime)+  deriving (Eq, Show)++periodicSequence :: Period   -- ^ Repeation period.+                 -> UTCTime  -- ^ Start time.+                 -> PeriodicSequence+periodicSequence per start = case per of+  PicoSeconds p -> PSecs (picosecondsToDiffTime p) dayi dayt+  Seconds s -> PSecs (fromIntegral s) dayi dayt+  Minutes mp -> PSecs (60 * fromIntegral mp) dayi dayt+  Hours h -> PSecs (3600 * fromIntegral h) dayi dayt+  Days d -> PDays (fromIntegral d) dayi dayt+  Weeks w -> PDays (fromIntegral w * 7) dayi dayt+  Months mp -> PCal 0 mp y m md dayt+  Years yp -> PCal (fromIntegral yp) 0 y m md dayt+  Workdays -> PWeek v (dMon + 7*w) i dayt+    where+      v = V.fromList [0, 1, 2, 3, 4]+      (w, i) = firstAfter v wday+  Weekdays s -> PWeek v (dMon + 7*w) i dayt+    where+      v = V.fromList . map fromEnum . S.toList $ s+      (w, i) = firstAfter v wday+  where+    (UTCTime day@(ModifiedJulianDay dayi) dayt) = start+    (y,m,md) = toGregorian day+    -- Day 0 is a Wednesday+    wday = (dayi + 2) `mod` 7+    dMon = dayi - wday++    firstAfter :: Vector Int -> Integer -> (Integer, Int)+    firstAfter v a = case V.findIndex (>= fromIntegral a) v of+      Just i -> (0, i)+      Nothing -> (1, 0)++-- | Accessor for the @n@th element of a 'PeriodicSequence'.+nth :: PeriodicSequence -> Int -> UTCTime+nth ps k0 = case ps of+  PSecs p day dt -> UTCTime (ModifiedJulianDay $ day + day') dt'+    where (day', dt') = (dt + p * fromIntegral k0) `divMod'` 86400+  PDays p day dt -> UTCTime (ModifiedJulianDay $ day + k * p) dt+  PCal yp mp y m d dt -> UTCTime (fromGregorian (y + k * yp + y') m' d) dt+    where+      (y', m') = first fromIntegral . second (+1) $ (m + k0 * mp - 1) `divMod` 12+  PWeek v day0 mday dt -> UTCTime (ModifiedJulianDay day) dt+    where+      day = day0 + fromIntegral (7 * w + v V.! i)+      (w, i) = (mday + k0) `divMod` V.length v+  where+    k = fromIntegral k0++-- | Returns an infine list of times in the periodic sequence.+--+-- The first element of the result is guaranteed to be not earlier+-- than the start time with which the sequence was created. (But, in+-- the case of Workdays and Weekdays it might be a later time.)+psToList :: PeriodicSequence -> [UTCTime]+psToList ps = go 0+  where+    go !k = nth ps k : go (k+1)++-- | Returns the time value which is one @period@ after the given time.+periodStep :: Period -> UTCTime -> UTCTime+periodStep p t = nth (periodicSequence p t) 1++-- | Returns the time value which is one @period@ before the given time.+periodStepBack :: Period -> UTCTime -> UTCTime+periodStepBack p t = nth (periodicSequence p t) (-1)++-- | Returns the elements of the periodic sequence starting at the+-- beginning and contained in the given time range.+psOver :: Period -> (UTCTime, UTCTime) -> [UTCTime]+psOver p (start, end) = takeWhile (<= end) $ psToList $ periodicSequence p start++--------------------------------------------------------------------------------+-- UTime functions++psToUTimeList :: PeriodicSequence -> [UTime]+psToUTimeList = map toUTime . psToList++periodStepUTime :: Period -> UTime -> UTime+periodStepUTime p = under utime (periodStep p)++periodStepBackUTime :: Period -> UTime -> UTime+periodStepBackUTime p = under utime (periodStepBack p)++psOverUTime :: Period -> (UTime, UTime) -> [UTime]+psOverUTime p (start, end)+  = takeWhile (<= end) . psToUTimeList . periodicSequence p $ fromUTime start++--------------------------------------------------------------------------------+-- Note(klao): there is a 'time-recurrence' package on Hackage, which+-- probably has the required functionality. But, it's licensed under+-- LGPL.
+ src/Data/TimeSeries/Storable.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Data.TimeSeries.Storable (+  TSeries(..),+  valuesAsHmatrixVector+  ) where++import Data.Typeable (Typeable)+import Data.TimeSeries.Class hiding (TSeries)+import Data.UTime (UTime)+import qualified Data.TimeSeries.Class as TSC+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Hybrid as H++-- | Unboxed time series that can hold 'VS.Storable' values.  The+-- internal representation is a parallel vector of 'UTime's and+-- the the unboxed 'VS.Storable' values.+newtype TSeries a = TSeries (H.Vector VS.Vector VS.Vector (UTime, a))+                    deriving (Eq, Show, Typeable)++type instance TSVector TSeries = H.Vector VS.Vector VS.Vector+type instance TSTimes TSeries = VS.Vector+type instance TSValues TSeries  = VS.Vector++instance VS.Storable a => TSC.TSeries TSeries a where+  toVector (TSeries v) = v+  fromVector = TSeries++  tsValues (TSeries v) = H.projectSnd v+  tsTimes (TSeries v) = H.projectFst v++  fromTimesValues ts vs = TSeries $ H.unsafeZip ts vs++-- | Convert a time series to a @VS.Vector@, by chopping of the time stamps.+--+-- This is the same as 'HMatrix.Vector', but by not declaring that as+-- the return value, we avoid an expensive dependency.+valuesAsHmatrixVector :: VS.Storable a => TSeries a -> VS.Vector a+valuesAsHmatrixVector = tsValues+{-# INLINE valuesAsHmatrixVector #-}
+ src/Data/TimeSeries/UTime.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}++module Data.TimeSeries.UTime (+  -- * Simple accessors+  tsLength,+  tsRange,+  tsTraversed,+  tsTraversedWithIndex,+  toPairList,+  -- * Lookup at time+  tsSearch,+  firstAfter,+  lastBefore,+  -- * Construction+  fromSortedPairList,+  fromUnsortedPairList,+  fromPeriodicData,+  -- * Lookup with interpolation+  TSInterpolate(..),+  interpolateAt,+  linearBetween,+  tsiExtend,+  tsiNoExtend,+  interpolateLinear,+  extendInterpolateLinear,+  tsGet,+  -- * Slicing+  tsSlice,+  justAfter,+  tsSliceByCount,+  tsSplitAt,+  -- * Merging time series+  TSMerge(..),+  tsMerge,+  tsMergeWith,+  tsMergeEnhance,+  -- * Resampling time series+  tsResampleLocal,+  extendForward,+  extendBackward,+  tsResampleGlobal,+  tsResampleMoving,+  -- * Shifting time series in time+  tsOffsetGeneral,+  tsOffsetByPeriod,+  ) where++import Control.Lens+import Data.Bits (shiftR)+import Data.Ord (comparing)+import Data.Maybe (catMaybes, fromJust)+import Data.TimeSeries.Class+import Data.TimeSeries.Periodic+import Data.UTime (UTime(..))+import qualified Data.Vector.Generic as G+import Statistics.Function (sortBy)++tsLength :: TSeries ts a => ts a -> Int+tsLength = G.length . toVector+{-# INLINE tsLength #-}++-- | Returns the first and last time stamp of a time series.+tsRange :: TSeries ts a => ts a -> Maybe (UTime, UTime)+tsRange ts = case tsLength ts of+  0 -> Nothing+  _ -> Just (G.head v, G.last v)+  where+    v = tsTimes ts++-- TODO(klao): Going through lists is probably inefficient! Check, and+-- go through streams it that's the case.++-- | Traversal of the values of a time series with access to the time stamp as index.+tsTraversed :: (TSeries ts a, TSeries ts b) => IndexedTraversal UTime (ts a) (ts b) a b+tsTraversed f ts+  = fromVector . G.fromListN (G.length v) <$> traverse (itraversed f) (G.toList v)+  where+    v = toVector ts+++-- | Traversal of ('UTime', @value@) pairs of a time series with+-- access to a positional index.+--+-- The user of this traversal should guarantee to not reorder the+-- events (ie. that the time stamps are modified in a monotonic way).+tsTraversedWithIndex :: (TSeries ts a, TSeries ts b)+                        => IndexedTraversal Int (ts a) (ts b) (UTime, a) (UTime, b)+tsTraversedWithIndex f ts+  = fromVector . G.fromListN (G.length v) <$> itraversed f (G.toList v)+  where+    v = toVector ts++-- | Construct a time series from a list of (time stamp, value) pairs+--+-- Precondition: the list /have to/ be sorted by time stamps.+fromSortedPairList :: TSeries ts a => [(UTime, a)] -> ts a+fromSortedPairList = fromVector . G.fromList++-- | Construct a time series from a list of (time stamp, value) pairs+--+-- The list is sorted by time stamps on construction.+fromUnsortedPairList :: TSeries ts a => [(UTime, a)] -> ts a+fromUnsortedPairList = fromVector . sortBy (comparing fst) . G.fromList++-- | Returns a list of (time stamp, value) pairs of a time series+-- sorted by time stamps.+toPairList :: TSeries ts a => ts a -> [(UTime, a)]+toPairList = G.toList . toVector++-- | Zip a 'PeriodicSequence' with a list of values.+fromPeriodicData :: TSeries ts a => PeriodicSequence -> [a] -> ts a+fromPeriodicData ps as = fromSortedPairList $ zip (psToUTimeList ps) as++--------------------------------------------------------------------------------+-- Lookup++-- | Returns the lowest index @i@ such that all events after @i@ have time+-- stamp at least t.+tsSearch :: TSeries ts a => ts a+            -> UTime -- ^ the reference time stamp @t@+            -> Int     -- ^ the returned index @i@+tsSearch ts t | n == 0     = 0+              | otherwise  = t `seq` go 0 n+  where+    v = tsTimes ts+    n = G.length v+    go !l !u | l >= u  = l+             | G.unsafeIndex v k < t  = go (k+1) u+             | otherwise  = go l k+      where+        k = (l + u) `shiftR` 1++-- | Returns the first event that has time stamp not earlier than @t@+-- or 'Nothing' if there's no such event in the series.+firstAfter :: TSeries ts a => ts a+           -> UTime  -- ^ the refenrece time stmap @t@+           -> Maybe (UTime, a)+firstAfter ts t | k < tsLength ts = Just (toVector ts G.! k)+                | otherwise = Nothing+  where+    k = tsSearch ts t++-- | Returns the last event that has time stamp not later than @t@+-- or 'Nothing' if there's no such event in the series.+lastBefore :: TSeries ts a => ts a+           -> UTime  -- ^ the reference time stamp @t@+           -> Maybe (UTime, a)+lastBefore ts t | k < n, t == t2  = Just e2+                | k > 0           = Just e1+                | otherwise       = Nothing+  where+    k = tsSearch ts t+    v = toVector ts+    n = tsLength ts+    e2@(t2, _) = v G.! k+    e1 = v G.! (k-1)++--------------------------------------------------------------------------------+-- Slicing++-- | Returns the slice of the time series within the provided time interval.+--+-- The time interval is interpreted as half-open, ie. the start time+-- is inclusive, but the end time is not. If you need different+-- behavior use the provided convenience function: 'justAfter' (for+-- start time, to make it exclusive; for end time, to make it+-- inclusive).+tsSlice :: TSeries ts a => ts a+        -> UTime -- ^ start time (inclusive)+        -> UTime -- ^ end time (exclusive)+        -> ts a+tsSlice ts tStart tEnd+  | tStart > tEnd  = error "tsSlice: start time later than end time"+  | otherwise  = fromVector $ G.slice start (end - start) $ toVector ts+  where+    start = tsSearch ts tStart+    end = tsSearch ts tEnd++-- | Returns the next representable time value.+justAfter :: UTime -> UTime+justAfter = succ++-- | Returns the slice of the time series within the provided index interval.+--+-- The index interval is half-open: start index is inclusive, end+-- index is exclusive.+tsSliceByCount :: TSeries ts a => ts a+               -> Int -- ^ start index (inclusive)+               -> Int -- ^ end index (exclusive)+               -> ts a+tsSliceByCount ts start end = fromVector $ G.slice start (end - start) $ toVector ts++-- | Split the time series into two parts: everything strictly before+-- the given time stamp, and everything after the given time stamp+-- (including it).+tsSplitAt :: TSeries ts a => UTime -> ts a -> (ts a, ts a)+tsSplitAt t ts = (before, after)+  where+    i = tsSearch ts t+    v = toVector ts+    (before, after) = G.splitAt i v & both %~ fromVector++--------------------------------------------------------------------------------+-- Interpolating++-- | Data type used to set up interpolation functions like+-- 'interpolateAt', 'tsMergeEnhance' and 'tsResampleLocal'.+data TSInterpolate a =+  TSInterpolate+  { tsiBefore  :: UTime -> (UTime, a) -> Maybe (UTime, a)+    -- ^ Function to interpolate for time stamps that are before the first item in the time series.+  , tsiAfter   :: UTime -> (UTime, a) -> Maybe (UTime, a)+    -- ^ Function to interpolate for time stamps that are after the last item in the time series.+  , tsiBetween :: UTime -> (UTime, a) -> (UTime, a) -> Maybe (UTime, a)+    -- ^ Function to interpolate for time stamps in the middle of the time series.+  }++interpolateAt :: TSeries ts a => TSInterpolate a -- ^ Parameters to use during the interpolation.+              -> ts a                -- ^ Input time series to interpolate from.+              -> UTime             -- ^ Time stamp to interpolate at.+              -> Maybe (UTime, a)  -- ^ The result of interpolation.+interpolateAt inter ts t | k < n, t == t2  = Just e2+                         | k < n, k > 0    = tsiBetween inter t e1 e2+                         | n > 0, k == 0   = tsiBefore  inter t e2+                         | n > 0, k == n   = tsiAfter   inter t e1+                         | otherwise       = Nothing+  where+    k = tsSearch ts t+    v = toVector ts+    n = tsLength ts+    e2@(t2, _) = v G.! k+    e1 = v G.! (k-1)++-- | Helper function to linearly interpolate a numeric value between two events.+--+-- Assumes that the two events are in order and the interpolating time+-- is strictly between the two time stamps.+--+-- Useful as the 'tsiBetween' field of a 'TSInterpolate'.+linearBetween :: Fractional a => UTime -> (UTime, a) -> (UTime, a)+                 -> Maybe (UTime, a)+linearBetween ut (ut0, x0) (ut1, x1) = Just (ut, wx / (t1 - t0))+  where+    f (UTime us) = fromIntegral us+    t = f ut+    t0 = f ut0+    t1 = f ut1+    wx = x0 * (t1 - t) + x1 * (t - t0)++-- | Defines trivial extending of a time series: uses the the same+-- value as the first/last item.+--+-- To be used as 'tsiBefore' or 'tsiAfter' field of a 'TSInterpolate'.+tsiExtend :: UTime -> (UTime, a) -> Maybe (UTime, a)+tsiExtend t (_, x) = Just (t, x)++-- | Defines non-extending time series.+--+-- To be used as 'tsiBefore' or 'tsiAfter' field of a 'TSInterpolate'.+tsiNoExtend :: UTime -> (UTime, a) -> Maybe (UTime, a)+tsiNoExtend = const $ const Nothing++-- | Linearly interpolates within time series; does not extend.+interpolateLinear :: Fractional a => TSInterpolate a+interpolateLinear = TSInterpolate tsiNoExtend tsiNoExtend linearBetween++-- | Linearly interpolates within time series; extends at the ends.+extendInterpolateLinear :: Fractional a => TSInterpolate a+extendInterpolateLinear = TSInterpolate tsiExtend tsiExtend linearBetween++-- | Access any time stamp in the given time series, with linear+-- interpolation and trivial extension at the ends if needed.+tsGet :: (Fractional a, TSeries ts a) => ts a -> UTime -> a+tsGet ts = snd . fromJust . interpolateAt extendInterpolateLinear ts++--------------------------------------------------------------------------------+-- Time series merging++-- | Structure describing a recipe for a generic merge.+data TSMerge a b c =+  TSMerge+  { tsmLeft  :: UTime -> a -> Maybe c+  , tsmRight :: UTime -> b -> Maybe c+  , tsmBoth  :: UTime -> a -> b -> Maybe c+  }++-- | Generic (non-interpolating) merge.+--+-- Every time stamp considered independently from all the+-- other. Conversion or combination of values is made according to the+-- provided recipe, based on whether the value is present in one or+-- both time series.+tsMerge :: (TSeries ts a, TSeries ts b, TSeries ts c)+           => TSMerge a b c -> ts a -> ts b -> ts c+tsMerge (TSMerge mleft mright mboth) tsa tsb = fromSortedPairList . catMaybes $ go as0 bs0+  where+    as0 = toPairList tsa+    bs0 = toPairList tsb+    fleft (t,a) = (t,) <$> mleft t a+    fright (t,b) = (t,) <$> mright t b+    go as [] = map fleft as+    go [] bs = map fright bs+    go as@((ta, a) : as') bs@((tb, b) : bs')+      | ta < tb   = fleft (ta, a) : go as' bs+      | ta > tb   = fright (tb, b) : go as bs'+      | otherwise = ((ta,) <$> mboth ta a b) : go as' bs'++-- | Simple (non-interpolating) merge, similar to zipWith.+--+-- Only the time stamps for which value is present in both series are+-- considered. Values are combined by the user-supplied function.+tsMergeWith :: (TSeries ts a, TSeries ts b, TSeries ts c)+           => (UTime -> a -> b -> c) -> ts a -> ts b -> ts c+tsMergeWith fboth tsa tsb = tsMerge merger tsa tsb+  where+    merger = TSMerge (const $ const Nothing) (const $ const Nothing) mboth+    mboth t a b = Just $ fboth t a b++-- | Merges two time series by extending/resampling them to match each other.+--+-- The two time series are extended/resampled with 'tsResampleLocal'+-- using the provided interpolators; and then merged with+-- 'tsMergeWith'.+tsMergeEnhance :: (TSeries ts a, TSeries ts b, TSeries ts c)+                  => (Bool, TSInterpolate a)+                  -> (Bool, TSInterpolate b)+                  -> (UTime -> a -> b -> c)+                  -> ts a -> ts b -> ts c+tsMergeEnhance aInterp bInterp fboth tsa tsb = tsMergeWith fboth tsaEnhanced tsbEnhanced+  where+    tsaEnhanced = tsResampleLocal (fst aInterp) (snd aInterp) (G.toList $ tsTimes tsb) tsa+    tsbEnhanced = tsResampleLocal (fst bInterp) (snd bInterp) (G.toList $ tsTimes tsa) tsb+++--------------------------------------------------------------------------------+-- Resampling++-- | Resample or extend a time series to have values at the provided time stamps.+--+-- Resampling is done by locally interpolating between the two+-- neighboring events (using the provided @interpolator@).+--+-- If the @extend?@ argument is @True@, the original time series is+-- extended; otherwise the result will have values only at the new+-- time stamps (and the elements of the original time series are+-- discarded if they don't appear in the provided time stamp+-- sequence).+tsResampleLocal :: TSeries ts a+                   => Bool             -- ^ extend?+                   -> TSInterpolate a  -- ^ interpolator+                   -> [UTime]        -- ^ time stamp sequence+                   -> ts a -> ts a+tsResampleLocal keepOriginal interp times series+  = fromSortedPairList $ catMaybes $ go False (toPairList series) times+  where+    go _ [] _ = []+    go eLast (p : ps) []+      | not keepOriginal = []+      | otherwise = map Just $ if eLast then ps else p : ps+    go eLast ps@(p1@(t1, _) : ps') ts@(t : ts')+      | t1 < t, keepOriginal, not eLast = Just p1 : go True ps ts+      | t < t1  = tsiBefore interp t p1 : go eLast ps ts'+      | t == t1 = Just p1 : go False ps' ts'+      | otherwise = case ps' of+        [] -> map (flip (tsiAfter interp) p1) ts+        (p2@(t2, _) : _)+          | t < t2    -> tsiBetween interp t p1 p2 : go eLast ps ts'+          | otherwise -> go False ps' ts++-- | Extend/resample a time series by copying values forward.+extendForward :: TSeries ts a => Bool -> [UTime] -> ts a -> ts a+extendForward keepOriginal = tsResampleLocal keepOriginal interpForward+  where+    interpForward = TSInterpolate tsiNoExtend tsiExtend keepLeft+    keepLeft t (_,x) _ = Just (t, x)++-- | Extend/resample a time series by copying values backward.+extendBackward :: TSeries ts a => Bool -> [UTime] -> ts a -> ts a+extendBackward keepOriginal = tsResampleLocal keepOriginal interpBackward+  where+    interpBackward = TSInterpolate tsiExtend tsiNoExtend keepRight+    keepRight t _ (_,x) = Just (t, x)++-- | Resample a time series to have values at provided time stamps.+--+-- For every new time stamp a user supplied function is evaluated with+-- that time stamp and two sub-series: one containing every event+-- strictly before the time stamp, and one containing events at or+-- after the time stamp. The results are collected to create the+-- resulting time series.+tsResampleGlobal :: TSeries ts a+                    => (UTime -> ts a -> ts a -> Maybe (UTime, a))+                    -> [UTime]+                    -> ts a -> ts a+tsResampleGlobal sample times series = fromSortedPairList $ catMaybes $ map sliceOn times+  where+    sliceOn t = sample t before after+      where+        (before, after) = tsSplitAt t series++-- | Resamples a time series by calculating aggregates over a moving+-- window of a given duration at the given time stamps.+--+-- If the time stamps for the window positions should be periodic too, you can use+-- @'psOver' ('tsRange' series)@ as the @times@ argument.+tsResampleMoving :: TSeries ts a+                  => (UTime -> ts a -> Maybe a)+                  -> Period      -- ^ window duration+                  -> [UTime]     -- ^ @times@: time stamps for the window ends+                  -> ts a -> ts a+tsResampleMoving sample p = tsResampleGlobal gSample+  where+    gSample t before _ = (t,) <$> sample t window+      where+        (_, window) = tsSplitAt (periodStepBackUTime p t) before++++--------------------------------------------------------------------------------+-- Shift time series in time.++-- | Shift time series in time by applying the user provided function+-- to all the time stamps.+--+-- Prerequisite: the provided time-modifying function has to be monotone.+tsOffsetGeneral :: TSeries ts a+                   => (UTime -> UTime)+                   -> ts a -> ts a+tsOffsetGeneral f = tsTraversedWithIndex . _1 %~ f++tsOffsetByPeriod :: TSeries ts a+                    => Period+                    -> ts a -> ts a+tsOffsetByPeriod p = tsOffsetGeneral $ periodStepUTime p
+ src/Data/UTime.hs view
@@ -0,0 +1,95 @@+-- | 'UTime' is a minimalistic efficient alternative to 'UTCTime'.+--+-- The 'UTime' representation is intentionally not opaque to allow+-- efficient low-level access. But, you should consider this module+-- \"somewhat internal\".++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.UTime (+  UTime(..),+  fromUTime,+  toUTime,+  toUTimeUp, toUTimeUp',+  toUTimeDown, toUTimeDown',+  utime,+  -- * For testing only:+  dtPico,+  ) where++import Control.Lens+import Data.Time+import Data.Int+import Foreign.Storable+import Unsafe.Coerce++newtype UTime = UTime Int64+                deriving (Eq, Ord, Enum, Bounded, Storable)++-- 'DiffTime' is currently implemented as a newtype around+-- 'Integer'. As long as it stays so, this function is safe; and if it+-- changes it will blow up noticeably.+--+-- Because the appropriate accessors/constructors are not exported,+-- all other conversion mechanisms involve unnecessary 'Rational'+-- arithmetics, which is probably the biggest source of inefficiency+-- in 'UTCTime'.+dtPico :: Iso' DiffTime Integer+dtPico = iso unsafeCoerce unsafeCoerce+{-# INLINE dtPico #-}++fromUTime :: UTime -> UTCTime+fromUTime (UTime micros) = UTCTime (ModifiedJulianDay day) dayTime+  where+    (d, dt) = micros `divMod` 86400000000+    day = fromIntegral $ 40587 + d+    dayTime = (fromIntegral $ 1000000 * dt) ^. from dtPico+{-# INLINE fromUTime #-}++toUTimeGeneric :: Int64 -> UTCTime -> UTime+toUTimeGeneric shift (UTCTime (ModifiedJulianDay day) dayTime) = UTime micros+  where+    micros = d * 86400000000 + dt+    d = fromIntegral day - 40587+    dt = (fromIntegral (dayTime ^. dtPico) + shift) `div` 1000000+{-# INLINE toUTimeGeneric #-}++-- | Converts 'UTCTime' to 'UTime' by rounding.+toUTime :: UTCTime -> UTime+toUTime = toUTimeGeneric 500000+-- TODO(klao): rounding is probably the right thing to do+-- here. But, truncating can make things cleaner and easier to+-- reason about...+{-# INLINE toUTime #-}++-- | Returns the smallest 'UTime' value representing a time not+-- earlier than the input 'UTCTime'.+toUTimeUp :: UTCTime -> UTime+toUTimeUp = toUTimeGeneric 999999+{-# INLINE toUTimeUp #-}++-- | Returns the smallest 'UTime' value representing a time strictly+-- later than the input 'UTCTime'.+toUTimeUp' :: UTCTime -> UTime+toUTimeUp' = toUTimeGeneric 1000000+{-# INLINE toUTimeUp' #-}++-- | Returns the largest 'UTime' value representing a time not+-- later than the input 'UTCTime'.+toUTimeDown :: UTCTime -> UTime+toUTimeDown = toUTimeGeneric 0+{-# INLINE toUTimeDown #-}++-- | Returns the largest 'UTime' value representing a time strictly+-- earlier than the input 'UTCTime'.+toUTimeDown' :: UTCTime -> UTime+toUTimeDown' = toUTimeGeneric (-1)+{-# INLINE toUTimeDown' #-}++utime :: Iso' UTCTime UTime+utime = iso toUTime fromUTime+{-# INLINE utime #-}++instance Show UTime where+  showsPrec p = showsPrec p . fromUTime+  show = show . fromUTime
+ tests/basicTest.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main  where++import Control.Lens+import Data.Time+import Data.TimeSeries+import Data.TimeSeries.Class+import qualified Data.TimeSeries.Boxed as TSB+import qualified Data.TimeSeries.Storable as TSS+import Test.Hspec+import Test.HUnit++t1, t12, t2, t23, t3, tOld, tFar :: UTCTime+tOld = UTCTime (fromGregorian 1900 01 01) 0+t1 = UTCTime (fromGregorian 2014 05 05) 0+t12 = UTCTime (fromGregorian 2014 05 20) 3600+t2 = UTCTime (fromGregorian 2014 06 15) 0+t23 = UTCTime (fromGregorian 2014 06 20) 28800+t3 = UTCTime (fromGregorian 2014 07 01) 0+tFar = UTCTime (fromGregorian 2024 07 07) 43200++exAbstract :: TSeries ts Int => ts Int+exAbstract = fromUnsortedPairList [(t1, 10), (t3, 30), (t2, 20)]++ex2Abstract :: TSeries ts Int => ts Int+ex2Abstract = fromUnsortedPairList [(t12, 12), (t2, 2), (t23, 23)]++exDoubleAbstract :: (TSeries ts Int, TSeries ts Double) => ts Double+exDoubleAbstract = exAbstract & tsTraversed %~ fromIntegral++emptyAbstract :: TSeries ts Double => ts Double+emptyAbstract = fromSortedPairList []++type TSeriesTestable ts a = (TSeries ts a, Show (ts a), Eq (ts a))++mainAbstract :: forall ts. ( TSeriesTestable ts Double+                           , TSeriesTestable ts Int+                           , TSeriesTestable ts Bool) => ts Double -> Spec+mainAbstract _witness = do+  let ex = exAbstract :: ts Int+      ex2 = ex2Abstract :: ts Int+      exDouble = exDoubleAbstract :: ts Double+      empty = emptyAbstract :: ts Double++  describe "fromUnsortedPairList" $ do+    it "sorts" $ do+      [(t1, 10), (t2, 20), (t3, 30)] @=? toPairList ex++  describe "tsLength" $ do+    it "0 on empty" $ do+      0 @=? tsLength empty+    it "3 on example" $ do+      3 @=? tsLength ex++  describe "tsRange" $ do+    it "Nothing on empty" $ do+      Nothing @=? tsRange empty+    it "(t1,t3) on example" $ do+      Just (t1,t3) @=? tsRange ex++  describe "tsLookup with AtOrAfter" $ do+    let lookup' t = tsLookup ex (AtOrAfter t)+    it "Nothing on far" $ do+      Nothing @=? lookup' tFar+    it "exact" $ do+      Just (t2,20) @=? lookup' t2+    it "t2 on t12" $ do+      Just (t2,20) @=? lookup' t12+    it "first on old" $ do+      Just (t1, 10) @=? lookup' tOld++  describe "tsLookup with AtOrBefore" $ do+    let lookup' t = tsLookup ex (AtOrBefore t)+    it "Nothing on old" $ do+      Nothing @=? lookup' tOld+    it "exact" $ do+      Just (t2,20) @=? lookup' t2+    it "t1 on t12" $ do+      Just (t1,10) @=? lookup' t12+    it "last on far" $ do+      Just (t3, 30) @=? lookup' tFar++  let roundToTwoDigits :: Maybe (UTCTime, Double) -> Maybe (UTCTime, Int)+      roundToTwoDigits = fmap (mapSnd (round . (* 100)))+        where+          mapSnd f (a, b) = (a, f b)++  let interp1 t = interpolateAt interpolateLinear exDouble t+  describe "interpolateAt with interpolateLinear" $ do+    it "exact" $ do+      Just (t1,10.0) @=? interp1 t1+    it "Nothing on old" $ do+      Nothing @=? interp1 tOld+    it "Nothing on far" $ do+      Nothing @=? interp1 tFar+    it "interpolates" $ do+      roundToTwoDigits (Just (t23, 20 + 10/3)) @=? (roundToTwoDigits $ interp1 t23)++  let interp2 t = interpolateAt extendInterpolateLinear exDouble t+  describe "interpolateAt with extendInterpolateLinear" $ do+    it "exact" $ do+      Just (t1,10.0) @=? interp2 t1+    it "extends on old" $ do+      Just (tOld, 10) @=? interp2 tOld+    it "extends on far" $ do+      Just (tFar, 30) @=? interp2 tFar+    it "interpolates" $ do+      roundToTwoDigits (Just (t23, 20 + 10/3)) @=? (roundToTwoDigits $ interp2 t23)++  describe "tsMergeWith" $ do+    it "empty with empty on the right" $ do+      empty @=? tsMergeWith undefined ex empty+    it "empty with empty on the left" $ do+      empty @=? tsMergeWith undefined empty ex+    it "equates with itself" $ do+      fromSortedPairList [(t1,True), (t2, True), (t3, True)]+      @=? tsMergeWith (const (==)) ex ex++  describe "tsMerge" $ do+    it "does it right" $ do+      fromSortedPairList [(t1, 20), (t12, -12), (t2, 18), (t23, -23), (t3, 60)]+      @=? tsMerge+        (TSMerge (const $ Just . (2*)) (const $ Just . negate) (\_ a b -> Just (a - b)))+        ex ex2++main :: IO ()+main = hspec $ do+  describe "Boxed" $ mainAbstract (undefined :: TSB.TSeries Double)+  describe "Storable" $ mainAbstract (undefined :: TSS.TSeries Double)
+ tests/basicUTimeTest.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main  where++import Control.Lens+import Data.Time+import Data.UTime+import Data.TimeSeries.UTime+import Data.TimeSeries.Class+import qualified Data.TimeSeries.Boxed as TSB+import qualified Data.TimeSeries.Storable as TSS+import Test.Hspec+import Test.HUnit++ut :: Integer -> Int -> Int -> DiffTime -> UTime+ut y m d dt = toUTime $ UTCTime (fromGregorian y m d) dt++t1, t12, t2, t23, t3, tOld, tFar :: UTime+tOld = ut 1900 01 01 0+t1 = ut 2014 05 05 0+t12 = ut 2014 05 20 3600+t2 = ut 2014 06 15 0+t23 = ut 2014 06 20 28800+t3 = ut 2014 07 01 0+tFar = ut 2024 07 07 43200++exAbstract :: TSeries ts Int => ts Int+exAbstract = fromUnsortedPairList [(t1, 10), (t3, 30), (t2, 20)]++ex2Abstract :: TSeries ts Int => ts Int+ex2Abstract = fromUnsortedPairList [(t12, 12), (t2, 2), (t23, 23)]++exDoubleAbstract :: (TSeries ts Int, TSeries ts Double) => ts Double+exDoubleAbstract = exAbstract & tsTraversed %~ fromIntegral++emptyAbstract :: TSeries ts Double => ts Double+emptyAbstract = fromSortedPairList []++type TSeriesTestable ts a = (TSeries ts a, Show (ts a), Eq (ts a))++mainAbstract :: forall ts. ( TSeriesTestable ts Double+                           , TSeriesTestable ts Int+                           , TSeriesTestable ts Bool) => ts Double -> Spec+mainAbstract _witness = do+  let ex = exAbstract :: ts Int+      ex2 = ex2Abstract :: ts Int+      exDouble = exDoubleAbstract :: ts Double+      empty = emptyAbstract :: ts Double++  describe "fromUnsortedPairList" $ do+    it "sorts" $ do+      [(t1, 10), (t2, 20), (t3, 30)] @=? toPairList ex++  describe "tsLength" $ do+    it "0 on empty" $ do+      0 @=? tsLength empty+    it "3 on example" $ do+      3 @=? tsLength ex++  describe "tsRange" $ do+    it "Nothing on empty" $ do+      Nothing @=? tsRange empty+    it "(t1,t3) on example" $ do+      Just (t1,t3) @=? tsRange ex++  describe "firstAfter" $ do+    it "Nothing on far" $ do+      Nothing @=? firstAfter ex tFar+    it "exact" $ do+      Just (t2,20) @=? firstAfter ex t2+    it "t2 on t12" $ do+      Just (t2,20) @=? firstAfter ex t12+    it "first on old" $ do+      Just (t1, 10) @=? firstAfter ex tOld++  describe "lastBefore" $ do+    it "Nothing on old" $ do+      Nothing @=? lastBefore ex tOld+    it "exact" $ do+      Just (t2,20) @=? lastBefore ex t2+    it "t1 on t12" $ do+      Just (t1,10) @=? lastBefore ex t12+    it "last on far" $ do+      Just (t3, 30) @=? lastBefore ex tFar++  let roundToTwoDigits :: Maybe (UTime, Double) -> Maybe (UTime, Int)+      roundToTwoDigits = fmap (mapSnd (round . (* 100)))+        where+          mapSnd f (a, b) = (a, f b)++  let interp1 t = interpolateAt interpolateLinear exDouble t+  describe "interpolateAt with interpolateLinear" $ do+    it "exact" $ do+      Just (t1,10.0) @=? interp1 t1+    it "Nothing on old" $ do+      Nothing @=? interp1 tOld+    it "Nothing on far" $ do+      Nothing @=? interp1 tFar+    it "interpolates" $ do+      roundToTwoDigits (Just (t23, 20 + 10/3)) @=? (roundToTwoDigits $ interp1 t23)++  let interp2 t = interpolateAt extendInterpolateLinear exDouble t+  describe "interpolateAt with extendInterpolateLinear" $ do+    it "exact" $ do+      Just (t1,10.0) @=? interp2 t1+    it "extends on old" $ do+      Just (tOld, 10) @=? interp2 tOld+    it "extends on far" $ do+      Just (tFar, 30) @=? interp2 tFar+    it "interpolates" $ do+      roundToTwoDigits (Just (t23, 20 + 10/3)) @=? (roundToTwoDigits $ interp2 t23)++  describe "tsMergeWith" $ do+    it "empty with empty on the right" $ do+      empty @=? tsMergeWith undefined ex empty+    it "empty with empty on the left" $ do+      empty @=? tsMergeWith undefined empty ex+    it "equates with itself" $ do+      fromSortedPairList [(t1,True), (t2, True), (t3, True)]+      @=? tsMergeWith (const (==)) ex ex++  describe "tsMerge" $ do+    it "does it right" $ do+      fromSortedPairList [(t1, 20), (t12, -12), (t2, 18), (t23, -23), (t3, 60)]+      @=? tsMerge+        (TSMerge (const $ Just . (2*)) (const $ Just . negate) (\_ a b -> Just (a - b)))+        ex ex2++main :: IO ()+main = hspec $ do+  describe "Boxed" $ mainAbstract (undefined :: TSB.TSeries Double)+  describe "Storable" $ mainAbstract (undefined :: TSS.TSeries Double)
+ tests/periodicTest.hs view
@@ -0,0 +1,75 @@+module Main (main) where++import qualified Data.Set as S+import Data.Time+import Data.TimeSeries.Periodic+import Test.Hspec+import Test.HUnit++day :: Integer -> Int -> Int -> Day+day = fromGregorian++ut :: Integer -> Int -> Int -> DiffTime -> UTCTime+ut y m d dt = UTCTime (day y m d) dt++t :: Int -> Int -> DiffTime -> DiffTime+t h m s = 3600 * fromIntegral h + 60 * fromIntegral m + s++periodic :: Period -> UTCTime -> Int -> Int -> [UTCTime]+periodic p start d k = take k $ drop d $ psToList $ periodicSequence p start++main :: IO ()+main = hspec $ do+  describe "Seconds" $ do+    let d1 h m s = ut 2014 07 03 (t h m s)+        d2 h m s = ut 2014 07 04 (t h m s)+        d3 h m s = ut 2014 07 05 (t h m s)+    it "overlaps" $ do+      [d1 23 59 58.1, d1 23 59 59.1, d2 0 0 0.1, d2 0 0 1.1]+      @=? periodic (Seconds 1) (d1 23 59 58.1) 0 4+    it "overlaps after a day" $ do+      [d2 23 59 56.1, d2 23 59 59.1, d3 0 0 2.1, d3 0 0 5.1]+      @=? periodic (Seconds 3) (d1 23 59 56.1) (86400 `div` 3) 4++  describe "Hours" $ do+    let d1 d h = ut 2014 07 d (t h 5 10.11)+    it "overlaps" $ do+      [d1 3 22, d1 3 23, d1 4 0, d1 4 1]+      @=? periodic (Hours 1) (d1 3 22) 0 4+    it "overlaps, few days later" $ do+      [d1 8 20, d1 8 23, d1 9 2, d1 9 5]+      @=? periodic (Hours 3) (d1 3 20) 40 4++  let dd y m d = ut y m d (t 2 10 3.4)+  describe "Months" $ do+    it "overlaps" $ do+      [dd 2013 11 05, dd 2013 12 05, dd 2014 01 05, dd 2014 02 05]+      @=? periodic (Months 1) (dd 2013 11 05) 0 4+    it "clips" $ do+      [dd 2011 08 31, dd 2012 02 29, dd 2012 08 31, dd 2013 02 28]+      @=? periodic (Months 6) (dd 2010 08 31) 2 4++  describe "Years" $ do+    it "overlaps" $ do+      [dd 1999 11 05, dd 2000 11 05, dd 2001 11 05, dd 2002 11 05]+      @=? periodic (Years 1) (dd 1899 11 05) 100 4+    it "clips" $ do+      [dd 1880 02 29, dd 1890 02 28, dd 1900 02 28, dd 1910 02 28]+      @=? periodic (Years 10) (dd 1880 02 29) 0 4++  describe "Workdays" $ do+    it "overlaps" $ do+      [dd 2014 07 03, dd 2014 07 04, dd 2014 07 07, dd 2014 07 08]+      @=? periodic Workdays (dd 2014 06 26) 5 4+    it "clips forward" $ do+      [dd 2014 06 30, dd 2014 07 01, dd 2014 07 02, dd 2014 07 03]+      @=? periodic Workdays (dd 2014 06 29) 0 4++  describe "Weekdays" $ do+    let s = S.fromList [Monday, Wednesday, Friday]+    it "overlaps" $ do+      [dd 2014 06 30, dd 2014 07 02, dd 2014 07 04, dd 2014 07 07]+      @=? periodic (Weekdays s) (dd 2014 06 23) 3 4+    it "clips forward" $ do+      [dd 2014 07 02, dd 2014 07 04, dd 2014 07 07, dd 2014 07 09]+      @=? periodic (Weekdays s) (dd 2014 07 01) 0 4
+ tests/utimeTest.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Control.Applicative+import Control.Lens+import Data.Time+import Data.UTime+import Test.Hspec+import Test.HUnit+import Test.QuickCheck++deriving instance Arbitrary UTime++instance Arbitrary UTCTime where+  arbitrary = UTCTime <$> (ModifiedJulianDay <$> day) <*> (review dtPico <$> dayTime)+    where+      day = choose (-36500000, 36500000)    -- 100000 years+      dayTime = choose (0, 86400 * 10^(12::Int) - 1)++mkUtc :: Integer -> Int -> Int -> DiffTime -> UTCTime+mkUtc y m d dt = UTCTime (fromGregorian y m d) dt++withinTolerance :: UTCTime -> UTCTime -> Bool+withinTolerance t1 t2 = abs (diffUTCTime t1 t2) <= 0.0000005++main :: IO ()+main = hspec $ do+  describe "UTime" $ do+    it "epoch at 0" $ do+      mkUtc 1970 01 01 0 @=? fromUTime (UTime 0)+    it "microsecond based" $ do+      mkUtc 1970 01 01 0.000001 @=? fromUTime (UTime 1)+    it "OK on a random future date" $ do+      mkUtc 2155 07 07 7268.123456 @=? fromUTime (UTime 5854212068123456)+    it "OK on a random past date" $ do+      mkUtc 1834 05 17 14463.123456 @=? fromUTime (UTime $ -4279982336876544)++  describe "UTime and back" $ do+    it "identity when rounding" $ do+      property $ \t -> t == (toUTime . fromUTime $ t)+    it "identity when up" $ do+      property $ \t -> t == (toUTimeUp . fromUTime $ t)+    it "identity when down" $ do+      property $ \t -> t == (toUTimeDown . fromUTime $ t)+    it "succ when up'" $ do+      property $ \t -> succ t == (toUTimeUp' . fromUTime $ t)+    it "pred when down'" $ do+      property $ \t -> pred t == (toUTimeDown' . fromUTime $ t)++  -- TODO(klao): modify the 'Arbitrary' instance for UTCTime, so that+  -- strict inequalities have a better chance of failing _if_ they+  -- were false.+  describe "UTCTime and back" $ do+    it "approx identity" $ do+      property $ \t ->+        t `withinTolerance` (fromUTime . toUTime $ t)+    it "up when up" $ do+      property $ \t -> t <= (fromUTime . toUTimeUp $ t)+    it "strictly up when up'" $ do+      property $ \t -> t < (fromUTime . toUTimeUp' $ t)+    it "down when down" $ do+      property $ \t -> t >= (fromUTime . toUTimeDown $ t)+    it "strictly down when down'" $ do+      property $ \t -> t > (fromUTime . toUTimeDown' $ t)
+ tslib.cabal view
@@ -0,0 +1,97 @@+name:                tslib+version:             0.1.4+license:             OtherLicense+license-file:        LICENSE+copyright:           FP Complete CORP+author:              Mihaly Barasz, Gergely Risko+maintainer:          Mihaly Barasz <klao@nilcons.com>, Gergely Risko <errge@nilcons.com>+category:            Data+build-type:          Simple+cabal-version:       >= 1.10+synopsis:            Time series library+-- description:++extra-source-files:+    changelog++library+  exposed-modules:+    Data.TimeSeries,+    Data.TimeSeries.Class,+    Data.TimeSeries.Boxed,+    Data.TimeSeries.Periodic,+    Data.TimeSeries.Storable,+    Data.TimeSeries.UTime,+    Data.UTime+  -- other-modules:+  -- other-extensions:+  default-language:    Haskell2010+  hs-source-dirs: src+  ghc-options:         -Wall+  build-depends:+    base               == 4.8.*,+    containers         >= 0.5  &&  < 0.6,+    hybrid-vectors     >= 0.1  &&  < 0.3,+    lens               >= 4.6,+    statistics         >= 0.11 &&  < 0.14,+    time               >= 1.2  &&  < 1.6,+    vector             >= 0.10 &&  < 0.11++test-suite basicTest+  type: exitcode-stdio-1.0+  main-is: basicTest.hs+  hs-source-dirs: tests+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+    tslib,+    base,+    lens,+    hspec,+    HUnit,+    time,+    vector++test-suite basicUTimeTest+  type: exitcode-stdio-1.0+  main-is: basicUTimeTest.hs+  hs-source-dirs: tests+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+    tslib,+    base,+    lens,+    hspec,+    HUnit,+    time,+    vector++test-suite periodicTest+  type: exitcode-stdio-1.0+  main-is: periodicTest.hs+  hs-source-dirs: tests+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+    tslib,+    base,+    containers,+    hspec,+    HUnit,+    time++test-suite utimeTest+  type: exitcode-stdio-1.0+  main-is: utimeTest.hs+  hs-source-dirs: tests+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+    tslib,+    base,+    lens,+    hspec,+    HUnit,+    QuickCheck,+    time