diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +All rights reserved diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,9 @@ +0.1.4 +----- + +* Fixing bug in tsResampleMoving. + +0.1.3 +----- + +* Adding tsMapMaybe utility. diff --git a/src/Data/TimeSeries.hs b/src/Data/TimeSeries.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries.hs @@ -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 diff --git a/src/Data/TimeSeries/Boxed.hs b/src/Data/TimeSeries/Boxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries/Boxed.hs @@ -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 diff --git a/src/Data/TimeSeries/Class.hs b/src/Data/TimeSeries/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries/Class.hs @@ -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 diff --git a/src/Data/TimeSeries/Periodic.hs b/src/Data/TimeSeries/Periodic.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries/Periodic.hs @@ -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. diff --git a/src/Data/TimeSeries/Storable.hs b/src/Data/TimeSeries/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries/Storable.hs @@ -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 #-} diff --git a/src/Data/TimeSeries/UTime.hs b/src/Data/TimeSeries/UTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries/UTime.hs @@ -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 diff --git a/src/Data/UTime.hs b/src/Data/UTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/UTime.hs @@ -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 diff --git a/tests/basicTest.hs b/tests/basicTest.hs new file mode 100644 --- /dev/null +++ b/tests/basicTest.hs @@ -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) diff --git a/tests/basicUTimeTest.hs b/tests/basicUTimeTest.hs new file mode 100644 --- /dev/null +++ b/tests/basicUTimeTest.hs @@ -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) diff --git a/tests/periodicTest.hs b/tests/periodicTest.hs new file mode 100644 --- /dev/null +++ b/tests/periodicTest.hs @@ -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 diff --git a/tests/utimeTest.hs b/tests/utimeTest.hs new file mode 100644 --- /dev/null +++ b/tests/utimeTest.hs @@ -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) diff --git a/tslib.cabal b/tslib.cabal new file mode 100644 --- /dev/null +++ b/tslib.cabal @@ -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 , Gergely Risko +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