diff --git a/Examples/cv-NelderMead-MACD.R b/Examples/cv-NelderMead-MACD.R
new file mode 100755
index 0000000..294d2a2
--- /dev/null
+++ b/Examples/cv-NelderMead-MACD.R
@@ -0,0 +1,1102 @@
+###########################################
+### This script is a one-piece runnable ###
+### example constructed from code in ###
+### the text. It is Windows and UNIX ###
+### compatible. ###
+###########################################
+
+
+# The goal is to generate a cross-validated
+# equity curve based on Nelder-Mead optimization
+# using the long-Only MACD strategy by
+# using the most possible availabe data to
+# optimize at each year. i.e. 2012 uses data
+# from 2000 through 2011. This will take considerable
+# time to run. It projects returns in excess of
+# buy-and-hold returns for SPY over the approx.
+# 11 years it trades.
+
+
+####Listing 2.1: Setting Path Variables####
+rootdir <- "~/AutoTrading/"
+datadir <- "~/AutoTrading/stockdata/"
+functiondir <- "~/AutoTrading/functions/"
+####
+
+####Listing 2.2: Yahoo! Finance CSV API Function####
+yahoo <- function(sym, current = TRUE,
+ a = 0, b = 1, c = 2000, d, e, f,
+ g = "d")
+{
+ if(current){
+ f <- as.numeric(substr(as.character(Sys.time()), start = 1, stop = 4))
+ d <- as.numeric(substr(as.character(Sys.time()), start = 6, stop = 7)) - 1
+ e <- as.numeric(substr(as.character(Sys.time()), start = 9, stop = 10))
+ }
+ require(data.table)
+ tryCatch(
+ suppressWarnings(
+ fread(paste0("http://ichart.yahoo.com/table.csv",
+ "?s=", sym,
+ "&a=", a,
+ "&b=", b,
+ "&c=", c,
+ "&d=", d,
+ "&e=", e,
+ "&f=", f,
+ "&g=", g,
+ "&ignore=.csv"), sep = ",")),
+ error = function(e) NULL
+ )
+}
+setwd(functiondir)
+dump(list = c("yahoo"), "yahoo.R")
+#####
+
+
+
+####Listing 2.3: List of S&P 500 Stocks####
+# Up-to-date at time of writing
+url <- "http://trading.chrisconlan.com/SPstocks.csv"
+S <- as.character(read.csv(url, header = FALSE)[,1])
+
+#S <- read.csv(url, header = FALSE, stringsAsFactors=F)[,1]
+#S2 = fread(url, header = FALSE)
+setwd(rootdir)
+dump(list = "S", "S.R")
+#####
+
+
+
+####Listing 2.4: Initial Directory Loader####
+# Load "invalid.R" file if available
+invalid <- character(0)
+setwd(rootdir)
+if("invalid.R" %in% list.files()) source("invalid.R")
+
+# Find all symbols not in directory and not missing
+setwd(datadir)
+toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid)
+
+# Fetch symbols with yahoo function, save as .csv or missing
+source(paste0(functiondir, "yahoo.R"))
+if(length(toload) != 0){
+ for(i in 1:length(toload)){
+ df <- yahoo(toload[i])
+ if(!is.null(df)) {
+ write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"),
+ row.names = FALSE)
+ } else {
+ invalid <- c(invalid, toload[i])
+ }
+ }}
+setwd(rootdir)
+dump(list = c("invalid"), "invalid.R")
+################
+
+
+# Clears R environment except for path variables and functions
+rm(list = setdiff(ls(), c("rootdir", "functiondir", "datadir", "yahoo")))
+
+
+####Listing 2.5: Loading Data into Memory####
+setwd(datadir)
+S <- sub(".csv", "", list.files())
+require(data.table)
+DATA <- list()
+for(i in S){
+ suppressWarnings(
+ DATA[[i]] <- fread(paste0(i, ".csv"), sep = ","))
+ DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)]
+}
+#####
+
+
+####Listing 2.6: CSV Update Method####
+for(i in S){
+ maxdate <- DATA[[i]][["Date"]][nrow(DATA[[i]])]
+ if(as.numeric(difftime(Sys.time(), maxdate, units = "hours")) >= 40.25){
+ maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400
+ weekend <- sum(c("Saturday", "Sunday") %in%
+ weekdays(c(maxdate, Sys.time()))) == 2
+ span <- as.numeric(difftime(Sys.time(), maxdate, units = "hours")) < 48
+ if(!weekend & !span){
+ c <- as.numeric(substr(maxdate, start = 1, stop = 4))
+ a <- as.numeric(substr(maxdate, start = 6, stop = 7)) - 1
+ b <- as.numeric(substr(maxdate, start = 9, stop = 10))
+ df <- yahoo(i, a = a, b = b, c = c)
+ if(!is.null(df)){
+ if(all(!is.na(df)) & nrow(df) > 0){
+ df <- df[nrow(df):1]
+ write.table(df, file = paste0(i, ".csv"), sep = ",",
+ row.names = FALSE, col.names = FALSE, append = TRUE)
+ DATA[[i]] <- rbind(DATA[[i]], df)
+ }
+ }
+ }
+ }
+}
+#######
+
+
+############################
+
+
+####Listing 2.7: YQL Update Method####
+setwd(datadir)
+library(XML)
+batchsize <- 101
+# i in 1:5 for this example
+for(i in 1:(ceiling(length(S) / batchsize)) ){
+ midQuery <- " ("
+ maxdate <- character(0)
+ startIndex <- ((i - 1) * batchsize + 1)
+ endIndex <- min(i * batchsize, length(S))
+
+ # find earliest date and build query
+ for(s in S[startIndex:(endIndex - 1)]){
+ maxdate <- c(maxdate, DATA[[s]][[1]][nrow(DATA[[s]])])
+ midQuery <- paste0(midQuery, "Â’", s, "Â’, ")
+ }
+ maxdate <- c(maxdate, DATA[[S[endIndex]]][[1]]
+ [nrow(DATA[[S[endIndex]]])])
+ startDate <- max(maxdate)
+ if( startDate <
+ substr(strptime(substr(Sys.time(), 0, 10), "%Y-%m-%d")
+ - 28 * 86400, 0, 10) ){
+ cat("Query is greater than 20 trading days. Download with csv method.")
+ break
+ }
+
+ # Adds a day (86400 seconds) to the earliest date to avoid duplicates
+ startDate <- substr(as.character(strptime(startDate, "%Y-%m-%d") + 86400), 0, 10)
+ endDate <- substr(Sys.time(), 0, 10)
+
+ # Yahoo! updates at 4:15 EST at earliest, check if it is past 4:15 day after last
+ isUpdated <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) >= 40.25
+
+ # If both days fall in the same weekend, we will not attempt to update
+ weekend <- sum(c("Saturday", "Sunday") %in%
+ weekdays(c(strptime(endDate, "%Y-%m-%d"),
+ c(strptime(startDate, "%Y-%m-%d"))))) == 2
+
+ span <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) < 48
+
+ if( startDate <= endDate &
+ !weekend &
+ !span &
+ isUpdated ){
+
+ # Piece this extremely long URL together
+ base <- "http://query.yahooapis.com/v1/public/yql?"
+ begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in "
+ midQuery <- paste0(midQuery, "Â’", S[min(i * batchsize, length(S))], "Â’) ")
+ endQuery <- paste0("and startDate = Â’", startDate,
+ "Â’ and endDate = Â’", endDate, "Â’")
+ endParams <- "&diagnostics=true&env=store://datatables.org/alltableswithkeys"
+ urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams)
+ urlstr=gsub("Â’", "'", urlstr)
+
+ # Fetch data and arrange in XML tree
+ doc <- xmlParse(urlstr)
+
+ # The next few lines rely heavily and XPath and quirks
+ # of S4 objects in the XML package in R.
+ # We retrieve every node (or branch) on //query/results/quote
+ # and retrieve the values Date, Open, High, etc. from the branch
+ df <- getNodeSet(doc, c("//query/results/quote"),
+ fun = function(v) xpathSApply(v,
+ c("./Date",
+ "./Open",
+ "./High",
+ "./Low",
+ "./Close",
+ "./Volume",
+ "./Adj_Close"),
+ xmlValue))
+
+ # If the URL found data we organize and update
+ if(length(df) != 0){
+
+ # We get the atrributes from the same tree, which happen
+ # to be dates we need
+ symbols <- unname(sapply(
+ getNodeSet(doc, c("//query/results/quote")), xmlAttrs))
+ df <- cbind(symbols, data.frame(t(data.frame(df, stringsAsFactors = FALSE)),
+ stringsAsFactors = FALSE, row.names = NULL))
+ names(df) <- c("Symbol", "Date",
+ "Open", "High", "Low", "Close", "Volume", "Adj Close")
+ df[,3:8] <- lapply(df[,3:8], as.numeric)
+ df <- df[order(df[,1], decreasing = FALSE),]
+ sym <- as.character(unique(df$Symbol))
+ for(s in sym){
+ temp <- df[df$Symbol == s, 2:8]
+ temp <- temp[order(temp[,1], decreasing = FALSE),]
+ startDate <- DATA[[s]][["Date"]][nrow(DATA[[s]])]
+ DATA[[s]] <- DATA[[s]][order(DATA[[s]][[1]], decreasing = FALSE)]
+ DATA[[s]] <- rbind(DATA[[s]], temp[temp$Date > startDate,])
+ write.table(DATA[[s]][DATA[[s]][["Date"]] > startDate],
+ file = paste0(s, ".csv"), sep = ",",
+ row.names = FALSE, col.names = FALSE, append = TRUE)
+ }}}}
+######
+
+
+####Listing 2.8: Organizing as Date-Uniform zoo Object####
+library(zoo)
+
+# Compute the date template as a column of a data.frame for merging
+datetemp <- sort(unique(unlist(sapply(DATA, function(v) v[["Date"]]))))
+datetemp <- data.frame(datetemp, stringsAsFactors = FALSE)
+names(datetemp) <- "Date"
+
+# Double-check that our data is unique and in ascending-date order
+DATA <- lapply(DATA, function(v) unique(v[order(v$Date),]))
+
+# Create 6 new objects that will hold our re-orgainzed data
+DATA[["Open"]] <- DATA[["High"]] <- DATA[["Low"]] <-
+ DATA[["Close"]] <- DATA[["Adj Close"]] <- DATA[["Volume"]] <- datetemp
+
+# This loop will sequentially append the columns of each symbol
+# to the appropriate Open, High, Low, etc. object
+for(s in S){
+ for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){
+ temp <- data.frame(cbind(DATA[[s]][["Date"]], DATA[[s]][[i]]),
+ stringsAsFactors = FALSE)
+ names(temp) <- c("Date", s)
+ temp[,2] <- as.numeric(temp[,2])
+ if(!any(!DATA[[i]][["Date"]][(nrow(DATA[[i]]) - nrow(temp)+1):nrow(DATA[[i]])]
+ == temp[,1])){
+ temp <- rbind(t(matrix(nrow = 2, ncol = nrow(DATA[[i]]) - nrow(temp),
+ dimnames = list(names(temp)))), temp)
+ DATA[[i]] <- cbind(DATA[[i]], temp[,2])
+ } else {
+ DATA[[i]] <- merge(DATA[[i]], temp, all.x = TRUE, by = "Date")
+ }
+ names(DATA[[i]]) <- c(names(DATA[[i]])[-(ncol(DATA[[i]]))], s)
+ }
+ DATA[[s]] <- NULL
+ if(which(S==s) %% 25 == 0 ){ print(paste(which(S==s),"/", length(S))) }
+}
+
+
+# Declare them as zoo objects for use with time-series functions
+DATA <- lapply(DATA, function(v) zoo(v[,2:ncol(v)], strptime(v[,1], "%Y-%m-%d")))
+# Remove extra variables
+
+rm(list = setdiff(ls(), c("DATA", "datadir", "functiondir", "rootdir")))
+####
+
+##############
+
+####Listing 3.1: Eliminating pre-S&P Data####
+setwd(rootdir)
+if( "SPdates.R" %in% list.files() ){
+ source("SPdates.R")
+} else {
+ url <- "http://trading.chrisconlan.com/SPdates.csv"
+ S <- read.csv(url, header = FALSE, stringsAsFactors = FALSE)
+ dump(list = "S", "SPdates.R")
+}
+names(S) <- c("Symbol", "Date")
+S$Date <- strptime(S$Date, "%m/%d/%Y")
+for(s in names(DATA[["Close"]])){
+ for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){
+ Sindex <- which(S[,1] == s)
+ if(S[Sindex, "Date"] != "1900-01-01 EST" &
+ S[Sindex, "Date"] >= "2000-01-01 EST"){
+ DATA[[i]][index(DATA[[i]]) <= S[Sindex, "Date"], s] <- NA
+ }
+ }
+ if(which(names(DATA[["Close"]])==s) %% 25 == 0 ){ print(paste(which(names(DATA[["Close"]])==s),"/", nrow(S))) }
+}
+######
+
+
+
+
+####Listing 3.6: Adjusting OHLC Data####
+# Declare new zoo data frame of adjustment factors
+MULT <- DATA[["Adj Close"]] / DATA[["Close"]]
+
+# Store Close and Open Prices in new variable "Price" and "OpenPrice"
+DATA[["Price"]] <- DATA[["Close"]]
+DATA[["OpenPrice"]] <- DATA[["Open"]]
+
+# Adjust Open, High, and Low
+DATA[["Open"]] <- DATA[["Open"]] * MULT
+DATA[["High"]] <- DATA[["High"]] * MULT
+DATA[["Low"]] <- DATA[["Low"]] * MULT
+
+# Copy Adjusted Close to Close
+DATA[["Close"]] <- DATA[["Adj Close"]]
+
+# Delete Adjusted Close
+DATA[["Adj Close"]] <- NULL
+######
+
+
+####Listing 3.7: Forward Replacement on Inactive Symbols####
+for(s in names(DATA[["Close"]]) ){
+ if(is.na(DATA[["Close"]][nrow(DATA[["Close"]]), s])){
+ maxInd <- max(which(!is.na(DATA[["Close"]][,s])))
+ for( i in c("Close", "Open", "High", "Low")){
+ DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Close"]][maxInd,s]
+ }
+ for( i in c("Price", "OpenPrice") ){
+ DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Price"]][maxInd,s]
+ }
+ DATA[["Volume"]][(maxInd+1):nrow(DATA[["Close"]]),s] <- 0
+ }
+}
+#######
+
+
+
+####Listing 3.8: Computing Return Matrices####
+# Pad with NAÂ’s to perserver dimension equality
+NAPAD <- zoo(matrix(NA, nrow = 1, ncol = ncol(DATA[["Close"]])),
+ order.by = index(DATA[["Close"]])[1])
+names(NAPAD) <- names(DATA[["Close"]])
+
+# Compute Daily Close-to-Close Returns
+RETURN <- rbind( NAPAD, ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 )
+
+# Compute Overnight Returns (Close-to-Open)
+OVERNIGHT <- rbind( NAPAD, ( DATA[["Open"]] / lag(DATA[["Close"]], k = -1) ) - 1 )
+######
+
+
+
+####Listing 6.7: Registering Parallel Backend in Windows####
+library(doParallel)
+workers <- 4
+registerDoParallel( cores = workers )
+#stopImplicitCluster()
+#########
+
+
+####Listing 6.9: Integer Mapping for Multicore Time Series Computations####
+delegate <- function( i = i, n = n, k = k, p = workers ){
+ nOut <- n - k + 1
+ nProc <- ceiling( nOut / p )
+ return( (( i - 1 ) * nProc + 1) : min(i * nProc + k - 1, n) )
+}
+#########
+
+
+####Listing 6.12: Wrapper Function for Multicore Time Series Computations####
+mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers, ...){
+ # On windows, objects in the global environment are not attached when
+ # foreach is called from within a function. Only the arguments of the
+ # function call are attached. So we will first get a list of the arguments
+ # and all objects in the global environment. Then we will remove the
+ # duplicates.
+ args <- names(mget(ls()))
+ exports <- ls(.GlobalEnv)
+ exports <- exports[!exports %in% args]
+
+ SERIES <- foreach( i = 1:workers, .combine = rbind,
+ .packages="zoo", .export=exports) %dopar% {
+ jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers)
+ rollapply(data[jRange,],
+ width = windowSize,
+ FUN = tsfunc,
+ align = "right",
+ by.column = byColumn)
+ }
+ names(SERIES) <- gsub("\\..+", "", names(SERIES))
+
+ if( windowSize > 1){
+ PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA),
+ order.by = index(data)[1:(windowSize-1)])
+ names(PAD) <- names(SERIES)
+ SERIES <- rbind(PAD, SERIES)
+ }
+ if(is.null(names(SERIES))){
+ names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)])
+ }
+ return(SERIES)
+}
+#######
+
+
+
+####Listing 6.13: Computing Indicators with our Multicore Wrapper####
+# Computing the return matrix
+tsfunc <- function(v) (v[2,] / v[1,]) - 1
+RETURN <- mcTimeSeries( DATA[["Close"]], tsfunc, FALSE, 2, workers )
+####
+
+
+rm(list = setdiff(ls(), c("datadir", "functiondir", "rootdir",
+ "DATA", "OVERNIGHT", "RETURN",
+ "delegate", "mcTimeSeries", "workers")))
+
+##################
+##################
+##################
+
+
+equNA <- function(v){
+ o <- which(!is.na(v))[1]
+ return(ifelse(is.na(o), length(v)+1, o))
+}
+
+
+##############
+
+
+
+####Listing 7.1: Simulating Perfomance####
+simulate <- function(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, maxAssets, startingCash,
+ slipFactor, spreadAdjust, flatCommission, perShareCommission,
+ verbose = FALSE, failThresh = 0,
+ initP = NULL, initp = NULL){
+
+ t0=Sys.time()
+
+ timer=matrix(0, nrow=16)
+ t1=proc.time()[3]
+ # Step 1
+ if( any( dim(ENTRY) != dim(EXIT) ) |
+ any( dim(EXIT) != dim(FAVOR) ) |
+ any( dim(FAVOR) != dim(CLOSE) ) |
+ any( dim(CLOSE) != dim(OPEN)) )
+ stop( "Mismatching dimensions in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.")
+
+ if( any( names(ENTRY) != names(EXIT)) |
+ any( names(EXIT) != names(FAVOR) ) |
+ any( names(FAVOR) != names(CLOSE) ) |
+ any( names(CLOSE) != names(OPEN) ) |
+ is.null(names(ENTRY)) | is.null(names(EXIT)) |
+ is.null(names(FAVOR)) | is.null(names(CLOSE)) |
+ is.null(names(OPEN)) )
+ stop( "Mismatching or missing column names in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.")
+
+ FAVOR <- zoo(t(apply(FAVOR, 1, function(v) ifelse(is.nan(v) | is.na(v), 0, v) )),
+ order.by = index(CLOSE))
+
+ timer[1]=timer[1] + proc.time()[3] - t1; t1=proc.time()[3]
+
+
+ t10=proc.time()[3]
+ # Step 2
+ K <- maxAssets
+ k <- 0
+ C <- rep(startingCash, times = nrow(CLOSE))
+ S <- names(CLOSE)
+ P <- p <- zoo( matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)),
+ order.by = index(CLOSE) )
+ timer[12]=timer[12] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ if( !is.null( initP ) & !is.null( initp ) ){
+ P[1:maxLookback,] <-
+ matrix(initP, ncol=length(initP), nrow=maxLookback, byrow = TRUE)
+ p[1:maxLookback,] <-
+ matrix(initp, ncol=length(initp), nrow=maxLookback, byrow = TRUE)
+ }
+
+ names(P) <- names(p) <- S
+ equity <- rep(NA, nrow(CLOSE))
+ timer[13]=timer[13] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ rmNA <- foreach(i = 1:3, .packages="zoo",
+ .export=c("FAVOR","ENTRY", "EXIT", "equNA")) %dopar% {
+ unlist(lapply(get(c("FAVOR", "ENTRY", "EXIT")[i]), equNA))
+ }
+ rmNA <- pmax(rmNA[[1]], rmNA[[2]], rmNA[[3]])
+
+ timer[14]=timer[14] + proc.time()[3] - t1; t1=proc.time()[3]
+
+
+ for( j in 1:ncol(ENTRY) ){
+ if( rmNA[j] > (maxLookback + 1) &
+ rmNA[j] < nrow(ENTRY) ){
+ sel <- 1:(rmNA[j]-1)
+ FAVOR[sel,j] <- NA
+ ENTRY[sel,j] <- NA
+ EXIT[sel,j] <- NA
+ }
+ }
+ timer[15]=timer[15] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ timer[16]=timer[16] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ timer[2]=timer[2] + proc.time()[3] - t10
+
+ # Step 3
+ for( i in maxLookback:(nrow(CLOSE)-1) ){
+
+ t1=proc.time()[3]
+ # Step 4
+ C[i+1] <- C[i]
+ P[i+1,] <- as.numeric(P[i,])
+ p[i+1,] <- as.numeric(p[i,])
+ longS <- S[which(P[i,] > 0)]
+ shortS <- S[which(P[i,] < 0)]
+ k <- length(longS) + length(shortS)
+
+ timer[3]=timer[3] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 5
+ longTrigger <- setdiff(S[which(ENTRY[i,] == 1)], longS)
+ shortTrigger <- setdiff(S[which(ENTRY[i,] == -1)], shortS)
+
+ trigger <- c(longTrigger, shortTrigger)
+
+ if( length(trigger) > K ) {
+
+ keepTrigger <- trigger[order(c(as.numeric(FAVOR[i,longTrigger]),-as.numeric(FAVOR[i,shortTrigger])), decreasing = TRUE)][1:K]
+
+ longTrigger <- longTrigger[longTrigger %in% keepTrigger]
+ shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger]
+ trigger <- c(longTrigger, shortTrigger)
+ }
+ triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger)))
+
+ timer[4]=timer[4] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 6
+ longExitTrigger <- longS[longS %in%
+ S[which(EXIT[i,] == 1 | EXIT[i,] == 999)]]
+ shortExitTrigger <- shortS[shortS %in%
+ S[which(EXIT[i,] == -1 | EXIT[i,] == 999)]]
+ exitTrigger <- c(longExitTrigger, shortExitTrigger)
+
+ timer[5]=timer[5] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 7
+ needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0)
+ if( needToExit > 0 ){
+ toExitLongS <- setdiff(longS, exitTrigger)
+ toExitShortS <- setdiff(shortS, exitTrigger)
+ toExit <- character(0)
+ for( counter in 1:needToExit ){
+ if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){
+ if( min(FAVOR[i,toExitLongS]) < min(-FAVOR[i,toExitShortS]) ){
+ pullMin <- which.min(FAVOR[i,toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else {
+ pullMin <- which.min(-FAVOR[i,toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){
+ pullMin <- which.min(FAVOR[i,toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){
+ pullMin <- which.min(-FAVOR[i,toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ }
+ longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit])
+ shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit])
+ }
+ timer[6]=timer[6] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 8
+ exitTrigger <- c(longExitTrigger, shortExitTrigger)
+ exitTriggerType <- c(rep(1, length(longExitTrigger)),
+ rep(-1, length(shortExitTrigger)))
+
+ timer[7]=timer[7] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 9
+ if( length(exitTrigger) > 0 ){
+ for( j in 1:length(exitTrigger) ){
+ exitPrice <- as.numeric(OPEN[i+1,exitTrigger[j]])
+ effectivePrice <- exitPrice * (1 - exitTriggerType[j] * slipFactor) -
+ exitTriggerType[j] * (perShareCommission + spreadAdjust)
+ if( exitTriggerType[j] == 1 ){
+ C[i+1] <- C[i+1] +
+ ( as.numeric( P[i,exitTrigger[j]] ) * effectivePrice )
+ - flatCommission
+ } else {
+ C[i+1] <- C[i+1] -
+ ( as.numeric( P[i,exitTrigger[j]] ) *
+ ( 2 * as.numeric(p[i, exitTrigger[j]]) - effectivePrice ) )
+ - flatCommission
+ }
+ P[i+1, exitTrigger[j]] <- 0
+ p[i+1, exitTrigger[j]] <- 0
+ k <- k - 1
+ }
+ }
+
+ timer[8]=timer[8] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 10
+ if( length(trigger) > 0 ){
+ for( j in 1:length(trigger) ){
+ entryPrice <- as.numeric(OPEN[i+1,trigger[j]])
+ effectivePrice <- entryPrice * (1 + triggerType[j] * slipFactor) +
+ triggerType[j] * (perShareCommission + spreadAdjust)
+
+ P[i+1,trigger[j]] <- triggerType[j] *
+ floor( ( (C[i+1] - flatCommission) / (K - k) ) / effectivePrice )
+
+ p[i+1,trigger[j]] <- effectivePrice
+
+ C[i+1] <- C[i+1] -
+ ( triggerType[j] * as.numeric(P[i+1,trigger[j]]) * effectivePrice )
+ - flatCommission
+
+ k <- k + 1
+ }
+ }
+
+ timer[9]=timer[9] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 11
+ equity[i] <- C[i+1]
+ for( s in S[which(P[i+1,] > 0)] ){
+ equity[i] <- equity[i] +
+ as.numeric(P[i+1,s]) *
+ as.numeric(OPEN[i+1,s])
+ }
+ for( s in S[which(P[i+1,] < 0)] ){
+ equity[i] <- equity[i] -
+ as.numeric(P[i+1,s]) *
+ ( 2 * as.numeric(p[i+1,s]) - as.numeric(OPEN[i+1,s]) )
+ }
+ if( equity[i] < failThresh ){
+ warning("\n*** Failure Threshold Breached ***\n")
+ break
+ }
+
+ timer[10]=timer[10] + proc.time()[3] - t1; t1=proc.time()[3]
+
+ # Step 12
+ if( verbose ){
+ if( i %% 21 == 0 ){
+ cat(paste0("################################## ",
+ round(100 * (i - maxLookback) /
+ (nrow(CLOSE) - 1 - maxLookback), 1), "%",
+ " ##################################\n"))
+ cat(paste0("$", signif(equity[i], 5), "m"))
+ cat("\n")
+ cat(paste0("CAGR: ",
+ round(100 * ((equity[i] / (equity[maxLookback]))^
+ (252/(i - maxLookback + 1)) - 1), 2),
+ "%"))
+ cat("\n")
+ cat(S[which(P[i+1,]!=0)])
+ cat("\n")
+ cat(paste("Current Simulation Date",as.character(index(CLOSE)[i])))
+ cat("\n")
+ print(Sys.time() - t0)
+ cat("\n\n")
+ }
+ }
+
+ timer[11]=timer[11] + proc.time()[3] - t1; t1=proc.time()[3]
+ }
+
+ # Step 13
+ return(list(equity = equity, C = C, P = P, p = p, timer=timer))
+}
+######
+
+#########################
+
+
+
+####Listing 8.1: Declaring the Evaluator Function####
+# Declare entry function for use inside evaluator
+entryfunc <- function(v, shThresh, INDIC){
+ nc <- ncol(v)/2
+ return(
+ as.numeric(v[1,1:nc] <= 0 &
+ v[2,1:nc] > 0 &
+ v[2,(nc+1):(2*nc)] >
+ quantile(v[2,(nc+1):(2*nc)],
+ shThresh, na.rm = TRUE)
+ )
+ )
+}
+
+evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014,
+ continuous = TRUE, verbose = FALSE,
+ negative = FALSE, transformOnly = FALSE,
+ returnData = FALSE, accountParams = NULL,
+ entryfunc){
+
+ print(rbind(PARAM, minVal, maxVal))
+ # Convert and declare parameters if they exist on continuous (-inf,inf) domain
+ if( continuous | transformOnly ){
+ PARAM <- minVal +
+ (maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) ))
+ if( transformOnly ){
+ return(PARAM)
+ }
+ }
+
+ # Max shares to hold
+ K <- 10
+
+ # Declare n1 as itself, n2 as a multiple of n1 defined by nFact,
+ # and declare the length and threshold in sharpe ratio for FAVOR
+ n1 <- max(round(PARAM[["n1"]]), 2)
+ n2 <- max(round(PARAM[["nFact"]] * PARAM[["n1"]]), 3, n1+1)
+ nSharpe <- max(round(PARAM[["nSharpe"]]), 2)
+ shThresh <- max(0, min(PARAM[["shThresh"]], .99))
+ maxLookback <- max(n1, n2, nSharpe) + 1
+
+ max(n2-n1+1,1)
+
+ # Subset data according to year, y
+ #period <-
+ #index(DATA[["Close"]]) >= strptime(paste0("01-01-", y), "%d-%m-%Y") &
+ #index(DATA[["Close"]]) < strptime(paste0("01-01-", y+1), "%d-%m-%Y")
+
+ # Subset data according to years, y
+ period <-
+ index(DATA[["Close"]]) >= strptime(paste0("01-01-", y[1]), "%d-%m-%Y") &
+ index(DATA[["Close"]]) < strptime(paste0("01-01-", y[length(y)]+1), "%d-%m-%Y")
+
+
+ period <- period |
+ ((1:nrow(DATA[["Close"]]) > (which(period)[1] - maxLookback)) &
+ (1:nrow(DATA[["Close"]]) <= (which(period)[sum(period)]) + 1))
+
+
+
+ CLOSE <- DATA[["Close"]][period,]
+ OPEN <- DATA[["Open"]][period,]
+ SUBRETURN <- RETURN[period,]
+
+ print(rbind(PARAM,cbind(n1,n2, nSharpe, shThresh)))
+ # Compute inputs for long-only MACD as in Listing 7.2
+ INDIC <- mcTimeSeries( CLOSE,
+ function(v)
+ colMeans(v[max(n2-n1+1,1):n2,], na.rm = T)
+ #colMeans(v[(n2-n1+1):n2,], na.rm = T) #May get less than 1
+ - colMeans(v, na.rm = T),
+ FALSE, n2, workers )
+
+ RMEAN <- mcTimeSeries( SUBRETURN, function(v) colMeans(v, na.rm = T),
+ FALSE, nSharpe, workers )
+
+ FAVOR <- RMEAN / mcTimeSeries( (SUBRETURN - RMEAN) ^ 2,
+ function(v) colMeans(v, na.rm = T),
+ FALSE, nSharpe, workers )
+
+ ENTRY <- mcTimeSeries(cbind(INDIC, FAVOR),
+ function(v) entryfunc(v, shThresh, INDIC),
+ FALSE, 2, workers, entryfunc, shThresh)
+
+ EXIT <- zoo(matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)),
+ order.by = index(CLOSE))
+ names(EXIT) <- names(CLOSE)
+
+
+ # Simulate and store results
+ if( is.null(accountParams) ){
+ RESULTS <- simulate(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, 100000,
+ 0.001, 0.01, 3.5, 0,
+ verbose, 0)
+ } else {
+ RESULTS <- simulate(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, accountParams[["C"]],
+ 0.001, 0.01, 3.5, 0,
+ verbose, 0,
+ initP = accountParams[["P"]], initp = accountParams[["p"]])
+ }
+
+
+ if(!returnData){
+ # Compute and return sharpe ratio
+ v <- RESULTS[["equity"]]
+ returns <- ( v[-1] / v[-length(v)] ) - 1
+ out <- mean(returns, na.rm = T) / sd(returns, na.rm = T)
+ if(!is.nan(out)){
+ if( negative ){
+ return( -out )
+ } else {
+ return( out )
+ }
+ } else {
+ return(0)
+ }
+
+ } else {
+ return(RESULTS)
+ }
+}
+
+###########
+
+
+
+####Listing 8.5: Nelder-Mead Optimization####
+optimize <- function(y, minVal, maxVal, entryfunc=entryfunc, maxIter=3, PARAMNaught=NULL, continuous=TRUE){
+
+ #K <- maxIter <-10
+ K <- maxIter
+
+
+ # Vector theta_0
+ initDelta <- 6
+ deltaThresh <- 0.05
+
+ if(is.null(PARAMNaught)){
+ PARAM <- PARAMNaught <-
+ c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) - initDelta/2
+ }else{
+ #continuous=FALSE
+ PARAM <- PARAMNaught
+
+ }
+
+ # Optimization parameters
+ alpha <- 1
+ gamma <- 2
+ rho <- .5
+ sigma <- .5
+
+ randomInit <- FALSE
+
+ np <- length(PARAM)
+
+ OPTIM <- data.frame(matrix(NA, ncol = np + 1, nrow = maxIter * (2 * np + 2)))
+ o <- 1
+
+ SIMPLEX <- data.frame(matrix(NA, ncol = np + 1, nrow = np + 1))
+ names(SIMPLEX) <- names(OPTIM) <- c(names(PARAM), "obj")
+
+
+ # Print function for reporting progress in loop
+ printUpdate <- function(){
+ cat("Iteration: ", k, "of", K, "\n")
+ cat("\t\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n")
+ cat("Global Best:\t",
+ paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n")
+ cat("Simplex Best:\t",
+ paste0(round(unlist(SIMPLEX[which.min(SIMPLEX$obj),]),3), "\t"), "\n")
+ cat("Simplex Size:\t",
+ paste0(max(round(simplexSize,3)), "\t"), "\n\n\n")
+ }
+
+ # Initialize SIMPLEX
+ for( i in 1:(np+1) ) {
+ SIMPLEX[i,1:np] <- PARAMNaught + initDelta * as.numeric(1:np == (i-1))
+ SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], minVal, maxVal, negative = TRUE,
+ y = y, entryfunc=entryfunc, continuous=continuous)
+ OPTIM[o,] <- SIMPLEX[i,]
+ o <- o + 1
+ }
+
+
+ # Optimization loop
+ for( k in 1:K ){
+
+ SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),]
+ centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
+
+ cat("Computing Reflection...\n")
+ reflection <- centroid + alpha * (centroid - SIMPLEX[np+1,-(np+1)])
+
+ reflectResult <- evaluate(reflection, minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc,
+ continuous=continuous)
+ OPTIM[o,] <- c(reflection, obj = reflectResult)
+ o <- o + 1
+
+ if( reflectResult > SIMPLEX[1,np+1] &
+ reflectResult < SIMPLEX[np, np+1] ){
+
+ SIMPLEX[np+1,] <- c(reflection, obj = reflectResult)
+
+ } else if( reflectResult < SIMPLEX[1,np+1] ) {
+
+ cat("Computing Expansion...\n")
+ expansion <- centroid + gamma * (reflection - centroid)
+ expansionResult <- evaluate(expansion,
+ minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc,
+ continuous=continuous)
+
+ OPTIM[o,] <- c(expansion, obj = expansionResult)
+ o <- o + 1
+
+ if( expansionResult < reflectResult ){
+ SIMPLEX[np+1,] <- c(expansion, obj = expansionResult)
+ } else {
+ SIMPLEX[np+1,] <- c(reflection, obj = reflectResult)
+ }
+
+ } else if( reflectResult > SIMPLEX[np, np+1] ) {
+
+ cat("Computing Contraction...\n")
+ contract <- centroid + rho * (SIMPLEX[np+1,-(np+1)] - centroid)
+ contractResult <- evaluate(contract, minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc,
+ continuous=continuous)
+
+
+ OPTIM[o,] <- c(contract, obj = contractResult)
+ o <- o + 1
+
+ if( contractResult < SIMPLEX[np+1, np+1] ){
+
+ SIMPLEX[np+1,] <- c(contract, obj = contractResult)
+
+ } else {
+ cat("Computing Shrink...\n")
+ for( i in 2:(np+1) ){
+ SIMPLEX[i,1:np] <- SIMPLEX[1,-(np+1)] +
+ sigma * (SIMPLEX[i,1:np] - SIMPLEX[1,-(np+1)])
+ SIMPLEX[i,np+1] <- c(obj = evaluate(SIMPLEX[i,1:np],
+ minVal, maxVal,
+ negative = TRUE, y = y, entryfunc=entryfunc,
+ continuous=continuous))
+ }
+
+ OPTIM[o:(o+np-1),] <- SIMPLEX[2:(np+1),]
+ o <- o + np
+ }
+ }
+
+ centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
+ simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1,
+ function(v) abs(v - centroid))))
+
+ if( max(simplexSize) < deltaThresh ){
+
+ cat("Size Threshold Breached: Restarting with Random Initiate\n\n")
+
+ for( i in 1:(np+1) ) {
+
+ SIMPLEX[i,1:np] <- (PARAMNaught * 0) +
+ runif(n = np, min = -initDelta, max = initDelta)
+
+ SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np],
+ minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc,
+ continuous=continuous)
+ OPTIM[o,] <- SIMPLEX[i,]
+ o <- o + 1
+
+ SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),]
+ centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
+ simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, function(v) abs(v - centroid))))
+ }
+
+ }
+ printUpdate()
+ }
+
+ #Pruning excess rows
+ OPTIM <- OPTIM[!is.na(OPTIM[,1]),]
+
+ # Return the best optimization in untransformed parameters
+ return(
+ evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE, entryfunc=entryfunc)
+ )
+}
+###########
+
+
+
+
+####Listing 8.6: Generating Valid Performance Projections with Cross Validation####
+set.seed(1234)
+minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01)
+maxVal <- c(n1 = 250, nFact = 5, nSharpe = 200, shThresh = .99)
+#minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01)
+#maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99)
+
+RESULTS <- list()
+accountParams <- list()
+testRange <- 2004:2015
+maxIter <- 3
+ResetPARAM <- FALSE #If TRUE reset the model parameters after each year of data is tested
+YearByYear <- TRUE #If TRUE optimize only for previous year of data (vs all years up to that point)
+
+# As defined in heuristic with delta_O = delta_P = 1 year
+for( yf in testRange ){
+
+
+ if(YearByYear){ y <- yf }else{ y <- testRange[1]:yf }
+ if( yf == testRange[1] | ResetPARAM ){ PARAM0=NULL }else{ PARAM0=PARAM }
+
+ PARAM <- optimize(y = y, minVal = minVal, maxVal = maxVal, entryfunc=entryfunc,
+ maxIter=maxIter, PARAMNaught=PARAM0)
+
+ print("Opt Done")
+
+ if( yf == testRange[1] ){
+ RESULTS[[as.character(yf+1)]] <-
+ evaluate(PARAM, y = yf + 1, minVal = minVal, maxVal = maxVal, continuous = TRUE,
+ returnData = TRUE, verbose = TRUE, entryfunc=entryfunc )
+ } else {
+
+ # Pass account parameters to next simulation after first year
+ strYear <- as.character(yf)
+ aLength <- length(RESULTS[[strYear]][["C"]])
+ accountParams[["C"]] <- (RESULTS[[strYear]][["C"]])[aLength]
+ accountParams[["P"]] <- (RESULTS[[strYear]][["P"]])[aLength]
+ accountParams[["p"]] <- (RESULTS[[strYear]][["p"]])[aLength]
+
+ RESULTS[[as.character(yf+1)]] <-
+ evaluate(PARAM, y = yf + 1, minVal = minVal, maxVal = maxVal, continuous = TRUE,
+ returnData = TRUE, verbose = TRUE,
+ accountParams = accountParams, entryfunc=entryfunc)
+ }
+
+ # extract equity curve
+ for( y2 in (testRange[1]:yf + 1) ){
+ strYear <- as.character(y2)
+ inYear <- substr(index(RESULTS[[strYear]][["P"]]), 1, 4) == strYear
+ equity <- (RESULTS[[strYear]][["equity"]])[inYear]
+ date <- (index(RESULTS[[strYear]][["P"]]))[inYear]
+ if( y2 == (testRange[1] + 1) ){
+ equitySeries <- zoo(equity, order.by = date)
+ } else {
+ equitySeries <- rbind(equitySeries, zoo(equity, order.by = date))
+ }
+ }
+
+ plot(equitySeries, main=yf)
+ grid(); abline(h=100000, lty=2, lwd=3)
+}
+#####
+
+
+
+
+#####
+# extract equity curve
+for( y in (testRange + 1) ){
+ strYear <- as.character(y)
+ inYear <- substr(index(RESULTS[[strYear]][["P"]]), 1, 4) == strYear
+ equity <- (RESULTS[[strYear]][["equity"]])[inYear]
+ date <- (index(RESULTS[[strYear]][["P"]]))[inYear]
+ if( y == (testRange[1] + 1) ){
+ equitySeries <- zoo(equity, order.by = date)
+ } else {
+ equitySeries <- rbind(equitySeries, zoo(equity, order.by = date))
+ }
+}
+
+plot(equitySeries)
+###############
+
+
+
+830x460
+plot(equitySeries, main = "Figure 8.12: Cross-Validated Equity Curve for Long-Only MACD",
+ylab = "Account Equity ($)", xlab = "")
+
+#cont to transform
+
+
+
+
+
+
diff --git a/LICENSE.txt b/LICENSE.txt
new file mode 100755
index 0000000..2a09269
--- /dev/null
+++ b/LICENSE.txt
@@ -0,0 +1,27 @@
+Freeware License, some rights reserved
+
+Copyright (c) 2016 Christopher Conlan
+
+Permission is hereby granted, free of charge, to anyone obtaining a copy
+of this software and associated documentation files (the "Software"),
+to work with the Software within the limits of freeware distribution and fair use.
+This includes the rights to use, copy, and modify the Software for personal use.
+Users are also allowed and encouraged to submit corrections and modifications
+to the Software for the benefit of other users.
+
+It is not allowed to reuse, modify, or redistribute the Software for
+commercial use in any way, or for a user’s educational materials such as books
+or blog articles without prior permission from the copyright holder.
+
+The above copyright notice and this permission notice need to be included
+in all copies or substantial portions of the software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS OR APRESS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+
diff --git a/Listings/Appendix B/B-1.R b/Listings/Appendix B/B-1.R
new file mode 100755
index 0000000..4b262ea
--- /dev/null
+++ b/Listings/Appendix B/B-1.R
@@ -0,0 +1,23 @@
+# Declare global variables a and b
+a <- 2
+b <- 3
+
+# Declare functions
+f <- function(){
+ a
+}
+
+g <-function(){
+ f() + b
+}
+
+h <- function(b){
+ f() + b
+}
+
+
+# a = 2 throughout.
+# b = 3 when not supplied as a parameter.
+f() # f() = 2
+g() # g() = 5
+h(5) # h(5) = 7
diff --git a/Listings/Appendix B/B-2.R b/Listings/Appendix B/B-2.R
new file mode 100755
index 0000000..85de074
--- /dev/null
+++ b/Listings/Appendix B/B-2.R
@@ -0,0 +1,30 @@
+mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers ){
+
+ SERIES <- foreach( i = 1:workers, .combine = rbind ) %dopar% {
+
+ jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers)
+
+ rollapply(data[jRange,],
+ width = windowSize,
+ FUN = tsfunc,
+ align = "right",
+ by.column = byColumn)
+
+ }
+
+ names(SERIES) <- gsub("\\..+", "", names(SERIES))
+
+ if( windowSize > 1){
+ PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA),
+ order.by = index(data)[1:(windowSize-1)])
+ names(PAD) <- names(SERIES)
+ SERIES <- rbind(PAD, SERIES)
+ }
+
+ if(is.null(names(SERIES))){
+ names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)])
+ }
+
+ return(SERIES)
+
+}
diff --git a/Listings/Appendix B/B-3.R b/Listings/Appendix B/B-3.R
new file mode 100755
index 0000000..acfbfc5
--- /dev/null
+++ b/Listings/Appendix B/B-3.R
@@ -0,0 +1,13 @@
+exitfunc <- function(v) {
+ # Body of developer's new exit function
+}
+
+evaluate(...) <- function(...){
+
+ # Body of the evaluate function
+
+ EXIT <- mcTimeSeries(CLOSE, exitfunc, TRUE, 20, workers)
+
+ # Remainder of the evaluate function
+
+}
diff --git a/Listings/Appendix B/B-4.R b/Listings/Appendix B/B-4.R
new file mode 100755
index 0000000..4ca2bf9
--- /dev/null
+++ b/Listings/Appendix B/B-4.R
@@ -0,0 +1,46 @@
+# Declare parameter alpha as function parameter
+exitfunc <- function(v, alpha) {
+ # Body of developer's new exit function
+}
+
+# Declare function object exitfunc as
+# function parameter to evaluator
+evaluate <- function(... , exitfunc){
+
+ # Body of the evaluate function
+
+ # alpha exists in the function scope
+ # of the evaluator
+ alpha <- 0.5
+
+ # Dynamically declare function object in
+ # mcTimeSeries. Pass exitfunc and alpha
+ # in the ellipses of the call because
+ # the second argument depends on them.
+ EXIT <- mcTimeSeries(CLOSE,
+ function(v) exitfunc(v, alpha),
+ TRUE, 20, workers,
+ exitfunc, alpha)
+
+ # Remainder of the evaluate function
+
+}
+
+
+optimize <- function(... , exitfunc){
+
+ # Alter all calls to evaluate to include
+ # new function object parameter exitfunc
+
+ # Body of the optimzer
+
+ evaluate( ... , exitfunc )
+
+ # Body of the optimzer
+
+ evaluate( ... , exitfunc )
+
+ # And so on. There are typically many calls
+ # to evaluate() within the optimizer.
+
+}
diff --git a/Listings/Appendix B/UNIX-mcTimeSeries.R b/Listings/Appendix B/UNIX-mcTimeSeries.R
new file mode 100755
index 0000000..85de074
--- /dev/null
+++ b/Listings/Appendix B/UNIX-mcTimeSeries.R
@@ -0,0 +1,30 @@
+mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers ){
+
+ SERIES <- foreach( i = 1:workers, .combine = rbind ) %dopar% {
+
+ jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers)
+
+ rollapply(data[jRange,],
+ width = windowSize,
+ FUN = tsfunc,
+ align = "right",
+ by.column = byColumn)
+
+ }
+
+ names(SERIES) <- gsub("\\..+", "", names(SERIES))
+
+ if( windowSize > 1){
+ PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA),
+ order.by = index(data)[1:(windowSize-1)])
+ names(PAD) <- names(SERIES)
+ SERIES <- rbind(PAD, SERIES)
+ }
+
+ if(is.null(names(SERIES))){
+ names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)])
+ }
+
+ return(SERIES)
+
+}
diff --git a/Listings/Chapter 1/1-1.R b/Listings/Chapter 1/1-1.R
new file mode 100755
index 0000000..92963d9
--- /dev/null
+++ b/Listings/Chapter 1/1-1.R
@@ -0,0 +1,13 @@
+# Checks if quantmod is installed, installs it if unavailable,
+# loads it and turns off needless warning messages
+if(!("quantmod" %in% as.character(installed.packages()[,1])))
+ { install.packages("quantmod") }
+library(quantmod)
+options("getSymbols.warning4.0"=FALSE,
+ "getSymbols.auto.assign"=FALSE)
+
+# Loads S&P 500 ETF data, stores closing prices as a vector
+SPY <- suppressWarnings(
+ getSymbols(c("SPY"),from = "2012-01-01"))
+SPY <- as.numeric(SPY$SPY.Close)[1:987]
+
diff --git a/Listings/Chapter 1/1-10.R b/Listings/Chapter 1/1-10.R
new file mode 100755
index 0000000..aaf4f6a
--- /dev/null
+++ b/Listings/Chapter 1/1-10.R
@@ -0,0 +1,6 @@
+# Create linearized equity curve and run regression
+y <- Et / Vt
+model <- lm(y ~ t)
+
+# Compute PPS by pulling "r.squared" value from summary function
+PPS <- ((Et[length(Et)] - Vt[1]) / Vt[1]) * summary(model)$r.squared
diff --git a/Listings/Chapter 1/1-2.R b/Listings/Chapter 1/1-2.R
new file mode 100755
index 0000000..0331e9e
--- /dev/null
+++ b/Listings/Chapter 1/1-2.R
@@ -0,0 +1,57 @@
+# Set Random Seed
+set.seed(123)
+
+# Create Time Index
+t <- 1:(length(SPY)-1)
+
+# Tradable Capital Vector
+Vt <- c(rep(10000, length(t)))
+
+# Benchmark Return Series
+Rb <- rep(NA, length(t))
+for(i in 2:length(t)) { Rb[i] <- (SPY[i] / SPY[i - 1]) - 1 }
+
+# Benchmark Equity Curve
+Eb <- rep(NA, length(t))
+Eb[1] <- Vt[1]
+for(i in 2:length(t)) { Eb[i] <- Eb[i-1] * (1 + Rb[i]) }
+
+# Randomly Simulated Return Series 1
+Rt <- rep(NA, length(t))
+for(i in 2:length(t)){
+ Rt[i] <- Rb[i] + rnorm(n = 1,
+ mean = 0.24/length(t),
+ sd = 2.5 * sd(Rb, na.rm = TRUE))
+}
+
+# Randomly Simulated Return Series 2
+Rt2 <- rep(NA, length(t))
+for(i in 2:length(t)){
+ Rt2[i] <- Rb[i] + rnorm(n = 1,
+ mean = 0.02/length(t),
+ sd = .75 * sd(Rb, na.rm = TRUE))
+}
+
+# Randomly Simulated Equity Curve 1
+Et <- rep(NA, length(t))
+Et <- Vt[1]
+for(i in 2:length(t)) { Et[i] <- Et[i-1] * (1 + Rt[i]) }
+
+# Randomly Simulated Equity Curve 2
+Et2 <- rep(NA, length(t))
+Et2 <- Vt[1]
+for(i in 2:length(t)) { Et2[i] <- Et2[i-1] * (1 + Rt2[i]) }
+
+# Plot of Et1 against the SPY Portfolio
+plot(y = Et, x = t, type = "l", col = 1,
+ xlab = "Time",
+ ylab= "Equity ($)",
+ main = "Figure 1.3: Randomly Generated Equity Curves")
+grid()
+abline(h = 10000)
+lines(y = Et2, x = t, col = 2)
+lines(y = Eb, x = t, col = 8)
+legend(x = "topleft", col = c(1,2,8), lwd = 2, legend = c("Curve 1",
+ "Curve 2",
+ "SPY"))
+
diff --git a/Listings/Chapter 1/1-3.R b/Listings/Chapter 1/1-3.R
new file mode 100755
index 0000000..e092dd2
--- /dev/null
+++ b/Listings/Chapter 1/1-3.R
@@ -0,0 +1,4 @@
+# Use na.rm = TRUE to ignore NA's at position 1 in return series
+SR <- mean(Rt, na.rm = TRUE) / sd(Rt, na.rm = TRUE)
+SR2 <- mean(Rt2, na.rm = TRUE) / sd(Rt2, na.rm = TRUE)
+SRb <- mean(Rb, na.rm = TRUE) / sd(Rb, na.rm = TRUE)
diff --git a/Listings/Chapter 1/1-4.R b/Listings/Chapter 1/1-4.R
new file mode 100755
index 0000000..9729348
--- /dev/null
+++ b/Listings/Chapter 1/1-4.R
@@ -0,0 +1,13 @@
+plot(y = Et, x = t, type = "l", col = 1,
+ xlab = "",
+ ylab= "Equity ($)",
+ main = "Figure 1.4: Sharpe Ratios")
+grid()
+abline(h = 10000)
+lines(y = Et2, x = t, col = 2)
+lines(y = Eb, x = t, col = 8)
+legend(x = "topleft", col = c(1,2,8), lwd = 2,
+ legend = c(paste0("SR = ", round(SR, 3)),
+ paste0("SR = ", round(SR2, 3)),
+ paste0("SR = ", round(SRb, 3))))
+
diff --git a/Listings/Chapter 1/1-5.R b/Listings/Chapter 1/1-5.R
new file mode 100755
index 0000000..b0a02f8
--- /dev/null
+++ b/Listings/Chapter 1/1-5.R
@@ -0,0 +1,21 @@
+MD <- function(curve, n = 1){
+
+ time <- length(curve)
+ v <- rep(NA, (time * (time - 1)) / 2)
+ k <- 1
+ for(i in 1:(length(curve)-1)){
+ for(j in (i+1):length(curve)){
+ v[k] <- curve[i] - curve[j]
+ k <- k + 1
+ }
+ }
+
+ m <- rep(NA, length(n))
+ for(i in 1:n){
+ m[i] <- max(v)
+ v[which.max(v)] <- -Inf
+ }
+
+ return(m)
+
+}
diff --git a/Listings/Chapter 1/1-6.R b/Listings/Chapter 1/1-6.R
new file mode 100755
index 0000000..f8bded1
--- /dev/null
+++ b/Listings/Chapter 1/1-6.R
@@ -0,0 +1,4 @@
+NPMD <- (Et[length(Et)] - Vt[1]) / MD(Et)
+
+Burke <- (Et[length(Et)] - Vt[1]) /
+ sqrt((1/length(Et)) * sum(MD(Et, n = round(length(Et) / 20))^2))
diff --git a/Listings/Chapter 1/1-7.R b/Listings/Chapter 1/1-7.R
new file mode 100755
index 0000000..dce513f
--- /dev/null
+++ b/Listings/Chapter 1/1-7.R
@@ -0,0 +1,9 @@
+PM <- function(Rt, upper = FALSE, n = 2, Rb = 0){
+ if(n != 0){
+ if(!upper) return(mean(pmax(Rb - Rt, 0, na.rm = TRUE)^n))
+ if(upper) return(mean(pmax(Rt - Rb, 0, na.rm = TRUE)^n))
+ } else {
+ if(!upper) return(mean(Rb >= Rt))
+ if(upper) return(mean(Rt > Rb))
+ }
+}
diff --git a/Listings/Chapter 1/1-8.R b/Listings/Chapter 1/1-8.R
new file mode 100755
index 0000000..698d51b
--- /dev/null
+++ b/Listings/Chapter 1/1-8.R
@@ -0,0 +1,2 @@
+Omega <- mean(Rt, na.rm = TRUE) / PM(Rt)^0.5
+UPR <- PM(Rt, upper = TRUE)^0.5 / PM(Rt)^0.5
diff --git a/Listings/Chapter 1/1-9.R b/Listings/Chapter 1/1-9.R
new file mode 100755
index 0000000..10b0e74
--- /dev/null
+++ b/Listings/Chapter 1/1-9.R
@@ -0,0 +1,23 @@
+# Scatterplot of Rt against Rb
+plot(y = Rt, x = Rb,
+ pch = 20,
+ cex = 0.5,
+ xlab = "SPY Returns",
+ ylab= "Return Series 1",
+ main = "Figure 1.7: Return Series 1 vs. SPY")
+grid()
+abline(h = 0)
+abline(v = 0)
+
+# Compute and store the regression model
+model <- lm(Rt ~ Rb)
+
+# Plot the regression line
+abline(model, col = 2)
+
+# Display alpha and beta
+legend(x = "topleft", col = c(0,2), lwd = 2,
+ legend = c("Alpha Beta R^2",
+ paste0(round(model$coefficients[1], 4), " ",
+ round(model$coefficients[2], 2), " ",
+ round(summary(model)$r.squared, 2))))
diff --git a/Listings/Chapter 10/10-1.R b/Listings/Chapter 10/10-1.R
new file mode 100755
index 0000000..2bec6bf
--- /dev/null
+++ b/Listings/Chapter 10/10-1.R
@@ -0,0 +1,13 @@
+# Warning: These are not to be run concurrently
+
+# UPDATE Job
+source("~/Platform/update.R")
+
+# PLAN Job
+source("~/Platform/plan.R")
+
+# TRADE Job
+source("~/Platform/trade.R")
+
+# MODEL Job
+source("~/Platform/model.R")
diff --git a/Listings/Chapter 10/10-10 b/Listings/Chapter 10/10-10
new file mode 100755
index 0000000..c5233e9
--- /dev/null
+++ b/Listings/Chapter 10/10-10
@@ -0,0 +1 @@
+0 19 * * 1-5 ~/Platform/plan.sh
diff --git a/Listings/Chapter 10/10-2.bat b/Listings/Chapter 10/10-2.bat
new file mode 100755
index 0000000..506b1bb
--- /dev/null
+++ b/Listings/Chapter 10/10-2.bat
@@ -0,0 +1 @@
+set path= %path%;C:\Program Files\R\R-3.3.0\bin\x64
diff --git a/Listings/Chapter 10/10-3.bat b/Listings/Chapter 10/10-3.bat
new file mode 100755
index 0000000..7e8e7e5
--- /dev/null
+++ b/Listings/Chapter 10/10-3.bat
@@ -0,0 +1 @@
+Rscript C:\Platform\plan.R
diff --git a/Listings/Chapter 10/10-4.bat b/Listings/Chapter 10/10-4.bat
new file mode 100755
index 0000000..5a34304
--- /dev/null
+++ b/Listings/Chapter 10/10-4.bat
@@ -0,0 +1,2 @@
+cd C:\Platform\errorlog
+Rscript C:\Platform\plan.R > planlog.txt 2>&1
diff --git a/Listings/Chapter 10/10-5.bat b/Listings/Chapter 10/10-5.bat
new file mode 100755
index 0000000..d45b5b9
--- /dev/null
+++ b/Listings/Chapter 10/10-5.bat
@@ -0,0 +1,3 @@
+set path= %path%;C:\Program Files\R\R-3.2.3\bin
+cd C:\Platform\errorlog\
+Rscript C:\Platform\plan.R > planlog.txt 2>&1
diff --git a/Listings/Chapter 10/10-6.bat b/Listings/Chapter 10/10-6.bat
new file mode 100755
index 0000000..0ffd263
--- /dev/null
+++ b/Listings/Chapter 10/10-6.bat
@@ -0,0 +1,2 @@
+schtasks /create /tn PLAN /sc weekly /d mon,tue,wed,thu,fri /mo 1 /st 19:00
+ /tr "C:\Platform\plan.bat"
diff --git a/Listings/Chapter 10/10-7.txt b/Listings/Chapter 10/10-7.txt
new file mode 100755
index 0000000..f658f0f
--- /dev/null
+++ b/Listings/Chapter 10/10-7.txt
@@ -0,0 +1,20 @@
+# Delete a task
+schtasks /delete /tn PLAN
+
+# Run a task
+schtasks /run /tn PLAN
+
+# End a currently run task, does not affect scheduling
+schtasks /end /tn PLAN
+
+# Get info on a task
+schtasks /query /tn PLAN
+
+# Modify a task (this example removes Wednesday from PLAN)
+schtasks /change /tn PLAN /d mon,tue,thu,fri
+
+# Disable a task, cancel scheduling
+schtasks /change /tn PLAN /disable
+
+# Enable an inactive task, resume scheduling
+schtasks /change /tn PLAN /enable
diff --git a/Listings/Chapter 10/10-8.sh b/Listings/Chapter 10/10-8.sh
new file mode 100755
index 0000000..20fa3ee
--- /dev/null
+++ b/Listings/Chapter 10/10-8.sh
@@ -0,0 +1,5 @@
+# Edit CRON jobs
+crontab -e
+
+# Delete all user-specified CRON jobs
+crontab -r
diff --git a/Listings/Chapter 10/10-9.sh b/Listings/Chapter 10/10-9.sh
new file mode 100755
index 0000000..4fd8791
--- /dev/null
+++ b/Listings/Chapter 10/10-9.sh
@@ -0,0 +1,3 @@
+#!/bin/bash
+cd ~/Platform/errorlog
+Rscript ~/Platform/plan.R > planlog.txt 2>&1
diff --git a/Listings/Chapter 2/2-1.R b/Listings/Chapter 2/2-1.R
new file mode 100755
index 0000000..8270ae9
--- /dev/null
+++ b/Listings/Chapter 2/2-1.R
@@ -0,0 +1,3 @@
+rootdir <- "~/Platform/"
+datadir <- "~/Platform/stockdata/"
+functiondir <- "~/Platform/functions/"
diff --git a/Listings/Chapter 2/2-2.R b/Listings/Chapter 2/2-2.R
new file mode 100755
index 0000000..cdc709e
--- /dev/null
+++ b/Listings/Chapter 2/2-2.R
@@ -0,0 +1,31 @@
+yahoo <- function(sym, current = TRUE,
+ a = 0, b = 1, c = 2000, d, e, f,
+ g = "d")
+{
+
+ if(current){
+ f <- as.numeric(substr(as.character(Sys.time()), start = 1, stop = 4))
+ d <- as.numeric(substr(as.character(Sys.time()), start = 6, stop = 7)) - 1
+ e <- as.numeric(substr(as.character(Sys.time()), start = 9, stop = 10))
+ }
+
+ require(data.table)
+
+ tryCatch(
+ suppressWarnings(
+ fread(paste0("http://ichart.yahoo.com/table.csv",
+ "?s=", sym,
+ "&a=", a,
+ "&b=", b,
+ "&c=", c,
+ "&d=", d,
+ "&e=", e,
+ "&f=", f,
+ "&g=", g,
+ "&ignore=.csv"), sep = ",")),
+ error = function(e) NULL
+ )
+}
+
+setwd(functiondir)
+dump(list = c("yahoo"), "yahoo.R")
diff --git a/Listings/Chapter 2/2-3.R b/Listings/Chapter 2/2-3.R
new file mode 100755
index 0000000..5591cd2
--- /dev/null
+++ b/Listings/Chapter 2/2-3.R
@@ -0,0 +1,3 @@
+# Up-to-date at time of writing (May 2016)
+url <- "http://trading.chrisconlan.com/SPstocks.csv"
+S <- as.character(read.csv(url, header = FALSE)[,1])
diff --git a/Listings/Chapter 2/2-4.R b/Listings/Chapter 2/2-4.R
new file mode 100755
index 0000000..77c60fe
--- /dev/null
+++ b/Listings/Chapter 2/2-4.R
@@ -0,0 +1,29 @@
+# Load "invalid.R" file if available
+invalid <- character(0)
+setwd(rootdir)
+if("invalid.R" %in% list.files()) source("invalid.R")
+
+
+# Find all symbols not in directory and not missing
+setwd(datadir)
+toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid)
+
+# Fetch symbols with yahoo function, save as .csv or missing
+source(paste0(functiondir, "yahoo.R"))
+if(length(toload) != 0){
+ for(i in 1:length(toload)){
+
+ df <- yahoo(toload[i])
+
+ if(!is.null(df)) {
+ write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"),
+ row.names = FALSE)
+ } else {
+ invalid <- c(invalid, toload[i])
+ }
+
+}
+}
+
+setwd(rootdir)
+dump(list = c("invalid"), "invalid.R")
diff --git a/Listings/Chapter 2/2-5.R b/Listings/Chapter 2/2-5.R
new file mode 100755
index 0000000..90d785b
--- /dev/null
+++ b/Listings/Chapter 2/2-5.R
@@ -0,0 +1,12 @@
+setwd(datadir)
+S <- sub(".csv", "", list.files())
+
+require(data.table)
+
+DATA <- list()
+for(i in S){
+ suppressWarnings(
+ DATA[[i]] <- fread(paste0(i, ".csv"), sep = ","))
+ DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)]
+}
+
diff --git a/Listings/Chapter 2/2-6.R b/Listings/Chapter 2/2-6.R
new file mode 100755
index 0000000..c3e7b28
--- /dev/null
+++ b/Listings/Chapter 2/2-6.R
@@ -0,0 +1,34 @@
+currentTime <- Sys.time()
+
+for(i in S){
+ # Store greatest date within DATA for symbol i
+ maxdate <- DATA[[i]][["Date"]][nrow(DATA[[i]])]
+ if(as.numeric(difftime(currentTime, maxdate, units = "hours")) >= 40.25){
+
+ # Push the maxdate forward one day
+ maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400
+
+ weekend <- sum(c("Saturday", "Sunday") %in%
+ weekdays(c(maxdate, currentTime))) == 2
+
+ span <- FALSE
+ if( weekend ){
+ span <- as.numeric(difftime(currentTime, maxdate, units = "hours")) >= 48
+ }
+
+ if(!weekend & !span){
+ c <- as.numeric(substr(maxdate, start = 1, stop = 4))
+ a <- as.numeric(substr(maxdate, start = 6, stop = 7)) - 1
+ b <- as.numeric(substr(maxdate, start = 9, stop = 10))
+ df <- yahoo(i, a = a, b = b, c = c)
+ if(!is.null(df)){
+ if(all(!is.na(df)) & nrow(df) > 0){
+ df <- df[nrow(df):1]
+ write.table(df, file = paste0(i, ".csv"), sep = ",",
+ row.names = FALSE, col.names = FALSE, append = TRUE)
+ DATA[[i]] <- rbind(DATA[[i]], df)
+ }
+ }
+ }
+ }
+}
diff --git a/Listings/Chapter 2/2-7.R b/Listings/Chapter 2/2-7.R
new file mode 100755
index 0000000..18625eb
--- /dev/null
+++ b/Listings/Chapter 2/2-7.R
@@ -0,0 +1,126 @@
+setwd(datadir)
+library(XML)
+
+currentTime <- Sys.time()
+
+batchsize <- 101
+
+# i in 1:5 for this example
+for(i in 1:(ceiling(length(S) / batchsize)) ){
+
+ midQuery <- " ("
+ maxdate <- character(0)
+
+startIndex <- ((i - 1) * batchsize + 1)
+endIndex <- min(i * batchsize, length(S))
+
+
+# find earliest date and build query
+for(s in S[startIndex:(endIndex - 1)]){
+ maxdate <- c(maxdate, DATA[[s]][[1]][nrow(DATA[[s]])])
+ midQuery <- paste0(midQuery, "'", s, "', ")
+}
+
+
+maxdate <- c(maxdate, DATA[[S[endIndex]]][[1]]
+ [nrow(DATA[[S[endIndex]]])])
+
+startDate <- max(maxdate)
+
+if( startDate <
+ substr(strptime(substr(currentTime, 0, 10), "%Y-%m-%d")
+ - 28 * 86400, 0, 10) ){
+ cat("Query is greater than 20 trading days. Download with csv method.")
+ break
+}
+
+
+# Adds a day (86400 seconds) to the earliest date to avoid duplicates
+startDate <- substr(as.character(strptime(startDate, "%Y-%m-%d") + 86400), 0, 10)
+endDate <- substr(currentTime, 0, 10)
+
+# Yahoo! updates at 4:15 EST at earliest, check if it is past 4:15 day after last
+isUpdated <- as.numeric(difftime(currentTime, startDate, units = "hours")) >=
+ 40.25
+
+# If both days fall in the same weekend, we will not attempt to update
+weekend <- sum(c("Saturday", "Sunday") %in%
+ weekdays(c(strptime(endDate, "%Y-%m-%d"),
+ c(strptime(startDate, "%Y-%m-%d"))))) == 2
+
+span <- FALSE
+if( weekend ){
+ span <- as.numeric(difftime(currentTime, startDate, units = "hours")) < 48
+}
+
+
+if( startDate <= endDate &
+ !weekend &
+ !span &
+ isUpdated ){
+
+# Piece this extremely long URL together
+base <- "http://query.yahooapis.com/v1/public/yql?"
+begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in "
+midQuery <- paste0(midQuery, "'", S[min(i * batchsize, length(S))], "') ")
+endQuery <- paste0("and startDate = '", startDate,
+ "' and endDate = '", endDate, "'")
+endParams <- "&diagnostics=true&env=store://datatables.org/alltableswithkeys"
+
+urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams)
+
+# Fetch data and arrange in XML tree
+doc <- xmlParse(urlstr)
+
+# The next few lines rely heavily and XPath and quirks
+# of S4 objects in the XML package in R.
+# We retrieve every node (or branch) on //query/results/quote
+# and retrieve the values Date, Open, High, etc. from the branch
+df <- getNodeSet(doc, c("//query/results/quote"),
+ fun = function(v) xpathSApply(v,
+ c("./Date",
+ "./Open",
+ "./High",
+ "./Low",
+ "./Close",
+ "./Volume",
+ "./Adj_Close"),
+ xmlValue))
+
+# If the URL found data we organize and update
+if(length(df) != 0){
+
+
+# We get the atrributes from the same tree, which happen
+# to be dates we need
+symbols <- unname(sapply(
+ getNodeSet(doc, c("//query/results/quote")), xmlAttrs))
+
+df <- cbind(symbols, data.frame(t(data.frame(df, stringsAsFactors = FALSE)),
+ stringsAsFactors = FALSE, row.names = NULL))
+
+names(df) <- c("Symbol", "Date",
+ "Open", "High", "Low", "Close", "Volume", "Adj Close")
+
+df[,3:8] <- lapply(df[,3:8], as.numeric)
+df <- df[order(df[,1], decreasing = FALSE),]
+
+sym <- as.character(unique(df$Symbol))
+
+for(s in sym){
+
+ temp <- df[df$Symbol == s, 2:8]
+ temp <- temp[order(temp[,1], decreasing = FALSE),]
+
+ startDate <- DATA[[s]][["Date"]][nrow(DATA[[s]])]
+
+ DATA[[s]] <- DATA[[s]][order(DATA[[s]][[1]], decreasing = FALSE)]
+ DATA[[s]] <- rbind(DATA[[s]], temp[temp$Date > startDate,])
+ write.table(DATA[[s]][DATA[[s]][["Date"]] > startDate],
+ file = paste0(s, ".csv"), sep = ",",
+ row.names = FALSE, col.names = FALSE, append = TRUE)
+
+}
+}
+}
+}
diff --git a/Listings/Chapter 2/2-8.R b/Listings/Chapter 2/2-8.R
new file mode 100755
index 0000000..461a70f
--- /dev/null
+++ b/Listings/Chapter 2/2-8.R
@@ -0,0 +1,49 @@
+library(zoo)
+
+# Compute the date template as a column of a data.frame for merging
+# Considers date are strings in YYYY-MM-DD format
+datetemp <- sort(unique(unlist(sapply(DATA, function(v) v[["Date"]]))))
+datetemp <- data.frame(datetemp, stringsAsFactors = FALSE)
+names(datetemp) <- "Date"
+
+# Double-check that our data is unique and in ascending-date order
+DATA <- lapply(DATA, function(v) unique(v[order(v$Date),]))
+
+# Create 6 new objects that will hold our re-orgainzed data
+DATA[["Open"]] <- DATA[["High"]] <- DATA[["Low"]] <-
+ DATA[["Close"]] <- DATA[["Adj Close"]] <- DATA[["Volume"]] <- datetemp
+
+# This loop will sequentially append the columns of each symbol
+# to the appropriate Open, High, Low, etc. object
+for(s in S){
+ for(i in rev(c("Open", "High", "Low", "Close", "Adj Close", "Volume"))){
+ temp <- data.frame(cbind(DATA[[s]][["Date"]], DATA[[s]][[i]]),
+ stringsAsFactors = FALSE)
+ names(temp) <- c("Date", s)
+ temp[,2] <- as.numeric(temp[,2])
+
+ if(!any(!DATA[[i]][["Date"]][(nrow(DATA[[i]]) - nrow(temp)+1):nrow(DATA[[i]])]
+ == temp[,1])){
+ temp <- rbind(t(matrix(nrow = 2, ncol = nrow(DATA[[i]]) - nrow(temp),
+ dimnames = list(names(temp)))), temp)
+ DATA[[i]] <- cbind(DATA[[i]], temp[,2])
+ } else {
+ DATA[[i]] <- merge(DATA[[i]], temp, all.x = TRUE, by = "Date")
+ }
+
+ names(DATA[[i]]) <- c(names(DATA[[i]])[-(ncol(DATA[[i]]))], s)
+ }
+ DATA[[s]] <- NULL
+
+ # Update user on progress
+ if( which( S == s ) %% 25 == 0 ){
+ cat( paste0(round(100 * which( S == s ) / length(S), 1), "% Complete\n") )
+ }
+
+}
+
+# Declare them as zoo objects for use with time-series functions
+DATA <- lapply(DATA, function(v) zoo(v[,2:ncol(v)], strptime(v[,1], "%Y-%m-%d")))
+
+# Remove extra variables
+rm(list = setdiff(ls(), c("DATA", "datadir", "functiondir", "rootdir")))
diff --git a/Listings/Chapter 3/3-1.R b/Listings/Chapter 3/3-1.R
new file mode 100755
index 0000000..512200a
--- /dev/null
+++ b/Listings/Chapter 3/3-1.R
@@ -0,0 +1,22 @@
+setwd(rootdir)
+
+if( "SPdates.R" %in% list.files() ){
+ source("SPdates.R")
+} else {
+ url <- "http://trading.chrisconlan.com/SPdates.csv"
+ S <- read.csv(url, header = FALSE, stringsAsFactors = FALSE)
+ dump(list = "S", "SPdates.R")
+}
+
+names(S) <- c("Symbol", "Date")
+S$Date <- strptime(S$Date, "%m/%d/%Y")
+
+for(s in names(DATA[["Close"]])){
+ for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){
+ Sindex <- which(S[,1] == s)
+ if(S[Sindex, "Date"] != "1900-01-01 EST" &
+ S[Sindex, "Date"] >= "2000-01-01 EST"){
+ DATA[[i]][index(DATA[[i]]) <= S[Sindex, "Date"], s] <- NA
+ }
+ }
+}
diff --git a/Listings/Chapter 3/3-2.R b/Listings/Chapter 3/3-2.R
new file mode 100755
index 0000000..f5fabfb
--- /dev/null
+++ b/Listings/Chapter 3/3-2.R
@@ -0,0 +1,9 @@
+temp <- c(DATA[["Close"]][index(DATA[["Close"]]) %in% c("2015-11-23",
+ "2015-11-24",
+ "2015-11-25"), "KORS"],
+ zoo(NA, order.by = strptime("2015-11-26", "%Y-%m-%d")) ,
+ DATA[["Close"]][index(DATA[["Close"]]) %in% c("2015-11-27"), "KORS"],
+ zoo(NA, order.by = strptime(c("2015-11-28", "2015-11-29"), "%Y-%m-%d")),
+ DATA[["Close"]][index(DATA[["Close"]]) %in% c("2015-11-30",
+ "2015-12-01",
+ "2015-12-02"), "KORS"])
diff --git a/Listings/Chapter 3/3-3.R b/Listings/Chapter 3/3-3.R
new file mode 100755
index 0000000..2b35341
--- /dev/null
+++ b/Listings/Chapter 3/3-3.R
@@ -0,0 +1,19 @@
+# Forward replacement function
+forwardfun <- function(v, n) {
+ if(is.na(v[n])){
+ return(v[max(which(!is.na(v)))])
+ } else {
+ return(v[n])
+ }
+}
+
+maxconsec <- 3
+
+# We pass maxconsec to rollapply() in "width = "
+# and pass it again to forwardfun() in "n = "
+forwardrep <- rollapply(temp,
+ width = maxconsec,
+ FUN = forwardfun,
+ n = maxconsec,
+ by.column = TRUE,
+ align = "right")
diff --git a/Listings/Chapter 3/3-4.R b/Listings/Chapter 3/3-4.R
new file mode 100755
index 0000000..591ab89
--- /dev/null
+++ b/Listings/Chapter 3/3-4.R
@@ -0,0 +1,20 @@
+# Linearly Smoothed Replacement Function
+linearfun <- function(v, n){
+ m <- (n + 1)/2
+ if(is.na(v[m])){
+ a <- max(which(!is.na(v) & seq(1:n) < m))
+ b <- min(which(!is.na(v) & seq(1:n) > m))
+ return(((b - m)/(b - a)) * v[a] +
+ ((m - a)/(b - a)) * v[b])
+ } else {
+ return(v[m])
+ }
+}
+
+maxconsec <- 5
+linearrep <- rollapply(temp,
+ width = maxconsec,
+ FUN = linearfun,
+ n = maxconsec,
+ by.column = TRUE,
+ align = "center")
diff --git a/Listings/Chapter 3/3-5.R b/Listings/Chapter 3/3-5.R
new file mode 100755
index 0000000..cd28c13
--- /dev/null
+++ b/Listings/Chapter 3/3-5.R
@@ -0,0 +1,27 @@
+voltemp <-
+ c(DATA[["Volume"]][index(DATA[["Close"]]) %in% c(index(temp)[1:3]), "KORS"],
+ zoo(NA, order.by = index(temp)[4]),
+ DATA[["Volume"]][index(DATA[["Close"]]) %in% c(index(temp)[5]), "KORS"],
+ zoo(NA, order.by = index(temp)[6:7]),
+ DATA[["Volume"]][index(DATA[["Close"]]) %in% c(index(temp[8:10])), "KORS"])
+
+# Volume-Weighted Smoothed Replacement Function
+volfun <- function(v, n, vol){
+ m <- (n + 1)/2
+ if(is.na(v[m])){
+ a <- max(which(!is.na(v) & seq(1:n) < m))
+ b <- min(which(!is.na(v) & seq(1:n) > m))
+ return(((v[a] + ((m-a-1)/(b-a)) * (v[b] - v[a])) * vol[a] +
+ (v[a] + ((m-a+1)/(b-a)) * (v[b] - v[a])) * vol[b]) /
+ (vol[a] + vol[b]))
+ } else {
+ return(v[m])
+ }
+}
+
+maxconsec <- 5
+volrep <- rollapply(cbind(temp, voltemp),
+ width = maxconsec,
+ FUN = function(v) volfun(v[,1], n = maxconsec, v[,2]),
+ by.column = FALSE,
+ align = "center")
diff --git a/Listings/Chapter 3/3-6.R b/Listings/Chapter 3/3-6.R
new file mode 100755
index 0000000..5c28875
--- /dev/null
+++ b/Listings/Chapter 3/3-6.R
@@ -0,0 +1,18 @@
+# Declare new zoo data frame of adjustment factors
+MULT <- DATA[["Adj Close"]] / DATA[["Close"]]
+
+# Store Close and Open Prices in new variable "Price" and "OpenPrice"
+DATA[["Price"]] <- DATA[["Close"]]
+DATA[["OpenPrice"]] <- DATA[["Open"]]
+
+# Adjust Open, High, and Low
+DATA[["Open"]] <- DATA[["Open"]] * MULT
+DATA[["High"]] <- DATA[["High"]] * MULT
+DATA[["Low"]] <- DATA[["Low"]] * MULT
+
+# Copy Adjusted Close to Close
+DATA[["Close"]] <- DATA[["Adj Close"]]
+
+# Delete Adjusted Close
+DATA[["Adj Close"]] <- NULL
+
diff --git a/Listings/Chapter 3/3-7.R b/Listings/Chapter 3/3-7.R
new file mode 100755
index 0000000..0040d0c
--- /dev/null
+++ b/Listings/Chapter 3/3-7.R
@@ -0,0 +1,12 @@
+for( s in names(DATA[["Close"]]) ){
+ if(is.na(DATA[["Close"]][nrow(DATA[["Close"]]), s])){
+ maxInd <- max(which(!is.na(DATA[["Close"]][,s])))
+ for( i in c("Close", "Open", "High", "Low")){
+ DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Close"]][maxInd,s]
+ }
+ for( i in c("Price", "OpenPrice") ){
+ DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Price"]][maxInd,s]
+ }
+ DATA[["Volume"]][(maxInd+1):nrow(DATA[["Close"]]),s] <- 0
+ }
+}
diff --git a/Listings/Chapter 3/3-8.R b/Listings/Chapter 3/3-8.R
new file mode 100755
index 0000000..fd33213
--- /dev/null
+++ b/Listings/Chapter 3/3-8.R
@@ -0,0 +1,11 @@
+# Pad with NA's to perserver dimension equality
+NAPAD <- zoo(matrix(NA, nrow = 1, ncol = ncol(DATA[["Close"]])),
+ order.by = index(DATA[["Close"]])[1])
+names(NAPAD) <- names(DATA[["Close"]])
+
+# Compute Daily Close-to-Close Returns
+RETURN <- rbind( NAPAD, ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 )
+
+# Compute Overnight Returns (Close-to-Open)
+OVERNIGHT <- rbind( NAPAD, ( DATA[["Open"]] / lag(DATA[["Close"]], k = -1) ) - 1 )
+
diff --git a/Listings/Chapter 4/4-1.R b/Listings/Chapter 4/4-1.R
new file mode 100755
index 0000000..1fb4afe
--- /dev/null
+++ b/Listings/Chapter 4/4-1.R
@@ -0,0 +1,8 @@
+n <- 20
+meanseries <-
+rollapply(DATA[["Close"]][,exampleset],
+ width = n,
+ FUN = mean,
+ by.column = TRUE,
+ fill = NA,
+ align = "right")
diff --git a/Listings/Chapter 4/4-2.R b/Listings/Chapter 4/4-2.R
new file mode 100755
index 0000000..6226831
--- /dev/null
+++ b/Listings/Chapter 4/4-2.R
@@ -0,0 +1,9 @@
+n1 <- 5
+n2 <- 34
+MACDseries <-
+rollapply(DATA[["Close"]][,exampleset],
+ width = n2,
+ FUN = function(v) mean(v[(n2 - n1 + 1):n2]) - mean(v),
+ by.column = TRUE,
+ fill = NA,
+ align = "right")
diff --git a/Listings/Chapter 4/4-3.R b/Listings/Chapter 4/4-3.R
new file mode 100755
index 0000000..1769324
--- /dev/null
+++ b/Listings/Chapter 4/4-3.R
@@ -0,0 +1,10 @@
+n <- 20
+rollsd <- rollapply(DATA[["Close"]][,exampleset],
+ width = n,
+ FUN = sd,
+ by.column = TRUE,
+ fill = NA,
+ align = "right")
+
+upperseries <- meanseries + 2 * rollsd
+lowerseries <- meanseries + 2 - rollsd
diff --git a/Listings/Chapter 4/4-4.R b/Listings/Chapter 4/4-4.R
new file mode 100755
index 0000000..155b4cd
--- /dev/null
+++ b/Listings/Chapter 4/4-4.R
@@ -0,0 +1,8 @@
+n <- 10
+customseries <-
+ rollapply(DATA[["Close"]][,exampleset],
+ width = n,
+ FUN = function(v) cor(v, n:1)^2 * ((v[n] - v[1])/n),
+ by.column = TRUE,
+ fill = NA,
+ align = "right")
diff --git a/Listings/Chapter 4/4-5.R b/Listings/Chapter 4/4-5.R
new file mode 100755
index 0000000..0f69faa
--- /dev/null
+++ b/Listings/Chapter 4/4-5.R
@@ -0,0 +1,28 @@
+CMFfunc <- function(close, high, low, volume){
+ apply(((2 * close - high - low) / (high - low)) * volume,
+ MARGIN = 2,
+ FUN = sum) /
+ apply(volume,
+ MARGIN = 2,
+ FUN = sum)
+}
+
+
+n <- 20
+k <- length(exampleset)
+CMFseries <-
+rollapply(cbind(DATA[["Close"]][,exampleset],
+ DATA[["High"]][,exampleset],
+ DATA[["Low"]][,exampleset],
+ DATA[["Volume"]][,exampleset]),
+ FUN = function(v) CMFfunc(v[,(1:k)],
+ v[,(k+1):(2*k)],
+ v[,(2*k + 1):(3*k)],
+ v[,(3*k + 1):(4*k)]),
+ by.column = FALSE,
+ width = n,
+ fill = NA,
+ align = "right")
+
+names(CMFseries) <- exampleset
+
diff --git a/Listings/Chapter 6/6-1.R b/Listings/Chapter 6/6-1.R
new file mode 100755
index 0000000..07e962c
--- /dev/null
+++ b/Listings/Chapter 6/6-1.R
@@ -0,0 +1,20 @@
+# Declare 10mil random numbers in a data frame
+df <- data.frame(matrix(nrow = 10000, ncol = 1000, runif(n = 10000 * 1000)))
+
+
+# Compute the sum of each row with a for loop
+# Completes in 96.692 seconds
+v1 <- rep(NA, 10000)
+for( i in 1:10000 ) {
+ v1[i] <- sum(df[i,])
+}
+
+
+# Use rowSums() binary
+# Completes in 0.053 seconds
+v2 <- rowSums(df)
+
+
+# Results are exactly the same
+# Expression evaluates to TRUE
+all.equal(v1, v2)
diff --git a/Listings/Chapter 6/6-10.R b/Listings/Chapter 6/6-10.R
new file mode 100755
index 0000000..e3e6d7d
--- /dev/null
+++ b/Listings/Chapter 6/6-10.R
@@ -0,0 +1,28 @@
+k <- 2
+
+# Using for a for loop, pre-allocated
+RETURN <- foreach( i = 1:workers, .combine = rbind,
+ .packages = "zoo" ) %dopar% {
+
+ CLOSE <- as.matrix(DATA[["Close"]])
+
+ jRange <- delegate( i = i, n = nrow(DATA[["Close"]]), k = k, p = workers)
+
+ subRETURN <- zoo(
+ matrix(numeric(),
+ ncol = ncol(DATA[["Close"]]),
+ nrow = length(jRange) - k + 1),
+ order.by = (index(DATA[["Close"]])[jRange])[-(1:(k-1))])
+
+ names(subRETURN) <- names(DATA[["Close"]])
+
+ for( j in jRange[-1] ){
+ jmod <- j - jRange[1]
+ subRETURN[jmod, ] <- (CLOSE[j,] / CLOSE[j-1,]) - 1
+ }
+
+ subRETURN
+
+}
+# Completes in 6.99 seconds
+
diff --git a/Listings/Chapter 6/6-11.R b/Listings/Chapter 6/6-11.R
new file mode 100755
index 0000000..2c4b6dc
--- /dev/null
+++ b/Listings/Chapter 6/6-11.R
@@ -0,0 +1,16 @@
+# Using rollapply(), automatically pre-allocated
+RETURN <- foreach( i = 1:workers, .combine = rbind,
+ .packages = "zoo") %dopar% {
+
+ jRange <- delegate( i = i, n = nrow(DATA[["Close"]]), k = k, p = workers)
+
+ rollapply(DATA[["Close"]][jRange,],
+ width = k,
+ FUN = function(v) (v[2,]/v[1,]) - 1,
+ align = "right",
+ by.column = FALSE,
+ na.pad = FALSE)
+
+}
+# Completes in 22.58 seconds
+
diff --git a/Listings/Chapter 6/6-12.R b/Listings/Chapter 6/6-12.R
new file mode 100755
index 0000000..2aefd77
--- /dev/null
+++ b/Listings/Chapter 6/6-12.R
@@ -0,0 +1,39 @@
+mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers, ... ){
+
+ # For Windows compatability
+ args <- names(mget(ls()))
+ export <- ls(.GlobalEnv)
+ export <- export[!export %in% args]
+
+ # foreach powerhouse
+ SERIES <- foreach( i = 1:workers, .combine = rbind,
+ .packages = loadedNamespaces(), .export = export) %dopar% {
+
+ jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers)
+
+ rollapply(data[jRange,],
+ width = windowSize,
+ FUN = tsfunc,
+ align = "right",
+ by.column = byColumn)
+
+ }
+
+ # Correct formatting of column names and dimensions
+ names(SERIES) <- gsub("\\..+", "", names(SERIES))
+
+ if( windowSize > 1){
+ PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA),
+ order.by = index(data)[1:(windowSize-1)])
+ names(PAD) <- names(SERIES)
+ SERIES <- rbind(PAD, SERIES)
+ }
+
+ if(is.null(names(SERIES))){
+ names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)])
+ }
+
+ # Return results
+ return(SERIES)
+
+}
diff --git a/Listings/Chapter 6/6-13.R b/Listings/Chapter 6/6-13.R
new file mode 100755
index 0000000..43b0db8
--- /dev/null
+++ b/Listings/Chapter 6/6-13.R
@@ -0,0 +1,37 @@
+# Computing the return matrix
+tsfunc <- function(v) (v[2,] / v[1,]) - 1
+RETURN <- mcTimeSeries( DATA[["Close"]], tsfunc, FALSE, 2, workers )
+
+
+# Computing a simple moving average
+SMA <- mcTimeSeries( DATA[["Close"]], mean, TRUE, 20, workers )
+
+
+# Computing an MACD, n1 = 5, n2 = 34
+tsfunc <- function(v) mean(v[(length(v) - 4):length(v)]) - mean(v)
+MACD <- mcTimeSeries( DATA[["Close"]], tsfunc, TRUE, 34, workers )
+
+
+# Computing Bollinger Bands, n = 20, scale = 2
+SDSeries <- mcTimeSeries(DATA[["Close"]], function(v) sd(v), TRUE, 20, workers)
+upperBand <- SMA + 2 * SDSeries
+lowerBand <- SMA - 2 * SDSeries
+
+
+# Computing custom indicator as in Listing 4.3
+tsfunc <- function(v) cor(v, length(v):1)^2 * ((v[length(v)] - v[1])/length(v))
+customIndicator <- mcTimeSeries( DATA[["Close"]], tsfunc, TRUE, 10, workers )
+
+
+# Computing Chaikin Money Flow, n = 20, (Using CMFfunc() function from Listing 4.5)
+cols <- ncol(DATA[["Close"]])
+CMFseries <- mcTimeSeries( cbind(DATA[["Close"]],
+ DATA[["High"]],
+ DATA[["Low"]],
+ DATA[["Volume"]]),
+ function(v) CMFfunc(v[,(1:cols)],
+ v[,(cols+1):(2*cols)],
+ v[,(2*cols + 1):(3*cols)],
+ v[,(3*cols + 1):(4*cols)]),
+ FALSE, 20, workers)
+
diff --git a/Listings/Chapter 6/6-2.R b/Listings/Chapter 6/6-2.R
new file mode 100755
index 0000000..b6dc5b1
--- /dev/null
+++ b/Listings/Chapter 6/6-2.R
@@ -0,0 +1,21 @@
+# Sequentially re-allocating space in a for loop
+RETURN <- NULL
+for(i in 2:nrow(DATA[["Close"]])){
+ RETURN <- rbind(RETURN, t((matrix(DATA[["Close"]][i, ]) /
+ matrix(DATA[["Close"]][i-1, ])) - 1))
+}
+RETURN <- zoo( RETURN, order.by = index(DATA[["Close"]])[-1])
+# 99.68 seconds
+
+
+
+# Pre-allocating space and computing in a for loop
+RETURN <- zoo(matrix(ncol = ncol(DATA[["Close"]]),
+ nrow = nrow(DATA[["Close"]])),
+ order.by = index(DATA[["Close"]]))
+
+for(i in 2:nrow(DATA[["Close"]])){
+ RETURN[i,] <- t((matrix(DATA[["Close"]][i, ]) / matrix(DATA[["Close"]][i-1, ])) - 1)
+}
+# 54.34 seconds
+
diff --git a/Listings/Chapter 6/6-3.R b/Listings/Chapter 6/6-3.R
new file mode 100755
index 0000000..1bf40e1
--- /dev/null
+++ b/Listings/Chapter 6/6-3.R
@@ -0,0 +1,19 @@
+# Using rollapply() element-by-element
+RETURN <- rollapply(DATA[["Close"]],
+ width = 2,
+ FUN = function(v) (v[2]/v[1]) - 1,
+ align = "right",
+ by.column = TRUE,
+ fill = NA)
+# 105.77 seconds
+
+
+
+# Using rollapply() row-by-row
+RETURN <- rollapply(DATA[["Close"]],
+ width = 2,
+ FUN = function(v) (v[2,]/v[1,]) - 1,
+ align = "right",
+ by.column = FALSE,
+ fill = NA)
+# 65.37 seconds
diff --git a/Listings/Chapter 6/6-4.R b/Listings/Chapter 6/6-4.R
new file mode 100755
index 0000000..b0fb7d4
--- /dev/null
+++ b/Listings/Chapter 6/6-4.R
@@ -0,0 +1,3 @@
+# Using the "lag" method introduced in Listing 3.8
+RETURN <- ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1
+# 0.459 seconds
diff --git a/Listings/Chapter 6/6-5.R b/Listings/Chapter 6/6-5.R
new file mode 100755
index 0000000..96d81bb
--- /dev/null
+++ b/Listings/Chapter 6/6-5.R
@@ -0,0 +1,3 @@
+timeLapse <- proc.time()[3]
+for( i in 1:1000000) v <- runif(1)
+proc.time()[3] - timeLapse
diff --git a/Listings/Chapter 6/6-6.R b/Listings/Chapter 6/6-6.R
new file mode 100755
index 0000000..bde6549
--- /dev/null
+++ b/Listings/Chapter 6/6-6.R
@@ -0,0 +1,3 @@
+library(doMC)
+workers <- 4
+registerDoMC( cores = workers )
diff --git a/Listings/Chapter 6/6-7.R b/Listings/Chapter 6/6-7.R
new file mode 100755
index 0000000..364f5b0
--- /dev/null
+++ b/Listings/Chapter 6/6-7.R
@@ -0,0 +1,3 @@
+library(doParallel)
+workers <- 4
+registerDoParallel( cores = workers )
diff --git a/Listings/Chapter 6/6-8.R b/Listings/Chapter 6/6-8.R
new file mode 100755
index 0000000..40eea15
--- /dev/null
+++ b/Listings/Chapter 6/6-8.R
@@ -0,0 +1,28 @@
+library(foreach)
+
+# Returns a list
+foreach( i = 1:4 ) %dopar% {
+ j <- i + 1
+ sqrt(j)
+}
+
+
+# Returns a vector
+foreach( i = 1:4, .combine = c ) %dopar% {
+ j <- i + 1
+ sqrt(j)
+}
+
+
+# Returns a matrix
+foreach( i = 1:4, .combine = rbind ) %dopar% {
+ j <- i + 1
+ matrix(c(i, j, sqrt(j)), nrow = 1)
+}
+
+
+# Returns a data frame
+foreach( i = 1:4, .combine = rbind ) %dopar% {
+ j <- i + 1
+ data.frame( i = i, j = j, sqrt.j = sqrt(j))
+}
diff --git a/Listings/Chapter 6/6-9.R b/Listings/Chapter 6/6-9.R
new file mode 100755
index 0000000..f8b0c18
--- /dev/null
+++ b/Listings/Chapter 6/6-9.R
@@ -0,0 +1,9 @@
+delegate <- function( i = i, n = n, k = k, p = workers ){
+ nOut <- n - k + 1
+ nProc <- ceiling( nOut / p )
+ return( (( i - 1 ) * nProc + 1) : min(i * nProc + k - 1, n) )
+}
+
+# Test i as 1 through 4 to verify it matches our example
+lapply(1:4, function(i) delegate(i, n = 100, k = 5, p = 4))
+
diff --git a/Listings/Chapter 7/7-1.R b/Listings/Chapter 7/7-1.R
new file mode 100755
index 0000000..20eb497
--- /dev/null
+++ b/Listings/Chapter 7/7-1.R
@@ -0,0 +1,259 @@
+equNA <- function(v){
+ o <- which(!is.na(v))[1]
+ return(ifelse(is.na(o), length(v)+1, o))
+}
+
+simulate <- function(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, maxAssets, startingCash,
+ slipFactor, spreadAdjust, flatCommission, perShareCommission,
+ verbose = FALSE, failThresh = 0,
+ initP = NULL, initp = NULL){
+
+
+# Step 1
+if( any( dim(ENTRY) != dim(EXIT) ) |
+ any( dim(EXIT) != dim(FAVOR) ) |
+ any( dim(FAVOR) != dim(CLOSE) ) |
+ any( dim(CLOSE) != dim(OPEN)) )
+ stop( "Mismatching dimensions in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.")
+
+if( any( names(ENTRY) != names(EXIT)) |
+ any( names(EXIT) != names(FAVOR) ) |
+ any( names(FAVOR) != names(CLOSE) ) |
+ any( names(CLOSE) != names(OPEN) ) |
+ is.null(names(ENTRY)) | is.null(names(EXIT)) |
+ is.null(names(FAVOR)) | is.null(names(CLOSE)) |
+ is.null(names(OPEN)) )
+ stop( "Mismatching or missing column names in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.")
+
+
+FAVOR <- zoo(t(apply(FAVOR, 1, function(v) ifelse(is.nan(v) | is.na(v), 0, v) )),
+ order.by = index(CLOSE))
+
+
+# Step 2
+K <- maxAssets
+k <- 0
+C <- rep(startingCash, times = nrow(CLOSE))
+S <- names(CLOSE)
+
+P <- p <- zoo( matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)),
+ order.by = index(CLOSE) )
+
+if( !is.null( initP ) & !is.null( initp ) ){
+ P[1:maxLookback,] <-
+ matrix(initP, ncol=length(initP), nrow=maxLookback, byrow = TRUE)
+ p[1:maxLookback,] <-
+ matrix(initp, ncol=length(initp), nrow=maxLookback, byrow = TRUE)
+}
+
+names(P) <- names(p) <- S
+
+equity <- rep(NA, nrow(CLOSE))
+
+
+
+rmNA <- pmax(unlist(lapply(FAVOR, equNA)),
+ unlist(lapply(ENTRY, equNA)),
+ unlist(lapply(EXIT, equNA)))
+
+for( j in 1:ncol(ENTRY) ){
+ toRm <- rmNA[j]
+ if( toRm > (maxLookback + 1) &
+ toRm < nrow(ENTRY) ){
+ FAVOR[1:(toRm-1),j] <- NA
+ ENTRY[1:(toRm-1),j] <- NA
+ EXIT[1:(toRm-1),j] <- NA
+ }
+}
+
+
+# Step 3
+for( i in maxLookback:(nrow(CLOSE)-1) ){
+
+ # Step 4
+ C[i+1] <- C[i]
+ P[i+1,] <- as.numeric(P[i,])
+ p[i+1,] <- as.numeric(p[i,])
+
+ longS <- S[which(P[i,] > 0)]
+ shortS <- S[which(P[i,] < 0)]
+ k <- length(longS) + length(shortS)
+
+ # Step 5
+ longTrigger <- setdiff(S[which(ENTRY[i,] == 1)], longS)
+ shortTrigger <- setdiff(S[which(ENTRY[i,] == -1)], shortS)
+ trigger <- c(longTrigger, shortTrigger)
+
+ if( length(trigger) > K ) {
+
+ keepTrigger <- trigger[order(c(as.numeric(FAVOR[i,longTrigger]),
+ -as.numeric(FAVOR[i,shortTrigger])),
+ decreasing = TRUE)][1:K]
+
+ longTrigger <- longTrigger[longTrigger %in% keepTrigger]
+ shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger]
+
+ trigger <- c(longTrigger, shortTrigger)
+
+ }
+
+ triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger)))
+
+
+ # Step 6
+ longExitTrigger <- longS[longS %in%
+ S[which(EXIT[i,] == 1 | EXIT[i,] == 999)]]
+
+ shortExitTrigger <- shortS[shortS %in%
+ S[which(EXIT[i,] == -1 | EXIT[i,] == 999)]]
+
+ exitTrigger <- c(longExitTrigger, shortExitTrigger)
+
+
+ # Step 7
+ needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0)
+
+ if( needToExit > 0 ){
+
+ toExitLongS <- setdiff(longS, exitTrigger)
+ toExitShortS <- setdiff(shortS, exitTrigger)
+
+ toExit <- character(0)
+
+ for( counter in 1:needToExit ){
+ if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){
+ if( min(FAVOR[i,toExitLongS]) < min(-FAVOR[i,toExitShortS]) ){
+ pullMin <- which.min(FAVOR[i,toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else {
+ pullMin <- which.min(-FAVOR[i,toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){
+ pullMin <- which.min(FAVOR[i,toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){
+ pullMin <- which.min(-FAVOR[i,toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ }
+
+ longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit])
+ shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit])
+
+ }
+
+ # Step 8
+ exitTrigger <- c(longExitTrigger, shortExitTrigger)
+ exitTriggerType <- c(rep(1, length(longExitTrigger)),
+ rep(-1, length(shortExitTrigger)))
+
+
+ # Step 9
+ if( length(exitTrigger) > 0 ){
+ for( j in 1:length(exitTrigger) ){
+
+ exitPrice <- as.numeric(OPEN[i+1,exitTrigger[j]])
+
+ effectivePrice <- exitPrice * (1 - exitTriggerType[j] * slipFactor) -
+ exitTriggerType[j] * (perShareCommission + spreadAdjust)
+
+ if( exitTriggerType[j] == 1 ){
+
+ C[i+1] <- C[i+1] +
+ ( as.numeric( P[i,exitTrigger[j]] ) * effectivePrice )
+ - flatCommission
+
+ } else {
+
+ C[i+1] <- C[i+1] -
+ ( as.numeric( P[i,exitTrigger[j]] ) *
+ ( 2 * as.numeric(p[i, exitTrigger[j]]) - effectivePrice ) )
+ - flatCommission
+ }
+
+ P[i+1, exitTrigger[j]] <- 0
+ p[i+1, exitTrigger[j]] <- 0
+
+ k <- k - 1
+
+ }
+ }
+
+
+ # Step 10
+ if( length(trigger) > 0 ){
+ for( j in 1:length(trigger) ){
+
+ entryPrice <- as.numeric(OPEN[i+1,trigger[j]])
+
+ effectivePrice <- entryPrice * (1 + triggerType[j] * slipFactor) +
+ triggerType[j] * (perShareCommission + spreadAdjust)
+
+ P[i+1,trigger[j]] <- triggerType[j] *
+ floor( ( (C[i+1] - flatCommission) / (K - k) ) / effectivePrice )
+
+ p[i+1,trigger[j]] <- effectivePrice
+
+ C[i+1] <- C[i+1] -
+ ( triggerType[j] * as.numeric(P[i+1,trigger[j]]) * effectivePrice )
+ - flatCommission
+
+ k <- k + 1
+
+ }
+ }
+
+
+ # Step 11
+ equity[i] <- C[i+1]
+ for( s in S[which(P[i+1,] > 0)] ){
+ equity[i] <- equity[i] +
+ as.numeric(P[i+1,s]) *
+ as.numeric(OPEN[i+1,s])
+ }
+
+ for( s in S[which(P[i+1,] < 0)] ){
+ equity[i] <- equity[i] -
+ as.numeric(P[i+1,s]) *
+ ( 2 * as.numeric(p[i+1,s]) - as.numeric(OPEN[i+1,s]) )
+ }
+
+ if( equity[i] < failThresh ){
+ warning("\n*** Failure Threshold Breached ***\n")
+ break
+ }
+
+ # Step 12
+ if( verbose ){
+ if( i %% 21 == 0 ){
+ cat(paste0("################################## ",
+ round(100 * (i - maxLookback) /
+ (nrow(CLOSE) - 1 - maxLookback), 1), "%",
+ " ##################################\n"))
+ cat(paste("Date:\t",as.character(index(CLOSE)[i])), "\n")
+ cat(paste0("Equity:\t", " $", signif(equity[i], 5), "\n"))
+ cat(paste0("CAGR:\t ",
+ round(100 * ((equity[i] / (equity[maxLookback]))^
+ (252/(i - maxLookback + 1)) - 1), 2),
+ "%"))
+ cat("\n")
+ cat("Assets:\t", S[P[i+1,] != 0])
+ cat("\n\n")
+ }
+ }
+
+
+
+}
+
+# Step 13
+return(list(equity = equity, C = C, P = P, p = p))
+
+}
diff --git a/Listings/Chapter 7/7-2.R b/Listings/Chapter 7/7-2.R
new file mode 100755
index 0000000..4554d1a
--- /dev/null
+++ b/Listings/Chapter 7/7-2.R
@@ -0,0 +1,44 @@
+SUBDATA <- lapply(DATA, function(v) v[-(1:3500),])
+SUBRETURN <- RETURN[-(1:3500),]
+
+n1 <- 5
+n2 <- 34
+nSharpe <- 20
+shThresh <- 0.80
+
+INDIC <- mcTimeSeries(SUBDATA[["Close"]],
+ function(v) mean(v[(n2 - n1 + 1):n2]) - mean(v),
+ TRUE, n2, workers)
+
+
+entryfunc <- function(v){
+ cols <- ncol(v) / 2
+ as.numeric(v[1,1:cols] <= 0 &
+ v[2,1:cols] > 0 &
+ v[2,(cols+1):(2*cols)] >
+ quantile(v[2,(cols+1):(2*cols)], shThresh, na.rm = TRUE)
+ )
+}
+
+FAVOR <- mcTimeSeries(SUBRETURN,
+ function(v) mean(v, na.rm = TRUE)/sd(v, na.rm = TRUE),
+ TRUE, nSharpe, workers)
+
+ENTRY <- mcTimeSeries(cbind(INDIC, FAVOR),
+ entryfunc,
+ FALSE, 2, workers)
+
+EXIT <- zoo(matrix(0, ncol=ncol(SUBDATA[["Close"]]), nrow=nrow(SUBDATA[["Close"]])),
+ order.by = index(SUBDATA[["Close"]]))
+names(EXIT) <- names(SUBDATA[["Close"]])
+
+K <- 10
+
+maxLookback <- max(n1, n2, nSharpe) + 1
+
+RESULTS <- simulate(SUBDATA[["Open"]], SUBDATA[["Close"]],
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, 100000,
+ 0.0005, 0.01, 3.5, 0,
+ TRUE, 0)
+
diff --git a/Listings/Chapter 7/7-3.R b/Listings/Chapter 7/7-3.R
new file mode 100755
index 0000000..ea7d8e4
--- /dev/null
+++ b/Listings/Chapter 7/7-3.R
@@ -0,0 +1,79 @@
+SUBDATA <- lapply(DATA, function(v) v[-(1:3500),])
+SUBRETURN <- RETURN[-(1:3500),]
+
+n1 <- 20
+n2 <- 100
+maxLookback <- max(n2, n1) + 1
+
+SD <- mcTimeSeries(SUBDATA[["Close"]],
+ function(v) sd(v, na.rm = TRUE),
+ TRUE, n1, workers)
+
+MOVAVG <- mcTimeSeries(SUBDATA[["Close"]],
+ function(v) mean(v, na.rm = TRUE),
+ TRUE, n1, workers)
+
+LONGMOVAVG <- mcTimeSeries(SUBDATA[["Close"]],
+ function(v) mean(v, na.rm = TRUE),
+ TRUE, n2, workers)
+
+bt <- (SUBDATA[["Close"]] - MOVAVG) / SD
+Bt <- (MOVAVG - LONGMOVAVG) / SD
+
+
+triggerfunc <- function(v, columns){
+
+ goLong <- as.numeric(
+ ((v[2,1:columns] >= 1 & v[2,1:columns] < 3) | v[2,1:columns] <= -3) &
+ (v[1,(columns+1):(2*columns)] >= -2 & v[2,(columns+1):(2*columns)] < -2)
+ )
+
+ goShort <- as.numeric(
+ ((v[2,1:columns] > -3 & v[2,1:columns] <= -1) | v[2,1:columns] >= 3) &
+ (v[1,(columns+1):(2*columns)] <= 2 & v[2,(columns+1):(2*columns)] > 2)
+ )
+
+ return( goLong - goShort )
+
+}
+
+
+exitfunc <- function(v, columns){
+
+ exitLong <- as.numeric(v[2,(columns+1):(2*columns)] >= 2 &
+ v[1,(columns+1):(2*columns)] < 2)
+
+ exitShort <- -as.numeric(v[1,(columns+1):(2*columns)] >= -2 &
+ v[2,(columns+1):(2*columns)] < -2)
+
+ exitAll <- 999 * as.numeric( (v[1,1:columns] >= 0 & v[2,1:columns] < 0) |
+ (v[1,1:columns] <= 0 & v[2,1:columns] > 0) )
+
+ out <- exitLong + exitShort + exitAll
+
+ out[out > 1] <- 999
+ out[!out %in% c(-1,0,1,999)] <- 0
+
+ return( out )
+
+}
+
+
+columns <- ncol(SUBDATA[["Close"]])
+
+ENTRY <- mcTimeSeries(cbind(Bt, bt), function(v) triggerfunc(v, columns),
+ FALSE, 2, workers)
+
+FAVOR <- mcTimeSeries(SUBRETURN, mean, TRUE, n1, workers)
+
+EXIT <- mcTimeSeries(cbind(Bt, bt), function(v) exitfunc(v, columns),
+ FALSE, 2, workers)
+
+K <- 20
+
+RESULTS <- simulate(SUBDATA[["Open"]], SUBDATA[["Close"]],
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, 100000,
+ 0.0005, 0.01, 3.5, 0,
+ TRUE, 0)
+
diff --git a/Listings/Chapter 7/7-4.R b/Listings/Chapter 7/7-4.R
new file mode 100755
index 0000000..744ae55
--- /dev/null
+++ b/Listings/Chapter 7/7-4.R
@@ -0,0 +1,67 @@
+SUBDATA <- lapply(DATA, function(v) v[-(1:3500),])
+SUBRETURN <- RETURN[-(1:3500),]
+
+truerangefunc <- function(v, cols){
+ pmax(v[2, (cols+1):(2*cols)] - v[2,1:cols],
+ abs(v[2, 1:cols]-v[1, (2*cols + 1):(3*cols)]),
+ abs(v[1, (cols+1):(2*cols)]-v[2, (2*cols + 1):(3*cols)]))
+}
+
+cols <- ncol(SUBDATA[["Close"]])
+TR <- mcTimeSeries(cbind(SUBDATA[["Low"]], SUBDATA[["High"]], SUBDATA[["Close"]]),
+ function(v) truerangefunc(v, cols), FALSE, 2, workers)
+
+# Calculate ATR with SMA method
+ATR <- mcTimeSeries(TR, mean, TRUE, 20, workers)
+
+ROLLMIN <- mcTimeSeries(SUBDATA[["Close"]], min, TRUE, 100, workers)
+ROLLMAX <- mcTimeSeries(SUBDATA[["Close"]], max, TRUE, 100, workers)
+
+m_plus <- (ROLLMAX - SUBDATA[["Close"]]) / ATR
+m_minus <- (SUBDATA[["Close"]] - ROLLMIN) / ATR
+
+
+RS <- mcTimeSeries(SUBRETURN,
+ function(v) mean(v[v>0], na.rm = T) / mean(v[v<0], na.rm = T),
+ TRUE, 20, workers)
+
+RSI <- mcTimeSeries( RS, function(v) 100 - (100 / (1 + v)), FALSE, 1, workers)
+
+
+
+entryfunc <- function(v, cols){
+
+ goshort <- v[2,1:cols] <= 2 &
+ (v[1,(2*cols+1):(3*cols)] > 70 &
+ v[2,(2*cols+1):(3*cols)] <= 70 )
+
+ golong <- v[2,(cols+1):(2*cols)] <= 2 &
+ (v[1,(2*cols+1):(3*cols)] < 30 &
+ v[2,(2*cols+1):(3*cols)] >= 30 )
+
+ return( as.numeric(golong) - as.numeric(goshort) )
+
+}
+
+ENTRY <- mcTimeSeries(cbind(m_plus, m_minus, RSI),
+ function(v) entryfunc(v, cols), FALSE, 2, workers)
+
+
+FAVOR <- mcTimeSeries(SUBRETURN, mean, TRUE, 20, workers)
+
+exitfunc <- function(v){
+ cols <- ncol(SUBDATA[["Close"]])
+ exitlong <- as.numeric(v > 70 | v < 15)
+ exitshort <- as.numeric(v < 30 | v > 85)
+ return( exitlong - exitshort )
+}
+
+EXIT <- mcTimeSeries(RSI, exitfunc, FALSE, 1, workers)
+
+K <- 20
+
+RESULTS <- simulate(SUBDATA[["Open"]], SUBDATA[["Close"]],
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, 100000,
+ 0.0005, 0.01, 3.5, 0,
+ TRUE, 0)
diff --git a/Listings/Chapter 7/7-5.R b/Listings/Chapter 7/7-5.R
new file mode 100755
index 0000000..6997958
--- /dev/null
+++ b/Listings/Chapter 7/7-5.R
@@ -0,0 +1,27 @@
+changeInEquity <- c(NA, RESULTS[["equity"]][-1] -
+ RESULTS[["equity"]][-length(RESULTS[["equity"]])])
+
+# Return Series as defined in Chapter 1
+R <- zoo(changeInEquity / (RESULTS[["equity"]]), order.by = index(SUBDATA[["Close"]]))
+
+plot(100 * R, type = "l", main = "Figure 7.1: Return Series for Long-Only MACD",
+ ylab = "Percent Return", xlab = "")
+grid()
+abline( h = 0, col = 8 )
+
+# Equity Cruve
+plot(y = RESULTS[["equity"]], x = index(SUBDATA[["Close"]]),
+ type = "l", main = "Figure 7.2: Equity Curve for Long-Only MACD",
+ ylab = "Account Equity ($)", xlab = "")
+abline(h = RESULTS[["C"]][1])
+grid()
+
+
+
+# Sharpe Ratio
+sharpeRatio <- mean(R, na.rm = T) / sd(R, na.rm = T)
+
+
+# Daily percent portfolio turnover
+changeP <- RESULTS[["P"]] - lag(RESULTS[["P"]], k = -1)
+percentTurnover <- 100 * (sum(changeP > 0) / nrow(DATA[["Close"]])) / K
diff --git a/Listings/Chapter 8/8-1.R b/Listings/Chapter 8/8-1.R
new file mode 100755
index 0000000..fadabe0
--- /dev/null
+++ b/Listings/Chapter 8/8-1.R
@@ -0,0 +1,142 @@
+y <- 2014
+
+minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01)
+maxVal <- c(n1 = 150, nFact = 5, nSharpe = 200, shThresh = .99)
+
+PARAM <- c(n1 = -2, nFact = -2, nSharpe = -2, shThresh = 0)
+
+# Declare entry function for use inside evaluator
+entryfunc <- function(v, shThresh){
+ cols <- ncol(v)/2
+ as.numeric(v[1,1:cols] <= 0 &
+ v[2,1:cols] > 0 &
+ v[2,(cols+1):(2*cols)] >
+ quantile(v[2,(cols+1):(2*cols)],
+ shThresh, na.rm = TRUE)
+ )
+}
+
+
+
+evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014,
+ transform = FALSE, verbose = FALSE,
+ negative = FALSE, transformOnly = FALSE,
+ returnData = FALSE, accountParams = NULL){
+
+ # Step 1
+ # Convert and declare parameters if they exist on unbounded (-inf,inf) domain
+ if( transform | transformOnly ){
+ PARAM <- minVal +
+ (maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) ))
+ if( transformOnly ){
+ return(PARAM)
+ }
+ }
+
+ # Step 2
+ # Declare n1 as itself, n2 as a multiple of n1 defined by nFact,
+ # and declare the length and threshold in sharpe ratio for FAVOR.
+ # This section should handle rounding and logical bounding
+ # in moving
+ n1 <- max(round(PARAM[["n1"]]), 2)
+ n2 <- max(round(PARAM[["nFact"]] * PARAM[["n1"]]), 3, n1+1)
+ nSharpe <- max(round(PARAM[["nSharpe"]]), 2)
+ shThresh <- max(0, min(PARAM[["shThresh"]], .99))
+ maxLookback <- max(n1, n2, nSharpe) + 1
+
+
+ # Step 3
+ # Subset data according to range of years y
+ period <-
+ index(DATA[["Close"]]) >= strptime(paste0("01-01-", y[1]), "%d-%m-%Y") &
+ index(DATA[["Close"]]) < strptime(paste0("01-01-", y[length(y)]+1), "%d-%m-%Y")
+
+ period <- period |
+ ((1:nrow(DATA[["Close"]]) > (which(period)[1] - maxLookback)) &
+ (1:nrow(DATA[["Close"]]) <= (which(period)[sum(period)]) + 1))
+
+
+ # Step 4
+ CLOSE <- DATA[["Close"]][period,]
+ OPEN <- DATA[["Open"]][period,]
+ SUBRETURN <- RETURN[period,]
+
+
+ # Step 5
+ # Compute inputs for long-only MACD as in Listing 7.2
+ # Code is optimized for speed using functions from caTools and zoo
+ require(caTools)
+
+ INDIC <- zoo(runmean(CLOSE, n1, endrule = "NA", align = "right") -
+ runmean(CLOSE, n2, endrule = "NA", align = "right"),
+ order.by = index(CLOSE))
+ names(INDIC) <- names(CLOSE)
+
+
+ RMEAN <- zoo(runmean(SUBRETURN, n1, endrule = "NA", align = "right"),
+ order.by = index(SUBRETURN))
+
+ FAVOR <- RMEAN / runmean( (SUBRETURN - RMEAN)^2, nSharpe,
+ endrule = "NA", align = "right" )
+ names(FAVOR) <- names(CLOSE)
+
+
+ ENTRY <- rollapply(cbind(INDIC, FAVOR),
+ FUN = function(v) entryfunc(v, shThresh),
+ width = 2,
+ fill = NA,
+ align = "right",
+ by.column = FALSE)
+ names(ENTRY) <- names(CLOSE)
+
+ EXIT <- zoo(matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)),
+ order.by = index(CLOSE))
+ names(EXIT) <- names(CLOSE)
+
+
+ # Step 6
+ # Max shares to hold
+ K <- 10
+
+ # Simulate and store results
+ if( is.null(accountParams) ){
+ RESULTS <- simulate(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, 100000,
+ 0.001, 0.01, 3.5, 0,
+ verbose, 0)
+ } else {
+ RESULTS <- simulate(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, accountParams[["C"]],
+ 0.001, 0.01, 3.5, 0,
+ verbose, 0,
+ initP = accountParams[["P"]], initp = accountParams[["p"]])
+ }
+
+ # Step 7
+ if(!returnData){
+
+ # Compute and return sharpe ratio
+ v <- RESULTS[["equity"]]
+ returns <- ( v[-1] / v[-length(v)] ) - 1
+ out <- mean(returns, na.rm = T) / sd(returns, na.rm = T)
+ if(!is.nan(out)){
+ if( negative ){
+ return( -out )
+ } else {
+ return( out )
+ }
+ } else {
+ return(0)
+ }
+
+ } else {
+ return(RESULTS)
+ }
+
+}
+
+# To test value of objective function
+objective <- evaluate(PARAM, minVal, maxVal, y)
+
diff --git a/Listings/Chapter 8/8-2.R b/Listings/Chapter 8/8-2.R
new file mode 100755
index 0000000..a313a90
--- /dev/null
+++ b/Listings/Chapter 8/8-2.R
@@ -0,0 +1,36 @@
+# Declare bounds and step size for optimization
+lowerBound <- c(n1 = 5, nFact = 3, nSharpe = 22, shThresh = 0.05)
+upperBound <- c(n1 = 80, nFact = 3, nSharpe = 22, shThresh = 0.95)
+stepSize <- c(n1 = 5, nFact = 1, nSharpe = 1, shThresh = 0.05)
+
+pnames <- names(stepSize)
+np <- length(pnames)
+
+# Declare list of all test points
+POINTS <- list()
+for( p in pnames ){
+ POINTS[[p]] <- seq(lowerBound[[p]], upperBound[[p]], stepSize[[p]])
+}
+
+OPTIM <- data.frame(matrix(NA, nrow = prod(unlist(lapply(POINTS, length))),
+ ncol = np + 1))
+names(OPTIM)[1:np] <- names(POINTS)
+names(OPTIM)[np+1] <- "obj"
+
+# Store all possible combinations of parameters
+for( i in 1:np ){
+ each <- prod(unlist(lapply(POINTS, length))[-(1:i)])
+ times <- prod(unlist(lapply(POINTS, length))[-(i:length(pnames))])
+ OPTIM[,i] <- rep(POINTS[[pnames[i]]], each = each, times = times)
+}
+
+# Test each row of OPTIM
+timeLapse <- proc.time()[3]
+for( i in 1:nrow(OPTIM) ){
+ OPTIM[i,np+1] <- evaluate(OPTIM[i,1:np], transform = FALSE, y = 2014)
+ cat(paste0("## ", floor( 100 * i / nrow(OPTIM)), "% complete\n"))
+ cat(paste0("## ",
+ round( ((proc.time()[3] - timeLapse) *
+ ((nrow(OPTIM) - i)/ i))/60, 2),
+ " minutes remaining\n\n"))
+}
diff --git a/Listings/Chapter 8/8-3.R b/Listings/Chapter 8/8-3.R
new file mode 100755
index 0000000..a6c207d
--- /dev/null
+++ b/Listings/Chapter 8/8-3.R
@@ -0,0 +1,13 @@
+library(lattice)
+wireframe(obj ~ n1*shThresh, data = OPTIM,
+ xlab = "n1", ylab = "shThresh",
+ main = "Long-Only MACD Exhaustive Optimization",
+ drape = TRUE,
+ colorkey = TRUE,
+ screen = list(z = 15, x = -60)
+)
+
+levelplot(obj ~ n1*shThresh, data = OPTIM,
+ xlab = "n1", ylab = "shThresh",
+ main = "Long-Only MACD Exhaustive Optimization"
+)
diff --git a/Listings/Chapter 8/8-4.R b/Listings/Chapter 8/8-4.R
new file mode 100755
index 0000000..eae5878
--- /dev/null
+++ b/Listings/Chapter 8/8-4.R
@@ -0,0 +1,123 @@
+# Maximum iterations
+# Max possible calls to evaluator is K * (4 * n + 1)
+K <- 100
+
+# Restart with random init when delta is below threshold
+deltaThresh <- 0.05
+
+# Set initial delta
+delta <- deltaNaught <- 1
+
+# Scale factor
+sigma <- 2
+
+
+# Vector theta_0
+PARAM <- PARAMNaught <- c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0)
+
+# bounds
+minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01)
+maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99)
+
+np <- length(PARAM)
+
+OPTIM <- data.frame(matrix(NA, nrow = K * (4 * np + 1), ncol = np + 1))
+names(OPTIM) <- c(names(PARAM), "obj"); o <- 1
+
+fmin <- fminNaught <- evaluate(PARAM, minVal, maxVal, negative = TRUE, y = y)
+OPTIM[o,] <- c(PARAM, fmin); o <- o + 1
+
+
+# Print function for reporting progress in loop
+printUpdate <- function(step){
+ if(step == "search"){
+ cat(paste0("Search step: ", k,"|",l,"|",m, "\n"))
+ } else if (step == "poll"){
+ cat(paste0("Poll step: ", k,"|",l,"|",m, "\n"))
+ }
+ names(OPTIM)
+ cat("\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n")
+ cat("Best:\t",
+ paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n")
+ cat("Theta:\t",
+ paste0(round(unlist(c(PARAM, fmin)),3), "\t"), "\n")
+ cat("Trial:\t",
+ paste0(round(as.numeric(OPTIM[o-1,]), 3), "\t"), "\n")
+ cat(paste0("Delta: ", round(delta,3) , "\t"), "\n\n")
+}
+
+for( k in 1:K ){
+
+ # SEARCH subroutine
+ for( l in 1:np ){
+ net <- (2 * rbinom(np, 1, .5) - 1) * runif(np, delta, sigma * delta)
+ for( m in c(-1,1) ){
+
+ testpoint <- PARAM + m * net
+ ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(testpoint, ftest); o <- o + 1
+ printUpdate("search")
+
+ }
+ }
+
+ if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){
+
+ minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)])
+ PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,]
+ fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos]
+ delta <- sigma * delta
+
+ } else {
+
+ # POLL Subroutine
+ for( l in 1:np ){
+ net <- delta * as.numeric(1:np == l)
+ for( m in c(-1,1) ){
+
+ testpoint <- PARAM + m * net
+ ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(testpoint, ftest); o <- o + 1
+ printUpdate("poll")
+
+ }
+ }
+
+ if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){
+
+ minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)])
+ PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,]
+ fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos]
+ delta <- sigma * delta
+
+ } else {
+
+ delta <- delta / sigma
+
+ }
+
+
+ }
+
+ cat(paste0("\nCompleted Full Iteration: ", k, "\n\n"))
+
+ # Restart with random initiate
+ if( delta < deltaThresh ) {
+
+ delta <- deltaNaught
+ fmin <- fminNaught
+ PARAM <- PARAMNaught + runif(n = np, min = -delta * sigma,
+ max = delta * sigma)
+
+ ftest <- evaluate(PARAM, minVal, maxVal,
+ negative = TRUE, y = y)
+ OPTIM[o,] <- c(PARAM, ftest); o <- o + 1
+
+ cat("\nDelta Threshold Breached, Restarting with Random Initiate\n\n")
+
+ }
+
+}
+
+# Return the best optimization in untransformed parameters
+evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE)
diff --git a/Listings/Chapter 8/8-5.R b/Listings/Chapter 8/8-5.R
new file mode 100755
index 0000000..7549d8b
--- /dev/null
+++ b/Listings/Chapter 8/8-5.R
@@ -0,0 +1,154 @@
+K <- maxIter <- 200
+
+# Vector theta_0
+initDelta <- 6
+deltaThresh <- 0.05
+PARAM <- PARAMNaught <-
+ c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) - initDelta/2
+
+# bounds
+minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01)
+maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99)
+
+# Optimization parameters
+alpha <- 1
+gamma <- 2
+rho <- .5
+sigma <- .5
+
+
+randomInit <- FALSE
+
+np <- length(initVals)
+
+
+OPTIM <- data.frame(matrix(NA, ncol = np + 1, nrow = maxIter * (2 * np + 2)))
+o <- 1
+
+SIMPLEX <- data.frame(matrix(NA, ncol = np + 1, nrow = np + 1))
+names(SIMPLEX) <- names(OPTIM) <- c(names(initVals), "obj")
+
+
+# Print function for reporting progress in loop
+printUpdate <- function(){
+ cat("Iteration: ", k, "of", K, "\n")
+ cat("\t\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n")
+ cat("Global Best:\t",
+ paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n")
+ cat("Simplex Best:\t",
+ paste0(round(unlist(SIMPLEX[which.min(SIMPLEX$obj),]),3), "\t"), "\n")
+ cat("Simplex Size:\t",
+ paste0(max(round(simplexSize,3)), "\t"), "\n\n\n")
+}
+
+
+# Initialize SIMPLEX
+for( i in 1:(np+1) ) {
+
+ SIMPLEX[i,1:np] <- PARAMNaught + initDelta * as.numeric(1:np == (i-1))
+ SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], minVal, maxVal, negative = TRUE,
+ y = y)
+ OPTIM[o,] <- SIMPLEX[i,]
+ o <- o + 1
+
+}
+
+
+
+# Optimization loop
+for( k in 1:K ){
+
+ SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),]
+ centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
+
+ cat("Computing Reflection...\n")
+ reflection <- centroid + alpha * (centroid - SIMPLEX[np+1,-(np+1)])
+
+ reflectResult <- evaluate(reflection, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(reflection, obj = reflectResult)
+ o <- o + 1
+
+ if( reflectResult > SIMPLEX[1,np+1] &
+ reflectResult < SIMPLEX[np, np+1] ){
+
+ SIMPLEX[np+1,] <- c(reflection, obj = reflectResult)
+
+ } else if( reflectResult < SIMPLEX[1,np+1] ) {
+
+ cat("Computing Expansion...\n")
+ expansion <- centroid + gamma * (reflection - centroid)
+ expansionResult <- evaluate(expansion,
+ minVal, maxVal, negative = TRUE, y = y)
+
+ OPTIM[o,] <- c(expansion, obj = expansionResult)
+ o <- o + 1
+
+ if( expansionResult < reflectResult ){
+ SIMPLEX[np+1,] <- c(expansion, obj = expansionResult)
+ } else {
+ SIMPLEX[np+1,] <- c(reflection, obj = reflectResult)
+ }
+
+ } else if( reflectResult > SIMPLEX[np, np+1] ) {
+
+ cat("Computing Contraction...\n")
+ contract <- centroid + rho * (SIMPLEX[np+1,-(np+1)] - centroid)
+ contractResult <- evaluate(contract, minVal, maxVal, negative = TRUE, y = y)
+
+ OPTIM[o,] <- c(contract, obj = contractResult)
+ o <- o + 1
+
+ if( contractResult < SIMPLEX[np+1, np+1] ){
+
+ SIMPLEX[np+1,] <- c(contract, obj = contractResult)
+
+ } else {
+ cat("Computing Shrink...\n")
+ for( i in 2:(np+1) ){
+ SIMPLEX[i,1:np] <- SIMPLEX[1,-(np+1)] +
+ sigma * (SIMPLEX[i,1:np] - SIMPLEX[1,-(np+1)])
+ SIMPLEX[i,np+1] <- c(obj = evaluate(SIMPLEX[i,1:np],
+ minVal, maxVal,
+ negative = TRUE, y = y))
+ }
+
+ OPTIM[o:(o+np-1),] <- SIMPLEX[2:(np+1),]
+ o <- o + np
+
+ }
+
+ }
+
+ centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
+ simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1,
+ function(v) abs(v - centroid))))
+
+ if( max(simplexSize) < deltaThresh ){
+
+ cat("Size Threshold Breached: Restarting with Random Initiate\n\n")
+
+ for( i in 1:(np+1) ) {
+
+ SIMPLEX[i,1:np] <- (PARAMNaught * 0) +
+ runif(n = np, min = -initDelta, max = initDelta)
+
+ SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np],
+ minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- SIMPLEX[i,]
+ o <- o + 1
+
+ SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),]
+ centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
+ simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, function(v) abs(v - centroid))))
+
+ }
+
+ }
+
+ printUpdate()
+
+}
+
+
+# Return the best optimization in untransformed parameters
+evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE)
diff --git a/Listings/Chapter 8/8-6.R b/Listings/Chapter 8/8-6.R
new file mode 100755
index 0000000..650b379
--- /dev/null
+++ b/Listings/Chapter 8/8-6.R
@@ -0,0 +1,54 @@
+minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01)
+maxVal <- c(n1 = 150, nFact = 5, nSharpe = 200, shThresh = .99)
+
+RESULTS <- list()
+accountParams <- list ()
+
+testRange <- 2004:2015
+
+# As defined in heuristic with delta_O = delta_P = 1 year
+for( y in testRange ){
+
+ PARAM <- optimize(y = y, minVal = minVal, maxVal = maxVal)
+
+ if( y == testRange[1] ){
+
+ RESULTS[[as.character(y+1)]] <-
+ evaluate(PARAM, y = y + 1, minVal = minVal, maxVal = maxVal,
+ transform = TRUE, returnData = TRUE, verbose = TRUE )
+
+ } else {
+
+ # Pass account parameters to next simulation after first year
+ strYear <- as.character(y)
+ aLength <- length(RESULTS[[strYear]][["C"]])
+ accountParams[["C"]] <-(RESULTS[[strYear]][["C"]])[aLength]
+ accountParams[["P"]] <- (RESULTS[[strYear]][["P"]])[aLength]
+ accountParams[["p"]] <- (RESULTS[[strYear]][["p"]])[aLength]
+
+ RESULTS[[as.character(y+1)]] <-
+ evaluate(PARAM, y = y + 1, minVal = minVal, maxVal = maxVal,
+ transform = TRUE, returnData = TRUE, verbose = TRUE,
+ accountParams = accountParams)
+
+ }
+
+}
+
+
+# extract equity curve
+for( y in (testRange + 1) ){
+
+ strYear <- as.character(y)
+ inYear <- substr(index(RESULTS[[strYear]][["P"]]), 1, 4) == strYear
+
+ equity <- (RESULTS[[strYear]][["equity"]])[inYear]
+ date <- (index(RESULTS[[strYear]][["P"]]))[inYear]
+
+ if( y == (testRange[1] + 1) ){
+ equitySeries <- zoo(equity, order.by = date)
+ } else {
+ equitySeries <- rbind(equitySeries, zoo(equity, order.by = date))
+ }
+
+}
diff --git a/Listings/Chapter 8/sampleOptimizeWrapper.R b/Listings/Chapter 8/sampleOptimizeWrapper.R
new file mode 100755
index 0000000..605f864
--- /dev/null
+++ b/Listings/Chapter 8/sampleOptimizeWrapper.R
@@ -0,0 +1,127 @@
+
+optimize <- function(y, minVal, maxVal){
+
+
+# Maximum iterations
+# Max possible calls to evaluator is K * (4 * n + 1)
+K <- 20
+
+# Restart with random init when delta is below threshold
+deltaThresh <- 0.05
+
+# Set initial delta
+delta <- deltaNaught <- 1
+
+# Scale factor
+sigma <- 2
+
+
+# Vector theta_0
+PARAM <- PARAMNaught <- c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0)
+
+np <- length(PARAM)
+
+OPTIM <- data.frame(matrix(NA, nrow = K * (4 * np + 1), ncol = np + 1))
+names(OPTIM) <- c(names(PARAM), "obj"); o <- 1
+
+fmin <- fminNaught <- evaluate(PARAM, minVal, maxVal, negative = TRUE, y = y)
+OPTIM[o,] <- c(PARAM, fmin); o <- o + 1
+
+
+# Print function for reporting progress in loop
+printUpdate <- function(step){
+ if(step == "search"){
+ cat(paste0("Search step: ", k,"|",l,"|",m, "\n"))
+ } else if (step == "poll"){
+ cat(paste0("Poll step: ", k,"|",l,"|",m, "\n"))
+ }
+ names(OPTIM)
+ cat("\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n")
+ cat("Best:\t", paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n")
+ cat("Theta:\t", paste0(round(unlist(c(PARAM, fmin)),3), "\t"), "\n")
+ cat("Trial:\t", paste0(round(as.numeric(OPTIM[o-1,]), 3), "\t"), "\n")
+ cat(paste0("Delta: ", round(delta,3) , "\t"), "\n\n")
+}
+
+for( k in 1:K ){
+
+ # SEARCH subroutine
+ for( l in 1:np ){
+ net <- (2 * rbinom(np, 1, .5) - 1) * runif(np, delta, sigma * delta)
+ for( m in c(-1,1) ){
+
+ testpoint <- PARAM + m * net
+ ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(testpoint, ftest); o <- o + 1
+ printUpdate("search")
+
+ }
+ }
+
+ if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){
+
+ minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)])
+ PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,]
+ fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos]
+ delta <- sigma * delta
+
+ } else {
+
+ # POLL Subroutine
+ for( l in 1:np ){
+ net <- delta * as.numeric(1:np == l)
+ for( m in c(-1,1) ){
+
+ testpoint <- PARAM + m * net
+ ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(testpoint, ftest); o <- o + 1
+ printUpdate("poll")
+
+ }
+ }
+
+ if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){
+
+ minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)])
+ PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,]
+ fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos]
+ delta <- sigma * delta
+
+ } else {
+
+ delta <- delta / sigma
+
+ }
+
+
+ }
+
+ cat(paste0("\nCompleted Full Iteration: ", k, "\n\n"))
+
+ # Restart with random initiate
+ if( delta < deltaThresh ) {
+
+ delta <- deltaNaught
+ fmin <- fminNaught
+ PARAM <- PARAMNaught + runif(n = np, min = -delta * sigma,
+ max = delta * sigma)
+
+ ftest <- evaluate(PARAM, minVal, maxVal,
+ negative = TRUE, y = y)
+ OPTIM[o,] <- c(PARAM, ftest); o <- o + 1
+
+ cat(paste0("\nDelta Threshold Breached, Restarting with Random Initiate\n\n"))
+
+ }
+
+}
+
+# Return the best optimization in untransformed parameters
+return(
+ evaluate(OPTIM[which.min(OPTIM$obj),1:np],
+ minVal, maxVal, transformOnly = TRUE)
+)
+
+
+}
+
diff --git a/Listings/Chapter 9/9-1.R b/Listings/Chapter 9/9-1.R
new file mode 100755
index 0000000..d93ebed
--- /dev/null
+++ b/Listings/Chapter 9/9-1.R
@@ -0,0 +1,127 @@
+# Normally declared by your strategy
+FAVOR <- rnorm(ncol(DATA[["Close"]]))
+ENTRY <- rbinom(ncol(DATA[["Close"]]), 1, .005) -
+ rbinom(ncol(DATA[["Close"]]), 1, .005)
+EXIT <- rbinom(ncol(DATA[["Close"]]), 1, .8) -
+ rbinom(ncol(DATA[["Close"]]), 1, .8)
+
+# Normally fetched from brokerage
+currentlyLong <- c("AA", "AAL", "AAPL")
+currentlyShort <- c("RAI", "RCL", "REGN")
+S <- names(DATA[["Close"]])
+initP <- (S %in% currentlyLong) - (S %in% currentlyShort)
+
+names(initP) <-
+ names(FAVOR) <-
+ names(ENTRY) <-
+ names(EXIT) <-
+ names(DATA[["Close"]])
+
+
+# At this point we have established everything normally
+# taken care of by your trading strategy.
+# Given named vectors of length ncol(DATA[["Close"]])
+# initP, FAVOR, ENTRY, and EXIT, we proceed.
+
+maxAssets <- 10
+startingCash <- 100000
+
+K <- maxAssets
+k <- 0
+C <- c(startingCash, NA)
+S <- names(DATA[["Close"]])
+P <- initP
+
+
+# Step 4
+longS <- S[which(P > 0)]
+shortS <- S[which(P < 0)]
+k <- length(longS) + length(shortS)
+
+# Step 5
+longTrigger <- setdiff(S[which(ENTRY == 1)], longS)
+shortTrigger <- setdiff(S[which(ENTRY == -1)], shortS)
+trigger <- c(longTrigger, shortTrigger)
+
+if( length(trigger) > K ) {
+
+ keepTrigger <- trigger[order(c(as.numeric(FAVOR[longTrigger]),
+ -as.numeric(FAVOR[shortTrigger])),
+ decreasing = TRUE)][1:K]
+
+ longTrigger <- longTrigger[longTrigger %in% keepTrigger]
+ shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger]
+
+ trigger <- c(longTrigger, shortTrigger)
+
+}
+
+triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger)))
+
+
+# Step 6
+longExitTrigger <- longS[longS %in% S[which(EXIT == 1 | EXIT == 999)]]
+
+shortExitTrigger <- shortS[shortS %in% S[which(EXIT == -1 | EXIT == 999)]]
+
+exitTrigger <- c(longExitTrigger, shortExitTrigger)
+
+
+# Step 7
+needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0)
+
+if( needToExit > 0 ){
+
+ toExitLongS <- setdiff(longS, exitTrigger)
+ toExitShortS <- setdiff(shortS, exitTrigger)
+
+ toExit <- character(0)
+
+ for( counter in 1:needToExit ){
+ if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){
+ if( min(FAVOR[toExitLongS]) < min(-FAVOR[toExitShortS]) ){
+ pullMin <- which.min(FAVOR[toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else {
+ pullMin <- which.min(-FAVOR[toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){
+ pullMin <- which.min(FAVOR[toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){
+ pullMin <- which.min(-FAVOR[toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ }
+
+ longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit])
+ shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit])
+
+}
+
+# Step 8
+exitTrigger <- c(longExitTrigger, shortExitTrigger)
+exitTriggerType <- c(rep(1, length(longExitTrigger)),
+ rep(-1, length(shortExitTrigger)))
+
+
+
+
+
+
+# Output planned trades
+setwd(rootdir)
+
+# First exit these
+write.csv(file = "stocksToExit.csv",
+ data.frame(list(sym = exitTrigger, type = exitTriggerType)))
+
+# Then enter these
+write.csv(file = "stocksToEnter.csv",
+ data.frame(list(sym = trigger, type = triggerType)))
+
diff --git a/Listings/Chapter 9/9-10.R b/Listings/Chapter 9/9-10.R
new file mode 100755
index 0000000..8f29964
--- /dev/null
+++ b/Listings/Chapter 9/9-10.R
@@ -0,0 +1,29 @@
+# Example is not executable.
+# For example purposes only.
+library(ROAuth)
+
+
+# Requesting with key-secret and access-request pair
+reqURL <- "requestUrl"
+accessURL <- "accessUrl"
+authURL <- "authenticationUrl"
+cKey <- "consumerKey"
+cSecret <- "consumerSecret"
+
+
+credentials <- OAuthFactory$new(consumerKey=cKey,
+ consumerSecret=cSecret,
+ requestURL=reqURL,
+ accessURL=accessURL,
+ authURL=authURL,
+ needsVerifier=FALSE)
+credentials$handshake()
+
+# Send GET Request to URL
+testURL <- "http://someurl.com/some parameters"
+credentials$OAuthRequest(testURL, "GET")
+
+
+# Send GET Request to URL
+testURL <- "http://someurl.com/some un-encoded parameters"
+credentials$OAuthRequest(testURL, "GET")
diff --git a/Listings/Chapter 9/9-11.R b/Listings/Chapter 9/9-11.R
new file mode 100755
index 0000000..1a1e311
--- /dev/null
+++ b/Listings/Chapter 9/9-11.R
@@ -0,0 +1,18 @@
+oKey <- "oauthKey"
+oSecret <- "oauthSecret"
+cKey <- "consumerKey"
+cSecret <- "consumerSecret"
+
+credentials <- OAuthFactory$new(consumerKey = cKey,
+ consumerSecret = cSecret,
+ oauthKey = oKey,
+ oauthSecret = oSecret,
+ needsVerifier=FALSE)
+
+# Manually declare authentication as complete
+credentials$handshakeComplete <- TRUE
+
+# Send a FIXML message through OAuth to testURL with POST request
+aFIXMLmessage <- c("content")
+testURL <- "https://testurl.com/"
+credentials$OAuthRequest(testURL, "POST", aFIXMLmessage)
diff --git a/Listings/Chapter 9/9-2.xml b/Listings/Chapter 9/9-2.xml
new file mode 100755
index 0000000..cc55b78
--- /dev/null
+++ b/Listings/Chapter 9/9-2.xml
@@ -0,0 +1,44 @@
+
+
+
+
+ 2016-01-12
+ 30.58
+ 30.969999
+ 30.209999
+ 30.690001
+ 12635300
+ 30.690001
+
+
+ 2016-01-11
+ 30.65
+ 30.75
+ 29.74
+ 30.17
+ 16676500
+ 30.17
+
+
+ 2016-01-12
+ 100.550003
+ 100.690002
+ 98.839996
+ 99.959999
+ 49154200
+ 98.818866
+
+
+ 2016-01-11
+ 98.970001
+ 99.059998
+ 97.339996
+ 98.529999
+ 49739400
+ 97.40519
+
+
+
+
+
diff --git a/Listings/Chapter 9/9-3.txt b/Listings/Chapter 9/9-3.txt
new file mode 100755
index 0000000..2953dc4
--- /dev/null
+++ b/Listings/Chapter 9/9-3.txt
@@ -0,0 +1,29 @@
+# Opening and closing XML tags, empty
+
+
+# Opening and closing XML tags, with value
+2016-01-11
+
+# Opening and closing XML tags, with value and attribute
+2016-01-11
+
+# Self-closing XML tag
+
+
+# Self-closing XML tag with attributes
+
+
+# XML Comment
+
+
+# XML Declaration
+
+
+# Processing Instruction
+
+
+# Character Data Entity (Escapes symbolic characters)
+ sqrt(y) ]]>
+
+# Document Type Declaration
+
diff --git a/Listings/Chapter 9/9-4.txt b/Listings/Chapter 9/9-4.txt
new file mode 100755
index 0000000..bc61aa4
--- /dev/null
+++ b/Listings/Chapter 9/9-4.txt
@@ -0,0 +1,18 @@
+# Child node
+child::someNode
+someNode
+
+# Attribute value
+attribute::someAttr
+@someAttr
+
+# Parent node
+someNode/parent::*/someSibling
+someNode/../someSibling
+
+# Descendent-or-self
+someNode/descendent-or-self::node()/someDescendent
+someNode//someDescendent
+
+# Ancestor (has no abbreviation)
+someNode/ancestor::someAncestorNode
diff --git a/Listings/Chapter 9/9-5.R b/Listings/Chapter 9/9-5.R
new file mode 100755
index 0000000..f0abd6e
--- /dev/null
+++ b/Listings/Chapter 9/9-5.R
@@ -0,0 +1,27 @@
+# Descend the tree to each individual stock quote
+getNodeSet(doc, "/query/results/quote")
+
+# Get the second quote
+getNodeSet(doc, "/query/results/quote[2]")
+
+# Descend to the third level of the tree, get second element
+getNodeSet(doc, "/*/*/*[2]")
+
+# Get all nodes named "quote" regardless of level
+getNodeSet(doc, "//quote")
+
+# Get all node with Symbol = AAPL attribute
+getNodeSet(doc, "/query/results/quote[@Symbol = 'AAPL']")
+
+# Get the last quote
+getNodeSet(doc, "/query/results/quote[last()]")
+
+# Get the first 3 quotes
+getNodeSet(doc, "/query/results/quote[position() <= 3]")
+
+# Get all quotes with closing price less than 40
+getNodeSet(doc, "/query/results/quote[./Close < 40]")
+
+# Get all closing prices less than 40
+getNodeSet(doc, "/query/results/quote[./Close < 40]/Close")
+
diff --git a/Listings/Chapter 9/9-6.R b/Listings/Chapter 9/9-6.R
new file mode 100755
index 0000000..d5732c6
--- /dev/null
+++ b/Listings/Chapter 9/9-6.R
@@ -0,0 +1,28 @@
+# Descend the tree to this point
+root <- "/query/results/quote"
+
+# Descend to each of these leaves for every node in root
+leaves <- c("./Date", "./Open", "./High", "./Low",
+ "./Close", "./Volume", "./Adj_Close")
+
+# Get data in list
+df <- getNodeSet(doc, root, fun = function(v) xpathSApply(v, leaves, xmlValue))
+
+# Get symbols as attributes
+sym <- getNodeSet(doc, root, fun = function(v) xpathSApply(v, ".", xmlAttrs))
+
+# This is equivalent to the above line in this case
+# sym <- as.character(getNodeSet(doc, "/query/results/quote/@Symbol"))
+
+# Organize as data frame
+df <- data.frame(t(data.frame(df)), stringsAsFactors = FALSE)
+
+# Append stock symbols
+df <- cbind(unlist(sym), df)
+df[,3:8] <- lapply(df[3:8], as.numeric)
+df[,1] <- as.character(df[,1])
+
+# Fix names
+rownames(df) <- NULL
+colnames(df) <- c("Symbol", substring(leaves, 3))
+
diff --git a/Listings/Chapter 9/9-7.xml b/Listings/Chapter 9/9-7.xml
new file mode 100755
index 0000000..1048cfe
--- /dev/null
+++ b/Listings/Chapter 9/9-7.xml
@@ -0,0 +1,6 @@
+
+
+
+
+
+
diff --git a/Listings/Chapter 9/9-8.R b/Listings/Chapter 9/9-8.R
new file mode 100755
index 0000000..a500e46
--- /dev/null
+++ b/Listings/Chapter 9/9-8.R
@@ -0,0 +1,25 @@
+library(XML)
+
+# Generate the XML message in Listing 9.7
+out <- newXMLNode("FIXML",
+ namespaceDefinitions =
+ "http://www.fixprotocol.org/FIXML-5-0-SP2")
+
+newXMLNode("Order",
+ attrs = c(TmInForce = 0, Typ = 1, Side = 1, Acct=999999),
+ parent = out)
+
+newXMLNode("Instrmt",
+ attrs = c(SecTyp = "CS", Sym = "AAPL"),
+ parent = out["Order"])
+
+newXMLNode("OrdQty",
+ attrs = c(Qty = 100),
+ parent = out["Order"])
+
+print(out)
+
+
+# Extra example for how to insert content in non-self-closing nodes
+newXMLNode("extraInfo", "invalid content.", parent = out["Order"])
+print(out)
diff --git a/Listings/Chapter 9/9-9.R b/Listings/Chapter 9/9-9.R
new file mode 100755
index 0000000..835658a
--- /dev/null
+++ b/Listings/Chapter 9/9-9.R
@@ -0,0 +1,23 @@
+library(RJSONIO)
+
+base <- "http://query.yahooapis.com/v1/public/yql?"
+begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in "
+midQuery <- "('YHOO', 'AAPL') "
+endQuery <- "and startDate = '2016-01-11' and endDate = '2016-01-12'"
+
+# Supply "format=json" argument to URL
+endParams <-
+ "&diagnostics=false&format=json&env=store://datatables.org/alltableswithkeys"
+
+urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams)
+
+# Encode URL before requesting
+# This is normally handled automatically by the XML package
+jdoc <- fromJSON(URLencode(urlstr))
+
+# Format and output data frame as in Listing 9.6
+df <- data.frame(t(data.frame(jdoc[["query"]][["results"]][["quote"]])),
+ stringsAsFactors = FALSE)
+df[,3:8] <- lapply(df[3:8], as.numeric)
+df[,1] <- as.character(df[,1])
+rownames(df) <- NULL
diff --git a/Platform/S.R b/Platform/S.R
new file mode 100755
index 0000000..fd4e84e
--- /dev/null
+++ b/Platform/S.R
@@ -0,0 +1,58 @@
+S <-
+c("MMM", "ABT", "ABBV", "ACN", "ACE", "ATVI", "ADBE", "ADT",
+"AAP", "AES", "AET", "AFL", "AMG", "A", "GAS", "APD", "ARG",
+"AKAM", "AA", "AGN", "ALXN", "ALLE", "ADS", "ALL", "GOOGL", "GOOG",
+"ALTR", "MO", "AMZN", "AEE", "AAL", "AEP", "AXP", "AIG", "AMT",
+"AMP", "ABC", "AME", "AMGN", "APH", "APC", "ADI", "AON", "APA",
+"AIV", "AAPL", "AMAT", "ADM", "AIZ", "T", "ADSK", "ADP", "AN",
+"AZO", "AVGO", "AVB", "AVY", "BHI", "BLL", "BAC", "BK", "BCR",
+"BXLT", "BAX", "BBT", "BDX", "BBBY", "BRK-B", "BBY", "BIIB",
+"BLK", "HRB", "BA", "BWA", "BXP", "BSX", "BMY", "BRCM", "BF-B",
+"CHRW", "CA", "CVC", "COG", "CAM", "CPB", "COF", "CAH", "HSIC",
+"KMX", "CCL", "CAT", "CBG", "CBS", "CELG", "CNP", "CTL", "CERN",
+"CF", "SCHW", "CHK", "CVX", "CMG", "CB", "CI", "XEC", "CINF",
+"CTAS", "CSCO", "C", "CTXS", "CLX", "CME", "CMS", "COH", "KO",
+"CCE", "CTSH", "CL", "CPGX", "CMCSA", "CMCSK", "CMA", "CAG",
+"COP", "CNX", "ED", "STZ", "GLW", "COST", "CCI", "CSRA", "CSX",
+"CMI", "CVS", "DHI", "DHR", "DRI", "DVA", "DE", "DLPH", "DAL",
+"XRAY", "DVN", "DO", "DFS", "DISCA", "DISCK", "DG", "DLTR", "D",
+"DOV", "DOW", "DPS", "DTE", "DD", "DUK", "DNB", "ETFC", "EMN",
+"ETN", "EBAY", "ECL", "EIX", "EW", "EA", "EMC", "EMR", "ENDP",
+"ESV", "ETR", "EOG", "EQT", "EFX", "EQIX", "EQR", "ESS", "EL",
+"ES", "EXC", "EXPE", "EXPD", "ESRX", "XOM", "FFIV", "FB", "FAST",
+"FDX", "FIS", "FITB", "FSLR", "FE", "FISV", "FLIR", "FLS", "FLR",
+"FMC", "FTI", "F", "FOSL", "BEN", "FCX", "FTR", "GME", "GPS",
+"GRMN", "GD", "GE", "GGP", "GIS", "GM", "GPC", "GILD", "GS",
+"GT", "GWW", "HAL", "HBI", "HOG", "HAR", "HRS", "HIG", "HAS",
+"HCA", "HCP", "HP", "HES", "HPE", "HD", "HON", "HRL", "HST",
+"HPQ", "HUM", "HBAN", "ITW", "ILMN", "IR", "INTC", "ICE", "IBM",
+"IP", "IPG", "IFF", "INTU", "ISRG", "IVZ", "IRM", "JEC", "JBHT",
+"JNJ", "JCI", "JPM", "JNPR", "KSU", "K", "KEY", "GMCR", "KMB",
+"KIM", "KMI", "KLAC", "KSS", "KHC", "KR", "LB", "LLL", "LH",
+"LRCX", "LM", "LEG", "LEN", "LVLT", "LUK", "LLY", "LNC", "LLTC",
+"LMT", "L", "LOW", "LYB", "MTB", "MAC", "M", "MNK", "MRO", "MPC",
+"MAR", "MMC", "MLM", "MAS", "MA", "MAT", "MKC", "MCD", "MHFI",
+"MCK", "MJN", "WRK", "MDT", "MRK", "MET", "KORS", "MCHP", "MU",
+"MSFT", "MHK", "TAP", "MDLZ", "MON", "MNST", "MCO", "MS", "MOS",
+"MSI", "MUR", "MYL", "NDAQ", "NOV", "NAVI", "NTAP", "NFLX", "NWL",
+"NFX", "NEM", "NWSA", "NWS", "NEE", "NLSN", "NKE", "NI", "NBL",
+"JWN", "NSC", "NTRS", "NOC", "NRG", "NUE", "NVDA", "ORLY", "OXY",
+"OMC", "OKE", "ORCL", "OI", "PCAR", "PH", "PDCO", "PAYX", "PYPL",
+"PNR", "PBCT", "POM", "PEP", "PKI", "PRGO", "PFE", "PCG", "PM",
+"PSX", "PNW", "PXD", "PBI", "PCL", "PNC", "RL", "PPG", "PPL",
+"PX", "PCP", "PCLN", "PFG", "PG", "PGR", "PLD", "PRU", "PEG",
+"PSA", "PHM", "PVH", "QRVO", "PWR", "QCOM", "DGX", "RRC", "RTN",
+"O", "RHT", "REGN", "RF", "RSG", "RAI", "RHI", "ROK", "COL",
+"ROP", "ROST", "RCL", "R", "CRM", "SNDK", "SCG", "SLB", "SNI",
+"STX", "SEE", "SRE", "SHW", "SIG", "SPG", "SWKS", "SLG", "SJM",
+"SNA", "SO", "LUV", "SWN", "SE", "STJ", "SWK", "SPLS", "SBUX",
+"HOT", "STT", "SRCL", "SYK", "STI", "SYMC", "SYF", "SYY", "TROW",
+"TGT", "TEL", "TE", "TGNA", "THC", "TDC", "TSO", "TXN", "TXT",
+"HSY", "TRV", "TMO", "TIF", "TWX", "TWC", "TJX", "TMK", "TSS",
+"TSCO", "RIG", "TRIP", "FOXA", "FOX", "TSN", "TYC", "USB", "UA",
+"UNP", "UAL", "UNH", "UPS", "URI", "UTX", "UHS", "UNM", "URBN",
+"VFC", "VLO", "VAR", "VTR", "VRSN", "VRSK", "VZ", "VRTX", "VIAB",
+"V", "VNO", "VMC", "WMT", "WBA", "DIS", "WM", "WAT", "ANTM",
+"WFC", "HCN", "WDC", "WU", "WY", "WHR", "WFM", "WMB", "WEC",
+"WYN", "WYNN", "XEL", "XRX", "XLNX", "XL", "XYL", "YHOO", "YUM",
+"ZBH", "ZION", "ZTS")
diff --git a/Platform/SPdates.R b/Platform/SPdates.R
new file mode 100755
index 0000000..f8f30c8
--- /dev/null
+++ b/Platform/SPdates.R
@@ -0,0 +1,156 @@
+S <-
+structure(list(V1 = c("A", "AAL", "AAP", "AAPL", "ABBV", "ABC",
+"ACE", "ACN", "ADM", "ADP", "ADS", "ADSK", "ADT", "AEE", "AET",
+"AIG", "AIV", "AIZ", "AKAM", "ALLE", "ALTR", "ALXN", "AME", "AMG",
+"AMGN", "AMT", "AMZN", "AN", "APD", "APH", "ARG", "ATVI", "AVB",
+"AVGO", "AVY", "AXP", "BAC", "BAX", "BCR", "BDX", "BF-B", "BIIB",
+"BLK", "BLL", "BRCM", "BRK-B", "BWA", "BXLT", "BXP", "C", "CA",
+"CAG", "CAM", "CB", "CBS", "CCI", "CERN", "CF", "CHK", "CI",
+"CLX", "CMCSA", "CME", "CMG", "CMI", "CNP", "CNX", "COG", "COH",
+"COL", "COST", "CPGX", "CRM", "CSCO", "CSRA", "CSX", "CTAS",
+"CVC", "DAL", "DFS", "DG", "DGX", "DHI", "DIS", "DISCA", "DISCK",
+"DLPH", "DLTR", "DNB", "DO", "DOV", "DPS", "DUK", "DVA", "DVN",
+"EBAY", "ECL", "EL", "EMN", "EMR", "ENDP", "EOG", "EQIX", "EQR",
+"EQT", "ESRX", "ESS", "ESV", "EW", "EXPD", "EXPE", "FAST", "FB",
+"FDX", "FFIV", "FISV", "FLIR", "FLR", "FLS", "FMC", "FOSL", "FOX",
+"FOXA", "FSLR", "FTI", "GGP", "GILD", "GIS", "GM", "GMCR", "GME",
+"GOOG", "GOOGL", "GPC", "GPS", "GRMN", "GS", "GWW", "HAR", "HAS",
+"HBI", "HCA", "HCN", "HCP", "HD", "HES", "HOT", "HPE", "HPQ",
+"HRB", "HRL", "HRS", "HSIC", "HST", "ICE", "IFF", "ILMN", "INTC",
+"INTU", "IPG", "IR", "IRM", "ISRG", "ITW", "IVZ", "JBHT", "JCI",
+"JEC", "JNJ", "JNPR", "JPM", "JWN", "KEY", "KHC", "KIM", "KMI",
+"KMX", "KORS", "KSU", "LB", "LEN", "LH", "LLL", "LLTC", "LLY",
+"LM", "LMT", "LNC", "LOW", "LRCX", "LUK", "LUV", "LVLT", "LYB",
+"MA", "MAC", "MAS", "MAT", "MCD", "MCHP", "MCO", "MDLZ", "MDT",
+"MET", "MHK", "MJN", "MKC", "MLM", "MMC", "MNK", "MNST", "MON",
+"MOS", "MPC", "MRO", "MSFT", "MTB", "MU", "MUR", "MYL", "NAVI",
+"NBL", "NDAQ", "NEE", "NEM", "NFLX", "NFX", "NI", "NKE", "NLSN",
+"NOC", "NOV", "NRG", "NUE", "NVDA", "NWL", "NWS", "NWSA", "O",
+"OI", "OKE", "ORCL", "ORLY", "OXY", "PBCT", "PCAR", "PCL", "PCLN",
+"PCP", "PDCO", "PFG", "PH", "PHM", "PKI", "PLD", "PM", "PNC",
+"PNR", "POM", "PRGO", "PRU", "PSA", "PSX", "PVH", "PWR", "PX",
+"PXD", "PYPL", "QRVO", "R", "RCL", "REGN", "RF", "RHI", "RHT",
+"RIG", "RL", "ROP", "ROST", "RRC", "RSG", "SBUX", "SCG", "SHW",
+"SIG", "SJM", "SLB", "SLG", "SNA", "SNDK", "SNI", "SPG", "SRCL",
+"STI", "STJ", "STX", "STZ", "SWK", "SWKS", "SWN", "SYF", "SYK",
+"SYMC", "SYY", "T", "TAP", "TDC", "TE", "TEL", "TGNA", "TGT",
+"THC", "TIF", "TJX", "TMK", "TRIP", "TSCO", "TSN", "TSO", "TSS",
+"TWC", "TXT", "TYC", "UA", "UAL", "UHS", "UNH", "UNM", "UPS",
+"URBN", "URI", "V", "VAR", "VFC", "VLO", "VNO", "VRSK", "VRSN",
+"VRTX", "VTR", "VZ", "WAT", "WBA", "WDC", "WEC", "WFC", "WMB",
+"WMT", "WU", "WYN", "WYNN", "XEC", "XL", "XRAY", "XYL", "ZION",
+"ZTS", "MMM", "ABT", "ADBE", "AES", "AFL", "GAS", "AA", "AGN",
+"ALL", "MO", "AEP", "AMP", "APC", "ADI", "AON", "APA", "AMAT",
+"AZO", "BHI", "BK", "BBT", "BBBY", "BBY", "BA", "BSX", "BMY",
+"CHRW", "CPB", "COF", "CAH", "CCL", "CAT", "CBG", "CELG", "CTL",
+"SCHW", "CVX", "CINF", "CTXS", "CMS", "KO", "CCE", "CTSH", "CL",
+"CMCSK", "CMA", "COP", "ED", "GLW", "CVS", "DHR", "DRI", "DE",
+"D", "DOW", "DTE", "DD", "ETFC", "ETN", "EIX", "EA", "EMC", "ETR",
+"EFX", "ES", "EXC", "XOM", "FIS", "FITB", "FE", "F", "BEN", "FCX",
+"FTR", "GD", "GE", "GT", "HAL", "HOG", "HIG", "HP", "HON", "HUM",
+"HBAN", "IBM", "IP", "K", "KMB", "KLAC", "KSS", "KR", "LEG",
+"L", "M", "MAR", "MHFI", "MCK", "WRK", "MRK", "MS", "MSI", "NTAP",
+"NSC", "NTRS", "OMC", "PAYX", "PEP", "PFE", "PCG", "PNW", "PBI",
+"PPG", "PPL", "PG", "PGR", "PEG", "QCOM", "RTN", "RAI", "ROK",
+"SEE", "SRE", "SO", "SE", "SPLS", "STT", "TROW", "TXN", "HSY",
+"TRV", "TMO", "TWX", "USB", "UNP", "UTX", "VIAB", "VMC", "WM",
+"ANTM", "WY", "WHR", "WFM", "XEL", "XRX", "XLNX", "YHOO", "YUM",
+"ZBH"), V2 = c("6/2/2000", "3/23/2015", "7/9/2015", "11/30/1982",
+"12/31/2012", "8/29/2001", "7/15/2010", "7/6/2011", "7/29/1981",
+"3/31/1981", "12/23/2013", "12/1/1989", "10/1/2012", "9/19/1991",
+"6/30/1976", "3/31/1980", "3/13/2003", "4/10/2007", "7/12/2007",
+"12/2/2013", "4/17/2000", "5/25/2012", "9/23/2013", "7/1/2014",
+"1/2/1992", "11/19/2007", "11/18/2005", "2/21/2003", "4/30/1985",
+"9/30/2008", "9/9/2009", "8/28/2015", "1/1/2007", "5/8/2014",
+"12/31/1987", "6/30/1976", "6/30/1976", "9/30/1972", "6/30/1975",
+"9/30/1972", "10/31/1982", "11/12/2003", "4/4/2011", "10/31/1984",
+"6/30/2000", "2/16/2010", "12/16/2011", "7/1/2015", "3/31/2006",
+"5/31/1988", "7/31/1987", "8/31/1983", "1/29/2008", "6/30/1976",
+"9/1/1994", "3/14/2012", "4/30/2010", "8/27/2008", "3/2/2006",
+"6/30/1976", "3/31/1969", "11/18/2002", "8/10/2006", "4/28/2011",
+"3/31/1965", "7/31/1985", "6/27/2006", "6/23/2008", "8/31/2004",
+"6/29/2001", "10/1/1993", "7/2/2015", "9/15/2008", "12/1/1993",
+"12/1/2015", "9/30/1967", "2/28/2001", "12/20/2010", "9/11/2013",
+"7/2/2007", "12/3/2012", "12/11/2002", "7/1/2005", "6/30/1976",
+"3/1/2010", "8/7/2014", "12/21/2012", "12/16/2011", "12/2/2008",
+"2/26/2009", "10/31/1985", "10/7/2008", "6/30/1976", "7/31/2008",
+"8/29/2000", "7/19/2002", "1/31/1989", "1/4/2006", "1/1/1994",
+"3/31/1965", "1/27/2015", "11/1/2000", "3/23/2015", "11/30/2001",
+"12/19/2008", "9/25/2003", "4/2/2014", "7/31/2012", "3/31/2011",
+"10/10/2007", "10/2/2007", "9/15/2009", "12/21/2013", "12/31/1980",
+"12/17/2010", "3/30/2001", "1/2/2009", "12/21/2000", "10/2/2008",
+"8/19/2009", "4/4/2012", "7/1/2013", "6/28/2013", "10/16/2009",
+"6/5/2009", "12/10/2013", "6/30/2004", "3/31/1969", "6/6/2013",
+"3/21/2014", "12/14/2007", "3/31/2006", "4/3/2014", "12/31/1973",
+"8/31/1986", "12/11/2012", "7/19/2002", "6/30/1981", "1/31/2006",
+"9/30/1984", "3/23/2015", "1/27/2015", "1/30/2009", "3/31/2008",
+"3/31/1988", "5/31/1984", "11/16/2000", "11/2/2015", "12/31/1974",
+"11/30/1986", "3/4/2009", "9/22/2008", "3/18/2015", "3/20/2007",
+"9/26/2007", "3/31/1976", "11/19/2015", "12/31/1976", "12/8/2000",
+"10/1/1992", "11/17/2010", "1/6/2009", "6/2/2008", "2/28/1986",
+"8/21/2008", "7/1/2015", "5/31/1986", "10/25/2007", "6/30/1973",
+"6/1/2006", "6/30/1975", "8/31/1986", "3/1/1994", "10/2/2012",
+"3/31/2006", "5/25/2012", "6/28/2010", "11/13/2013", "5/24/2013",
+"9/30/1983", "10/3/2005", "10/29/2004", "11/30/2004", "3/31/2000",
+"12/31/1970", "4/21/2006", "7/31/1984", "6/30/1976", "2/29/1984",
+"6/5/2012", "8/27/2007", "7/1/1994", "11/5/2014", "9/5/2012",
+"7/18/2008", "5/8/2013", "6/30/1981", "3/31/1982", "6/30/1970",
+"9/7/2007", "10/2/2000", "10/2/2012", "10/31/1986", "12/8/2000",
+"12/21/2013", "12/21/2009", "3/20/2003", "7/2/2014", "8/31/1987",
+"8/19/2014", "6/28/2012", "8/13/2002", "9/23/2011", "6/30/2011",
+"5/1/1991", "6/1/1994", "2/26/2004", "9/27/1994", "8/12/2005",
+"4/22/2004", "5/1/2014", "10/8/2007", "10/22/2008", "6/30/1976",
+"6/30/1969", "12/17/2010", "12/17/2010", "11/1/2000", "11/30/1988",
+"7/8/2013", "6/30/1985", "3/11/2005", "1/29/2010", "4/30/1985",
+"11/29/2001", "4/30/1989", "8/1/2013", "8/1/2013", "4/7/2015",
+"1/2/2009", "3/15/2010", "8/31/1989", "3/27/2009", "12/31/1982",
+"11/13/2008", "12/31/1980", "1/16/2002", "11/3/2009", "6/1/2007",
+"10/10/2005", "7/19/2002", "11/30/1985", "4/30/1984", "5/31/1985",
+"7/16/2003", "3/31/2008", "4/30/1988", "10/1/2012", "11/9/2007",
+"12/16/2011", "7/19/2002", "8/18/2005", "4/23/2012", "2/15/2013",
+"7/1/2009", "7/1/1992", "9/24/2008", "7/20/2015", "6/11/2015",
+"12/31/1982", "12/5/2014", "4/30/2013", "6/30/2004", "12/4/2000",
+"7/27/2009", "10/21/2013", "2/2/2007", "12/23/2009", "12/21/2009",
+"12/20/2007", "12/5/2008", "6/7/2000", "1/2/2009", "6/30/1964",
+"7/29/2015", "11/6/2008", "3/31/1965", "3/23/2015", "9/30/1982",
+"4/19/2006", "7/1/2008", "6/25/2002", "11/19/2008", "5/31/1988",
+"11/30/1989", "7/2/2012", "7/1/2005", "9/30/1982", "3/12/2015",
+"6/6/2008", "11/18/2015", "12/11/2000", "3/28/2003", "12/31/1986",
+"11/30/1983", "2/8/2005", "10/1/2007", "10/9/2001", "10/14/2011",
+"12/31/1975", "12/31/1976", "3/31/1979", "6/20/2000", "9/30/1985",
+"4/30/1989", "12/20/2011", "1/24/2014", "8/10/2005", "9/27/2007",
+"1/2/2008", "3/30/2009", "12/31/1978", "8/26/2010", "5/1/2014",
+"9/2/2015", "9/20/2014", "7/1/1994", "3/1/1994", "7/19/2002",
+"2/8/2010", "9/20/2014", "12/21/2009", "2/12/2007", "6/30/1979",
+"4/28/2004", "8/11/2005", "10/7/2015", "1/31/2006", "9/20/2013",
+"3/4/2009", "11/30/1983", "12/31/2001", "12/31/1979", "7/1/2009",
+"10/31/2008", "6/30/1976", "3/31/1975", "8/31/1982", "9/29/2006",
+"7/31/2006", "11/14/2008", "6/20/2014", "8/31/2001", "11/14/2008",
+"10/31/2011", "6/22/2001", "6/21/2013", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"4/17/1996", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "12/3/1997", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"12/15/1994", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "7/5/1985",
+"1/1/1900", "1/1/1900", "1/1/1900", "08/28/2015", "1/1/1900",
+"6/30/2015", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/3/1983", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "7/8/1999",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900",
+"1/1/1900")), .Names = c("V1", "V2"), class = "data.frame", row.names = c(NA,
+-505L))
diff --git a/Platform/compute/MCinit.R b/Platform/compute/MCinit.R
new file mode 100755
index 0000000..ca975ba
--- /dev/null
+++ b/Platform/compute/MCinit.R
@@ -0,0 +1,9 @@
+if( CONFIG[["isUNIX"]] ){
+ library(doMC)
+ workers <- CONFIG[["workers"]]
+ registerDoMC( cores = workers )
+} else {
+ library(doParallel)
+ workers <- CONFIG[["workers"]]
+ registerDoParallel( cores = workers )
+}
diff --git a/Platform/compute/functions.R b/Platform/compute/functions.R
new file mode 100755
index 0000000..763e748
--- /dev/null
+++ b/Platform/compute/functions.R
@@ -0,0 +1,309 @@
+# Listings 6.9, 6.12, and 7.1
+library(foreach)
+
+
+delegate <- function( i = i, n = n, k = k, p = workers ){
+ nOut <- n - k + 1
+ nProc <- ceiling( nOut / p )
+ return( (( i - 1 ) * nProc + 1) : min(i * nProc + k - 1, n) )
+}
+
+
+mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers, ... ){
+
+ args <- names(mget(ls()))
+ export <- ls(.GlobalEnv)
+ export <- export[!export %in% args]
+
+ SERIES <- foreach( i = 1:workers, .combine = rbind,
+ .packages = loadedNamespaces(), .export = export) %dopar% {
+
+ jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers)
+
+ rollapply(data[jRange,],
+ width = windowSize,
+ FUN = tsfunc,
+ align = "right",
+ by.column = byColumn)
+
+ }
+
+ names(SERIES) <- gsub("\\..+", "", names(SERIES))
+
+ if( windowSize > 1){
+ PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA),
+ order.by = index(data)[1:(windowSize-1)])
+ names(PAD) <- names(SERIES)
+ SERIES <- rbind(PAD, SERIES)
+ }
+
+ if(is.null(names(SERIES))){
+ names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)])
+ }
+
+ return(SERIES)
+
+}
+
+
+
+equNA <- function(v){
+ o <- which(!is.na(v))[1]
+ return(ifelse(is.na(o), length(v)+1, o))
+}
+
+simulate <- function(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, maxAssets, startingCash,
+ slipFactor, spreadAdjust, flatCommission, perShareCommission,
+ verbose = FALSE, failThresh = 0,
+ initP = NULL, initp = NULL){
+
+
+# Step 1
+if( any( dim(ENTRY) != dim(EXIT) ) |
+ any( dim(EXIT) != dim(FAVOR) ) |
+ any( dim(FAVOR) != dim(CLOSE) ) |
+ any( dim(CLOSE) != dim(OPEN)) )
+ stop( "Mismatching dimensions in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.")
+
+if( any( names(ENTRY) != names(EXIT)) |
+ any( names(EXIT) != names(FAVOR) ) |
+ any( names(FAVOR) != names(CLOSE) ) |
+ any( names(CLOSE) != names(OPEN) ) |
+ is.null(names(ENTRY)) | is.null(names(EXIT)) |
+ is.null(names(FAVOR)) | is.null(names(CLOSE)) |
+ is.null(names(OPEN)) )
+ stop( "Mismatching or missing column names in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.")
+
+
+FAVOR <- zoo(t(apply(FAVOR, 1, function(v) ifelse(is.nan(v) | is.na(v), 0, v) )),
+ order.by = index(CLOSE))
+
+
+# Step 2
+K <- maxAssets
+k <- 0
+C <- rep(startingCash, times = nrow(CLOSE))
+S <- names(CLOSE)
+
+P <- p <- zoo( matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)),
+ order.by = index(CLOSE) )
+
+if( !is.null( initP ) & !is.null( initp ) ){
+ P[1:maxLookback,] <-
+ matrix(initP, ncol=length(initP), nrow=maxLookback, byrow = TRUE)
+ p[1:maxLookback,] <-
+ matrix(initp, ncol=length(initp), nrow=maxLookback, byrow = TRUE)
+}
+
+names(P) <- names(p) <- S
+
+equity <- rep(NA, nrow(CLOSE))
+
+
+
+rmNA <- pmax(unlist(lapply(FAVOR, equNA)),
+ unlist(lapply(ENTRY, equNA)),
+ unlist(lapply(EXIT, equNA)))
+
+for( j in 1:ncol(ENTRY) ){
+ toRm <- rmNA[j]
+ if( toRm > (maxLookback + 1) &
+ toRm < nrow(ENTRY) ){
+ FAVOR[1:(toRm-1),j] <- NA
+ ENTRY[1:(toRm-1),j] <- NA
+ EXIT[1:(toRm-1),j] <- NA
+ }
+}
+
+
+# Step 3
+for( i in maxLookback:(nrow(CLOSE)-1) ){
+
+ # Step 4
+ C[i+1] <- C[i]
+ P[i+1,] <- as.numeric(P[i,])
+ p[i+1,] <- as.numeric(p[i,])
+
+ longS <- S[which(P[i,] > 0)]
+ shortS <- S[which(P[i,] < 0)]
+ k <- length(longS) + length(shortS)
+
+ # Step 5
+ longTrigger <- setdiff(S[which(ENTRY[i,] == 1)], longS)
+ shortTrigger <- setdiff(S[which(ENTRY[i,] == -1)], shortS)
+ trigger <- c(longTrigger, shortTrigger)
+
+ if( length(trigger) > K ) {
+
+ keepTrigger <- trigger[order(c(as.numeric(FAVOR[i,longTrigger]),
+ -as.numeric(FAVOR[i,shortTrigger])),
+ decreasing = TRUE)][1:K]
+
+ longTrigger <- longTrigger[longTrigger %in% keepTrigger]
+ shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger]
+
+ trigger <- c(longTrigger, shortTrigger)
+
+ }
+
+ triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger)))
+
+
+ # Step 6
+ longExitTrigger <- longS[longS %in%
+ S[which(EXIT[i,] == 1 | EXIT[i,] == 999)]]
+
+ shortExitTrigger <- shortS[shortS %in%
+ S[which(EXIT[i,] == -1 | EXIT[i,] == 999)]]
+
+ exitTrigger <- c(longExitTrigger, shortExitTrigger)
+
+
+ # Step 7
+ needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0)
+
+ if( needToExit > 0 ){
+
+ toExitLongS <- setdiff(longS, exitTrigger)
+ toExitShortS <- setdiff(shortS, exitTrigger)
+
+ toExit <- character(0)
+
+ for( counter in 1:needToExit ){
+ if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){
+ if( min(FAVOR[i,toExitLongS]) < min(-FAVOR[i,toExitShortS]) ){
+ pullMin <- which.min(FAVOR[i,toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else {
+ pullMin <- which.min(-FAVOR[i,toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){
+ pullMin <- which.min(FAVOR[i,toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){
+ pullMin <- which.min(-FAVOR[i,toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ }
+
+ longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit])
+ shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit])
+
+ }
+
+ # Step 8
+ exitTrigger <- c(longExitTrigger, shortExitTrigger)
+ exitTriggerType <- c(rep(1, length(longExitTrigger)),
+ rep(-1, length(shortExitTrigger)))
+
+
+ # Step 9
+ if( length(exitTrigger) > 0 ){
+ for( j in 1:length(exitTrigger) ){
+
+ exitPrice <- as.numeric(OPEN[i+1,exitTrigger[j]])
+
+ effectivePrice <- exitPrice * (1 - exitTriggerType[j] * slipFactor) -
+ exitTriggerType[j] * (perShareCommission + spreadAdjust)
+
+ if( exitTriggerType[j] == 1 ){
+
+ C[i+1] <- C[i+1] +
+ ( as.numeric( P[i,exitTrigger[j]] ) * effectivePrice )
+ - flatCommission
+
+ } else {
+
+ C[i+1] <- C[i+1] -
+ ( as.numeric( P[i,exitTrigger[j]] ) *
+ ( 2 * as.numeric(p[i, exitTrigger[j]]) - effectivePrice ) )
+ - flatCommission
+ }
+
+ P[i+1, exitTrigger[j]] <- 0
+ p[i+1, exitTrigger[j]] <- 0
+
+ k <- k - 1
+
+ }
+ }
+
+
+ # Step 10
+ if( length(trigger) > 0 ){
+ for( j in 1:length(trigger) ){
+
+ entryPrice <- as.numeric(OPEN[i+1,trigger[j]])
+
+ effectivePrice <- entryPrice * (1 + triggerType[j] * slipFactor) +
+ triggerType[j] * (perShareCommission + spreadAdjust)
+
+ P[i+1,trigger[j]] <- triggerType[j] *
+ floor( ( (C[i+1] - flatCommission) / (K - k) ) / effectivePrice )
+
+ p[i+1,trigger[j]] <- effectivePrice
+
+ C[i+1] <- C[i+1] -
+ ( triggerType[j] * as.numeric(P[i+1,trigger[j]]) * effectivePrice )
+ - flatCommission
+
+ k <- k + 1
+
+ }
+ }
+
+
+ # Step 11
+ equity[i] <- C[i+1]
+ for( s in S[which(P[i+1,] > 0)] ){
+ equity[i] <- equity[i] +
+ as.numeric(P[i+1,s]) *
+ as.numeric(OPEN[i+1,s])
+ }
+
+ for( s in S[which(P[i+1,] < 0)] ){
+ equity[i] <- equity[i] -
+ as.numeric(P[i+1,s]) *
+ ( 2 * as.numeric(p[i+1,s]) - as.numeric(OPEN[i+1,s]) )
+ }
+
+ if( equity[i] < failThresh ){
+ warning("\n*** Failure Threshold Breached ***\n")
+ break
+ }
+
+ # Step 12
+ if( verbose ){
+ if( i %% 21 == 0 ){
+ cat(paste0("################################## ",
+ round(100 * (i - maxLookback) /
+ (nrow(CLOSE) - 1 - maxLookback), 1), "%",
+ " ##################################\n"))
+ cat(paste("Date:\t",as.character(index(CLOSE)[i])), "\n")
+ cat(paste0("Equity:\t", " $", signif(equity[i], 5), "\n"))
+ cat(paste0("CAGR:\t ",
+ round(100 * ((equity[i] / (equity[maxLookback]))^
+ (252/(i - maxLookback + 1)) - 1), 2),
+ "%"))
+ cat("\n")
+ cat("Assets:\t", S[P[i+1,] != 0])
+ cat("\n\n")
+ }
+ }
+
+
+
+}
+
+# Step 13
+return(list(equity = equity, C = C, P = P, p = p))
+
+}
+
diff --git a/Platform/config.R b/Platform/config.R
new file mode 100755
index 0000000..c52dc3b
--- /dev/null
+++ b/Platform/config.R
@@ -0,0 +1,40 @@
+DIR <- list()
+DIR[["root"]] <- "~/Platform/"
+DIR[["data"]] <- "~/Platform/stockdata/"
+DIR[["function"]] <- "~/Platform/functions/"
+DIR[["load"]] <- "~/Platform/load/"
+DIR[["compute"]] <- "~/Platform/compute/"
+DIR[["plan"]] <- "~/Platform/plan/"
+DIR[["model"]] <- "~/Platform/model/"
+
+CONFIG <- list()
+
+# Windows users should set to FALSE
+CONFIG[["isUNIX"]] <- TRUE
+
+# Set to the desired number of multicore
+# processes. Windows users need to be conscious
+# of memory requirements of these processes.
+CONFIG[["workers"]] <- 4
+
+# Max assets to be held in simulation, optimization,
+# and potentially trade execution.
+CONFIG[["maxAssets"]] <- 10
+
+# Max iterations in optimization function
+# for MODEL job. All users need to be conscious of
+# time constraints.
+CONFIG[["maxIter"]] <- 100
+
+# Range or scalar value of years
+# to train strategy on for MODEL job
+CONFIG[["y"]] <- 2016
+
+CONFIG[["minVal"]] <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01)
+CONFIG[["maxVal"]] <- c(n1 = 150, nFact = 5, nSharpe = 200, shThresh = .99)
+
+CONFIG[["PARAMnaught"]] <- c(n1 = -2, nFact = -2, nSharpe = -2, shThresh = 0)
+
+
+setwd(DIR[["root"]])
+
diff --git a/Platform/functions/yahoo.R b/Platform/functions/yahoo.R
new file mode 100755
index 0000000..05d69cf
--- /dev/null
+++ b/Platform/functions/yahoo.R
@@ -0,0 +1,30 @@
+# Listing 2.2
+yahoo <- function(sym, current = TRUE,
+ a = 0, b = 1, c = 2000, d, e, f,
+ g = "d")
+{
+
+ if(current){
+ f <- as.numeric(substr(as.character(Sys.time()), start = 1, stop = 4))
+ d <- as.numeric(substr(as.character(Sys.time()), start = 6, stop = 7)) - 1
+ e <- as.numeric(substr(as.character(Sys.time()), start = 9, stop = 10))
+ }
+
+ require(data.table)
+
+ tryCatch(
+ suppressWarnings(
+ fread(paste0("http://ichart.yahoo.com/table.csv",
+ "?s=", sym,
+ "&a=", a,
+ "&b=", b,
+ "&c=", c,
+ "&d=", d,
+ "&e=", e,
+ "&f=", f,
+ "&g=", g,
+ "&ignore=.csv"), sep = ",")),
+ error = function(e) NULL
+ )
+}
+
diff --git a/Platform/invalid.R b/Platform/invalid.R
new file mode 100755
index 0000000..b6b4b95
--- /dev/null
+++ b/Platform/invalid.R
@@ -0,0 +1,2 @@
+invalid <-
+character(0)
diff --git a/Platform/load.R b/Platform/load.R
new file mode 100755
index 0000000..9cb2709
--- /dev/null
+++ b/Platform/load.R
@@ -0,0 +1,33 @@
+setwd(DIR[["load"]])
+cat("initial.R\n\n")
+source("initial.R")
+
+setwd(DIR[["load"]])
+cat("loadToMemory.R\n\n")
+source("loadToMemory.R")
+
+setwd(DIR[["load"]])
+cat("updateStocks.R\n\n")
+source("updateStocks.R")
+
+setwd(DIR[["load"]])
+cat("dateUnif.R\n\n")
+source("dateUnif.R")
+
+setwd(DIR[["load"]])
+cat("spClean.R\n\n")
+source("spClean.R")
+
+setwd(DIR[["load"]])
+cat("adjustClose.R\n\n")
+source("adjustClose.R")
+
+setwd(DIR[["load"]])
+cat("return.R\n\n")
+source("return.R")
+
+setwd(DIR[["load"]])
+cat("fillInactive.R\n\n")
+source("fillInactive.R")
+
+cat("\n")
diff --git a/Platform/load/adjustClose.R b/Platform/load/adjustClose.R
new file mode 100755
index 0000000..d1de941
--- /dev/null
+++ b/Platform/load/adjustClose.R
@@ -0,0 +1,12 @@
+# Listing 3.6
+MULT <- DATA[["Adj Close"]] / DATA[["Close"]]
+
+DATA[["Price"]] <- DATA[["Close"]]
+DATA[["OpenPrice"]] <- DATA[["Open"]]
+
+DATA[["Open"]] <- DATA[["Open"]] * MULT
+DATA[["High"]] <- DATA[["High"]] * MULT
+DATA[["Low"]] <- DATA[["Low"]] * MULT
+DATA[["Close"]] <- DATA[["Adj Close"]]
+
+DATA[["Adj Close"]] <- NULL
diff --git a/Platform/load/dateUnif.R b/Platform/load/dateUnif.R
new file mode 100755
index 0000000..7691178
--- /dev/null
+++ b/Platform/load/dateUnif.R
@@ -0,0 +1,43 @@
+# Listing 2.8
+library(zoo)
+
+datetemp <- sort(unique(unlist(sapply(DATA, function(v) v[["Date"]]))))
+datetemp <- data.frame(datetemp, stringsAsFactors = FALSE)
+names(datetemp) <- "Date"
+
+DATA <- lapply(DATA, function(v) unique(v[order(v$Date),]))
+
+DATA[["Open"]] <- DATA[["High"]] <- DATA[["Low"]] <-
+ DATA[["Close"]] <- DATA[["Adj Close"]] <- DATA[["Volume"]] <- datetemp
+
+for(s in S){
+ for(i in rev(c("Open", "High", "Low", "Close", "Adj Close", "Volume"))){
+ temp <- data.frame(cbind(DATA[[s]][["Date"]], DATA[[s]][[i]]),
+ stringsAsFactors = FALSE)
+ names(temp) <- c("Date", s)
+ temp[,2] <- as.numeric(temp[,2])
+
+ if(!any(!DATA[[i]][["Date"]][(nrow(DATA[[i]]) - nrow(temp)+1):nrow(DATA[[i]])]
+ == temp[,1])){
+ temp <- rbind(t(matrix(nrow = 2, ncol = nrow(DATA[[i]]) - nrow(temp),
+ dimnames = list(names(temp)))), temp)
+ DATA[[i]] <- cbind(DATA[[i]], temp[,2])
+ } else {
+ DATA[[i]] <- merge(DATA[[i]], temp, all.x = TRUE, by = "Date")
+ }
+
+ names(DATA[[i]]) <- c(names(DATA[[i]])[-(ncol(DATA[[i]]))], s)
+ }
+ DATA[[s]] <- NULL
+
+ # Update user on progress
+ if( which( S == s ) %% 25 == 0 ){
+ cat( paste0(round(100 * which( S == s ) / length(S), 1), "% Complete\n") )
+ }
+
+}
+
+DATA <- lapply(DATA, function(v) zoo(v[,2:ncol(v)], strptime(v[,1], "%Y-%m-%d")))
+
+rm(list = setdiff(ls(), c("DATA", "DIR", "CONFIG")))
+gc()
diff --git a/Platform/load/fillInactive.R b/Platform/load/fillInactive.R
new file mode 100755
index 0000000..e15d361
--- /dev/null
+++ b/Platform/load/fillInactive.R
@@ -0,0 +1,13 @@
+# Listing 3.7
+for( s in names(DATA[["Close"]]) ){
+ if(is.na(DATA[["Close"]][nrow(DATA[["Close"]]), s])){
+ maxInd <- max(which(!is.na(DATA[["Close"]][,s])))
+ for( i in c("Close", "Open", "High", "Low")){
+ DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Close"]][maxInd,s]
+ }
+ for( i in c("Price", "OpenPrice") ){
+ DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Price"]][maxInd,s]
+ }
+ DATA[["Volume"]][(maxInd+1):nrow(DATA[["Close"]]),s] <- 0
+ }
+}
diff --git a/Platform/load/initial.R b/Platform/load/initial.R
new file mode 100755
index 0000000..ba4830a
--- /dev/null
+++ b/Platform/load/initial.R
@@ -0,0 +1,39 @@
+# Listing 2.4
+setwd(DIR[["function"]])
+source("yahoo.R")
+
+setwd(DIR[["root"]])
+if("S.R" %in% list.files()) {
+ source("S.R")
+} else {
+ url <- "http://trading.chrisconlan.com/SPstocks.csv"
+ S <- as.character(read.csv(url, header = FALSE)[,1])
+ dump(list = "S", "S.R")
+}
+
+invalid <- character(0)
+if("invalid.R" %in% list.files()) source("invalid.R")
+
+setwd(DIR[["data"]])
+toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid)
+
+if(length(toload) != 0){
+ for(i in 1:length(toload)){
+
+ df <- yahoo(toload[i])
+
+ if(!is.null(df)) {
+ write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"),
+ row.names = FALSE)
+ } else {
+ invalid <- c(invalid, toload[i])
+ }
+
+}
+}
+
+setwd(DIR[["root"]])
+dump(list = c("invalid"), "invalid.R")
+
+rm(list = setdiff(ls(), c("CONFIG", "DIR", "yahoo")))
+gc()
diff --git a/Platform/load/loadToMemory.R b/Platform/load/loadToMemory.R
new file mode 100755
index 0000000..c08921b
--- /dev/null
+++ b/Platform/load/loadToMemory.R
@@ -0,0 +1,12 @@
+# Listing 2.5
+setwd(DIR[["data"]])
+S <- sub(".csv", "", list.files())
+
+library(data.table)
+
+DATA <- list()
+for(i in S){
+ suppressWarnings(
+ DATA[[i]] <- fread(paste0(i, ".csv"), sep = ","))
+ DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)]
+}
diff --git a/Platform/load/return.R b/Platform/load/return.R
new file mode 100755
index 0000000..61eb413
--- /dev/null
+++ b/Platform/load/return.R
@@ -0,0 +1,7 @@
+# Listing 3.8
+NAPAD <- zoo(matrix(NA, nrow = 1, ncol = ncol(DATA[["Close"]])), order.by = index(DATA[["Close"]])[1])
+names(NAPAD) <- names(DATA[["Close"]])
+
+RETURN <- rbind( NAPAD, ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 )
+
+OVERNIGHT <- rbind( NAPAD, ( DATA[["Open"]] / lag(DATA[["Close"]], k = -1) ) - 1 )
diff --git a/Platform/load/spClean.R b/Platform/load/spClean.R
new file mode 100755
index 0000000..1ca4582
--- /dev/null
+++ b/Platform/load/spClean.R
@@ -0,0 +1,23 @@
+# Listing 3.1
+setwd(DIR[["root"]])
+
+if( "SPdates.R" %in% list.files() ){
+ source("SPdates.R")
+} else {
+ url <- "http://trading.chrisconlan.com/SPdates.csv"
+ S <- read.csv(url, header = FALSE, stringsAsFactors = FALSE)
+ dump(list = "S", "SPdates.R")
+}
+
+names(S) <- c("Symbol", "Date")
+S$Date <- strptime(S$Date, "%m/%d/%Y")
+
+for(s in names(DATA[["Close"]])){
+ for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){
+ Sindex <- which(S[,1] == s)
+ if(S[Sindex, "Date"] != "1900-01-01 EST" &
+ S[Sindex, "Date"] >= "2000-01-01 EST"){
+ DATA[[i]][index(DATA[[i]]) <= S[Sindex, "Date"], s] <- NA
+ }
+ }
+}
diff --git a/Platform/load/updateStocks.R b/Platform/load/updateStocks.R
new file mode 100755
index 0000000..c22b245
--- /dev/null
+++ b/Platform/load/updateStocks.R
@@ -0,0 +1,201 @@
+# Listings 2.6 and 2.7
+setwd(DIR[["data"]])
+library(XML)
+
+batchsize <- 51
+
+redownload <- character(0)
+
+for(i in 1:(ceiling(length(S) / batchsize)) ){
+
+ midQuery <- " ("
+ maxdate <- character(0)
+
+startIndex <- ((i - 1) * batchsize + 1)
+endIndex <- min(i * batchsize, length(S))
+
+
+for(s in S[startIndex:(endIndex - 1)]){
+ maxdate <- c(maxdate, DATA[[s]][[1]][nrow(DATA[[s]])])
+ midQuery <- paste0(midQuery, "'", s, "', ")
+}
+
+
+maxdate <- c(maxdate, DATA[[S[endIndex]]][[1]]
+ [nrow(DATA[[S[endIndex]]])])
+
+startDate <- max(maxdate)
+
+useCSV <- FALSE
+if( startDate <
+ substr(strptime(substr(Sys.time(), 0, 10), "%Y-%m-%d")
+ - 20 * 86400, 0, 10) ){
+ cat("Query is greater than 20 days. Updating with csv method.")
+ useCSV <- TRUE
+ break
+}
+
+startDate <- substr(as.character(strptime(startDate, "%Y-%m-%d") + 86400), 0, 10)
+endDate <- substr(Sys.time(), 0, 10)
+
+
+isUpdated <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) >= 40.25
+
+weekend <- sum(c("Saturday", "Sunday") %in%
+ weekdays(c(strptime(endDate, "%Y-%m-%d"),
+ c(strptime(startDate, "%Y-%m-%d"))))) == 2
+
+
+span <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) < 48
+
+runXMLupdate <- startDate <= endDate & !weekend & !span & isUpdated
+
+# Push back query date to validate extra days against adj. close
+startDateQuery <- substr(as.character(
+ strptime(startDate, "%Y-%m-%d") - 7 * 86400
+ ), 0, 10)
+
+
+
+if( runXMLupdate ){
+
+base <- "http://query.yahooapis.com/v1/public/yql?"
+begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in "
+midQuery <- paste0(midQuery, "'", S[min(i * batchsize, length(S))], "') ")
+endQuery <- paste0("and startDate = '", startDateQuery,
+ "' and endDate = '", endDate, "'")
+endParams <- "&diagnostics=true&env=store://datatables.org/alltableswithkeys"
+
+urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams)
+
+doc <- xmlParse(urlstr)
+
+df <- getNodeSet(doc, c("//query/results/quote"),
+ fun = function(v) xpathSApply(v,
+ c("./Date",
+ "./Open",
+ "./High",
+ "./Low",
+ "./Close",
+ "./Volume",
+ "./Adj_Close"),
+ xmlValue))
+
+if(length(df) != 0){
+
+symbols <- unname(sapply(
+ getNodeSet(doc, c("//query/results/quote")), xmlAttrs))
+
+df <- cbind(symbols, data.frame(t(data.frame(df, stringsAsFactors = FALSE)),
+ stringsAsFactors = FALSE, row.names = NULL))
+
+names(df) <- c("Symbol", "Date",
+ "Open", "High", "Low", "Close", "Volume", "Adj Close")
+
+df[,3:8] <- lapply(df[,3:8], as.numeric)
+df <- df[order(df[,1], decreasing = FALSE),]
+
+sym <- as.character(unique(df$Symbol))
+
+for(s in sym){
+
+ temp <- df[df$Symbol == s, 2:8]
+ temp <- temp[order(temp[,1], decreasing = FALSE),]
+
+ # Check if the Adj. Close data is equal for matching dates
+ # if not, save symbol to redownload later
+ if(any( !DATA[[s]][DATA[[s]][["Date"]] %in% temp[,1]]$"Adj Close" ==
+ temp[temp[,1] %in% DATA[[s]][["Date"]],7] ))
+ {
+
+ redownload <- c(redownload, s)
+
+ } else {
+
+ startDate <- DATA[[s]][["Date"]][nrow(DATA[[s]])]
+
+ DATA[[s]] <- DATA[[s]][order(DATA[[s]][[1]], decreasing = FALSE)]
+ DATA[[s]] <- rbind(DATA[[s]], temp[temp$Date > startDate,])
+ write.table(DATA[[s]][DATA[[s]][["Date"]] > startDate],
+ file = paste0(s, ".csv"), sep = ",",
+ row.names = FALSE, col.names = FALSE, append = TRUE)
+ }
+
+
+}
+}
+}
+}
+
+if( useCSV ){
+for(i in S){
+ maxdate <- DATA[[i]][["Date"]][nrow(DATA[[i]])]
+ isUpdated <- as.numeric(difftime(Sys.time(), maxdate, units = "hours")) >= 40.25
+ if( isUpdated ){
+
+ maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400
+
+ weekend <- sum(c("Saturday", "Sunday") %in%
+ weekdays(c(maxdate, Sys.time()))) == 2
+
+ span <- FALSE
+ if( weekend ){
+ span <- as.numeric(difftime(Sys.time(), maxdate, units = "hours")) < 48
+ }
+
+ # Push back query date to validate extra days against adj. close
+ startDateQuery <- maxdate - 7 * 86400
+
+ if(!weekend & !span){
+ c <- as.numeric(substr(startDateQuery, start = 1, stop = 4))
+ a <- as.numeric(substr(startDateQuery, start = 6, stop = 7)) - 1
+ b <- as.numeric(substr(startDateQuery, start = 9, stop = 10))
+ df <- yahoo(i, a = a, b = b, c = c)
+ if(!is.null(df)){
+ if(all(!is.na(df)) & nrow(df) > 0){
+
+ df <- df[nrow(df):1]
+
+ if( any(!DATA[[i]][DATA[[i]][["Date"]] %in% df[["Date"]]]$"Adj Close" ==
+ df[["Adj Close"]][df[["Date"]] %in% DATA[[i]][["Date"]]]) )
+ {
+
+ redownload <- c(redownload, i)
+
+ } else {
+ write.table(df, file = paste0(i, ".csv"), sep = ",",
+ row.names = FALSE, col.names = FALSE, append = TRUE)
+ DATA[[i]] <- rbind(DATA[[i]], df)
+ }
+
+ }
+ }
+ }
+ }
+}
+}
+
+
+
+# Re-download, store, and load into memory the symbols with
+# altered adj. close data
+setwd(DIR[["data"]])
+if(length(redownload) != 0){
+ for( i in redownload ){
+
+ df <- yahoo(i)
+ if(!is.null(df)) {
+ write.csv(df[nrow(df):1], file = paste0(i, ".csv"),
+ row.names = FALSE)
+ }
+
+ suppressWarnings(
+ DATA[[i]] <- fread(paste0(i, ".csv"), sep = ","))
+ DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)]
+
+}
+}
+
+
+rm(list = setdiff(ls(), c("S", "DATA", "DIR", "CONFIG")))
+gc()
diff --git a/Platform/model.R b/Platform/model.R
new file mode 100755
index 0000000..f8152ff
--- /dev/null
+++ b/Platform/model.R
@@ -0,0 +1,20 @@
+source("~/Platform/config.R")
+
+setwd(DIR[["root"]])
+cat("load.R\n\n")
+source("load.R")
+
+setwd(DIR[["compute"]])
+cat("MCinit.R\n\n")
+source("MCinit.R")
+
+cat("functions.R\n\n")
+source("functions.R")
+
+
+setwd(DIR[["model"]])
+cat("optimize.R\n\n")
+source("optimize.R")
+
+
+cat("\n")
diff --git a/Platform/model/evaluateFunc.R b/Platform/model/evaluateFunc.R
new file mode 100755
index 0000000..1d258c1
--- /dev/null
+++ b/Platform/model/evaluateFunc.R
@@ -0,0 +1,125 @@
+
+# Listng 8.1
+
+# Declare entry function for use inside evaluator
+entryfunc <- function(v, shThresh){
+ cols <- ncol(v) / 2
+ as.numeric(v[1,1:cols] <= 0 &
+ v[2,1:cols] > 0 &
+ v[2,(cols+1):(2*cols)] >
+ quantile(v[2,(cols+1):(2*cols)],
+ shThresh, na.rm = TRUE)
+ )
+}
+
+evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014,
+ transform = TRUE, verbose = FALSE,
+ negative = FALSE, transformOnly = FALSE,
+ returnData = FALSE, accountParams = NULL){
+
+ # Convert and declare parameters if they exist on domain (-inf,inf) domain
+ if( transform | transformOnly ){
+ PARAM <- minVal +
+ (maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) ))
+ if( transformOnly ){
+ return(PARAM)
+ }
+ }
+
+ # Max shares to hold
+ K <- CONFIG[["maxAssets"]]
+
+ # Declare n1 as itself, n2 as a multiple of n1 defined by nFact,
+ # and declare the length and threshold in sharpe ratio for FAVOR
+ n1 <- max(round(PARAM[["n1"]]), 2)
+ n2 <- max(round(PARAM[["nFact"]] * PARAM[["n1"]]), 3, n1+1)
+ nSharpe <- max(round(PARAM[["nSharpe"]]), 2)
+ shThresh <- max(0, min(PARAM[["shThresh"]], .99))
+ maxLookback <- max(n1, n2, nSharpe) + 1
+
+
+
+ # Subset data according to year, y
+ period <-
+ index(DATA[["Close"]]) >= strptime(paste0("01-01-", y[1]), "%d-%m-%Y") &
+ index(DATA[["Close"]]) < strptime(paste0("01-01-", y[length(y)]+1), "%d-%m-%Y")
+
+ period <- period |
+ ((1:nrow(DATA[["Close"]]) > (which(period)[1] - maxLookback)) &
+ (1:nrow(DATA[["Close"]]) <= (which(period)[sum(period)]) + 1))
+
+ CLOSE <- DATA[["Close"]][period,]
+ OPEN <- DATA[["Open"]][period,]
+ SUBRETURN <- RETURN[period,]
+
+
+ # Compute inputs for long-only MACD as in Listing 7.2
+ # Code is optimized for speed using functions from caTools and zoo
+ require(caTools)
+
+ INDIC <- zoo(runmean(CLOSE, n1, endrule = "NA", align = "right") -
+ runmean(CLOSE, n2, endrule = "NA", align = "right"),
+ order.by = index(CLOSE))
+ names(INDIC) <- names(CLOSE)
+
+
+ RMEAN <- zoo(runmean(SUBRETURN, n1, endrule = "NA", align = "right"),
+ order.by = index(SUBRETURN))
+
+ FAVOR <- RMEAN / runmean( (SUBRETURN - RMEAN)^2, nSharpe,
+ endrule = "NA", align = "right" )
+ names(FAVOR) <- names(CLOSE)
+
+
+ ENTRY <- rollapply(cbind(INDIC, FAVOR),
+ FUN = function(v) entryfunc(v, shThresh),
+ width = 2,
+ fill = NA,
+ align = "right",
+ by.column = FALSE)
+ names(ENTRY) <- names(CLOSE)
+
+ EXIT <- zoo(matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)),
+ order.by = index(CLOSE))
+ names(EXIT) <- names(CLOSE)
+
+
+
+ # Simulate and store results
+ if( is.null(accountParams) ){
+ RESULTS <- simulate(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, 100000,
+ 0.001, 0.01, 3.5, 0,
+ verbose, 0)
+ } else {
+ RESULTS <- simulate(OPEN, CLOSE,
+ ENTRY, EXIT, FAVOR,
+ maxLookback, K, accountParams[["C"]],
+ 0.001, 0.01, 3.5, 0,
+ verbose, 0,
+ initP = accountParams[["P"]], initp = accountParams[["p"]])
+ }
+
+
+ if(!returnData){
+
+ # Compute and return sharpe ratio
+ v <- RESULTS[["equity"]]
+ returns <- ( v[-1] / v[-length(v)] ) - 1
+ out <- mean(returns, na.rm = T) / sd(returns, na.rm = T)
+ if(!is.nan(out)){
+ if( negative ){
+ return( -out )
+ } else {
+ return( out )
+ }
+ } else {
+ return(0)
+ }
+
+ } else {
+ return(RESULTS)
+ }
+
+}
diff --git a/Platform/model/optimize.R b/Platform/model/optimize.R
new file mode 100755
index 0000000..4056e74
--- /dev/null
+++ b/Platform/model/optimize.R
@@ -0,0 +1,14 @@
+setwd(DIR[["model"]])
+
+minVal <- CONFIG[["minVal"]]
+maxVal <- CONFIG[["maxVal"]]
+PARAM <- CONFIG[["PARAMnaught"]]
+
+source("evaluateFunc.R")
+source("optimizeFunc.R")
+
+PARAMout <- optimize(y = CONFIG[["y"]], minVal, maxVal)
+
+setwd(DIR[["plan"]])
+
+write.csv(data.frame(PARAMout), "stratParams.csv")
diff --git a/Platform/model/optimizeFunc.R b/Platform/model/optimizeFunc.R
new file mode 100755
index 0000000..a8fbc41
--- /dev/null
+++ b/Platform/model/optimizeFunc.R
@@ -0,0 +1,127 @@
+# Example optimization function coded for
+# Generalized pattern search (Listing 8.4)
+optimize <- function(y, minVal, maxVal){
+
+
+# Maximum iterations
+# Max possible calls to evaluator is K * (4 * n + 1)
+K <- CONFIG[["maxIter"]]
+
+# Restart with random init when delta is below threshold
+deltaThresh <- 0.05
+
+# Set initial delta
+delta <- deltaNaught <- 1
+
+# Scale factor
+sigma <- 2
+
+
+# Vector theta_0
+PARAM <- PARAMNaught <- CONFIG[["PARAMnaught"]]
+
+np <- length(PARAM)
+
+OPTIM <- data.frame(matrix(NA, nrow = K * (4 * np + 1), ncol = np + 1))
+names(OPTIM) <- c(names(PARAM), "obj"); o <- 1
+
+fmin <- fminNaught <- evaluate(PARAM, minVal, maxVal, negative = TRUE, y = y)
+OPTIM[o,] <- c(PARAM, fmin); o <- o + 1
+
+
+# Print function for reporting progress in loop
+printUpdate <- function(step){
+ if(step == "search"){
+ cat(paste0("Search step: ", k,"|",l,"|",m, "\n"))
+ } else if (step == "poll"){
+ cat(paste0("Poll step: ", k,"|",l,"|",m, "\n"))
+ }
+ names(OPTIM)
+ cat("\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n")
+ cat("Best:\t", paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n")
+ cat("Theta:\t", paste0(round(unlist(c(PARAM, fmin)),3), "\t"), "\n")
+ cat("Trial:\t", paste0(round(as.numeric(OPTIM[o-1,]), 3), "\t"), "\n")
+ cat(paste0("Delta: ", round(delta,3) , "\t"), "\n\n")
+}
+
+for( k in 1:K ){
+
+ # SEARCH subroutine
+ for( l in 1:np ){
+ net <- (2 * rbinom(np, 1, .5) - 1) * runif(np, delta, sigma * delta)
+ for( m in c(-1,1) ){
+
+ testpoint <- PARAM + m * net
+ ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(testpoint, ftest); o <- o + 1
+ printUpdate("search")
+
+ }
+ }
+
+ if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){
+
+ minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)])
+ PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,]
+ fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos]
+ delta <- sigma * delta
+
+ } else {
+
+ # POLL Subroutine
+ for( l in 1:np ){
+ net <- delta * as.numeric(1:np == l)
+ for( m in c(-1,1) ){
+
+ testpoint <- PARAM + m * net
+ ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y)
+ OPTIM[o,] <- c(testpoint, ftest); o <- o + 1
+ printUpdate("poll")
+
+ }
+ }
+
+ if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){
+
+ minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)])
+ PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,]
+ fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos]
+ delta <- sigma * delta
+
+ } else {
+
+ delta <- delta / sigma
+
+ }
+
+
+ }
+
+ cat(paste0("\nCompleted Full Iteration: ", k, "\n\n"))
+
+ # Restart with random initiate
+ if( delta < deltaThresh ) {
+
+ delta <- deltaNaught
+ fmin <- fminNaught
+ PARAM <- PARAMNaught + runif(n = np, min = -delta * sigma,
+ max = delta * sigma)
+
+ ftest <- evaluate(PARAM, minVal, maxVal,
+ negative = TRUE, y = y)
+ OPTIM[o,] <- c(PARAM, ftest); o <- o + 1
+
+ cat(paste0("\nDelta Threshold Breached, Restarting with Random Initiate\n\n"))
+
+ }
+
+}
+
+# Return the best optimization in untransformed parameters
+return(
+ evaluate(OPTIM[which.min(OPTIM$obj),1:np],
+ minVal, maxVal, transformOnly = TRUE)
+)
+
+
+}
diff --git a/Platform/plan.R b/Platform/plan.R
new file mode 100755
index 0000000..ef983ad
--- /dev/null
+++ b/Platform/plan.R
@@ -0,0 +1,21 @@
+source("~/Platform/config.R")
+
+
+setwd(DIR[["root"]])
+cat("load.R\n\n")
+source("load.R")
+
+
+setwd(DIR[["compute"]])
+cat("MCinit.R\n\n")
+source("MCinit.R")
+
+cat("functions.R\n\n")
+source("functions.R")
+
+setwd(DIR[["plan"]])
+cat("decisionGen.R\n\n")
+source("decisionGen.R")
+
+
+cat("\n")
diff --git a/Platform/plan/decisionGen.R b/Platform/plan/decisionGen.R
new file mode 100755
index 0000000..1b07bc0
--- /dev/null
+++ b/Platform/plan/decisionGen.R
@@ -0,0 +1,219 @@
+# Listing 9.1
+setwd(DIR[["plan"]])
+
+
+# Normally declared by your strategy.
+# Long-only MACD is computed with rollapply()
+# here for sake of example.
+n1 <- 5
+n2 <- 34
+nSharpe <- 20
+shThresh <- 0.50
+
+INDIC <- rollapply(DATA[["Close"]][nrow(DATA[["Close"]]) - n2:0, ],
+ width = n2,
+ FUN = function(v) mean(v[(n2 - n1 + 1):n2]) - mean(v),
+ by.column = TRUE,
+ align = "right")
+
+
+
+FAVOR <- rollapply(DATA[["Close"]][nrow(DATA[["Close"]]) - nSharpe:0, ],
+ FUN = function(v) mean(v, na.rm = TRUE)/sd(v, na.rm = TRUE),
+ by.column = TRUE,
+ width = nSharpe,
+ align = "right")
+
+
+entryfunc <- function(v, shThresh){
+ cols <- ncol(v) / 2
+ as.numeric(v[1,1:cols] <= 0 &
+ v[2,1:cols] > 0 &
+ v[2,(cols+1):(2*cols)] >
+ quantile(v[2,(cols+1):(2*cols)],
+ shThresh, na.rm = TRUE)
+ )
+}
+
+
+cols <- ncol(INDIC)
+
+ENTRY <- rollapply(cbind(INDIC, FAVOR),
+ function(v) entryfunc(v, cols),
+ by.column = FALSE,
+ width = 2,
+ align = "right")
+
+
+# ***IMPORTANT***
+# The quick version used in the PLAN job accepts named vectors
+# respresenting the most recent single row of ENTRY, FAVOR, and EXIT.
+# These lines convert the zoo/data frame/matrix objects computed
+# in the above lines to named vectors of the last row of data.
+
+FAVOR <- as.numeric(FAVOR[nrow(FAVOR),])
+names(FAVOR) <- names(DATA[["Close"]])
+
+ENTRY <- as.numeric(ENTRY[nrow(ENTRY),])
+names(ENTRY) <- names(DATA[["Close"]])
+
+EXIT <- zoo(matrix(0, ncol=ncol(DATA[["Close"]]), nrow = 1),
+ order.by = index(DATA[["Close"]]))
+names(EXIT) <- names(DATA[["Close"]])
+
+
+
+# Normally fetched from brokerage.
+# These are arbitrarily declared here.
+# Users need to fetch this information from the brokerage
+# for production use.
+currentlyLong <- c("AA", "AAL", "AAPL")
+currentlyShort <- c("")
+S <- names(DATA[["Close"]])
+initP <- (S %in% currentlyLong) - (S %in% currentlyShort)
+cashOnHand <- 54353.54
+
+
+
+names(initP) <-
+ names(FAVOR) <-
+ names(ENTRY) <-
+ names(EXIT) <-
+ names(DATA[["Close"]])
+
+
+# At this point we have established everything normally
+# taken care of by your strategy.
+# Given named vectors of length ncol(DATA[["Close"]])
+# initP, FAVOR, ENTRY, and EXIT
+
+maxAssets <- CONFIG[["maxAssets"]]
+
+K <- maxAssets
+k <- 0
+C <- c(cashOnHand, NA)
+S <- names(DATA[["Close"]])
+P <- initP
+
+
+# Normally declared by your strategy
+FAVOR <- rnorm(ncol(DATA[["Close"]]))
+ENTRY <- rbinom(ncol(DATA[["Close"]]), 1, .005) -
+ rbinom(ncol(DATA[["Close"]]), 1, .005)
+EXIT <- rbinom(ncol(DATA[["Close"]]), 1, .8) -
+ rbinom(ncol(DATA[["Close"]]), 1, .8)
+
+# Normally fetched from brokerage
+currentlyLong <- c("AA", "AAL", "AAPL")
+currentlyShort <- c("RAI", "RCL", "REGN")
+S <- names(DATA[["Close"]])
+initP <- (S %in% currentlyLong) - (S %in% currentlyShort)
+
+names(initP) <-
+ names(FAVOR) <-
+ names(ENTRY) <-
+ names(EXIT) <-
+ names(DATA[["Close"]])
+
+
+# At this point we have established everything normally
+# taken care of by your strategy.
+# Given named vectors of length ncol(DATA[["Close"]])
+# initP, FAVOR, ENTRY, and EXIT
+
+maxAssets <- 10
+startingCash <- 100000
+
+K <- maxAssets
+k <- 0
+C <- c(startingCash, NA)
+S <- names(DATA[["Close"]])
+P <- initP
+
+
+# Step 4
+longS <- S[which(P > 0)]
+shortS <- S[which(P < 0)]
+k <- length(longS) + length(shortS)
+
+# Step 5
+longTrigger <- setdiff(S[which(ENTRY == 1)], longS)
+shortTrigger <- setdiff(S[which(ENTRY == -1)], shortS)
+trigger <- c(longTrigger, shortTrigger)
+
+if( length(trigger) > K ) {
+
+ keepTrigger <- trigger[order(c(as.numeric(FAVOR[longTrigger]),
+ -as.numeric(FAVOR[shortTrigger])),
+ decreasing = TRUE)][1:K]
+
+ longTrigger <- longTrigger[longTrigger %in% keepTrigger]
+ shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger]
+
+ trigger <- c(longTrigger, shortTrigger)
+
+}
+
+triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger)))
+
+
+# Step 6
+longExitTrigger <- longS[longS %in% S[which(EXIT == 1 | EXIT == 999)]]
+
+shortExitTrigger <- shortS[shortS %in% S[which(EXIT == -1 | EXIT == 999)]]
+
+exitTrigger <- c(longExitTrigger, shortExitTrigger)
+
+
+# Step 7
+needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0)
+
+if( needToExit > 0 ){
+
+ toExitLongS <- setdiff(longS, exitTrigger)
+ toExitShortS <- setdiff(shortS, exitTrigger)
+
+ toExit <- character(0)
+
+ for( counter in 1:needToExit ){
+ if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){
+ if( min(FAVOR[toExitLongS]) < min(-FAVOR[toExitShortS]) ){
+ pullMin <- which.min(FAVOR[toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else {
+ pullMin <- which.min(-FAVOR[toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){
+ pullMin <- which.min(FAVOR[toExitLongS])
+ toExit <- c(toExit, toExitLongS[pullMin])
+ toExitLongS <- toExitLongS[-pullMin]
+ } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){
+ pullMin <- which.min(-FAVOR[toExitShortS])
+ toExit <- c(toExit, toExitShortS[pullMin])
+ toExitShortS <- toExitShortS[-pullMin]
+ }
+ }
+
+ longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit])
+ shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit])
+
+}
+
+# Step 8
+exitTrigger <- c(longExitTrigger, shortExitTrigger)
+exitTriggerType <- c(rep(1, length(longExitTrigger)),
+ rep(-1, length(shortExitTrigger)))
+
+
+setwd(DIR[["plan"]])
+
+# First exit these
+write.csv(file = "stocksToExit.csv",
+ data.frame(list(sym = exitTrigger, type = exitTriggerType)))
+
+# Then enter these
+write.csv(file = "stocksToEnter.csv",
+ data.frame(list(sym = trigger, type = triggerType)))
diff --git a/Platform/trade.R b/Platform/trade.R
new file mode 100755
index 0000000..533b896
--- /dev/null
+++ b/Platform/trade.R
@@ -0,0 +1,8 @@
+# First exit these
+toExit <- read.csv(file = "stocksToExit.csv")
+
+# Then enter these
+toEnter <- read.csv(file = "stocksToEnter.csv")
+
+# This is open-ended...
+# This may be done inside or outside R depending on choice of brokerage and AP
diff --git a/Platform/update.R b/Platform/update.R
new file mode 100755
index 0000000..bd97e20
--- /dev/null
+++ b/Platform/update.R
@@ -0,0 +1,15 @@
+source("~/Platform/config.R")
+
+setwd(DIR[["load"]])
+cat("initial.R\n\n")
+source("initial.R")
+
+setwd(DIR[["load"]])
+cat("loadToMemory.R\n\n")
+source("loadToMemory.R")
+
+setwd(DIR[["load"]])
+cat("updateStocks.R\n\n")
+source("updateStocks.R")
+
+cat("\n")
diff --git a/README.md b/README.md
new file mode 100755
index 0000000..ccd0536
--- /dev/null
+++ b/README.md
@@ -0,0 +1,15 @@
+#Apress Source Code
+
+This repository accompanies [*Automated Trading with R*](http://www.apress.com/9781484221778) by Christopher Conlan (Apress, 2016).
+
+
+
+Download the files as a zip using the green button, or clone the repository to your machine using Git.
+
+##Releases
+
+Release v1.0 corresponds to the code in the published book, without corrections or updates.
+
+##Contributions
+
+See the file Contributing.md for more information on how you can contribute to this repository.
diff --git a/contributing.md b/contributing.md
new file mode 100755
index 0000000..905ff61
--- /dev/null
+++ b/contributing.md
@@ -0,0 +1,14 @@
+# Contributing to Apress Source Code
+
+Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers.
+
+## How to Contribute
+
+1. Make sure you have a GitHub account.
+2. Fork the repository for the relevant book.
+3. Create a new branch on which to make your change, e.g.
+`git checkout -b my_code_contribution`
+4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted.
+5. Submit a pull request.
+
+Thank you for your contribution!
\ No newline at end of file