diff --git a/src/ATrade/BarAggregator.hs b/src/ATrade/BarAggregator.hs index 226639b..672a97e 100644 --- a/src/ATrade/BarAggregator.hs +++ b/src/ATrade/BarAggregator.hs @@ -19,6 +19,7 @@ module ATrade.BarAggregator ( mkAggregatorFromBars, handleTicks, handleTick, + updateTime, handleBar, hmsToDiffTime ) where @@ -144,6 +145,42 @@ handleTick tick = runState $ do barClose = barClose bar, barVolume = 0 } +updateTime :: Tick -> BarAggregator -> (Maybe Bar, BarAggregator) +updateTime tick = runState $ do + lLastTicks %= M.insert (security tick, datatype tick) tick + tws <- gets tickTimeWindows + mybars <- gets bars + if (any (isInTimeInterval tick) tws) + then + case M.lookup (security tick) mybars of + Just series -> case bsBars series of + (b:bs) -> do + let currentBn = barNumber (barTimestamp b) (tfSeconds $ bsTimeframe series) + if currentBn == barNumber (timestamp tick) (tfSeconds $ bsTimeframe series) + then do + lBars %= M.insert (security tick) series { bsBars = updateBarTimestamp b tick : bs } + return Nothing + else do + lBars %= M.insert (security tick) series { bsBars = emptyBarFromTick tick : b : bs } + return $ Just b + _ -> return Nothing + _ -> return Nothing + else + return Nothing + where + isInTimeInterval t (a, b) = (utctDayTime . timestamp) t >= a && (utctDayTime . timestamp) t <= b + emptyBarFromTick !newtick = Bar { barSecurity = security newtick, + barTimestamp = timestamp newtick, + barOpen = value newtick, + barHigh = value newtick, + barLow = value newtick, + barClose = value newtick, + barVolume = 0 } + + updateBarTimestamp !bar newtick = bar { barTimestamp = newTimestamp } + where + newTimestamp = timestamp newtick + handleBar :: Bar -> BarAggregator -> (Maybe Bar, BarAggregator) handleBar bar = runState $ do tws <- gets tickTimeWindows diff --git a/src/ATrade/Driver/Real/QuoteSourceThread.hs b/src/ATrade/Driver/Real/QuoteSourceThread.hs index 089a41e..28426df 100644 --- a/src/ATrade/Driver/Real/QuoteSourceThread.hs +++ b/src/ATrade/Driver/Real/QuoteSourceThread.hs @@ -37,11 +37,17 @@ startQuoteSourceThread ctx qsEp strategy eventChan agg tickFilter maybeSourceTim case qdata of QDTick tick -> when (goodTick tick) $ do writeChan eventChan (NewTick tick) - when (isNothing maybeSourceTimeframe) $ do - aggValue <- readIORef agg - case handleTick tick aggValue of - (Just bar, !newAggValue) -> writeIORef agg newAggValue >> writeChan eventChan (NewBar bar) - (Nothing, !newAggValue) -> writeIORef agg newAggValue + case maybeSourceTimeframe of + Nothing -> do + aggValue <- readIORef agg + case handleTick tick aggValue of + (Just bar, !newAggValue) -> writeIORef agg newAggValue >> writeChan eventChan (NewBar bar) + (Nothing, !newAggValue) -> writeIORef agg newAggValue + Just _ -> do + aggValue <- readIORef agg + case updateTime tick aggValue of + (Just bar, !newAggValue) -> writeIORef agg newAggValue >> writeChan eventChan (NewBar bar) + (Nothing, !newAggValue) -> writeIORef agg newAggValue QDBar (_, bar) -> do aggValue <- readIORef agg when (isJust maybeSourceTimeframe) $ do diff --git a/test/Test/BarAggregator.hs b/test/Test/BarAggregator.hs index d9269d0..a9263b5 100644 --- a/test/Test/BarAggregator.hs +++ b/test/Test/BarAggregator.hs @@ -33,6 +33,7 @@ unitTests = testGroup "BarAggregator" [ , testTwoBarsInSameBar , testTwoBarsInSameBarLastBar , testNextBarAfterBarClose + , testUpdateTime ] properties = testGroup "BarAggregator" [ @@ -192,6 +193,37 @@ testNextBarAfterBarClose = testCase "Three bars (smaller timeframe) - next bar a barClose = fromDouble c, barVolume = v } +testUpdateTime :: TestTree +testUpdateTime = testCase "updateTime - next bar - creates new bar with zero volume" $ do + let series = BarSeries "TEST_TICKER" (Timeframe 3600) [] + let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] + let (_, newagg) = handleBar (bar testTimestamp1 12.00 13.00 10.00 11.00 1) agg + let (_, newagg') = handleBar (bar testTimestamp2 12.00 15.00 11.00 12.00 2) newagg + let (newBar, newagg'') = updateTime (tick testTimestamp4 13.00 100) newagg' + let expectedNewBar = Bar "TEST_TICKER" testTimestamp2 12.00 15.00 10.00 12.00 3 + let expectedBar = Bar "TEST_TICKER" testTimestamp4 13.00 13.00 13.00 13.00 0 + (head <$> bsBars <$> (M.lookup "TEST_TICKER" $ bars newagg'')) @?= Just expectedBar + newBar @?= Just expectedNewBar + where + testTimestamp1 = (UTCTime (fromGregorian 1970 1 1) 560) + testTimestamp2 = (UTCTime (fromGregorian 1970 1 1) 600) + testTimestamp3 = (UTCTime (fromGregorian 1970 1 1) 3600) + testTimestamp4 = (UTCTime (fromGregorian 1970 1 1) 3660) + tick ts v vol = Tick { + security = "TEST_TICKER" + , datatype = LastTradePrice + , timestamp = ts + , value = v + , volume = vol } + bar ts o h l c v = Bar { + barSecurity = "TEST_TICKER", + barTimestamp = ts, + barOpen = fromDouble o, + barHigh = fromDouble h, + barLow = fromDouble l, + barClose = fromDouble c, + barVolume = v } + prop_allTicksInOneBar :: TestTree prop_allTicksInOneBar = QC.testProperty "All ticks in one bar" $ QC.forAll (QC.choose (1, 86400)) $ \timeframe -> QC.forAll (QC.listOf1 (genTick "TEST_TICKER" baseTime timeframe)) $ \ticks -> @@ -215,4 +247,3 @@ prop_allTicksInOneBar = QC.testProperty "All ticks in one bar" $ QC.forAll (QC.c currentBar tickerId agg = headMay =<< (bsBars <$> M.lookup tickerId (bars agg)) baseTime = UTCTime (fromGregorian 1970 1 1) 0 -