Drezil/ibhelper
1
1
Fork 0
Code Issues 12 Pull Requests Projects Releases Wiki Activity

further implemented #12 & tested preliminary. Should(tm) work fine now.

Browse Source
This commit is contained in:
Nicole Dresselhaus 2022-08-08 08:37:59 +02:00
parent 16b4eb83e1
commit 42183873d8
4 changed files with 111 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
deps/dear-implot.hs vendored

@ -1 +1 @@
Subproject commit f3d5b63b541d8048568f134403838213c77177e4
Subproject commit 2b3810f7927a83c7cf95612497eaeceed56ca5e8

90
src/Chart.hs
View File

@ -3,7 +3,13 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
module Chart (newChart, FillerException(..), getUpdatedChartCache, getChunkedDay) where
module Chart (newChart
, FillerException(..)
, getUpdatedChartCache
, getChunkedDay
, timePointToIndex
, indexToTimePoint
) where
import Import
import Control.Concurrent (forkIO)
@ -40,19 +46,29 @@ newChart contract = do
unless (sym `HM.member` hm) $ do
today <- liftIO getCurrentDay :: RIO App Day
(cacheErrors, cacheData) <- do
files <- liftIO $ listDirectory $ "cache" </> show con
res <- forM files $ \cacheFileName -> do
let fname = "cache" </> show con </> cacheFileName
ifM (liftIO $ doesFileExist fname)
(bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname))
(return $ Left $ "cachefile "<>cacheFileName<>" not found.")
return $ partitionEithers res
ifM (fmap not $ liftIO $ doesDirectoryExist $ "cache" </> show con)
(return $ (["no data-chache found for " <> show con], [])) $ do
files <- liftIO $ listDirectory $ "cache" </> show con
res <- forM files $ \cacheFileName -> do
let fname = "cache" </> show con </> cacheFileName
ifM (liftIO $ doesFileExist fname)
(bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname))
(return $ Left $ "cachefile "<>cacheFileName<>" not found.")
return $ partitionEithers res
unless (null cacheErrors) $ forM_ cacheErrors $ \err -> logError (displayShow err)
let (unknownDates, cacheData') = partition (isNothing . fst) cacheData
unless (null unknownDates) $ logError $ display $ T.pack $ show (length unknownDates) <> " files had no parsable Date."
let cacheData'' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData'
logError $ displayShow $ HM.keys cacheData''
c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData'' HM.!? today) (HM.delete today cacheData'') undefined defChartSettings defChartCacheSettings emptyChartCacheData Nothing False
c <- liftIO $ newTVarIO $ Chart con
(fromMaybe FT.empty $ cacheData'' HM.!? today)
(HM.delete today cacheData'')
undefined
defChartSettings
defChartCacheSettings
(emptyChartCacheData defChartCacheSettings)
Nothing
False
tid <- liftIO $ forkIO $ fillChart app contract c
liftIO $ atomically $ do
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
@ -110,14 +126,14 @@ toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
l = minimum as'
h = maximum as'
getUpdatedChartCache :: MonadIO m => Chart -> Maybe ChartCacheSettings -> m (Maybe TimePoint, ChartCacheData)
getUpdatedChartCache :: Chart -> Maybe ChartCacheSettings -> RIO App (Maybe TimePoint, ChartCacheData)
getUpdatedChartCache Chart{..} chartCacheSettings' = do
let ChartCacheSettings cRes cTicks = fromMaybe chartCacheSettings chartCacheSettings'
now <- liftIO getCurrentTime
-- - recalculate cacheUpdateStart & cacheUpdateEnd
let cacheUpdateEnd = (utcTimeToSeconds now + cRes) `div` cRes
let cacheUpdateEnd = ((utcTimeToSeconds now + cRes) `div` cRes) * cRes
cacheUpdateStart = cacheUpdateEnd - (cRes * cTicks)
ChartCacheData ccData ccRange ccFill = chartCache
ChartCacheData ccData ccAxis ccRange ccFill = chartCache
chunks = case ccFill of
Nothing -> [(cacheUpdateStart, cacheUpdateEnd)]
Just (mi, ma) -> if
@ -131,32 +147,30 @@ getUpdatedChartCache Chart{..} chartCacheSettings' = do
| otherwise -> []
| otherwise -> []
-- - chunk them with chunhChart
chunkedChart = L.concat $ for chunks $ \(start, end) -> chunkChart (min 0 start) end cRes chartData
chunkedChart = L.filter (not . null . snd) $ L.concat $ for chunks $ \(start, end) -> chunkChart (min 0 start) end cRes chartData
lUpdate = cacheUpdateEnd - cRes
-- - calculate Range and need for shift
shiftNeccessary = case ccRange of
Nothing -> False
Just (_,ma) -> cacheUpdateEnd > ma
(newRange, shiftInterval) = if not shiftNeccessary && isJust ccRange then (fromJust ccRange, 0) else
let interval = (cTicks + 20) `div` 20 :: Int
iTo = (cacheUpdateEnd + cRes * interval) `div` (cRes * interval)
let interval = cTicks `div` 20 :: Int
iTo = ((cacheUpdateEnd + cRes * interval) `div` (cRes * interval)) * (cRes * interval)
iFrom = iTo - 20 * (cRes * interval)
in ((iFrom,iTo), interval)
ccAxis' = if not shiftNeccessary && isJust ccRange then ccAxis
else VS.enumFromStepN (fromIntegral $ fst newRange) (fromIntegral cRes) cTicks
logDebug $ displayShow ("now, updateEnd, lUpdate" :: Text, utcTimeToSeconds now, cacheUpdateEnd, lUpdate)
-- create data for updates
let timePointToIndex' :: (Int, Int) -> (Int, Int) -> TimePoint -> Int
timePointToIndex' (cRes', cTicks') (rFrom, rTo) (TimePoint p) = let result = (p - rFrom) `div` cRes in
if
| p < rFrom || p > rTo -> error $ "timePointToIndex' " <> show ((cRes', cTicks'),(rFrom, rTo),TimePoint p) <> ": " <> show p <> " out of range."
| result < 0 || result >= cTicks' -> error $ "timePointToIndex' " <> show ((cRes', cTicks'),(rFrom, rTo),TimePoint p) <> ": " <> show result <> " is invalid index"
| otherwise -> result
timePointToIndex :: TimePoint -> Int
timePointToIndex = timePointToIndex' newRange (cRes, cTicks)
-- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma)
(!foldedData,_,_) = foldl' folder ([], ChartPoint 0 0 0 [], mempty) chunkedChart
let timePointToIndex' :: TimePoint -> Int
timePointToIndex' = timePointToIndex (Just $ ChartCacheSettings cRes cTicks) newRange
let indexToTimePoint' :: Int -> TimePoint
indexToTimePoint' = indexToTimePoint (Just $ ChartCacheSettings cRes cTicks) newRange
-- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma)
let (!foldedData,_,_) = foldl' folder ([], ChartPoint 0 0 0 [], mempty) chunkedChart
folder :: ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float]) -> (TimePoint, [ChartPoint]) -> ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float])
folder old (_,[]) = old
folder (acc, lastPoint, smaMap) (tp,cdata) = ((timePointToIndex tp, cp):acc, cp, foldl' (.) id smaUpdates smaMap)
folder (acc, lastPoint, smaMap) (tp,cdata) = ((timePointToIndex' tp, cp):acc, cp, foldl' (.) id smaUpdates smaMap)
where
cp = ChartPoint tp m vol studies
(studies, smaUpdates) = unzip $ catMaybes $ (chartStudySettings chartSettings :: [ChartStudyType]) <&> \case
@ -203,10 +217,30 @@ getUpdatedChartCache Chart{..} chartCacheSettings' = do
ChartStudyTypeClose -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_close $ findOLHC s)) <$> foldedData))
ChartStudyTypeSMA x -> id --TODO: implement #13
ChartStudyTypeVolume -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,volume $ findVolume s)) <$> foldedData))
return (Just $ TimePoint lUpdate, ChartCacheData (foldl' (.) id updates ccData) (Just newRange) Nothing) -- FIXME: fillData still missing
let ccData' = foldl' (.) id updates ccData
-- logInfo $ displayShow chartCache
-- logInfo $ displayShow (cacheUpdateStart, cacheUpdateEnd)
-- logInfo $ displayShow (newRange, chunkedChart)
let ma = timePointToIndex' $ TimePoint lUpdate
mi = fromMaybe ma $ fst <$> ccFill
return (Just $ TimePoint lUpdate, ChartCacheData ccData' ccAxis' (Just newRange) (Just $ (mi, timePointToIndex' $ TimePoint lUpdate)))
getChunkedDay :: Chart -> Maybe Int -> (Maybe TimePoint, [ChartPoint])
getChunkedDay Chart{..} chunkResolution = (lUpdate, toCachePoint <$> chunkedData)
where
chunkedData = chunkChart 0 86400 (fromMaybe (chartCacheResolution chartCacheSettings) chunkResolution) chartData
lUpdate = fmap fst . lastMaybe $ chunkedData
indexToTimePoint :: Maybe ChartCacheSettings -> (Int, Int) -> Int -> TimePoint
indexToTimePoint ccs (rFrom, rTo) i = TimePoint $ rFrom + i*cRes
where
ChartCacheSettings cRes _ = fromMaybe defChartCacheSettings ccs
timePointToIndex :: Maybe ChartCacheSettings -> (Int, Int) -> TimePoint -> Int
timePointToIndex ccs (rFrom, rTo) (TimePoint p) = if
| p < rFrom || p > rTo -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show p <> " out of range."
| result < 0 || result >= cTicks -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show result <> " is invalid index"
| otherwise -> result
where
ChartCacheSettings cRes cTicks = fromMaybe defChartCacheSettings ccs
result = (p - rFrom) `div` cRes

28
src/Run.hs
View File

@ -4,24 +4,24 @@
module Run (run) where
import Import
import Chart
import Types
import Chart
import Control.Concurrent
import Data.Aeson (encodeFile)
import Data.Bits
import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree)
import DearImGui
import DearImGui.Plot
import DearImGui.OpenGL3
import DearImGui.SDL
import Data.Maybe (fromJust)
import Data.Time.Clock
import Data.Tuple.Extra
import DearImGui
import DearImGui.OpenGL3
import DearImGui.Plot
import DearImGui.SDL
import Graphics.GL
import SDL
--import Data.StateVar
import qualified Data.Text as T
import qualified Data.List as L
import qualified Data.HashMap.Strict as HM
--import qualified Data.FingerTree as FT
import qualified Data.Vector.Storable as VS
import IBClient.Connection
@ -232,8 +232,16 @@ renderLoop = do
withPlot "Test" $ do
-- TODO: set axes
-- let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
-- plotLine (T.unpack symbol) x y
return ()
setupAxisLimits (both fromIntegral $ fromMaybe (0,86400) $ chartCacheCurrent chartCache) (-100,2500) Nothing
let ChartCacheSettings _ cTicks = chartCacheSettings
(f, t) = fromMaybe (0, cTicks) $ chartCacheFilledTo chartCache
direct = chartCacheData chartCache HM.!? ChartStudyTypeDirect
x = chartCacheAxis chartCache
-- t-f == 0 means there is still 1 point in it. VS.slice takes number of points as second argument. Add 1!
-- dataSlice = VS.slice f (t-f+1)
dataSliceLine = if t-f < 1 then VS.slice (max 0 $ f-1) 2 else VS.slice f (t-f+1) -- need at least 2 points to make a line... duh!
when (isJust direct) $ do
plotLine (T.unpack symbol) (dataSliceLine x) (dataSliceLine $ fromJust direct)
return ()

49
src/Types.hs
View File

@ -36,7 +36,8 @@ data Options = Options
data WindowParams = WindowParams
{ _windowWidth :: Int
, _windowHeight :: Int
} deriving (Show, Generic, FromJSON, ToJSON)
} deriving stock (Show, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Default WindowParams where
def = WindowParams 1024 768
@ -44,7 +45,8 @@ instance Default WindowParams where
data TWSConnection = TWSConnection
{ _host :: Text
, _port :: Text
} deriving (Show, Generic, FromJSON, ToJSON)
} deriving stock (Show, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Default TWSConnection where
def = TWSConnection "127.0.0.1" "7497"
@ -68,7 +70,8 @@ data Settings = Settings
{ _windowParams :: WindowParams
, _twsConnection :: TWSConnection
, _logLevel :: LogLevel
} deriving (Show, Generic, FromJSON, ToJSON)
} deriving stock (Show, Generic)
deriving anyclass (FromJSON, ToJSON)
makeLenses ''WindowParams
makeLenses ''TWSConnection
@ -80,7 +83,7 @@ instance Default Settings where
data TWSConnectionStatus = TWSDisconnected
| TWSConnecting
| TWSConnected
deriving (Show, Eq, Enum, Bounded)
deriving stock (Show, Eq, Enum, Bounded)
data TWSConnectionRefs = TWSConnectionRefs
{ twsConnectionRefsHost :: TVar Text
@ -115,14 +118,14 @@ data IBAccount = IBAccount
{ _accountInfo :: IBAccountInfo
, _accountPortfolio :: [IBPortfolioValue]
, _accountStrategies :: [IBAccountStrategy]
} deriving (Show, Eq)
} deriving stock (Show, Eq)
data IBAccountInfo = IBAccountInfo
{ _accountName :: Text
, _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency)
, _accountLastUpdate :: Text
} deriving (Show, Eq)
} deriving stock (Show, Eq)
data IBPortfolioValue = IBPortfolioValue
{ _contract :: IBContract
@ -132,10 +135,11 @@ data IBPortfolioValue = IBPortfolioValue
, _averageCost :: Float
, _unrealizedPNL :: Float
, _realizedPNL :: Float
} deriving (Show, Eq)
} deriving stock (Show, Eq)
newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy
deriving newtype (Show, Eq)
deriving stock (Show)
deriving newtype (Eq)
data IBSymbolSample = IBSymbolSample
{ _symbolId :: Int
@ -144,7 +148,7 @@ data IBSymbolSample = IBSymbolSample
, _primaryExchange :: Text
, _currency :: Text
, _derivatives :: [Text]
} deriving (Show, Eq)
} deriving stock (Show, Eq)
makeLenses ''IBAccountStrategy
makeLenses ''IBAccountInfo
@ -155,7 +159,7 @@ data ChartSettings = ChartSettings
, chartStart :: Maybe UTCTime
, chartEnd :: Maybe UTCTime
, chartStudySettings :: [ChartStudyType]
} deriving (Show, Eq)
} deriving stock (Show, Eq)
defChartSettings :: ChartSettings
defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect]
@ -163,7 +167,7 @@ defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect]
updateChartStudySettings :: Chart -> [ChartStudyType] -> Chart
updateChartStudySettings Chart{..} s =
let chartSettings = chartSettings { chartStudySettings = [] }
chartCache = emptyChartCacheData
chartCache = emptyChartCacheData chartCacheSettings
lastCacheUpdate = Nothing
in Chart{..}
@ -171,6 +175,9 @@ updateChartStudySettings Chart{..} s =
--
-- History and Resolution yield 1 day by default. Do not increase over 5000 as memery-consumption explodes!
-- Think of it as timePlotted = candleWidth * numberOfCandles
--
-- chartCacheHistory should be a multiple of 20 as there often is 5% buffer in various caches and this
-- fills the caches more optimally
data ChartCacheSettings = ChartCacheSettings
{ chartCacheResolution :: Int
, chartCacheHistory :: Int
@ -189,18 +196,21 @@ newtype TimePoint = TimePoint Int
data ChartStudies = SMA { window :: Int, value :: Float }
| OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float}
| Volume { volume :: Float }
deriving (Show, Eq, Generic, FromJSON, ToJSON)
deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)
data ChartPoint = ChartPoint
{ timeOfDay :: TimePoint
, pointValue :: Float
, pointVolume :: Float
, pointExtra :: [ChartStudies]
} deriving (Show, Eq, Generic, FromJSON, ToJSON)
} deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Measured TimePoint ChartPoint where
measure = timeOfDay
-- | Tick-based data
data ChartStudyType = ChartStudyTypeDirect
| ChartStudyTypeSMA Int
| ChartStudyTypeOpen
@ -212,13 +222,14 @@ data ChartStudyType = ChartStudyTypeDirect
deriving anyclass (Hashable)
data ChartCacheData = ChartCacheData
{ chartCacheData :: HashMap ChartStudyType (VS.Vector Float)
, chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
, chartCacheFilled :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
{ chartCacheData :: HashMap ChartStudyType (VS.Vector Float)
, chartCacheAxis :: VS.Vector Float
, chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
, chartCacheFilledTo :: Maybe (Int,Int) -- ^ in index into the vectors given range of "Current"
} deriving stock (Show, Eq)
emptyChartCacheData :: ChartCacheData
emptyChartCacheData = ChartCacheData mempty Nothing Nothing
emptyChartCacheData :: ChartCacheSettings -> ChartCacheData
emptyChartCacheData ChartCacheSettings{..} = ChartCacheData mempty (VS.replicate chartCacheHistory 0) Nothing Nothing
data Chart = Chart
{ chartContractID :: Int
@ -230,7 +241,7 @@ data Chart = Chart
, chartCache :: ChartCacheData -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
, lastCacheUpdate :: Maybe TimePoint
, chartDirty :: Bool
} deriving (Show, Eq)
} deriving stock (Show, Eq)
newtype InjetiveGettable a b = InjetiveGettable
{ gettable :: TVar a