This is a sample model used to model the predicted highs and lows within a specified window of time, based on analytic transformations of past data. It includes a few diagnostic visualizations.

demo_analysis.R

library(compiler)
enableJIT(3)
# proprietary analytic functions
source("functions.R")
# database helper functions
source("database.R")
library(DSTrading)
library(ggplot2)
library(tidyverse)
library(lubridate)
library(scales)
library(randomForestSRC)

# xts with columns: time, open, high, low, close, volume, vwap
ts500 <-getData("queries/500tick.sql")


# various analytic transformations from raw price data
getTS <- function(ts,stt,swi,ltt,pred_window){
  ts <- ts[ ! duplicated( index(ts), fromLast = TRUE ),  ]
  ts$hl2 = (ts$high + ts$low)/2
  ts$atr = ATR(HLC(ts),stt)$atr
  ts$swi = SWI3(ts$close,duration=swi/8)
  ts$swimom = momentum(ts$swi)
  ts$swi1 = SWI3(ts$close,duration=swi/2)
  ts$swi2 = SWI3(ts$close,duration=swi)
  ts$center <- superSmoother(ts$close,stt)
  ts$center2 <- superSmoother(ts$center,stt*2)
  ts$hurst = hurstCoefficient(ts$center,stt*3)
  ts$sma <- decycler(ts$center,ltt)
  ts$lmom <- momentum(ts$sma,1)
  ts$laccel <- momentum(ts$lmom,1)
  ts$smom <- momentum(ts$center,1)
  ts$saccel <- momentum(ts$smom,1)
  ts$dev <- with(ts,sqrt(decycler((close - sma)^2,ltt*2-1)))
  ts$up1 <- with(ts,sma + 1*dev)
  ts$dn1 <- with(ts,sma - 1*dev)
  ts$up2 <- with(ts,sma + 2*dev)
  ts$dn2 <- with(ts,sma - 2*dev)
  ts$pctile <- runPercentRank(ts$smom,ltt)
  ts$sdmom <- runSD(ts$smom,ltt)
  ts$z <- ts$lmom/runSD(ts$lmom,ltt)
  ts$avgtrend <- decycler(ts$swi2,ltt)
  ts$pb <- sign(ts$swi) != sign(ts$swi2)
  ts$pctB <- (ts$center - ts$sma)/ts$dev
  ts$out_h <- (lag(runMax(ts$high,pred_window),-pred_window) - ts$close)
  ts$out_l <- (lag(runMin(ts$low,pred_window),-pred_window) - ts$close)
  ts$out_h2 <- (lag(runMax(ts$high,pred_window*2),-pred_window*2) - ts$close)
  ts$out_l2 <- (lag(runMin(ts$low,pred_window*2),-pred_window*2) - ts$close)
  return(ts)
}


d500 <- getTS(ts500,10,400,400,5)



# dates <- unique(as.character(sort(as.Date(index(d4500)))))

dt1 <- '2018-12-01'
dt2 <- '2019-01-04'
dt3 <- '2019-01-07'
win_train <- paste0(dt1," 00:00::",dt2," 23:59:59")
win_test <- paste0(dt3," 00:00::")

m1 <- d500[win_train]
m2 <- d500[win_test]

train <- na.omit(data.frame(time=index(m1),m1))
train <- subset(train,pb==T)
test <- na.omit(data.frame(time=index(m2),m2))

mod_high <- rfsrc(out_h ~ atr + swi + swi1 + swimom + smom + lmom + pctB,data=train,importance = T,ntree=500)
plot(mod_high)
mod_low <- rfsrc(out_l ~ atr + swi + swi1 + swimom + smom + lmom + pctB,data=train,importance = T,ntree=500)
plot(mod_low)


test$pred_h <- predict(mod_high,test)$predicted
test$pred_l <- predict(mod_low,test)$predicted
test$pred_h <- with(test,ifelse(pb==T & pred_h > 1,pred_h,NA))
test$pred_l <- with(test,ifelse(pb==T & pred_l < -1,pred_l,NA))
test$pred_h_price <- test$pred_h + test$close
test$pred_l_price <- test$pred_l + test$close


ggplot(test)+
  geom_point(aes(x=out_h2,y=pred_h))

ggplot(test)+
  geom_point(aes(x=out_l2,y=pred_l))


# ggplot(test,aes(x=time))+
#   geom_line(aes(y=close),alpha=0.3)+
#   geom_point(aes(y=pred_h_price),color="blue")+
#   geom_point(aes(y=pred_l_price),color="red")

out = xts(test[,-1],order.by = test$time)
dt <- '2019-01-07'
win <- paste0(dt," 00:00::",dt," 23:59:59")
out = data.frame(out[win])

ggplot(out,aes(x=index(out)))+
  geom_line(aes(y=close),alpha=0.3)+
  geom_line(aes(y=sma),alpha=0.5,color="yellow")+
  geom_line(aes(y=center),alpha=0.5,color="light blue")+
  geom_ribbon(aes(ymax=up2,ymin=dn2),alpha=0.2,color="yellow")+
  geom_point(aes(y=pred_h_price,color=out_h2 > 4 & out_l2 > -8))