library(ggplot2,forecast)
library(astsa)
library(zoo,lmtest)
##
## Attaching package: 'zoo'
## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric
library(fUnitRoots)
## Loading required package: timeDate
## Loading required package: timeSeries
##
## Attaching package: 'timeSeries'
## The following object is masked from 'package:zoo':
##
## time<-
## Loading required package: fBasics
##
## Attaching package: 'fBasics'
## The following object is masked from 'package:astsa':
##
## nyse
library(FitARMA)
## Loading required package: FitAR
## Loading required package: lattice
## Loading required package: leaps
## Loading required package: ltsa
## Loading required package: bestglm
library(strucchange)
## Loading required package: sandwich
library(reshape)
library(Rmisc)
## Loading required package: plyr
##
## Attaching package: 'plyr'
## The following objects are masked from 'package:reshape':
##
## rename, round_any
library(fBasics)
library(tsoutliers)
## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo
library(TSA)
## Registered S3 methods overwritten by 'TSA':
## method from
## fitted.Arima forecast
## plot.Arima forecast
##
## Attaching package: 'TSA'
## The following objects are masked from 'package:timeDate':
##
## kurtosis, skewness
## The following objects are masked from 'package:stats':
##
## acf, arima
## The following object is masked from 'package:utils':
##
## tar
library(dygraphs)
library(quantmod)
## Loading required package: xts
## Loading required package: TTR
##
## Attaching package: 'TTR'
## The following object is masked from 'package:fBasics':
##
## volatility
## Version 0.4-0 included new data defaults. See ?getSymbols.
library(lubridate)
##
## Attaching package: 'lubridate'
## The following object is masked from 'package:reshape':
##
## stamp
## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, union
library(DT)
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:lubridate':
##
## intersect, setdiff, union
## The following objects are masked from 'package:xts':
##
## first, last
## The following objects are masked from 'package:plyr':
##
## arrange, count, desc, failwith, id, mutate, rename, summarise,
## summarize
## The following object is masked from 'package:reshape':
##
## rename
## The following objects are masked from 'package:timeSeries':
##
## filter, lag
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
#library(quantstrat)
library(xml2)
library(tidyverse)
## -- Attaching packages ---------------------------------------------------------------------------------------------- tidyverse 1.3.0 --
## v tibble 3.0.0 v purrr 0.3.4
## v tidyr 1.0.2 v stringr 1.4.0
## v readr 1.3.1 v forcats 0.5.0
## -- Conflicts ------------------------------------------------------------------------------------------------- tidyverse_conflicts() --
## x dplyr::arrange() masks plyr::arrange()
## x lubridate::as.difftime() masks base::as.difftime()
## x stringr::boundary() masks strucchange::boundary()
## x purrr::compact() masks plyr::compact()
## x dplyr::count() masks plyr::count()
## x lubridate::date() masks base::date()
## x tidyr::expand() masks reshape::expand()
## x dplyr::failwith() masks plyr::failwith()
## x dplyr::filter() masks timeSeries::filter(), stats::filter()
## x dplyr::first() masks xts::first()
## x dplyr::id() masks plyr::id()
## x lubridate::intersect() masks base::intersect()
## x dplyr::lag() masks timeSeries::lag(), stats::lag()
## x dplyr::last() masks xts::last()
## x dplyr::mutate() masks plyr::mutate()
## x dplyr::rename() masks plyr::rename(), reshape::rename()
## x lubridate::setdiff() masks base::setdiff()
## x readr::spec() masks TSA::spec()
## x lubridate::stamp() masks reshape::stamp()
## x dplyr::summarise() masks plyr::summarise()
## x dplyr::summarize() masks plyr::summarize()
## x lubridate::union() masks base::union()
library(tidyquant)
## Loading required package: PerformanceAnalytics
##
## Attaching package: 'PerformanceAnalytics'
## The following objects are masked from 'package:TSA':
##
## kurtosis, skewness
## The following objects are masked from 'package:timeDate':
##
## kurtosis, skewness
## The following object is masked from 'package:graphics':
##
## legend
## == Need to Learn tidyquant? ===========================================================================================================
## Business Science offers a 1-hour course - Learning Lab #9: Performance Analysis & Portfolio Optimization with tidyquant!
## </> Learn more at: https://university.business-science.io/p/learning-labs-pro </>
library(remotes)
#library(fluxcapacitor)
# https://rdrr.io/github/jonaselm/fluxcapacitor/
startdt<- cbind("2010","-01","-01")
startdt <- paste(startdt, collapse="")
startdt
## [1] "2010-01-01"
enddt<- cbind("2020","-04","-17")
enddt <- paste(enddt, collapse="")
enddt
## [1] "2020-04-17"
start_time <- Sys.time()
tickers<-c("^DJI","DAL","SPY","QQQ","TVIX", "UAL", "SNE", "GOOG", "AAPL", "COST", "SBUX", "NFLX", "FB", "MSFT", "NVDA", "RCL", "DIS", "BA", "LMT", "TSLA", "CHGG", "EDU", "GSX", "HD", "SCI", "BABA", "AMZN", "CSCO", "ROKU", "PDD", "ADBE", "MDB", "BILI", "SHOP", "ICE", "IIPR", "MA", "PYPL", "V", "ISRG", "NVTA", "FN", "SE", "AMD", "SNPS", "SQ", "TTD", "WIX","TPL", "SAVE", "HLT", "VRTX", "TWTR", "MRVL", "TTDKY", "MRAAY","FDX","AMAT","WB", "ANET", "WW", "QRVO", "SQ", "HEES", "SAP", "APPN", "NTNX", "QCOM", "DELL", "HUBS", "SEDG", "NTDOY", "UBER", "AMD", "PINS", "NVTA", "OKTA", "TAL", "TDOC","KO", "ABBV", "T", "MMM", "PEP", "LUV", "MRK", "ZNGA", "ATVI", "INTU", "ARCE", "DVA", "TGNA", "AVID", "JNJ", "AGN", "UNH", "CMCSA", "MU" , "C", "JPM", "BAC", "FIS", "CRM","BMY")
tick<-68
Price<- c(tickers[tick]) %>%
tq_get(get = "stock.prices",
from = startdt,
to = enddt) %>%
group_by(symbol)
min_max<-function(data){
data=timetk::tk_tbl(data, silent = TRUE)
min.close<-min(data$close)
max.close<-max(data$close)
cbind(min.close,max.close)
}
if (nrow(Price)<252) {
MinMax <- Price %>%
tq_mutate(mutate_fun = rollapply,
width = 20,
FUN = min_max,
by.column = FALSE,
col_rename = c("min", "max"))
}
if (nrow(Price)>=252) {
MinMax <- Price %>%
tq_mutate(mutate_fun = rollapply,
width = 252,
FUN = min_max,
by.column = FALSE,
col_rename = c("min", "max"))
}
WkReturn<-Price%>%tq_transmute(select = close,
mutate_fun = periodReturn,
period = "weekly",
col_rename = "WkReturn")
MinMax$minRange<-MinMax$min*1.02
MinMax$downTouch <- NA
MinMax$downTouch.Low<-NA
MinMax$downTouch.Hgh<-NA
MinMax$downTouch[which(MinMax$low<=MinMax$min)]<-MinMax$low[which(MinMax$low<=MinMax$min)]
MinMax$downTouch.Low[which(MinMax$low<=MinMax$minRange)]<-MinMax$low[which(MinMax$low<=MinMax$minRange)]
MinMax$downTouch.Hgh[which(MinMax$low<=MinMax$minRange)]<-MinMax$high[which(MinMax$low<=MinMax$minRange)]
MA<-as.data.frame(TTR::SMA(Price$close,n=200))
colnames(MA)<-"SMA"
#RSI based on 200 days lookback period with simple moving average
RSISMA<-as.data.frame(TTR:: RSI(Price$close, n=200, maType="SMA"))
colnames(RSISMA)<-"RSI.SMA"
#RSI based on 200 days lookback period
RSI<-as.data.frame(TTR:: RSI(Price$close,n=200))
colnames(RSI)<-"RSI"
MinMax<-as.data.frame(MinMax)
WkReturn<-as.data.frame(WkReturn)
MinMax<-cbind(MinMax, MA, RSISMA,RSI)
#calculated distance percentage from max to close within the min to max range
MinMax_D<-MinMax
MinMax_D$range.minmax <-MinMax_D$max - MinMax_D$min
MinMax_D$cls.Rg.Pct<-(MinMax_D$close-MinMax_D$min)/MinMax_D$range.minmax
MinMax_D$cls.Up.Pct<-1-MinMax_D$cls.Rg.Pct
MinMax_D$range.SMAmax <-MinMax_D$max - MinMax_D$SMA
MinMax_D$cls.SMA.Pct<-(MinMax_D$close-MinMax_D$SMA)/MinMax_D$range.SMAmax
#find peak
# https://rpubs.com/mengxu/peak_detection
x<-MinMax_D$date
y<-MinMax_D$close
span_V<-0.01
Wvalue<-25
y.smooth <- loess(y ~ as.numeric(x),span=span_V)$fitted
plot(x,y,col='gray',type='l')+lines(x,y.smooth,col='red',type='l')
## integer(0)
argmax <- function(x, y, w=1, ...) {
require(zoo)
n <- length(y)
y.smooth <- loess(y ~ as.numeric(x), ...)$fitted
y.max <- rollapply(zoo(y.smooth), 2*w+1, max, align="center")
delta <- y.max - y.smooth[-c(1:w, n+1-1:w)]
i.max <- which(delta <= 0) + w
list(x=x[i.max], i=i.max, y.hat=y.smooth)
}
peak<-argmax(x,y,w=Wvalue,span=span_V)
P.test <- function(w, span) {
peaks <- argmax(x, y, w=w, span=span)
plot(x, y, cex=0.75, col="black", type='l',main=paste("w = ", w, ", span = ", span, sep=""))
lines(x, peaks$y.hat, lwd=2,col='blue') #$
y.min <- min(y)
sapply(peaks$i, function(i) lines(c(x[i],x[i]), c(y.min, peaks$y.hat[i]), col="Red", lty=2))
points(x[peaks$i], peaks$y.hat[peaks$i], col="Red", pch=19, cex=1.25)
}
P.test(Wvalue,0.01)
argmin <- function(x, y, w=1, ...) {
require(zoo)
n <- length(y)
y.smooth <- loess(y ~ as.numeric(x), ...)$fitted
y.min <- rollapply(zoo(y.smooth), 2*w+1, min, align="center")
delta <- y.min - y.smooth[-c(1:w, n+1-1:w)]
i.min <- which(delta >= 0) + w
list(x=x[i.min], i=i.min, y.hat=y.smooth)
}
valley<-argmin(x,y,w=Wvalue,span=span_V)
V.test <- function(w, span) {
valley <- argmin(x, y, w=w, span=span)
plot(x, y, cex=0.75, col="black", type='l',main=paste("w = ", w, ", span = ", span, sep=""))
lines(x, valley$y.hat, col='blue', lwd=2) #$
y.min <- min(y)
sapply(valley$i, function(i) lines(c(x[i],x[i]), c(y.min, valley$y.hat[i]), col="Red", lty=2))
points(x[valley$i], valley$y.hat[valley$i], col="black", pch=19, cex=1.25)
}
V.test(Wvalue,0.01)
#put all peaks and valleys together
P<-as.data.frame(cbind(x,y))
P$peak<-NA
for (j in 1: length(peak$i)) {
P$peak[c(peak$i[j])]<-P$y[c(peak$i[j])]
}
V<-as.data.frame(cbind(x,y))
V$valley<-NA
for (j in 1: length(valley$i)) {
V$valley[c(valley$i[j])]<-V$y[c(valley$i[j])]
}
PV<-cbind(P,V)
#remoe x and y column
PV<-PV[,-c(4,5)]
PV_plot<-xts(PV[,c(2,3,4)],MinMax$date)
dateWindow <- c(startdt, enddt)
dygraph(PV_plot[,c('y','peak','valley')])%>% dySeries("valley", pointSize = 4, color = 'blue', label = "valley")%>% dySeries("peak", pointSize = 4, color = 'red', label = "peak")%>%dyRangeSelector(dateWindow = dateWindow)%>%dyLegend(show = "onmouseover", labelsDiv = NULL,labelsSeparateLines = FALSE, hideOnMouseOut = TRUE, width=500)
#set sell position threhold
# MinMax<-xts(MinMax,MinMax$date)
MinMax_P<-cbind(MinMax_D,PV[,-c(1,2)] )
MinMax_P$sell<-NA
MinMax_P$sell[which(MinMax_P$cls.Up.Pct>=0.2)]<-MinMax_P$close[which(MinMax_P$cls.Up.Pct>=0.2)]
#find Sell point
data_P<-as.data.frame(MinMax_P)
data_P$peakc<-NA
for (j in 1: length(peak$i)) {
data_P$peakc[c(peak$i[j])]<-'peak'
}
data_P$valleyc<-NA
for (j in 1: length(valley$i)) {
data_P$valleyc[c(valley$i[j])]<-'valley'
}
data_P$VP<-NA
#can't really compare NA with another value, so using == would not work.
data_P$VP<-ifelse(data_P$peakc %in% 'peak','P',ifelse(data_P$valleyc %in% 'valley','V',NA))
data_P$order<-NA
#assign sell to 1 if sell vaule is there
data_P$sell.Temp<-ifelse(is.na(data_P$sell)==1,0,1 )
#mark first sell point from the sell series range
data_P$selltrue<-NA
for (i in 2: length(data_P$sell)-1) {
data_P$selltrue[i+1]<-ifelse( data_P$sell.Temp[i]!=data_P$sell.Temp[i+1] & data_P$sell.Temp[i]==0 ,1,0)
}
#remove all not first sell value
data_P$sell<-ifelse(data_P$selltrue==1, data_P$sell, NA)
#fill function from tidyr, fill NA with first P or V
data_P<-data_P%>%fill(VP)
#remove sell point in uptrend line which is false sell point
data_P$sell<-ifelse(data_P$VP=='V', NA, data_P$sell)
MinMax_P<-as.data.frame(data_P)
#set buy position threhold
# MinMax<-xts(MinMax,MinMax$date)
MinMax_P$buy<-NA
MinMax_P$buy[which(MinMax_P$cls.SMA.Pct>=0.19)]<-MinMax_P$close[which(MinMax_P$cls.SMA.Pct>=0.19)]
#find Buy point
data_P<-as.data.frame(MinMax_P)
data_P$peakc<-NA
for (j in 1: length(peak$i)) {
data_P$peakc[c(peak$i[j])]<-'peak'
}
data_P$valleyc<-NA
for (j in 1: length(valley$i)) {
data_P$valleyc[c(valley$i[j])]<-'valley'
}
data_P$VP<-NA
#can't really compare NA with another value, so using == would not work.
data_P$VP<-ifelse(data_P$peakc %in% 'peak','P',ifelse(data_P$valleyc %in% 'valley','V',NA))
#assign buy to 1 if buy vaule is there
data_P$buy.Temp<-ifelse(is.na(data_P$buy)==1,0,1 )
#mark first buy point from the buy series range
data_P$buytrue<-NA
for (i in 2: length(data_P$buy)-1) {
data_P$buytrue[i+1]<-ifelse( data_P$buy.Temp[i]!=data_P$buy.Temp[i+1] & data_P$buy.Temp[i]==0 ,1,0)
}
#remove all not first sell value
data_P$buy<-ifelse(data_P$buytrue==1, data_P$buy, NA)
#fill function from tidyr, fill NA with first P or V
data_P<-data_P%>%fill(VP)
#remove buy point in downtrend line which is false buy point
data_P$buy<-ifelse(data_P$VP=='P', NA, data_P$buy)
MinMax_P<-as.data.frame(data_P)
MinMax_Plot<-xts(MinMax_P,MinMax_P$date)
dateWindow <- c(startdt, enddt)
if ( "downTouch" %in% names(MinMax)==1) {
dygraph(MinMax_Plot[,c("close","min","max","downTouch","downTouch.Low","downTouch.Hgh","SMA","cls.Up.Pct","cls.SMA.Pct","peak","valley","sell","buy")],main = paste0('"', tickers[tick],' 364 days min max, 200 MA', '"'))%>%dySeries("downTouch.Low", strokeWidth = .5, label = "TLow")%>%dySeries("downTouch.Hgh", strokeWidth = .5, label = "THgh")%>% dySeries("downTouch",strokeWidth = 4, pointSize = 4, color="#010100",label = "DownTouch")%>%dySeries("cls.Up.Pct",axis='y2',strokePattern = "dashed", strokeWidth = 0.5,color="#fff0f5")%>%dySeries("cls.SMA.Pct",axis='y2',strokePattern = "dashed", strokeWidth = 0.5,color="#ffffff")%>% dySeries("peak", pointSize = 4, color = 'red', label = "peak")%>% dySeries("valley", pointSize = 5, color = 'blue', label = "valley")%>%dySeries("sell", pointSize = 4, color = 'green', label = "sell")%>%dySeries("buy", pointSize = 4, color = '#FBCB05', label = "buy")%>%
dyRangeSelector(dateWindow = dateWindow)%>%dyLegend(show = "onmouseover", labelsDiv = NULL,labelsSeparateLines = FALSE, hideOnMouseOut = TRUE, width=500)
}
# data_P<-data_P%>% mutate(order = as.integer(factor(VP)))
# data_P$num <- ave(data_P$VP, FUN = seq_along)
data_P$pct<-NA
data_P$sell[which(is.na(data_P$sell)==0)]
## [1] 54.04 54.59 56.88 62.56 63.83 63.55 64.35 64.97 65.35 65.16 64.23 62.44
## [13] 67.38 67.11 67.19 67.04 67.09 71.99 76.17 64.16 64.19 64.44 64.56 64.50
## [25] 61.73 64.85 65.00 66.73 76.62 84.89 84.63 85.31 87.03
#find cloest peak
BeforeAfter<-which(data_P$pct==20)>=which(data_P$peakc=='peak')
BeforeAfter
## logical(0)
end_time <- Sys.time()
end_time - start_time
## Time difference of 17.21635 secs