├── Examples ├── cv-NelderMead-MACD.R └── quandl-run.R ├── Listings ├── Appendix B │ ├── B-1.R │ ├── B-2.R │ ├── B-3.R │ ├── B-4.R │ └── UNIX-mcTimeSeries.R ├── Chapter 1 │ ├── 1-1.R │ ├── 1-10.R │ ├── 1-2.R │ ├── 1-3.R │ ├── 1-4.R │ ├── 1-5.R │ ├── 1-6.R │ ├── 1-7.R │ ├── 1-8.R │ └── 1-9.R ├── Chapter 10 │ ├── 10-1.R │ ├── 10-10 │ ├── 10-2.bat │ ├── 10-3.bat │ ├── 10-4.bat │ ├── 10-5.bat │ ├── 10-6.bat │ ├── 10-7.txt │ ├── 10-8.sh │ └── 10-9.sh ├── Chapter 2 │ ├── 2-1.R │ ├── 2-2.R │ ├── 2-3-quandl.R │ ├── 2-3.R │ ├── 2-4-quandl.R │ ├── 2-4.R │ ├── 2-5.R │ ├── 2-6.R │ ├── 2-7.R │ └── 2-8.R ├── Chapter 3 │ ├── 3-1.R │ ├── 3-2.R │ ├── 3-3.R │ ├── 3-4.R │ ├── 3-5.R │ ├── 3-6.R │ ├── 3-7.R │ └── 3-8.R ├── Chapter 4 │ ├── 4-1.R │ ├── 4-2.R │ ├── 4-3.R │ ├── 4-4.R │ └── 4-5.R ├── Chapter 6 │ ├── 6-1.R │ ├── 6-10.R │ ├── 6-11.R │ ├── 6-12.R │ ├── 6-13.R │ ├── 6-2.R │ ├── 6-3.R │ ├── 6-4.R │ ├── 6-5.R │ ├── 6-6.R │ ├── 6-7.R │ ├── 6-8.R │ └── 6-9.R ├── Chapter 7 │ ├── 7-1.R │ ├── 7-2.R │ ├── 7-3.R │ ├── 7-4.R │ └── 7-5.R ├── Chapter 8 │ ├── 8-1.R │ ├── 8-2.R │ ├── 8-3.R │ ├── 8-4.R │ ├── 8-5.R │ ├── 8-6.R │ └── sampleOptimizeWrapper.R └── Chapter 9 │ ├── 9-1.R │ ├── 9-10.R │ ├── 9-11.R │ ├── 9-2.xml │ ├── 9-3.txt │ ├── 9-4.txt │ ├── 9-5.R │ ├── 9-6.R │ ├── 9-7.xml │ ├── 9-8.R │ └── 9-9.R ├── Platform ├── S.R ├── SPdates.R ├── compute │ ├── MCinit.R │ └── functions.R ├── config.R ├── functions │ ├── quandl.R │ └── yahoo.R ├── invalid.R ├── load.R ├── load │ ├── adjustClose.R │ ├── dateUnif.R │ ├── fillInactive.R │ ├── initial.R │ ├── loadToMemory.R │ ├── return.R │ ├── spClean.R │ └── updateStocks.R ├── model.R ├── model │ ├── evaluateFunc.R │ ├── optimize.R │ └── optimizeFunc.R ├── plan.R ├── plan │ └── decisionGen.R ├── trade.R └── update.R └── README.md /Examples/cv-NelderMead-MACD.R: -------------------------------------------------------------------------------- 1 | ########################################### 2 | ### This script is a one-piece runnable ### 3 | ### example constructed from code in ### 4 | ### the text. It is Windows and UNIX ### 5 | ### compatible. ### 6 | ########################################### 7 | 8 | 9 | # The goal is to generate a cross-validated 10 | # equity curve based on Nelder-Mead optimization 11 | # using the long-Only MACD strategy by 12 | # using the most possible availabe data to 13 | # optimize at each year. i.e. 2012 uses data 14 | # from 2000 through 2011. This will take considerable 15 | # time to run. It projects returns in excess of 16 | # buy-and-hold returns for SPY over the approx. 17 | # 11 years it trades. 18 | 19 | 20 | ####Listing 2.1: Setting Path Variables#### 21 | rootdir <- "~/AutoTrading/" 22 | datadir <- "~/AutoTrading/stockdata/" 23 | functiondir <- "~/AutoTrading/functions/" 24 | #### 25 | 26 | ####Listing 2.2: Yahoo! Finance CSV API Function#### 27 | yahoo <- function(sym, current = TRUE, 28 | a = 0, b = 1, c = 2000, d, e, f, 29 | g = "d") 30 | { 31 | if(current){ 32 | f <- as.numeric(substr(as.character(Sys.time()), start = 1, stop = 4)) 33 | d <- as.numeric(substr(as.character(Sys.time()), start = 6, stop = 7)) - 1 34 | e <- as.numeric(substr(as.character(Sys.time()), start = 9, stop = 10)) 35 | } 36 | require(data.table) 37 | tryCatch( 38 | suppressWarnings( 39 | fread(paste0("http://ichart.yahoo.com/table.csv", 40 | "?s=", sym, 41 | "&a=", a, 42 | "&b=", b, 43 | "&c=", c, 44 | "&d=", d, 45 | "&e=", e, 46 | "&f=", f, 47 | "&g=", g, 48 | "&ignore=.csv"), sep = ",")), 49 | error = function(e) NULL 50 | ) 51 | } 52 | setwd(functiondir) 53 | dump(list = c("yahoo"), "yahoo.R") 54 | ##### 55 | 56 | 57 | 58 | ####Listing 2.3: List of S&P 500 Stocks#### 59 | # Up-to-date at time of writing 60 | url <- "http://trading.chrisconlan.com/SPstocks.csv" 61 | S <- as.character(read.csv(url, header = FALSE)[,1]) 62 | 63 | #S <- read.csv(url, header = FALSE, stringsAsFactors=F)[,1] 64 | #S2 = fread(url, header = FALSE) 65 | setwd(rootdir) 66 | dump(list = "S", "S.R") 67 | ##### 68 | 69 | 70 | 71 | ####Listing 2.4: Initial Directory Loader#### 72 | # Load "invalid.R" file if available 73 | invalid <- character(0) 74 | setwd(rootdir) 75 | if("invalid.R" %in% list.files()) source("invalid.R") 76 | 77 | # Find all symbols not in directory and not missing 78 | setwd(datadir) 79 | toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid) 80 | 81 | # Fetch symbols with yahoo function, save as .csv or missing 82 | source(paste0(functiondir, "yahoo.R")) 83 | if(length(toload) != 0){ 84 | for(i in 1:length(toload)){ 85 | df <- yahoo(toload[i]) 86 | if(!is.null(df)) { 87 | write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"), 88 | row.names = FALSE) 89 | } else { 90 | invalid <- c(invalid, toload[i]) 91 | } 92 | }} 93 | setwd(rootdir) 94 | dump(list = c("invalid"), "invalid.R") 95 | ################ 96 | 97 | 98 | # Clears R environment except for path variables and functions 99 | rm(list = setdiff(ls(), c("rootdir", "functiondir", "datadir", "yahoo"))) 100 | 101 | 102 | ####Listing 2.5: Loading Data into Memory#### 103 | setwd(datadir) 104 | S <- sub(".csv", "", list.files()) 105 | require(data.table) 106 | DATA <- list() 107 | for(i in S){ 108 | suppressWarnings( 109 | DATA[[i]] <- fread(paste0(i, ".csv"), sep = ",")) 110 | DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)] 111 | } 112 | ##### 113 | 114 | 115 | ####Listing 2.6: CSV Update Method#### 116 | for(i in S){ 117 | maxdate <- DATA[[i]][["Date"]][nrow(DATA[[i]])] 118 | if(as.numeric(difftime(Sys.time(), maxdate, units = "hours")) >= 40.25){ 119 | maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400 120 | weekend <- sum(c("Saturday", "Sunday") %in% 121 | weekdays(c(maxdate, Sys.time()))) == 2 122 | span <- as.numeric(difftime(Sys.time(), maxdate, units = "hours")) < 48 123 | if(!weekend & !span){ 124 | c <- as.numeric(substr(maxdate, start = 1, stop = 4)) 125 | a <- as.numeric(substr(maxdate, start = 6, stop = 7)) - 1 126 | b <- as.numeric(substr(maxdate, start = 9, stop = 10)) 127 | df <- yahoo(i, a = a, b = b, c = c) 128 | if(!is.null(df)){ 129 | if(all(!is.na(df)) & nrow(df) > 0){ 130 | df <- df[nrow(df):1] 131 | write.table(df, file = paste0(i, ".csv"), sep = ",", 132 | row.names = FALSE, col.names = FALSE, append = TRUE) 133 | DATA[[i]] <- rbind(DATA[[i]], df) 134 | } 135 | } 136 | } 137 | } 138 | } 139 | ####### 140 | 141 | 142 | ############################ 143 | 144 | 145 | ####Listing 2.7: YQL Update Method#### 146 | setwd(datadir) 147 | library(XML) 148 | batchsize <- 101 149 | # i in 1:5 for this example 150 | for(i in 1:(ceiling(length(S) / batchsize)) ){ 151 | midQuery <- " (" 152 | maxdate <- character(0) 153 | startIndex <- ((i - 1) * batchsize + 1) 154 | endIndex <- min(i * batchsize, length(S)) 155 | 156 | # find earliest date and build query 157 | for(s in S[startIndex:(endIndex - 1)]){ 158 | maxdate <- c(maxdate, DATA[[s]][[1]][nrow(DATA[[s]])]) 159 | midQuery <- paste0(midQuery, "’", s, "’, ") 160 | } 161 | maxdate <- c(maxdate, DATA[[S[endIndex]]][[1]] 162 | [nrow(DATA[[S[endIndex]]])]) 163 | startDate <- max(maxdate) 164 | if( startDate < 165 | substr(strptime(substr(Sys.time(), 0, 10), "%Y-%m-%d") 166 | - 28 * 86400, 0, 10) ){ 167 | cat("Query is greater than 20 trading days. Download with csv method.") 168 | break 169 | } 170 | 171 | # Adds a day (86400 seconds) to the earliest date to avoid duplicates 172 | startDate <- substr(as.character(strptime(startDate, "%Y-%m-%d") + 86400), 0, 10) 173 | endDate <- substr(Sys.time(), 0, 10) 174 | 175 | # Yahoo! updates at 4:15 EST at earliest, check if it is past 4:15 day after last 176 | isUpdated <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) >= 40.25 177 | 178 | # If both days fall in the same weekend, we will not attempt to update 179 | weekend <- sum(c("Saturday", "Sunday") %in% 180 | weekdays(c(strptime(endDate, "%Y-%m-%d"), 181 | c(strptime(startDate, "%Y-%m-%d"))))) == 2 182 | 183 | span <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) < 48 184 | 185 | if( startDate <= endDate & 186 | !weekend & 187 | !span & 188 | isUpdated ){ 189 | 190 | # Piece this extremely long URL together 191 | base <- "http://query.yahooapis.com/v1/public/yql?" 192 | begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in " 193 | midQuery <- paste0(midQuery, "’", S[min(i * batchsize, length(S))], "’) ") 194 | endQuery <- paste0("and startDate = ’", startDate, 195 | "’ and endDate = ’", endDate, "’") 196 | endParams <- "&diagnostics=true&env=store://datatables.org/alltableswithkeys" 197 | urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams) 198 | urlstr=gsub("’", "'", urlstr) 199 | 200 | # Fetch data and arrange in XML tree 201 | doc <- xmlParse(urlstr) 202 | 203 | # The next few lines rely heavily and XPath and quirks 204 | # of S4 objects in the XML package in R. 205 | # We retrieve every node (or branch) on //query/results/quote 206 | # and retrieve the values Date, Open, High, etc. from the branch 207 | df <- getNodeSet(doc, c("//query/results/quote"), 208 | fun = function(v) xpathSApply(v, 209 | c("./Date", 210 | "./Open", 211 | "./High", 212 | "./Low", 213 | "./Close", 214 | "./Volume", 215 | "./Adj_Close"), 216 | xmlValue)) 217 | 218 | # If the URL found data we organize and update 219 | if(length(df) != 0){ 220 | 221 | # We get the atrributes from the same tree, which happen 222 | # to be dates we need 223 | symbols <- unname(sapply( 224 | getNodeSet(doc, c("//query/results/quote")), xmlAttrs)) 225 | df <- cbind(symbols, data.frame(t(data.frame(df, stringsAsFactors = FALSE)), 226 | stringsAsFactors = FALSE, row.names = NULL)) 227 | names(df) <- c("Symbol", "Date", 228 | "Open", "High", "Low", "Close", "Volume", "Adj Close") 229 | df[,3:8] <- lapply(df[,3:8], as.numeric) 230 | df <- df[order(df[,1], decreasing = FALSE),] 231 | sym <- as.character(unique(df$Symbol)) 232 | for(s in sym){ 233 | temp <- df[df$Symbol == s, 2:8] 234 | temp <- temp[order(temp[,1], decreasing = FALSE),] 235 | startDate <- DATA[[s]][["Date"]][nrow(DATA[[s]])] 236 | DATA[[s]] <- DATA[[s]][order(DATA[[s]][[1]], decreasing = FALSE)] 237 | DATA[[s]] <- rbind(DATA[[s]], temp[temp$Date > startDate,]) 238 | write.table(DATA[[s]][DATA[[s]][["Date"]] > startDate], 239 | file = paste0(s, ".csv"), sep = ",", 240 | row.names = FALSE, col.names = FALSE, append = TRUE) 241 | }}}} 242 | ###### 243 | 244 | 245 | ####Listing 2.8: Organizing as Date-Uniform zoo Object#### 246 | library(zoo) 247 | 248 | # Compute the date template as a column of a data.frame for merging 249 | datetemp <- sort(unique(unlist(sapply(DATA, function(v) v[["Date"]])))) 250 | datetemp <- data.frame(datetemp, stringsAsFactors = FALSE) 251 | names(datetemp) <- "Date" 252 | 253 | # Double-check that our data is unique and in ascending-date order 254 | DATA <- lapply(DATA, function(v) unique(v[order(v$Date),])) 255 | 256 | # Create 6 new objects that will hold our re-orgainzed data 257 | DATA[["Open"]] <- DATA[["High"]] <- DATA[["Low"]] <- 258 | DATA[["Close"]] <- DATA[["Adj Close"]] <- DATA[["Volume"]] <- datetemp 259 | 260 | # This loop will sequentially append the columns of each symbol 261 | # to the appropriate Open, High, Low, etc. object 262 | for(s in S){ 263 | for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){ 264 | temp <- data.frame(cbind(DATA[[s]][["Date"]], DATA[[s]][[i]]), 265 | stringsAsFactors = FALSE) 266 | names(temp) <- c("Date", s) 267 | temp[,2] <- as.numeric(temp[,2]) 268 | if(!any(!DATA[[i]][["Date"]][(nrow(DATA[[i]]) - nrow(temp)+1):nrow(DATA[[i]])] 269 | == temp[,1])){ 270 | temp <- rbind(t(matrix(nrow = 2, ncol = nrow(DATA[[i]]) - nrow(temp), 271 | dimnames = list(names(temp)))), temp) 272 | DATA[[i]] <- cbind(DATA[[i]], temp[,2]) 273 | } else { 274 | DATA[[i]] <- merge(DATA[[i]], temp, all.x = TRUE, by = "Date") 275 | } 276 | names(DATA[[i]]) <- c(names(DATA[[i]])[-(ncol(DATA[[i]]))], s) 277 | } 278 | DATA[[s]] <- NULL 279 | if(which(S==s) %% 25 == 0 ){ print(paste(which(S==s),"/", length(S))) } 280 | } 281 | 282 | 283 | # Declare them as zoo objects for use with time-series functions 284 | DATA <- lapply(DATA, function(v) zoo(v[,2:ncol(v)], strptime(v[,1], "%Y-%m-%d"))) 285 | # Remove extra variables 286 | 287 | rm(list = setdiff(ls(), c("DATA", "datadir", "functiondir", "rootdir"))) 288 | #### 289 | 290 | ############## 291 | 292 | ####Listing 3.1: Eliminating pre-S&P Data#### 293 | setwd(rootdir) 294 | if( "SPdates.R" %in% list.files() ){ 295 | source("SPdates.R") 296 | } else { 297 | url <- "http://trading.chrisconlan.com/SPdates.csv" 298 | S <- read.csv(url, header = FALSE, stringsAsFactors = FALSE) 299 | dump(list = "S", "SPdates.R") 300 | } 301 | names(S) <- c("Symbol", "Date") 302 | S$Date <- strptime(S$Date, "%m/%d/%Y") 303 | for(s in names(DATA[["Close"]])){ 304 | for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){ 305 | Sindex <- which(S[,1] == s) 306 | if(S[Sindex, "Date"] != "1900-01-01 EST" & 307 | S[Sindex, "Date"] >= "2000-01-01 EST"){ 308 | DATA[[i]][index(DATA[[i]]) <= S[Sindex, "Date"], s] <- NA 309 | } 310 | } 311 | if(which(names(DATA[["Close"]])==s) %% 25 == 0 ){ print(paste(which(names(DATA[["Close"]])==s),"/", nrow(S))) } 312 | } 313 | ###### 314 | 315 | 316 | 317 | 318 | ####Listing 3.6: Adjusting OHLC Data#### 319 | # Declare new zoo data frame of adjustment factors 320 | MULT <- DATA[["Adj Close"]] / DATA[["Close"]] 321 | 322 | # Store Close and Open Prices in new variable "Price" and "OpenPrice" 323 | DATA[["Price"]] <- DATA[["Close"]] 324 | DATA[["OpenPrice"]] <- DATA[["Open"]] 325 | 326 | # Adjust Open, High, and Low 327 | DATA[["Open"]] <- DATA[["Open"]] * MULT 328 | DATA[["High"]] <- DATA[["High"]] * MULT 329 | DATA[["Low"]] <- DATA[["Low"]] * MULT 330 | 331 | # Copy Adjusted Close to Close 332 | DATA[["Close"]] <- DATA[["Adj Close"]] 333 | 334 | # Delete Adjusted Close 335 | DATA[["Adj Close"]] <- NULL 336 | ###### 337 | 338 | 339 | ####Listing 3.7: Forward Replacement on Inactive Symbols#### 340 | for(s in names(DATA[["Close"]]) ){ 341 | if(is.na(DATA[["Close"]][nrow(DATA[["Close"]]), s])){ 342 | maxInd <- max(which(!is.na(DATA[["Close"]][,s]))) 343 | for( i in c("Close", "Open", "High", "Low")){ 344 | DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Close"]][maxInd,s] 345 | } 346 | for( i in c("Price", "OpenPrice") ){ 347 | DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Price"]][maxInd,s] 348 | } 349 | DATA[["Volume"]][(maxInd+1):nrow(DATA[["Close"]]),s] <- 0 350 | } 351 | } 352 | ####### 353 | 354 | 355 | 356 | ####Listing 3.8: Computing Return Matrices#### 357 | # Pad with NA’s to perserver dimension equality 358 | NAPAD <- zoo(matrix(NA, nrow = 1, ncol = ncol(DATA[["Close"]])), 359 | order.by = index(DATA[["Close"]])[1]) 360 | names(NAPAD) <- names(DATA[["Close"]]) 361 | 362 | # Compute Daily Close-to-Close Returns 363 | RETURN <- rbind( NAPAD, ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 ) 364 | 365 | # Compute Overnight Returns (Close-to-Open) 366 | OVERNIGHT <- rbind( NAPAD, ( DATA[["Open"]] / lag(DATA[["Close"]], k = -1) ) - 1 ) 367 | ###### 368 | 369 | 370 | 371 | ####Listing 6.7: Registering Parallel Backend in Windows#### 372 | library(doParallel) 373 | workers <- 4 374 | registerDoParallel( cores = workers ) 375 | #stopImplicitCluster() 376 | ######### 377 | 378 | 379 | ####Listing 6.9: Integer Mapping for Multicore Time Series Computations#### 380 | delegate <- function( i = i, n = n, k = k, p = workers ){ 381 | nOut <- n - k + 1 382 | nProc <- ceiling( nOut / p ) 383 | return( (( i - 1 ) * nProc + 1) : min(i * nProc + k - 1, n) ) 384 | } 385 | ######### 386 | 387 | 388 | ####Listing 6.12: Wrapper Function for Multicore Time Series Computations#### 389 | mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers, ...){ 390 | # On windows, objects in the global environment are not attached when 391 | # foreach is called from within a function. Only the arguments of the 392 | # function call are attached. So we will first get a list of the arguments 393 | # and all objects in the global environment. Then we will remove the 394 | # duplicates. 395 | args <- names(mget(ls())) 396 | exports <- ls(.GlobalEnv) 397 | exports <- exports[!exports %in% args] 398 | 399 | SERIES <- foreach( i = 1:workers, .combine = rbind, 400 | .packages="zoo", .export=exports) %dopar% { 401 | jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers) 402 | rollapply(data[jRange,], 403 | width = windowSize, 404 | FUN = tsfunc, 405 | align = "right", 406 | by.column = byColumn) 407 | } 408 | names(SERIES) <- gsub("\\..+", "", names(SERIES)) 409 | 410 | if( windowSize > 1){ 411 | PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA), 412 | order.by = index(data)[1:(windowSize-1)]) 413 | names(PAD) <- names(SERIES) 414 | SERIES <- rbind(PAD, SERIES) 415 | } 416 | if(is.null(names(SERIES))){ 417 | names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)]) 418 | } 419 | return(SERIES) 420 | } 421 | ####### 422 | 423 | 424 | 425 | ####Listing 6.13: Computing Indicators with our Multicore Wrapper#### 426 | # Computing the return matrix 427 | tsfunc <- function(v) (v[2,] / v[1,]) - 1 428 | RETURN <- mcTimeSeries( DATA[["Close"]], tsfunc, FALSE, 2, workers ) 429 | #### 430 | 431 | 432 | rm(list = setdiff(ls(), c("datadir", "functiondir", "rootdir", 433 | "DATA", "OVERNIGHT", "RETURN", 434 | "delegate", "mcTimeSeries", "workers"))) 435 | 436 | ################## 437 | ################## 438 | ################## 439 | 440 | 441 | equNA <- function(v){ 442 | o <- which(!is.na(v))[1] 443 | return(ifelse(is.na(o), length(v)+1, o)) 444 | } 445 | 446 | 447 | ############## 448 | 449 | 450 | 451 | ####Listing 7.1: Simulating Perfomance#### 452 | simulate <- function(OPEN, CLOSE, 453 | ENTRY, EXIT, FAVOR, 454 | maxLookback, maxAssets, startingCash, 455 | slipFactor, spreadAdjust, flatCommission, perShareCommission, 456 | verbose = FALSE, failThresh = 0, 457 | initP = NULL, initp = NULL){ 458 | 459 | t0=Sys.time() 460 | 461 | timer=matrix(0, nrow=16) 462 | t1=proc.time()[3] 463 | # Step 1 464 | if( any( dim(ENTRY) != dim(EXIT) ) | 465 | any( dim(EXIT) != dim(FAVOR) ) | 466 | any( dim(FAVOR) != dim(CLOSE) ) | 467 | any( dim(CLOSE) != dim(OPEN)) ) 468 | stop( "Mismatching dimensions in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.") 469 | 470 | if( any( names(ENTRY) != names(EXIT)) | 471 | any( names(EXIT) != names(FAVOR) ) | 472 | any( names(FAVOR) != names(CLOSE) ) | 473 | any( names(CLOSE) != names(OPEN) ) | 474 | is.null(names(ENTRY)) | is.null(names(EXIT)) | 475 | is.null(names(FAVOR)) | is.null(names(CLOSE)) | 476 | is.null(names(OPEN)) ) 477 | stop( "Mismatching or missing column names in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.") 478 | 479 | FAVOR <- zoo(t(apply(FAVOR, 1, function(v) ifelse(is.nan(v) | is.na(v), 0, v) )), 480 | order.by = index(CLOSE)) 481 | 482 | timer[1]=timer[1] + proc.time()[3] - t1; t1=proc.time()[3] 483 | 484 | 485 | t10=proc.time()[3] 486 | # Step 2 487 | K <- maxAssets 488 | k <- 0 489 | C <- rep(startingCash, times = nrow(CLOSE)) 490 | S <- names(CLOSE) 491 | P <- p <- zoo( matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)), 492 | order.by = index(CLOSE) ) 493 | timer[12]=timer[12] + proc.time()[3] - t1; t1=proc.time()[3] 494 | 495 | if( !is.null( initP ) & !is.null( initp ) ){ 496 | P[1:maxLookback,] <- 497 | matrix(initP, ncol=length(initP), nrow=maxLookback, byrow = TRUE) 498 | p[1:maxLookback,] <- 499 | matrix(initp, ncol=length(initp), nrow=maxLookback, byrow = TRUE) 500 | } 501 | 502 | names(P) <- names(p) <- S 503 | equity <- rep(NA, nrow(CLOSE)) 504 | timer[13]=timer[13] + proc.time()[3] - t1; t1=proc.time()[3] 505 | 506 | rmNA <- foreach(i = 1:3, .packages="zoo", 507 | .export=c("FAVOR","ENTRY", "EXIT", "equNA")) %dopar% { 508 | unlist(lapply(get(c("FAVOR", "ENTRY", "EXIT")[i]), equNA)) 509 | } 510 | rmNA <- pmax(rmNA[[1]], rmNA[[2]], rmNA[[3]]) 511 | 512 | timer[14]=timer[14] + proc.time()[3] - t1; t1=proc.time()[3] 513 | 514 | 515 | for( j in 1:ncol(ENTRY) ){ 516 | if( rmNA[j] > (maxLookback + 1) & 517 | rmNA[j] < nrow(ENTRY) ){ 518 | sel <- 1:(rmNA[j]-1) 519 | FAVOR[sel,j] <- NA 520 | ENTRY[sel,j] <- NA 521 | EXIT[sel,j] <- NA 522 | } 523 | } 524 | timer[15]=timer[15] + proc.time()[3] - t1; t1=proc.time()[3] 525 | 526 | timer[16]=timer[16] + proc.time()[3] - t1; t1=proc.time()[3] 527 | 528 | timer[2]=timer[2] + proc.time()[3] - t10 529 | 530 | # Step 3 531 | for( i in maxLookback:(nrow(CLOSE)-1) ){ 532 | 533 | t1=proc.time()[3] 534 | # Step 4 535 | C[i+1] <- C[i] 536 | P[i+1,] <- as.numeric(P[i,]) 537 | p[i+1,] <- as.numeric(p[i,]) 538 | longS <- S[which(P[i,] > 0)] 539 | shortS <- S[which(P[i,] < 0)] 540 | k <- length(longS) + length(shortS) 541 | 542 | timer[3]=timer[3] + proc.time()[3] - t1; t1=proc.time()[3] 543 | 544 | # Step 5 545 | longTrigger <- setdiff(S[which(ENTRY[i,] == 1)], longS) 546 | shortTrigger <- setdiff(S[which(ENTRY[i,] == -1)], shortS) 547 | 548 | trigger <- c(longTrigger, shortTrigger) 549 | 550 | if( length(trigger) > K ) { 551 | 552 | keepTrigger <- trigger[order(c(as.numeric(FAVOR[i,longTrigger]),-as.numeric(FAVOR[i,shortTrigger])), decreasing = TRUE)][1:K] 553 | 554 | longTrigger <- longTrigger[longTrigger %in% keepTrigger] 555 | shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger] 556 | trigger <- c(longTrigger, shortTrigger) 557 | } 558 | triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger))) 559 | 560 | timer[4]=timer[4] + proc.time()[3] - t1; t1=proc.time()[3] 561 | 562 | # Step 6 563 | longExitTrigger <- longS[longS %in% 564 | S[which(EXIT[i,] == 1 | EXIT[i,] == 999)]] 565 | shortExitTrigger <- shortS[shortS %in% 566 | S[which(EXIT[i,] == -1 | EXIT[i,] == 999)]] 567 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 568 | 569 | timer[5]=timer[5] + proc.time()[3] - t1; t1=proc.time()[3] 570 | 571 | # Step 7 572 | needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0) 573 | if( needToExit > 0 ){ 574 | toExitLongS <- setdiff(longS, exitTrigger) 575 | toExitShortS <- setdiff(shortS, exitTrigger) 576 | toExit <- character(0) 577 | for( counter in 1:needToExit ){ 578 | if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){ 579 | if( min(FAVOR[i,toExitLongS]) < min(-FAVOR[i,toExitShortS]) ){ 580 | pullMin <- which.min(FAVOR[i,toExitLongS]) 581 | toExit <- c(toExit, toExitLongS[pullMin]) 582 | toExitLongS <- toExitLongS[-pullMin] 583 | } else { 584 | pullMin <- which.min(-FAVOR[i,toExitShortS]) 585 | toExit <- c(toExit, toExitShortS[pullMin]) 586 | toExitShortS <- toExitShortS[-pullMin] 587 | } 588 | } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){ 589 | pullMin <- which.min(FAVOR[i,toExitLongS]) 590 | toExit <- c(toExit, toExitLongS[pullMin]) 591 | toExitLongS <- toExitLongS[-pullMin] 592 | } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){ 593 | pullMin <- which.min(-FAVOR[i,toExitShortS]) 594 | toExit <- c(toExit, toExitShortS[pullMin]) 595 | toExitShortS <- toExitShortS[-pullMin] 596 | } 597 | } 598 | longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit]) 599 | shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit]) 600 | } 601 | timer[6]=timer[6] + proc.time()[3] - t1; t1=proc.time()[3] 602 | 603 | # Step 8 604 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 605 | exitTriggerType <- c(rep(1, length(longExitTrigger)), 606 | rep(-1, length(shortExitTrigger))) 607 | 608 | timer[7]=timer[7] + proc.time()[3] - t1; t1=proc.time()[3] 609 | 610 | # Step 9 611 | if( length(exitTrigger) > 0 ){ 612 | for( j in 1:length(exitTrigger) ){ 613 | exitPrice <- as.numeric(OPEN[i+1,exitTrigger[j]]) 614 | effectivePrice <- exitPrice * (1 - exitTriggerType[j] * slipFactor) - 615 | exitTriggerType[j] * (perShareCommission + spreadAdjust) 616 | if( exitTriggerType[j] == 1 ){ 617 | C[i+1] <- C[i+1] + 618 | ( as.numeric( P[i,exitTrigger[j]] ) * effectivePrice ) 619 | - flatCommission 620 | } else { 621 | C[i+1] <- C[i+1] - 622 | ( as.numeric( P[i,exitTrigger[j]] ) * 623 | ( 2 * as.numeric(p[i, exitTrigger[j]]) - effectivePrice ) ) 624 | - flatCommission 625 | } 626 | P[i+1, exitTrigger[j]] <- 0 627 | p[i+1, exitTrigger[j]] <- 0 628 | k <- k - 1 629 | } 630 | } 631 | 632 | timer[8]=timer[8] + proc.time()[3] - t1; t1=proc.time()[3] 633 | 634 | # Step 10 635 | if( length(trigger) > 0 ){ 636 | for( j in 1:length(trigger) ){ 637 | entryPrice <- as.numeric(OPEN[i+1,trigger[j]]) 638 | effectivePrice <- entryPrice * (1 + triggerType[j] * slipFactor) + 639 | triggerType[j] * (perShareCommission + spreadAdjust) 640 | 641 | P[i+1,trigger[j]] <- triggerType[j] * 642 | floor( ( (C[i+1] - flatCommission) / (K - k) ) / effectivePrice ) 643 | 644 | p[i+1,trigger[j]] <- effectivePrice 645 | 646 | C[i+1] <- C[i+1] - 647 | ( triggerType[j] * as.numeric(P[i+1,trigger[j]]) * effectivePrice ) 648 | - flatCommission 649 | 650 | k <- k + 1 651 | } 652 | } 653 | 654 | timer[9]=timer[9] + proc.time()[3] - t1; t1=proc.time()[3] 655 | 656 | # Step 11 657 | equity[i] <- C[i+1] 658 | for( s in S[which(P[i+1,] > 0)] ){ 659 | equity[i] <- equity[i] + 660 | as.numeric(P[i+1,s]) * 661 | as.numeric(OPEN[i+1,s]) 662 | } 663 | for( s in S[which(P[i+1,] < 0)] ){ 664 | equity[i] <- equity[i] - 665 | as.numeric(P[i+1,s]) * 666 | ( 2 * as.numeric(p[i+1,s]) - as.numeric(OPEN[i+1,s]) ) 667 | } 668 | if( equity[i] < failThresh ){ 669 | warning("\n*** Failure Threshold Breached ***\n") 670 | break 671 | } 672 | 673 | timer[10]=timer[10] + proc.time()[3] - t1; t1=proc.time()[3] 674 | 675 | # Step 12 676 | if( verbose ){ 677 | if( i %% 21 == 0 ){ 678 | cat(paste0("################################## ", 679 | round(100 * (i - maxLookback) / 680 | (nrow(CLOSE) - 1 - maxLookback), 1), "%", 681 | " ##################################\n")) 682 | cat(paste0("$", signif(equity[i], 5), "m")) 683 | cat("\n") 684 | cat(paste0("CAGR: ", 685 | round(100 * ((equity[i] / (equity[maxLookback]))^ 686 | (252/(i - maxLookback + 1)) - 1), 2), 687 | "%")) 688 | cat("\n") 689 | cat(S[which(P[i+1,]!=0)]) 690 | cat("\n") 691 | cat(paste("Current Simulation Date",as.character(index(CLOSE)[i]))) 692 | cat("\n") 693 | print(Sys.time() - t0) 694 | cat("\n\n") 695 | } 696 | } 697 | 698 | timer[11]=timer[11] + proc.time()[3] - t1; t1=proc.time()[3] 699 | } 700 | 701 | # Step 13 702 | return(list(equity = equity, C = C, P = P, p = p, timer=timer)) 703 | } 704 | ###### 705 | 706 | ######################### 707 | 708 | 709 | 710 | ####Listing 8.1: Declaring the Evaluator Function#### 711 | # Declare entry function for use inside evaluator 712 | entryfunc <- function(v, shThresh, INDIC){ 713 | nc <- ncol(v)/2 714 | return( 715 | as.numeric(v[1,1:nc] <= 0 & 716 | v[2,1:nc] > 0 & 717 | v[2,(nc+1):(2*nc)] > 718 | quantile(v[2,(nc+1):(2*nc)], 719 | shThresh, na.rm = TRUE) 720 | ) 721 | ) 722 | } 723 | 724 | evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014, 725 | continuous = TRUE, verbose = FALSE, 726 | negative = FALSE, transformOnly = FALSE, 727 | returnData = FALSE, accountParams = NULL, 728 | entryfunc){ 729 | 730 | print(rbind(PARAM, minVal, maxVal)) 731 | # Convert and declare parameters if they exist on continuous (-inf,inf) domain 732 | if( continuous | transformOnly ){ 733 | PARAM <- minVal + 734 | (maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) )) 735 | if( transformOnly ){ 736 | return(PARAM) 737 | } 738 | } 739 | 740 | # Max shares to hold 741 | K <- 10 742 | 743 | # Declare n1 as itself, n2 as a multiple of n1 defined by nFact, 744 | # and declare the length and threshold in sharpe ratio for FAVOR 745 | n1 <- max(round(PARAM[["n1"]]), 2) 746 | n2 <- max(round(PARAM[["nFact"]] * PARAM[["n1"]]), 3, n1+1) 747 | nSharpe <- max(round(PARAM[["nSharpe"]]), 2) 748 | shThresh <- max(0, min(PARAM[["shThresh"]], .99)) 749 | maxLookback <- max(n1, n2, nSharpe) + 1 750 | 751 | max(n2-n1+1,1) 752 | 753 | # Subset data according to year, y 754 | #period <- 755 | #index(DATA[["Close"]]) >= strptime(paste0("01-01-", y), "%d-%m-%Y") & 756 | #index(DATA[["Close"]]) < strptime(paste0("01-01-", y+1), "%d-%m-%Y") 757 | 758 | # Subset data according to years, y 759 | period <- 760 | index(DATA[["Close"]]) >= strptime(paste0("01-01-", y[1]), "%d-%m-%Y") & 761 | index(DATA[["Close"]]) < strptime(paste0("01-01-", y[length(y)]+1), "%d-%m-%Y") 762 | 763 | 764 | period <- period | 765 | ((1:nrow(DATA[["Close"]]) > (which(period)[1] - maxLookback)) & 766 | (1:nrow(DATA[["Close"]]) <= (which(period)[sum(period)]) + 1)) 767 | 768 | 769 | 770 | CLOSE <- DATA[["Close"]][period,] 771 | OPEN <- DATA[["Open"]][period,] 772 | SUBRETURN <- RETURN[period,] 773 | 774 | print(rbind(PARAM,cbind(n1,n2, nSharpe, shThresh))) 775 | # Compute inputs for long-only MACD as in Listing 7.2 776 | INDIC <- mcTimeSeries( CLOSE, 777 | function(v) 778 | colMeans(v[max(n2-n1+1,1):n2,], na.rm = T) 779 | #colMeans(v[(n2-n1+1):n2,], na.rm = T) #May get less than 1 780 | - colMeans(v, na.rm = T), 781 | FALSE, n2, workers ) 782 | 783 | RMEAN <- mcTimeSeries( SUBRETURN, function(v) colMeans(v, na.rm = T), 784 | FALSE, nSharpe, workers ) 785 | 786 | FAVOR <- RMEAN / mcTimeSeries( (SUBRETURN - RMEAN) ^ 2, 787 | function(v) colMeans(v, na.rm = T), 788 | FALSE, nSharpe, workers ) 789 | 790 | ENTRY <- mcTimeSeries(cbind(INDIC, FAVOR), 791 | function(v) entryfunc(v, shThresh, INDIC), 792 | FALSE, 2, workers, entryfunc, shThresh) 793 | 794 | EXIT <- zoo(matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)), 795 | order.by = index(CLOSE)) 796 | names(EXIT) <- names(CLOSE) 797 | 798 | 799 | # Simulate and store results 800 | if( is.null(accountParams) ){ 801 | RESULTS <- simulate(OPEN, CLOSE, 802 | ENTRY, EXIT, FAVOR, 803 | maxLookback, K, 100000, 804 | 0.001, 0.01, 3.5, 0, 805 | verbose, 0) 806 | } else { 807 | RESULTS <- simulate(OPEN, CLOSE, 808 | ENTRY, EXIT, FAVOR, 809 | maxLookback, K, accountParams[["C"]], 810 | 0.001, 0.01, 3.5, 0, 811 | verbose, 0, 812 | initP = accountParams[["P"]], initp = accountParams[["p"]]) 813 | } 814 | 815 | 816 | if(!returnData){ 817 | # Compute and return sharpe ratio 818 | v <- RESULTS[["equity"]] 819 | returns <- ( v[-1] / v[-length(v)] ) - 1 820 | out <- mean(returns, na.rm = T) / sd(returns, na.rm = T) 821 | if(!is.nan(out)){ 822 | if( negative ){ 823 | return( -out ) 824 | } else { 825 | return( out ) 826 | } 827 | } else { 828 | return(0) 829 | } 830 | 831 | } else { 832 | return(RESULTS) 833 | } 834 | } 835 | 836 | ########### 837 | 838 | 839 | 840 | ####Listing 8.5: Nelder-Mead Optimization#### 841 | optimize <- function(y, minVal, maxVal, entryfunc=entryfunc, maxIter=3, PARAMNaught=NULL, continuous=TRUE){ 842 | 843 | #K <- maxIter <-10 844 | K <- maxIter 845 | 846 | 847 | # Vector theta_0 848 | initDelta <- 6 849 | deltaThresh <- 0.05 850 | 851 | if(is.null(PARAMNaught)){ 852 | PARAM <- PARAMNaught <- 853 | c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) - initDelta/2 854 | }else{ 855 | #continuous=FALSE 856 | PARAM <- PARAMNaught 857 | 858 | } 859 | 860 | # Optimization parameters 861 | alpha <- 1 862 | gamma <- 2 863 | rho <- .5 864 | sigma <- .5 865 | 866 | randomInit <- FALSE 867 | 868 | np <- length(PARAM) 869 | 870 | OPTIM <- data.frame(matrix(NA, ncol = np + 1, nrow = maxIter * (2 * np + 2))) 871 | o <- 1 872 | 873 | SIMPLEX <- data.frame(matrix(NA, ncol = np + 1, nrow = np + 1)) 874 | names(SIMPLEX) <- names(OPTIM) <- c(names(PARAM), "obj") 875 | 876 | 877 | # Print function for reporting progress in loop 878 | printUpdate <- function(){ 879 | cat("Iteration: ", k, "of", K, "\n") 880 | cat("\t\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n") 881 | cat("Global Best:\t", 882 | paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n") 883 | cat("Simplex Best:\t", 884 | paste0(round(unlist(SIMPLEX[which.min(SIMPLEX$obj),]),3), "\t"), "\n") 885 | cat("Simplex Size:\t", 886 | paste0(max(round(simplexSize,3)), "\t"), "\n\n\n") 887 | } 888 | 889 | # Initialize SIMPLEX 890 | for( i in 1:(np+1) ) { 891 | SIMPLEX[i,1:np] <- PARAMNaught + initDelta * as.numeric(1:np == (i-1)) 892 | SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], minVal, maxVal, negative = TRUE, 893 | y = y, entryfunc=entryfunc, continuous=continuous) 894 | OPTIM[o,] <- SIMPLEX[i,] 895 | o <- o + 1 896 | } 897 | 898 | 899 | # Optimization loop 900 | for( k in 1:K ){ 901 | 902 | SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),] 903 | centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)]) 904 | 905 | cat("Computing Reflection...\n") 906 | reflection <- centroid + alpha * (centroid - SIMPLEX[np+1,-(np+1)]) 907 | 908 | reflectResult <- evaluate(reflection, minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc, 909 | continuous=continuous) 910 | OPTIM[o,] <- c(reflection, obj = reflectResult) 911 | o <- o + 1 912 | 913 | if( reflectResult > SIMPLEX[1,np+1] & 914 | reflectResult < SIMPLEX[np, np+1] ){ 915 | 916 | SIMPLEX[np+1,] <- c(reflection, obj = reflectResult) 917 | 918 | } else if( reflectResult < SIMPLEX[1,np+1] ) { 919 | 920 | cat("Computing Expansion...\n") 921 | expansion <- centroid + gamma * (reflection - centroid) 922 | expansionResult <- evaluate(expansion, 923 | minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc, 924 | continuous=continuous) 925 | 926 | OPTIM[o,] <- c(expansion, obj = expansionResult) 927 | o <- o + 1 928 | 929 | if( expansionResult < reflectResult ){ 930 | SIMPLEX[np+1,] <- c(expansion, obj = expansionResult) 931 | } else { 932 | SIMPLEX[np+1,] <- c(reflection, obj = reflectResult) 933 | } 934 | 935 | } else if( reflectResult > SIMPLEX[np, np+1] ) { 936 | 937 | cat("Computing Contraction...\n") 938 | contract <- centroid + rho * (SIMPLEX[np+1,-(np+1)] - centroid) 939 | contractResult <- evaluate(contract, minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc, 940 | continuous=continuous) 941 | 942 | 943 | OPTIM[o,] <- c(contract, obj = contractResult) 944 | o <- o + 1 945 | 946 | if( contractResult < SIMPLEX[np+1, np+1] ){ 947 | 948 | SIMPLEX[np+1,] <- c(contract, obj = contractResult) 949 | 950 | } else { 951 | cat("Computing Shrink...\n") 952 | for( i in 2:(np+1) ){ 953 | SIMPLEX[i,1:np] <- SIMPLEX[1,-(np+1)] + 954 | sigma * (SIMPLEX[i,1:np] - SIMPLEX[1,-(np+1)]) 955 | SIMPLEX[i,np+1] <- c(obj = evaluate(SIMPLEX[i,1:np], 956 | minVal, maxVal, 957 | negative = TRUE, y = y, entryfunc=entryfunc, 958 | continuous=continuous)) 959 | } 960 | 961 | OPTIM[o:(o+np-1),] <- SIMPLEX[2:(np+1),] 962 | o <- o + np 963 | } 964 | } 965 | 966 | centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)]) 967 | simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, 968 | function(v) abs(v - centroid)))) 969 | 970 | if( max(simplexSize) < deltaThresh ){ 971 | 972 | cat("Size Threshold Breached: Restarting with Random Initiate\n\n") 973 | 974 | for( i in 1:(np+1) ) { 975 | 976 | SIMPLEX[i,1:np] <- (PARAMNaught * 0) + 977 | runif(n = np, min = -initDelta, max = initDelta) 978 | 979 | SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], 980 | minVal, maxVal, negative = TRUE, y = y, entryfunc=entryfunc, 981 | continuous=continuous) 982 | OPTIM[o,] <- SIMPLEX[i,] 983 | o <- o + 1 984 | 985 | SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),] 986 | centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)]) 987 | simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, function(v) abs(v - centroid)))) 988 | } 989 | 990 | } 991 | printUpdate() 992 | } 993 | 994 | #Pruning excess rows 995 | OPTIM <- OPTIM[!is.na(OPTIM[,1]),] 996 | 997 | # Return the best optimization in untransformed parameters 998 | return( 999 | evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE, entryfunc=entryfunc) 1000 | ) 1001 | } 1002 | ########### 1003 | 1004 | 1005 | 1006 | 1007 | ####Listing 8.6: Generating Valid Performance Projections with Cross Validation#### 1008 | set.seed(1234) 1009 | minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01) 1010 | maxVal <- c(n1 = 250, nFact = 5, nSharpe = 200, shThresh = .99) 1011 | #minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01) 1012 | #maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99) 1013 | 1014 | RESULTS <- list() 1015 | accountParams <- list() 1016 | testRange <- 2004:2015 1017 | maxIter <- 3 1018 | ResetPARAM <- FALSE #If TRUE reset the model parameters after each year of data is tested 1019 | YearByYear <- TRUE #If TRUE optimize only for previous year of data (vs all years up to that point) 1020 | 1021 | # As defined in heuristic with delta_O = delta_P = 1 year 1022 | for( yf in testRange ){ 1023 | 1024 | 1025 | if(YearByYear){ y <- yf }else{ y <- testRange[1]:yf } 1026 | if( yf == testRange[1] | ResetPARAM ){ PARAM0=NULL }else{ PARAM0=PARAM } 1027 | 1028 | PARAM <- optimize(y = y, minVal = minVal, maxVal = maxVal, entryfunc=entryfunc, 1029 | maxIter=maxIter, PARAMNaught=PARAM0) 1030 | 1031 | print("Opt Done") 1032 | 1033 | if( yf == testRange[1] ){ 1034 | RESULTS[[as.character(yf+1)]] <- 1035 | evaluate(PARAM, y = yf + 1, minVal = minVal, maxVal = maxVal, continuous = TRUE, 1036 | returnData = TRUE, verbose = TRUE, entryfunc=entryfunc ) 1037 | } else { 1038 | 1039 | # Pass account parameters to next simulation after first year 1040 | strYear <- as.character(yf) 1041 | aLength <- length(RESULTS[[strYear]][["C"]]) 1042 | accountParams[["C"]] <- (RESULTS[[strYear]][["C"]])[aLength] 1043 | accountParams[["P"]] <- (RESULTS[[strYear]][["P"]])[aLength] 1044 | accountParams[["p"]] <- (RESULTS[[strYear]][["p"]])[aLength] 1045 | 1046 | RESULTS[[as.character(yf+1)]] <- 1047 | evaluate(PARAM, y = yf + 1, minVal = minVal, maxVal = maxVal, continuous = TRUE, 1048 | returnData = TRUE, verbose = TRUE, 1049 | accountParams = accountParams, entryfunc=entryfunc) 1050 | } 1051 | 1052 | # extract equity curve 1053 | for( y2 in (testRange[1]:yf + 1) ){ 1054 | strYear <- as.character(y2) 1055 | inYear <- substr(index(RESULTS[[strYear]][["P"]]), 1, 4) == strYear 1056 | equity <- (RESULTS[[strYear]][["equity"]])[inYear] 1057 | date <- (index(RESULTS[[strYear]][["P"]]))[inYear] 1058 | if( y2 == (testRange[1] + 1) ){ 1059 | equitySeries <- zoo(equity, order.by = date) 1060 | } else { 1061 | equitySeries <- rbind(equitySeries, zoo(equity, order.by = date)) 1062 | } 1063 | } 1064 | 1065 | plot(equitySeries, main=yf) 1066 | grid(); abline(h=100000, lty=2, lwd=3) 1067 | } 1068 | ##### 1069 | 1070 | 1071 | 1072 | 1073 | ##### 1074 | # extract equity curve 1075 | for( y in (testRange + 1) ){ 1076 | strYear <- as.character(y) 1077 | inYear <- substr(index(RESULTS[[strYear]][["P"]]), 1, 4) == strYear 1078 | equity <- (RESULTS[[strYear]][["equity"]])[inYear] 1079 | date <- (index(RESULTS[[strYear]][["P"]]))[inYear] 1080 | if( y == (testRange[1] + 1) ){ 1081 | equitySeries <- zoo(equity, order.by = date) 1082 | } else { 1083 | equitySeries <- rbind(equitySeries, zoo(equity, order.by = date)) 1084 | } 1085 | } 1086 | 1087 | plot(equitySeries) 1088 | ############### 1089 | 1090 | 1091 | 1092 | plot(equitySeries, main = "Figure 8.12: Cross-Validated Equity Curve for Long-Only MACD", 1093 | ylab = "Account Equity ($)", xlab = "") 1094 | 1095 | #cont to transform 1096 | 1097 | 1098 | 1099 | 1100 | 1101 | 1102 | -------------------------------------------------------------------------------- /Examples/quandl-run.R: -------------------------------------------------------------------------------- 1 | ########################################### 2 | ### This script is a one-piece runnable ### 3 | ### example constructed from code ### 4 | ### using Quandl API instead of yahoo! ### 5 | ### It is Windows and UNIX ### 6 | ### compatible. ### 7 | ########################################### 8 | 9 | 10 | # The goal is use Quandl API instead of Yahoo! API 11 | # for downloading and Yahoo! YQL for updating 12 | # it is intended to reproduce the same same steps 13 | # as stated on the text book. 14 | # The end result is a DATA file similar to 15 | # listings in Chapter 2 16 | # Quandl https://www.quandl.com/ 17 | # Quandl API r https://www.quandl.com/tools/r 18 | # Quandl doocs https://www.quandl.com/tools/r 19 | # Quandl has the capability of downloading data frames as zoo objects 20 | # therefore, we will re-name each column after downloading and writing as csv 21 | 22 | # set root as working directory, change it to your wd 23 | setwd("~") 24 | 25 | # delete AutoTrading folder if exists. We will start fresh 26 | if(file.exists("./AutoTrading")) { 27 | unlink("./AutoTrading", recursive=TRUE) 28 | } 29 | # create AutoTrading folders 30 | dir.create("./AutoTrading") 31 | dir.create("./AutoTrading/stockdata") 32 | dir.create("./Autotrading/functions") 33 | 34 | ####Listing 2.1: Setting Path Variables 35 | rootdir <- "~/Autotrading" 36 | datadir <- "~/AutoTrading/stockdata/" 37 | functiondir <- "~/AutoTrading/functions/" 38 | #### 39 | 40 | ####Listing 2.2 modified for quandl instead of Yahoo! 41 | #insert your Quandl APO here 42 | require(Quandl) 43 | quandl_api = "MYAPIKEY" 44 | 45 | #add my key to Quandl API 46 | Quandl.api_key(quandl_api) 47 | 48 | # this function downloads the columns needed as from start_date 49 | quandl_get <- function(sym, start_date = "2017-01-01") { 50 | require(devtools) 51 | require(Quandl) 52 | # create a vector with all lines 53 | tryCatch(Quandl(c( 54 | paste0("WIKI/", sym, ".8"), # Adj. Open 55 | paste0("WIKI/", sym, ".9"), # Adj. High 56 | paste0("WIKI/", sym, ".10"), # Adj. Low 57 | paste0("WIKI/", sym, ".11"), # Adj. Close 58 | paste0("WIKI/", sym, ".12")), # Adj. Volume 59 | start_date = start_date, 60 | type = "zoo" 61 | )) 62 | } 63 | #### 64 | 65 | 66 | # save quandl.R file in /functions with 'quandl'_get function 67 | setwd(functiondir) 68 | dump(list = c("quandl_get"), "quandl.R") 69 | #S <- read.csv(url, header = FALSE, stringsAsFactors=F)[,1] 70 | 71 | ####Listing 2.3: List of S&P 500 Stocks#### 72 | # Up-to-date at time of writing 73 | 74 | url <- "http://trading.chrisconlan.com/SPstocks.csv" 75 | 76 | # Option A: Read S from url 77 | # S <- as.character(read.csv(url, header = FALSE)[,1]) 78 | 79 | # Option B: for testing read a S-test.R CSV file with shorter stock tickers 80 | S <- c("MMM", "ACN", "BLK", "HRB", "BWA", "BF-B") 81 | 82 | #Change '-' for '_'. Quandl needs it 83 | #Method 1, generic 84 | S <- gsub("-", "_", S) 85 | 86 | setwd(rootdir) 87 | dump(list = "S", "S.R") 88 | ##### 89 | 90 | #### 2.4 91 | # Load "invalid.R" file if available 92 | invalid <- character(0) 93 | setwd(rootdir) 94 | if("invalid.R" %in% list.files()) source("invalid.R") 95 | 96 | 97 | # Find all symbols not in directory and not missing 98 | setwd(datadir) 99 | toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid) 100 | 101 | #load new column names 102 | column_names <- c("Open", "High", "Low", "Close", "Volume") 103 | 104 | # Fetch symbols with quandl_get function, save as .csv or missing 105 | source(paste0(functiondir, "quandl.R")) 106 | if(length(toload) != 0){ 107 | for(i in 1:length(toload)){ 108 | 109 | df <- quandl_get(toload[i]) 110 | 111 | if(!is.null(df)) { 112 | #changing names 113 | colnames(df) <- column_names 114 | # as zoo objects downloaded, row names must be TRUE. Use write ZOO 115 | write.zoo(df, file = paste0(toload[i], ".csv")) 116 | } else { 117 | invalid <- c(invalid, toload[i]) 118 | } 119 | 120 | } 121 | } 122 | 123 | setwd(rootdir) 124 | dump(list = c("invalid"), "invalid.R") 125 | 126 | # Clears R environment except for path variables and functions 127 | rm( list = setdiff( ls(), c(" rootdir", "functiondir", "datadir", "quandl_get", "column_names"))) 128 | gc() 129 | #### 130 | 131 | #### 2.5 132 | setwd(datadir) 133 | S <- sub(".csv", "", list.files()) 134 | 135 | require(data.table) 136 | 137 | DATA <- list() 138 | for(i in S){ 139 | suppressWarnings( 140 | # read as Zoo instead of fread 141 | # DATA[[i]] <- fread(paste0(i, ".csv"), sep = ",")) 142 | DATA[[i]] <- read.zoo(paste0(i, ".csv"), header = TRUE) 143 | ) 144 | # sort by index 145 | DATA[[i]] <- zoo(DATA[[i]], order.by = index(DATA[[i]])) 146 | } 147 | #### 148 | 149 | #### 2.6 update method with quandl_get function 150 | # To prove that this works, at this point you might want to delete some rows in 151 | # any of the csv files under stockdata. 152 | # force system time to "EST" 153 | Sys.setenv(TZ="EST") 154 | currentTime <- Sys.time() 155 | 156 | for(i in S){ 157 | # Store greatest date within DATA for symbol i 158 | maxdate <- max(index(DATA[[i]])[nrow(DATA[[i]])]) 159 | if(as.numeric(difftime(currentTime, maxdate, units = "hours")) >= 40.25){ 160 | 161 | # Push the maxdate forward one day 162 | maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400 163 | 164 | weekend <- sum(c("Saturday", "Sunday") %in% 165 | weekdays(c(maxdate, currentTime))) == 2 166 | 167 | if(!weekend){ 168 | # if !weekend then start_date for quandl = maxdate 169 | start_date = as.character(maxdate) 170 | df <- quandl_get(i, start_date = start_date) 171 | colnames(df) <- column_names 172 | if(!is.null(df)){ 173 | if(all(!is.na(df)) & nrow(df) > 0){ 174 | # df <- df[nrow(df):1] # not needed, is type = "zoo" 175 | # write csv file with new data, duplicates might exist 176 | write.zoo(df, file = paste0(i, ".csv"), 177 | row.names = FALSE, col.names = FALSE, append = TRUE) 178 | DATA[[i]] <- rbind(DATA[[i]], df) 179 | # just in case, sort by index. Remove duplicates? 180 | DATA[[i]] <- zoo(DATA[[i]], order.by = index(DATA[[i]])) 181 | } 182 | } 183 | } 184 | } 185 | } 186 | 187 | #### 2.7 method not needed 188 | #### 189 | -------------------------------------------------------------------------------- /Listings/Appendix B/B-1.R: -------------------------------------------------------------------------------- 1 | # Declare global variables a and b 2 | a <- 2 3 | b <- 3 4 | 5 | # Declare functions 6 | f <- function(){ 7 | a 8 | } 9 | 10 | g <-function(){ 11 | f() + b 12 | } 13 | 14 | h <- function(b){ 15 | f() + b 16 | } 17 | 18 | 19 | # a = 2 throughout. 20 | # b = 3 when not supplied as a parameter. 21 | f() # f() = 2 22 | g() # g() = 5 23 | h(5) # h(5) = 7 24 | -------------------------------------------------------------------------------- /Listings/Appendix B/B-2.R: -------------------------------------------------------------------------------- 1 | mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers ){ 2 | 3 | SERIES <- foreach( i = 1:workers, .combine = rbind ) %dopar% { 4 | 5 | jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers) 6 | 7 | rollapply(data[jRange,], 8 | width = windowSize, 9 | FUN = tsfunc, 10 | align = "right", 11 | by.column = byColumn) 12 | 13 | } 14 | 15 | names(SERIES) <- gsub("\\..+", "", names(SERIES)) 16 | 17 | if( windowSize > 1){ 18 | PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA), 19 | order.by = index(data)[1:(windowSize-1)]) 20 | names(PAD) <- names(SERIES) 21 | SERIES <- rbind(PAD, SERIES) 22 | } 23 | 24 | if(is.null(names(SERIES))){ 25 | names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)]) 26 | } 27 | 28 | return(SERIES) 29 | 30 | } 31 | -------------------------------------------------------------------------------- /Listings/Appendix B/B-3.R: -------------------------------------------------------------------------------- 1 | exitfunc <- function(v) { 2 | # Body of developer's new exit function 3 | } 4 | 5 | evaluate(...) <- function(...){ 6 | 7 | # Body of the evaluate function 8 | 9 | EXIT <- mcTimeSeries(CLOSE, exitfunc, TRUE, 20, workers) 10 | 11 | # Remainder of the evaluate function 12 | 13 | } 14 | -------------------------------------------------------------------------------- /Listings/Appendix B/B-4.R: -------------------------------------------------------------------------------- 1 | # Declare parameter alpha as function parameter 2 | exitfunc <- function(v, alpha) { 3 | # Body of developer's new exit function 4 | } 5 | 6 | # Declare function object exitfunc as 7 | # function parameter to evaluator 8 | evaluate <- function(... , exitfunc){ 9 | 10 | # Body of the evaluate function 11 | 12 | # alpha exists in the function scope 13 | # of the evaluator 14 | alpha <- 0.5 15 | 16 | # Dynamically declare function object in 17 | # mcTimeSeries. Pass exitfunc and alpha 18 | # in the ellipses of the call because 19 | # the second argument depends on them. 20 | EXIT <- mcTimeSeries(CLOSE, 21 | function(v) exitfunc(v, alpha), 22 | TRUE, 20, workers, 23 | exitfunc, alpha) 24 | 25 | # Remainder of the evaluate function 26 | 27 | } 28 | 29 | 30 | optimize <- function(... , exitfunc){ 31 | 32 | # Alter all calls to evaluate to include 33 | # new function object parameter exitfunc 34 | 35 | # Body of the optimzer 36 | 37 | evaluate( ... , exitfunc ) 38 | 39 | # Body of the optimzer 40 | 41 | evaluate( ... , exitfunc ) 42 | 43 | # And so on. There are typically many calls 44 | # to evaluate() within the optimizer. 45 | 46 | } 47 | -------------------------------------------------------------------------------- /Listings/Appendix B/UNIX-mcTimeSeries.R: -------------------------------------------------------------------------------- 1 | mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers ){ 2 | 3 | SERIES <- foreach( i = 1:workers, .combine = rbind ) %dopar% { 4 | 5 | jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers) 6 | 7 | rollapply(data[jRange,], 8 | width = windowSize, 9 | FUN = tsfunc, 10 | align = "right", 11 | by.column = byColumn) 12 | 13 | } 14 | 15 | names(SERIES) <- gsub("\\..+", "", names(SERIES)) 16 | 17 | if( windowSize > 1){ 18 | PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA), 19 | order.by = index(data)[1:(windowSize-1)]) 20 | names(PAD) <- names(SERIES) 21 | SERIES <- rbind(PAD, SERIES) 22 | } 23 | 24 | if(is.null(names(SERIES))){ 25 | names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)]) 26 | } 27 | 28 | return(SERIES) 29 | 30 | } 31 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-1.R: -------------------------------------------------------------------------------- 1 | # Checks if quantmod is installed, installs it if unavailable, 2 | # loads it and turns off needless warning messages 3 | if(!("quantmod" %in% as.character(installed.packages()[,1]))) 4 | { install.packages("quantmod") } 5 | library(quantmod) 6 | options("getSymbols.warning4.0"=FALSE, 7 | "getSymbols.auto.assign"=FALSE) 8 | 9 | # Loads S&P 500 ETF data, stores closing prices as a vector 10 | SPY <- suppressWarnings( 11 | getSymbols(c("SPY"),from = "2012-01-01")) 12 | SPY <- as.numeric(SPY$SPY.Close)[1:987] 13 | 14 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-10.R: -------------------------------------------------------------------------------- 1 | # Create linearized equity curve and run regression 2 | y <- Et / Vt 3 | model <- lm(y ~ t) 4 | 5 | # Compute PPS by pulling "r.squared" value from summary function 6 | PPS <- ((Et[length(Et)] - Vt[1]) / Vt[1]) * summary(model)$r.squared 7 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-2.R: -------------------------------------------------------------------------------- 1 | # Set Random Seed 2 | set.seed(123) 3 | 4 | # Create Time Index 5 | t <- 1:(length(SPY)-1) 6 | 7 | # Tradable Capital Vector 8 | Vt <- c(rep(10000, length(t))) 9 | 10 | # Benchmark Return Series 11 | Rb <- rep(NA, length(t)) 12 | for(i in 2:length(t)) { Rb[i] <- (SPY[i] / SPY[i - 1]) - 1 } 13 | 14 | # Benchmark Equity Curve 15 | Eb <- rep(NA, length(t)) 16 | Eb[1] <- Vt[1] 17 | for(i in 2:length(t)) { Eb[i] <- Eb[i-1] * (1 + Rb[i]) } 18 | 19 | # Randomly Simulated Return Series 1 20 | Rt <- rep(NA, length(t)) 21 | for(i in 2:length(t)){ 22 | Rt[i] <- Rb[i] + rnorm(n = 1, 23 | mean = 0.24/length(t), 24 | sd = 2.5 * sd(Rb, na.rm = TRUE)) 25 | } 26 | 27 | # Randomly Simulated Return Series 2 28 | Rt2 <- rep(NA, length(t)) 29 | for(i in 2:length(t)){ 30 | Rt2[i] <- Rb[i] + rnorm(n = 1, 31 | mean = 0.02/length(t), 32 | sd = .75 * sd(Rb, na.rm = TRUE)) 33 | } 34 | 35 | # Randomly Simulated Equity Curve 1 36 | Et <- rep(NA, length(t)) 37 | Et <- Vt[1] 38 | for(i in 2:length(t)) { Et[i] <- Et[i-1] * (1 + Rt[i]) } 39 | 40 | # Randomly Simulated Equity Curve 2 41 | Et2 <- rep(NA, length(t)) 42 | Et2 <- Vt[1] 43 | for(i in 2:length(t)) { Et2[i] <- Et2[i-1] * (1 + Rt2[i]) } 44 | 45 | # Plot of Et1 against the SPY Portfolio 46 | plot(y = Et, x = t, type = "l", col = 1, 47 | xlab = "Time", 48 | ylab= "Equity ($)", 49 | main = "Figure 1.3: Randomly Generated Equity Curves") 50 | grid() 51 | abline(h = 10000) 52 | lines(y = Et2, x = t, col = 2) 53 | lines(y = Eb, x = t, col = 8) 54 | legend(x = "topleft", col = c(1,2,8), lwd = 2, legend = c("Curve 1", 55 | "Curve 2", 56 | "SPY")) 57 | 58 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-3.R: -------------------------------------------------------------------------------- 1 | # Use na.rm = TRUE to ignore NA's at position 1 in return series 2 | SR <- mean(Rt, na.rm = TRUE) / sd(Rt, na.rm = TRUE) 3 | SR2 <- mean(Rt2, na.rm = TRUE) / sd(Rt2, na.rm = TRUE) 4 | SRb <- mean(Rb, na.rm = TRUE) / sd(Rb, na.rm = TRUE) 5 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-4.R: -------------------------------------------------------------------------------- 1 | plot(y = Et, x = t, type = "l", col = 1, 2 | xlab = "", 3 | ylab= "Equity ($)", 4 | main = "Figure 1.4: Sharpe Ratios") 5 | grid() 6 | abline(h = 10000) 7 | lines(y = Et2, x = t, col = 2) 8 | lines(y = Eb, x = t, col = 8) 9 | legend(x = "topleft", col = c(1,2,8), lwd = 2, 10 | legend = c(paste0("SR = ", round(SR, 3)), 11 | paste0("SR = ", round(SR2, 3)), 12 | paste0("SR = ", round(SRb, 3)))) 13 | 14 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-5.R: -------------------------------------------------------------------------------- 1 | MD <- function(curve, n = 1){ 2 | 3 | time <- length(curve) 4 | v <- rep(NA, (time * (time - 1)) / 2) 5 | k <- 1 6 | for(i in 1:(length(curve)-1)){ 7 | for(j in (i+1):length(curve)){ 8 | v[k] <- curve[i] - curve[j] 9 | k <- k + 1 10 | } 11 | } 12 | 13 | m <- rep(NA, length(n)) 14 | for(i in 1:n){ 15 | m[i] <- max(v) 16 | v[which.max(v)] <- -Inf 17 | } 18 | 19 | return(m) 20 | 21 | } 22 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-6.R: -------------------------------------------------------------------------------- 1 | NPMD <- (Et[length(Et)] - Vt[1]) / MD(Et) 2 | 3 | Burke <- (Et[length(Et)] - Vt[1]) / 4 | sqrt((1/length(Et)) * sum(MD(Et, n = round(length(Et) / 20))^2)) 5 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-7.R: -------------------------------------------------------------------------------- 1 | PM <- function(Rt, upper = FALSE, n = 2, Rb = 0){ 2 | if(n != 0){ 3 | if(!upper) return(mean(pmax(Rb - Rt, 0, na.rm = TRUE)^n)) 4 | if(upper) return(mean(pmax(Rt - Rb, 0, na.rm = TRUE)^n)) 5 | } else { 6 | if(!upper) return(mean(Rb >= Rt)) 7 | if(upper) return(mean(Rt > Rb)) 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-8.R: -------------------------------------------------------------------------------- 1 | Omega <- mean(Rt, na.rm = TRUE) / PM(Rt)^0.5 2 | UPR <- PM(Rt, upper = TRUE)^0.5 / PM(Rt)^0.5 3 | -------------------------------------------------------------------------------- /Listings/Chapter 1/1-9.R: -------------------------------------------------------------------------------- 1 | # Scatterplot of Rt against Rb 2 | plot(y = Rt, x = Rb, 3 | pch = 20, 4 | cex = 0.5, 5 | xlab = "SPY Returns", 6 | ylab= "Return Series 1", 7 | main = "Figure 1.7: Return Series 1 vs. SPY") 8 | grid() 9 | abline(h = 0) 10 | abline(v = 0) 11 | 12 | # Compute and store the regression model 13 | model <- lm(Rt ~ Rb) 14 | 15 | # Plot the regression line 16 | abline(model, col = 2) 17 | 18 | # Display alpha and beta 19 | legend(x = "topleft", col = c(0,2), lwd = 2, 20 | legend = c("Alpha Beta R^2", 21 | paste0(round(model$coefficients[1], 4), " ", 22 | round(model$coefficients[2], 2), " ", 23 | round(summary(model)$r.squared, 2)))) 24 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-1.R: -------------------------------------------------------------------------------- 1 | # Warning: These are not to be run concurrently 2 | 3 | # UPDATE Job 4 | source("~/Platform/update.R") 5 | 6 | # PLAN Job 7 | source("~/Platform/plan.R") 8 | 9 | # TRADE Job 10 | source("~/Platform/trade.R") 11 | 12 | # MODEL Job 13 | source("~/Platform/model.R") 14 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-10: -------------------------------------------------------------------------------- 1 | 0 19 * * 1-5 ~/Platform/plan.sh 2 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-2.bat: -------------------------------------------------------------------------------- 1 | set path= %path%;C:\Program Files\R\R-3.3.0\bin\x64 2 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-3.bat: -------------------------------------------------------------------------------- 1 | Rscript C:\Platform\plan.R 2 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-4.bat: -------------------------------------------------------------------------------- 1 | cd C:\Platform\errorlog 2 | Rscript C:\Platform\plan.R > planlog.txt 2>&1 3 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-5.bat: -------------------------------------------------------------------------------- 1 | set path= %path%;C:\Program Files\R\R-3.2.3\bin 2 | cd C:\Platform\errorlog\ 3 | Rscript C:\Platform\plan.R > planlog.txt 2>&1 4 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-6.bat: -------------------------------------------------------------------------------- 1 | schtasks /create /tn PLAN /sc weekly /d mon,tue,wed,thu,fri /mo 1 /st 19:00 2 | /tr "C:\Platform\plan.bat" 3 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-7.txt: -------------------------------------------------------------------------------- 1 | # Delete a task 2 | schtasks /delete /tn PLAN 3 | 4 | # Run a task 5 | schtasks /run /tn PLAN 6 | 7 | # End a currently run task, does not affect scheduling 8 | schtasks /end /tn PLAN 9 | 10 | # Get info on a task 11 | schtasks /query /tn PLAN 12 | 13 | # Modify a task (this example removes Wednesday from PLAN) 14 | schtasks /change /tn PLAN /d mon,tue,thu,fri 15 | 16 | # Disable a task, cancel scheduling 17 | schtasks /change /tn PLAN /disable 18 | 19 | # Enable an inactive task, resume scheduling 20 | schtasks /change /tn PLAN /enable 21 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-8.sh: -------------------------------------------------------------------------------- 1 | # Edit CRON jobs 2 | crontab -e 3 | 4 | # Delete all user-specified CRON jobs 5 | crontab -r 6 | -------------------------------------------------------------------------------- /Listings/Chapter 10/10-9.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | cd ~/Platform/errorlog 3 | Rscript ~/Platform/plan.R > planlog.txt 2>&1 4 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-1.R: -------------------------------------------------------------------------------- 1 | rootdir <- "~/Platform/" 2 | datadir <- "~/Platform/stockdata/" 3 | functiondir <- "~/Platform/functions/" 4 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-2.R: -------------------------------------------------------------------------------- 1 | yahoo <- function(sym, current = TRUE, 2 | a = 0, b = 1, c = 2000, d, e, f, 3 | g = "d") 4 | { 5 | 6 | if(current){ 7 | f <- as.numeric(substr(as.character(Sys.time()), start = 1, stop = 4)) 8 | d <- as.numeric(substr(as.character(Sys.time()), start = 6, stop = 7)) - 1 9 | e <- as.numeric(substr(as.character(Sys.time()), start = 9, stop = 10)) 10 | } 11 | 12 | require(data.table) 13 | 14 | tryCatch( 15 | suppressWarnings( 16 | fread(paste0("http://ichart.yahoo.com/table.csv", 17 | "?s=", sym, 18 | "&a=", a, 19 | "&b=", b, 20 | "&c=", c, 21 | "&d=", d, 22 | "&e=", e, 23 | "&f=", f, 24 | "&g=", g, 25 | "&ignore=.csv"), sep = ",")), 26 | error = function(e) NULL 27 | ) 28 | } 29 | 30 | setwd(functiondir) 31 | dump(list = c("yahoo"), "yahoo.R") 32 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-3-quandl.R: -------------------------------------------------------------------------------- 1 | # Up-to-date at time of writing (May 2016) 2 | url <- "http://trading.chrisconlan.com/SPstocks.csv" 3 | S <- as.character(read.csv(url, header = FALSE)[,1]) 4 | 5 | # Changing stocks names. Because Quandl reads stocks with "_" instead of "-" 6 | S <- gsub("-", "_", S) 7 | 8 | # save S.R with stock list from url 9 | setwd(rootdir) 10 | dump(list = "S", "S.R") 11 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-3.R: -------------------------------------------------------------------------------- 1 | # Up-to-date at time of writing (May 2016) 2 | url <- "http://trading.chrisconlan.com/SPstocks.csv" 3 | S <- as.character(read.csv(url, header = FALSE)[,1]) 4 | 5 | # save S.R with stock list from URL 6 | setwd(rootdir) 7 | dump(list = "S", "S.R") 8 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-4-quandl.R: -------------------------------------------------------------------------------- 1 | # Load "invalid.R" file if available 2 | invalid <- character(0) 3 | setwd(rootdir) 4 | if("invalid.R" %in% list.files()) source("invalid.R") 5 | 6 | 7 | # Find all symbols not in directory and not missing 8 | setwd(datadir) 9 | toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid) 10 | 11 | # Fetch symbols with quandl function (instead of yahoo), save as .csv or missing 12 | source(paste0(functiondir, "quandl.R")) 13 | if(length(toload) != 0){ 14 | for(i in 1:length(toload)){ 15 | 16 | df <- quandl_get(toload[i]) 17 | 18 | if(!is.null(df)) { 19 | write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"), 20 | row.names = FALSE) 21 | } else { 22 | invalid <- c(invalid, toload[i]) 23 | } 24 | 25 | } 26 | } 27 | 28 | setwd(rootdir) 29 | dump(list = c("invalid"), "invalid.R") 30 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-4.R: -------------------------------------------------------------------------------- 1 | # Load "invalid.R" file if available 2 | invalid <- character(0) 3 | setwd(rootdir) 4 | if("invalid.R" %in% list.files()) source("invalid.R") 5 | 6 | 7 | # Find all symbols not in directory and not missing 8 | setwd(datadir) 9 | toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid) 10 | 11 | # Fetch symbols with yahoo function, save as .csv or missing 12 | source(paste0(functiondir, "yahoo.R")) 13 | if(length(toload) != 0){ 14 | for(i in 1:length(toload)){ 15 | 16 | df <- yahoo(toload[i]) 17 | 18 | if(!is.null(df)) { 19 | write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"), 20 | row.names = FALSE) 21 | } else { 22 | invalid <- c(invalid, toload[i]) 23 | } 24 | 25 | } 26 | } 27 | 28 | setwd(rootdir) 29 | dump(list = c("invalid"), "invalid.R") 30 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-5.R: -------------------------------------------------------------------------------- 1 | setwd(datadir) 2 | S <- sub(".csv", "", list.files()) 3 | 4 | require(data.table) 5 | 6 | DATA <- list() 7 | for(i in S){ 8 | suppressWarnings( 9 | DATA[[i]] <- fread(paste0(i, ".csv"), sep = ",")) 10 | DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)] 11 | } 12 | 13 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-6.R: -------------------------------------------------------------------------------- 1 | currentTime <- Sys.time() 2 | 3 | for(i in S){ 4 | # Store greatest date within DATA for symbol i 5 | maxdate <- DATA[[i]][["Date"]][nrow(DATA[[i]])] 6 | if(as.numeric(difftime(currentTime, maxdate, units = "hours")) >= 40.25){ 7 | 8 | # Push the maxdate forward one day 9 | maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400 10 | 11 | weekend <- sum(c("Saturday", "Sunday") %in% 12 | weekdays(c(maxdate, currentTime))) == 2 13 | 14 | span <- FALSE 15 | if( weekend ){ 16 | span <- as.numeric(difftime(currentTime, maxdate, units = "hours")) >= 48 17 | } 18 | 19 | if(!weekend & !span){ 20 | c <- as.numeric(substr(maxdate, start = 1, stop = 4)) 21 | a <- as.numeric(substr(maxdate, start = 6, stop = 7)) - 1 22 | b <- as.numeric(substr(maxdate, start = 9, stop = 10)) 23 | df <- yahoo(i, a = a, b = b, c = c) 24 | if(!is.null(df)){ 25 | if(all(!is.na(df)) & nrow(df) > 0){ 26 | df <- df[nrow(df):1] 27 | write.table(df, file = paste0(i, ".csv"), sep = ",", 28 | row.names = FALSE, col.names = FALSE, append = TRUE) 29 | DATA[[i]] <- rbind(DATA[[i]], df) 30 | } 31 | } 32 | } 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-7.R: -------------------------------------------------------------------------------- 1 | setwd(datadir) 2 | library(XML) 3 | 4 | currentTime <- Sys.time() 5 | 6 | batchsize <- 101 7 | 8 | # i in 1:5 for this example 9 | for(i in 1:(ceiling(length(S) / batchsize)) ){ 10 | 11 | midQuery <- " (" 12 | maxdate <- character(0) 13 | 14 | startIndex <- ((i - 1) * batchsize + 1) 15 | endIndex <- min(i * batchsize, length(S)) 16 | 17 | 18 | # find earliest date and build query 19 | for(s in S[startIndex:(endIndex - 1)]){ 20 | maxdate <- c(maxdate, DATA[[s]][[1]][nrow(DATA[[s]])]) 21 | midQuery <- paste0(midQuery, "'", s, "', ") 22 | } 23 | 24 | 25 | maxdate <- c(maxdate, DATA[[S[endIndex]]][[1]] 26 | [nrow(DATA[[S[endIndex]]])]) 27 | 28 | startDate <- max(maxdate) 29 | 30 | if( startDate < 31 | substr(strptime(substr(currentTime, 0, 10), "%Y-%m-%d") 32 | - 28 * 86400, 0, 10) ){ 33 | cat("Query is greater than 20 trading days. Download with csv method.") 34 | break 35 | } 36 | 37 | 38 | # Adds a day (86400 seconds) to the earliest date to avoid duplicates 39 | startDate <- substr(as.character(strptime(startDate, "%Y-%m-%d") + 86400), 0, 10) 40 | endDate <- substr(currentTime, 0, 10) 41 | 42 | # Yahoo! updates at 4:15 EST at earliest, check if it is past 4:15 day after last 43 | isUpdated <- as.numeric(difftime(currentTime, startDate, units = "hours")) >= 44 | 40.25 45 | 46 | # If both days fall in the same weekend, we will not attempt to update 47 | weekend <- sum(c("Saturday", "Sunday") %in% 48 | weekdays(c(strptime(endDate, "%Y-%m-%d"), 49 | c(strptime(startDate, "%Y-%m-%d"))))) == 2 50 | 51 | span <- FALSE 52 | if( weekend ){ 53 | span <- as.numeric(difftime(currentTime, startDate, units = "hours")) < 48 54 | } 55 | 56 | 57 | if( startDate <= endDate & 58 | !weekend & 59 | !span & 60 | isUpdated ){ 61 | 62 | # Piece this extremely long URL together 63 | base <- "http://query.yahooapis.com/v1/public/yql?" 64 | begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in " 65 | midQuery <- paste0(midQuery, "'", S[min(i * batchsize, length(S))], "') ") 66 | endQuery <- paste0("and startDate = '", startDate, 67 | "' and endDate = '", endDate, "'") 68 | endParams <- "&diagnostics=true&env=store://datatables.org/alltableswithkeys" 69 | 70 | urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams) 71 | 72 | # Fetch data and arrange in XML tree 73 | doc <- xmlParse(urlstr) 74 | 75 | # The next few lines rely heavily and XPath and quirks 76 | # of S4 objects in the XML package in R. 77 | # We retrieve every node (or branch) on //query/results/quote 78 | # and retrieve the values Date, Open, High, etc. from the branch 79 | df <- getNodeSet(doc, c("//query/results/quote"), 80 | fun = function(v) xpathSApply(v, 81 | c("./Date", 82 | "./Open", 83 | "./High", 84 | "./Low", 85 | "./Close", 86 | "./Volume", 87 | "./Adj_Close"), 88 | xmlValue)) 89 | 90 | # If the URL found data we organize and update 91 | if(length(df) != 0){ 92 | 93 | 94 | # We get the atrributes from the same tree, which happen 95 | # to be dates we need 96 | symbols <- unname(sapply( 97 | getNodeSet(doc, c("//query/results/quote")), xmlAttrs)) 98 | 99 | df <- cbind(symbols, data.frame(t(data.frame(df, stringsAsFactors = FALSE)), 100 | stringsAsFactors = FALSE, row.names = NULL)) 101 | 102 | names(df) <- c("Symbol", "Date", 103 | "Open", "High", "Low", "Close", "Volume", "Adj Close") 104 | 105 | df[,3:8] <- lapply(df[,3:8], as.numeric) 106 | df <- df[order(df[,1], decreasing = FALSE),] 107 | 108 | sym <- as.character(unique(df$Symbol)) 109 | 110 | for(s in sym){ 111 | 112 | temp <- df[df$Symbol == s, 2:8] 113 | temp <- temp[order(temp[,1], decreasing = FALSE),] 114 | 115 | startDate <- DATA[[s]][["Date"]][nrow(DATA[[s]])] 116 | 117 | DATA[[s]] <- DATA[[s]][order(DATA[[s]][[1]], decreasing = FALSE)] 118 | DATA[[s]] <- rbind(DATA[[s]], temp[temp$Date > startDate,]) 119 | write.table(DATA[[s]][DATA[[s]][["Date"]] > startDate], 120 | file = paste0(s, ".csv"), sep = ",", 121 | row.names = FALSE, col.names = FALSE, append = TRUE) 122 | 123 | } 124 | } 125 | } 126 | } 127 | -------------------------------------------------------------------------------- /Listings/Chapter 2/2-8.R: -------------------------------------------------------------------------------- 1 | library(zoo) 2 | 3 | # Compute the date template as a column of a data.frame for merging 4 | # Considers date are strings in YYYY-MM-DD format 5 | datetemp <- sort(unique(unlist(sapply(DATA, function(v) v[["Date"]])))) 6 | datetemp <- data.frame(datetemp, stringsAsFactors = FALSE) 7 | names(datetemp) <- "Date" 8 | 9 | # Double-check that our data is unique and in ascending-date order 10 | DATA <- lapply(DATA, function(v) unique(v[order(v$Date),])) 11 | 12 | # Create 6 new objects that will hold our re-orgainzed data 13 | DATA[["Open"]] <- DATA[["High"]] <- DATA[["Low"]] <- 14 | DATA[["Close"]] <- DATA[["Adj Close"]] <- DATA[["Volume"]] <- datetemp 15 | 16 | # This loop will sequentially append the columns of each symbol 17 | # to the appropriate Open, High, Low, etc. object 18 | for(s in S){ 19 | for(i in rev(c("Open", "High", "Low", "Close", "Adj Close", "Volume"))){ 20 | temp <- data.frame(cbind(DATA[[s]][["Date"]], DATA[[s]][[i]]), 21 | stringsAsFactors = FALSE) 22 | names(temp) <- c("Date", s) 23 | temp[,2] <- as.numeric(temp[,2]) 24 | 25 | if(!any(!DATA[[i]][["Date"]][(nrow(DATA[[i]]) - nrow(temp)+1):nrow(DATA[[i]])] 26 | == temp[,1])){ 27 | temp <- rbind(t(matrix(nrow = 2, ncol = nrow(DATA[[i]]) - nrow(temp), 28 | dimnames = list(names(temp)))), temp) 29 | DATA[[i]] <- cbind(DATA[[i]], temp[,2]) 30 | } else { 31 | DATA[[i]] <- merge(DATA[[i]], temp, all.x = TRUE, by = "Date") 32 | } 33 | 34 | names(DATA[[i]]) <- c(names(DATA[[i]])[-(ncol(DATA[[i]]))], s) 35 | } 36 | DATA[[s]] <- NULL 37 | 38 | # Update user on progress 39 | if( which( S == s ) %% 25 == 0 ){ 40 | cat( paste0(round(100 * which( S == s ) / length(S), 1), "% Complete\n") ) 41 | } 42 | 43 | } 44 | 45 | # Declare them as zoo objects for use with time-series functions 46 | DATA <- lapply(DATA, function(v) zoo(v[,2:ncol(v)], strptime(v[,1], "%Y-%m-%d"))) 47 | 48 | # Remove extra variables 49 | rm(list = setdiff(ls(), c("DATA", "datadir", "functiondir", "rootdir"))) 50 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-1.R: -------------------------------------------------------------------------------- 1 | setwd(rootdir) 2 | 3 | if( "SPdates.R" %in% list.files() ){ 4 | source("SPdates.R") 5 | } else { 6 | url <- "http://trading.chrisconlan.com/SPdates.csv" 7 | S <- read.csv(url, header = FALSE, stringsAsFactors = FALSE) 8 | dump(list = "S", "SPdates.R") 9 | } 10 | 11 | names(S) <- c("Symbol", "Date") 12 | S$Date <- strptime(S$Date, "%m/%d/%Y") 13 | 14 | for(s in names(DATA[["Close"]])){ 15 | for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){ 16 | Sindex <- which(S[,1] == s) 17 | if(S[Sindex, "Date"] != "1900-01-01 EST" & 18 | S[Sindex, "Date"] >= "2000-01-01 EST"){ 19 | DATA[[i]][index(DATA[[i]]) <= S[Sindex, "Date"], s] <- NA 20 | } 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-2.R: -------------------------------------------------------------------------------- 1 | temp <- c(DATA[["Close"]][index(DATA[["Close"]]) %in% c("2015-11-23", 2 | "2015-11-24", 3 | "2015-11-25"), "KORS"], 4 | zoo(NA, order.by = strptime("2015-11-26", "%Y-%m-%d")) , 5 | DATA[["Close"]][index(DATA[["Close"]]) %in% c("2015-11-27"), "KORS"], 6 | zoo(NA, order.by = strptime(c("2015-11-28", "2015-11-29"), "%Y-%m-%d")), 7 | DATA[["Close"]][index(DATA[["Close"]]) %in% c("2015-11-30", 8 | "2015-12-01", 9 | "2015-12-02"), "KORS"]) 10 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-3.R: -------------------------------------------------------------------------------- 1 | # Forward replacement function 2 | forwardfun <- function(v, n) { 3 | if(is.na(v[n])){ 4 | return(v[max(which(!is.na(v)))]) 5 | } else { 6 | return(v[n]) 7 | } 8 | } 9 | 10 | maxconsec <- 3 11 | 12 | # We pass maxconsec to rollapply() in "width = " 13 | # and pass it again to forwardfun() in "n = " 14 | forwardrep <- rollapply(temp, 15 | width = maxconsec, 16 | FUN = forwardfun, 17 | n = maxconsec, 18 | by.column = TRUE, 19 | align = "right") 20 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-4.R: -------------------------------------------------------------------------------- 1 | # Linearly Smoothed Replacement Function 2 | linearfun <- function(v, n){ 3 | m <- (n + 1)/2 4 | if(is.na(v[m])){ 5 | a <- max(which(!is.na(v) & seq(1:n) < m)) 6 | b <- min(which(!is.na(v) & seq(1:n) > m)) 7 | return(((b - m)/(b - a)) * v[a] + 8 | ((m - a)/(b - a)) * v[b]) 9 | } else { 10 | return(v[m]) 11 | } 12 | } 13 | 14 | maxconsec <- 5 15 | linearrep <- rollapply(temp, 16 | width = maxconsec, 17 | FUN = linearfun, 18 | n = maxconsec, 19 | by.column = TRUE, 20 | align = "center") 21 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-5.R: -------------------------------------------------------------------------------- 1 | voltemp <- 2 | c(DATA[["Volume"]][index(DATA[["Close"]]) %in% c(index(temp)[1:3]), "KORS"], 3 | zoo(NA, order.by = index(temp)[4]), 4 | DATA[["Volume"]][index(DATA[["Close"]]) %in% c(index(temp)[5]), "KORS"], 5 | zoo(NA, order.by = index(temp)[6:7]), 6 | DATA[["Volume"]][index(DATA[["Close"]]) %in% c(index(temp[8:10])), "KORS"]) 7 | 8 | # Volume-Weighted Smoothed Replacement Function 9 | volfun <- function(v, n, vol){ 10 | m <- (n + 1)/2 11 | if(is.na(v[m])){ 12 | a <- max(which(!is.na(v) & seq(1:n) < m)) 13 | b <- min(which(!is.na(v) & seq(1:n) > m)) 14 | return(((v[a] + ((m-a-1)/(b-a)) * (v[b] - v[a])) * vol[a] + 15 | (v[a] + ((m-a+1)/(b-a)) * (v[b] - v[a])) * vol[b]) / 16 | (vol[a] + vol[b])) 17 | } else { 18 | return(v[m]) 19 | } 20 | } 21 | 22 | maxconsec <- 5 23 | volrep <- rollapply(cbind(temp, voltemp), 24 | width = maxconsec, 25 | FUN = function(v) volfun(v[,1], n = maxconsec, v[,2]), 26 | by.column = FALSE, 27 | align = "center") 28 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-6.R: -------------------------------------------------------------------------------- 1 | # Declare new zoo data frame of adjustment factors 2 | MULT <- DATA[["Adj Close"]] / DATA[["Close"]] 3 | 4 | # Store Close and Open Prices in new variable "Price" and "OpenPrice" 5 | DATA[["Price"]] <- DATA[["Close"]] 6 | DATA[["OpenPrice"]] <- DATA[["Open"]] 7 | 8 | # Adjust Open, High, and Low 9 | DATA[["Open"]] <- DATA[["Open"]] * MULT 10 | DATA[["High"]] <- DATA[["High"]] * MULT 11 | DATA[["Low"]] <- DATA[["Low"]] * MULT 12 | 13 | # Copy Adjusted Close to Close 14 | DATA[["Close"]] <- DATA[["Adj Close"]] 15 | 16 | # Delete Adjusted Close 17 | DATA[["Adj Close"]] <- NULL 18 | 19 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-7.R: -------------------------------------------------------------------------------- 1 | for( s in names(DATA[["Close"]]) ){ 2 | if(is.na(DATA[["Close"]][nrow(DATA[["Close"]]), s])){ 3 | maxInd <- max(which(!is.na(DATA[["Close"]][,s]))) 4 | for( i in c("Close", "Open", "High", "Low")){ 5 | DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Close"]][maxInd,s] 6 | } 7 | for( i in c("Price", "OpenPrice") ){ 8 | DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Price"]][maxInd,s] 9 | } 10 | DATA[["Volume"]][(maxInd+1):nrow(DATA[["Close"]]),s] <- 0 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /Listings/Chapter 3/3-8.R: -------------------------------------------------------------------------------- 1 | # Pad with NA's to perserver dimension equality 2 | NAPAD <- zoo(matrix(NA, nrow = 1, ncol = ncol(DATA[["Close"]])), 3 | order.by = index(DATA[["Close"]])[1]) 4 | names(NAPAD) <- names(DATA[["Close"]]) 5 | 6 | # Compute Daily Close-to-Close Returns 7 | RETURN <- rbind( NAPAD, ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 ) 8 | 9 | # Compute Overnight Returns (Close-to-Open) 10 | OVERNIGHT <- rbind( NAPAD, ( DATA[["Open"]] / lag(DATA[["Close"]], k = -1) ) - 1 ) 11 | 12 | -------------------------------------------------------------------------------- /Listings/Chapter 4/4-1.R: -------------------------------------------------------------------------------- 1 | n <- 20 2 | meanseries <- 3 | rollapply(DATA[["Close"]][,exampleset], 4 | width = n, 5 | FUN = mean, 6 | by.column = TRUE, 7 | fill = NA, 8 | align = "right") 9 | -------------------------------------------------------------------------------- /Listings/Chapter 4/4-2.R: -------------------------------------------------------------------------------- 1 | n1 <- 5 2 | n2 <- 34 3 | MACDseries <- 4 | rollapply(DATA[["Close"]][,exampleset], 5 | width = n2, 6 | FUN = function(v) mean(v[(n2 - n1 + 1):n2]) - mean(v), 7 | by.column = TRUE, 8 | fill = NA, 9 | align = "right") 10 | -------------------------------------------------------------------------------- /Listings/Chapter 4/4-3.R: -------------------------------------------------------------------------------- 1 | n <- 20 2 | rollsd <- rollapply(DATA[["Close"]][,exampleset], 3 | width = n, 4 | FUN = sd, 5 | by.column = TRUE, 6 | fill = NA, 7 | align = "right") 8 | 9 | upperseries <- meanseries + 2 * rollsd 10 | lowerseries <- meanseries + 2 - rollsd 11 | -------------------------------------------------------------------------------- /Listings/Chapter 4/4-4.R: -------------------------------------------------------------------------------- 1 | n <- 10 2 | customseries <- 3 | rollapply(DATA[["Close"]][,exampleset], 4 | width = n, 5 | FUN = function(v) cor(v, n:1)^2 * ((v[n] - v[1])/n), 6 | by.column = TRUE, 7 | fill = NA, 8 | align = "right") 9 | -------------------------------------------------------------------------------- /Listings/Chapter 4/4-5.R: -------------------------------------------------------------------------------- 1 | CMFfunc <- function(close, high, low, volume){ 2 | apply(((2 * close - high - low) / (high - low)) * volume, 3 | MARGIN = 2, 4 | FUN = sum) / 5 | apply(volume, 6 | MARGIN = 2, 7 | FUN = sum) 8 | } 9 | 10 | 11 | n <- 20 12 | k <- length(exampleset) 13 | CMFseries <- 14 | rollapply(cbind(DATA[["Close"]][,exampleset], 15 | DATA[["High"]][,exampleset], 16 | DATA[["Low"]][,exampleset], 17 | DATA[["Volume"]][,exampleset]), 18 | FUN = function(v) CMFfunc(v[,(1:k)], 19 | v[,(k+1):(2*k)], 20 | v[,(2*k + 1):(3*k)], 21 | v[,(3*k + 1):(4*k)]), 22 | by.column = FALSE, 23 | width = n, 24 | fill = NA, 25 | align = "right") 26 | 27 | names(CMFseries) <- exampleset 28 | 29 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-1.R: -------------------------------------------------------------------------------- 1 | # Declare 10mil random numbers in a data frame 2 | df <- data.frame(matrix(nrow = 10000, ncol = 1000, runif(n = 10000 * 1000))) 3 | 4 | 5 | # Compute the sum of each row with a for loop 6 | # Completes in 96.692 seconds 7 | v1 <- rep(NA, 10000) 8 | for( i in 1:10000 ) { 9 | v1[i] <- sum(df[i,]) 10 | } 11 | 12 | 13 | # Use rowSums() binary 14 | # Completes in 0.053 seconds 15 | v2 <- rowSums(df) 16 | 17 | 18 | # Results are exactly the same 19 | # Expression evaluates to TRUE 20 | all.equal(v1, v2) 21 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-10.R: -------------------------------------------------------------------------------- 1 | k <- 2 2 | 3 | # Using for a for loop, pre-allocated 4 | RETURN <- foreach( i = 1:workers, .combine = rbind, 5 | .packages = "zoo" ) %dopar% { 6 | 7 | CLOSE <- as.matrix(DATA[["Close"]]) 8 | 9 | jRange <- delegate( i = i, n = nrow(DATA[["Close"]]), k = k, p = workers) 10 | 11 | subRETURN <- zoo( 12 | matrix(numeric(), 13 | ncol = ncol(DATA[["Close"]]), 14 | nrow = length(jRange) - k + 1), 15 | order.by = (index(DATA[["Close"]])[jRange])[-(1:(k-1))]) 16 | 17 | names(subRETURN) <- names(DATA[["Close"]]) 18 | 19 | for( j in jRange[-1] ){ 20 | jmod <- j - jRange[1] 21 | subRETURN[jmod, ] <- (CLOSE[j,] / CLOSE[j-1,]) - 1 22 | } 23 | 24 | subRETURN 25 | 26 | } 27 | # Completes in 6.99 seconds 28 | 29 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-11.R: -------------------------------------------------------------------------------- 1 | # Using rollapply(), automatically pre-allocated 2 | RETURN <- foreach( i = 1:workers, .combine = rbind, 3 | .packages = "zoo") %dopar% { 4 | 5 | jRange <- delegate( i = i, n = nrow(DATA[["Close"]]), k = k, p = workers) 6 | 7 | rollapply(DATA[["Close"]][jRange,], 8 | width = k, 9 | FUN = function(v) (v[2,]/v[1,]) - 1, 10 | align = "right", 11 | by.column = FALSE, 12 | na.pad = FALSE) 13 | 14 | } 15 | # Completes in 22.58 seconds 16 | 17 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-12.R: -------------------------------------------------------------------------------- 1 | mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers, ... ){ 2 | 3 | # For Windows compatability 4 | args <- names(mget(ls())) 5 | export <- ls(.GlobalEnv) 6 | export <- export[!export %in% args] 7 | 8 | # foreach powerhouse 9 | SERIES <- foreach( i = 1:workers, .combine = rbind, 10 | .packages = loadedNamespaces(), .export = export) %dopar% { 11 | 12 | jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers) 13 | 14 | rollapply(data[jRange,], 15 | width = windowSize, 16 | FUN = tsfunc, 17 | align = "right", 18 | by.column = byColumn) 19 | 20 | } 21 | 22 | # Correct formatting of column names and dimensions 23 | names(SERIES) <- gsub("\\..+", "", names(SERIES)) 24 | 25 | if( windowSize > 1){ 26 | PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA), 27 | order.by = index(data)[1:(windowSize-1)]) 28 | names(PAD) <- names(SERIES) 29 | SERIES <- rbind(PAD, SERIES) 30 | } 31 | 32 | if(is.null(names(SERIES))){ 33 | names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)]) 34 | } 35 | 36 | # Return results 37 | return(SERIES) 38 | 39 | } 40 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-13.R: -------------------------------------------------------------------------------- 1 | # Computing the return matrix 2 | tsfunc <- function(v) (v[2,] / v[1,]) - 1 3 | RETURN <- mcTimeSeries( DATA[["Close"]], tsfunc, FALSE, 2, workers ) 4 | 5 | 6 | # Computing a simple moving average 7 | SMA <- mcTimeSeries( DATA[["Close"]], mean, TRUE, 20, workers ) 8 | 9 | 10 | # Computing an MACD, n1 = 5, n2 = 34 11 | tsfunc <- function(v) mean(v[(length(v) - 4):length(v)]) - mean(v) 12 | MACD <- mcTimeSeries( DATA[["Close"]], tsfunc, TRUE, 34, workers ) 13 | 14 | 15 | # Computing Bollinger Bands, n = 20, scale = 2 16 | SDSeries <- mcTimeSeries(DATA[["Close"]], function(v) sd(v), TRUE, 20, workers) 17 | upperBand <- SMA + 2 * SDSeries 18 | lowerBand <- SMA - 2 * SDSeries 19 | 20 | 21 | # Computing custom indicator as in Listing 4.3 22 | tsfunc <- function(v) cor(v, length(v):1)^2 * ((v[length(v)] - v[1])/length(v)) 23 | customIndicator <- mcTimeSeries( DATA[["Close"]], tsfunc, TRUE, 10, workers ) 24 | 25 | 26 | # Computing Chaikin Money Flow, n = 20, (Using CMFfunc() function from Listing 4.5) 27 | cols <- ncol(DATA[["Close"]]) 28 | CMFseries <- mcTimeSeries( cbind(DATA[["Close"]], 29 | DATA[["High"]], 30 | DATA[["Low"]], 31 | DATA[["Volume"]]), 32 | function(v) CMFfunc(v[,(1:cols)], 33 | v[,(cols+1):(2*cols)], 34 | v[,(2*cols + 1):(3*cols)], 35 | v[,(3*cols + 1):(4*cols)]), 36 | FALSE, 20, workers) 37 | 38 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-2.R: -------------------------------------------------------------------------------- 1 | # Sequentially re-allocating space in a for loop 2 | RETURN <- NULL 3 | for(i in 2:nrow(DATA[["Close"]])){ 4 | RETURN <- rbind(RETURN, t((matrix(DATA[["Close"]][i, ]) / 5 | matrix(DATA[["Close"]][i-1, ])) - 1)) 6 | } 7 | RETURN <- zoo( RETURN, order.by = index(DATA[["Close"]])[-1]) 8 | # 99.68 seconds 9 | 10 | 11 | 12 | # Pre-allocating space and computing in a for loop 13 | RETURN <- zoo(matrix(ncol = ncol(DATA[["Close"]]), 14 | nrow = nrow(DATA[["Close"]])), 15 | order.by = index(DATA[["Close"]])) 16 | 17 | for(i in 2:nrow(DATA[["Close"]])){ 18 | RETURN[i,] <- t((matrix(DATA[["Close"]][i, ]) / matrix(DATA[["Close"]][i-1, ])) - 1) 19 | } 20 | # 54.34 seconds 21 | 22 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-3.R: -------------------------------------------------------------------------------- 1 | # Using rollapply() element-by-element 2 | RETURN <- rollapply(DATA[["Close"]], 3 | width = 2, 4 | FUN = function(v) (v[2]/v[1]) - 1, 5 | align = "right", 6 | by.column = TRUE, 7 | fill = NA) 8 | # 105.77 seconds 9 | 10 | 11 | 12 | # Using rollapply() row-by-row 13 | RETURN <- rollapply(DATA[["Close"]], 14 | width = 2, 15 | FUN = function(v) (v[2,]/v[1,]) - 1, 16 | align = "right", 17 | by.column = FALSE, 18 | fill = NA) 19 | # 65.37 seconds 20 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-4.R: -------------------------------------------------------------------------------- 1 | # Using the "lag" method introduced in Listing 3.8 2 | RETURN <- ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 3 | # 0.459 seconds 4 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-5.R: -------------------------------------------------------------------------------- 1 | timeLapse <- proc.time()[3] 2 | for( i in 1:1000000) v <- runif(1) 3 | proc.time()[3] - timeLapse 4 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-6.R: -------------------------------------------------------------------------------- 1 | library(doMC) 2 | workers <- 4 3 | registerDoMC( cores = workers ) 4 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-7.R: -------------------------------------------------------------------------------- 1 | library(doParallel) 2 | workers <- 4 3 | registerDoParallel( cores = workers ) 4 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-8.R: -------------------------------------------------------------------------------- 1 | library(foreach) 2 | 3 | # Returns a list 4 | foreach( i = 1:4 ) %dopar% { 5 | j <- i + 1 6 | sqrt(j) 7 | } 8 | 9 | 10 | # Returns a vector 11 | foreach( i = 1:4, .combine = c ) %dopar% { 12 | j <- i + 1 13 | sqrt(j) 14 | } 15 | 16 | 17 | # Returns a matrix 18 | foreach( i = 1:4, .combine = rbind ) %dopar% { 19 | j <- i + 1 20 | matrix(c(i, j, sqrt(j)), nrow = 1) 21 | } 22 | 23 | 24 | # Returns a data frame 25 | foreach( i = 1:4, .combine = rbind ) %dopar% { 26 | j <- i + 1 27 | data.frame( i = i, j = j, sqrt.j = sqrt(j)) 28 | } 29 | -------------------------------------------------------------------------------- /Listings/Chapter 6/6-9.R: -------------------------------------------------------------------------------- 1 | delegate <- function( i = i, n = n, k = k, p = workers ){ 2 | nOut <- n - k + 1 3 | nProc <- ceiling( nOut / p ) 4 | return( (( i - 1 ) * nProc + 1) : min(i * nProc + k - 1, n) ) 5 | } 6 | 7 | # Test i as 1 through 4 to verify it matches our example 8 | lapply(1:4, function(i) delegate(i, n = 100, k = 5, p = 4)) 9 | 10 | -------------------------------------------------------------------------------- /Listings/Chapter 7/7-1.R: -------------------------------------------------------------------------------- 1 | equNA <- function(v){ 2 | o <- which(!is.na(v))[1] 3 | return(ifelse(is.na(o), length(v)+1, o)) 4 | } 5 | 6 | simulate <- function(OPEN, CLOSE, 7 | ENTRY, EXIT, FAVOR, 8 | maxLookback, maxAssets, startingCash, 9 | slipFactor, spreadAdjust, flatCommission, perShareCommission, 10 | verbose = FALSE, failThresh = 0, 11 | initP = NULL, initp = NULL){ 12 | 13 | 14 | # Step 1 15 | if( any( dim(ENTRY) != dim(EXIT) ) | 16 | any( dim(EXIT) != dim(FAVOR) ) | 17 | any( dim(FAVOR) != dim(CLOSE) ) | 18 | any( dim(CLOSE) != dim(OPEN)) ) 19 | stop( "Mismatching dimensions in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.") 20 | 21 | if( any( names(ENTRY) != names(EXIT)) | 22 | any( names(EXIT) != names(FAVOR) ) | 23 | any( names(FAVOR) != names(CLOSE) ) | 24 | any( names(CLOSE) != names(OPEN) ) | 25 | is.null(names(ENTRY)) | is.null(names(EXIT)) | 26 | is.null(names(FAVOR)) | is.null(names(CLOSE)) | 27 | is.null(names(OPEN)) ) 28 | stop( "Mismatching or missing column names in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.") 29 | 30 | 31 | FAVOR <- zoo(t(apply(FAVOR, 1, function(v) ifelse(is.nan(v) | is.na(v), 0, v) )), 32 | order.by = index(CLOSE)) 33 | 34 | 35 | # Step 2 36 | K <- maxAssets 37 | k <- 0 38 | C <- rep(startingCash, times = nrow(CLOSE)) 39 | S <- names(CLOSE) 40 | 41 | P <- p <- zoo( matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)), 42 | order.by = index(CLOSE) ) 43 | 44 | if( !is.null( initP ) & !is.null( initp ) ){ 45 | P[1:maxLookback,] <- 46 | matrix(initP, ncol=length(initP), nrow=maxLookback, byrow = TRUE) 47 | p[1:maxLookback,] <- 48 | matrix(initp, ncol=length(initp), nrow=maxLookback, byrow = TRUE) 49 | } 50 | 51 | names(P) <- names(p) <- S 52 | 53 | equity <- rep(NA, nrow(CLOSE)) 54 | 55 | 56 | 57 | rmNA <- pmax(unlist(lapply(FAVOR, equNA)), 58 | unlist(lapply(ENTRY, equNA)), 59 | unlist(lapply(EXIT, equNA))) 60 | 61 | for( j in 1:ncol(ENTRY) ){ 62 | toRm <- rmNA[j] 63 | if( toRm > (maxLookback + 1) & 64 | toRm < nrow(ENTRY) ){ 65 | FAVOR[1:(toRm-1),j] <- NA 66 | ENTRY[1:(toRm-1),j] <- NA 67 | EXIT[1:(toRm-1),j] <- NA 68 | } 69 | } 70 | 71 | 72 | # Step 3 73 | for( i in maxLookback:(nrow(CLOSE)-1) ){ 74 | 75 | # Step 4 76 | C[i+1] <- C[i] 77 | P[i+1,] <- as.numeric(P[i,]) 78 | p[i+1,] <- as.numeric(p[i,]) 79 | 80 | longS <- S[which(P[i,] > 0)] 81 | shortS <- S[which(P[i,] < 0)] 82 | k <- length(longS) + length(shortS) 83 | 84 | # Step 5 85 | longTrigger <- setdiff(S[which(ENTRY[i,] == 1)], longS) 86 | shortTrigger <- setdiff(S[which(ENTRY[i,] == -1)], shortS) 87 | trigger <- c(longTrigger, shortTrigger) 88 | 89 | if( length(trigger) > K ) { 90 | 91 | keepTrigger <- trigger[order(c(as.numeric(FAVOR[i,longTrigger]), 92 | -as.numeric(FAVOR[i,shortTrigger])), 93 | decreasing = TRUE)][1:K] 94 | 95 | longTrigger <- longTrigger[longTrigger %in% keepTrigger] 96 | shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger] 97 | 98 | trigger <- c(longTrigger, shortTrigger) 99 | 100 | } 101 | 102 | triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger))) 103 | 104 | 105 | # Step 6 106 | longExitTrigger <- longS[longS %in% 107 | S[which(EXIT[i,] == 1 | EXIT[i,] == 999)]] 108 | 109 | shortExitTrigger <- shortS[shortS %in% 110 | S[which(EXIT[i,] == -1 | EXIT[i,] == 999)]] 111 | 112 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 113 | 114 | 115 | # Step 7 116 | needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0) 117 | 118 | if( needToExit > 0 ){ 119 | 120 | toExitLongS <- setdiff(longS, exitTrigger) 121 | toExitShortS <- setdiff(shortS, exitTrigger) 122 | 123 | toExit <- character(0) 124 | 125 | for( counter in 1:needToExit ){ 126 | if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){ 127 | if( min(FAVOR[i,toExitLongS]) < min(-FAVOR[i,toExitShortS]) ){ 128 | pullMin <- which.min(FAVOR[i,toExitLongS]) 129 | toExit <- c(toExit, toExitLongS[pullMin]) 130 | toExitLongS <- toExitLongS[-pullMin] 131 | } else { 132 | pullMin <- which.min(-FAVOR[i,toExitShortS]) 133 | toExit <- c(toExit, toExitShortS[pullMin]) 134 | toExitShortS <- toExitShortS[-pullMin] 135 | } 136 | } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){ 137 | pullMin <- which.min(FAVOR[i,toExitLongS]) 138 | toExit <- c(toExit, toExitLongS[pullMin]) 139 | toExitLongS <- toExitLongS[-pullMin] 140 | } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){ 141 | pullMin <- which.min(-FAVOR[i,toExitShortS]) 142 | toExit <- c(toExit, toExitShortS[pullMin]) 143 | toExitShortS <- toExitShortS[-pullMin] 144 | } 145 | } 146 | 147 | longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit]) 148 | shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit]) 149 | 150 | } 151 | 152 | # Step 8 153 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 154 | exitTriggerType <- c(rep(1, length(longExitTrigger)), 155 | rep(-1, length(shortExitTrigger))) 156 | 157 | 158 | # Step 9 159 | if( length(exitTrigger) > 0 ){ 160 | for( j in 1:length(exitTrigger) ){ 161 | 162 | exitPrice <- as.numeric(OPEN[i+1,exitTrigger[j]]) 163 | 164 | effectivePrice <- exitPrice * (1 - exitTriggerType[j] * slipFactor) - 165 | exitTriggerType[j] * (perShareCommission + spreadAdjust) 166 | 167 | if( exitTriggerType[j] == 1 ){ 168 | 169 | C[i+1] <- C[i+1] + 170 | ( as.numeric( P[i,exitTrigger[j]] ) * effectivePrice ) 171 | - flatCommission 172 | 173 | } else { 174 | 175 | C[i+1] <- C[i+1] - 176 | ( as.numeric( P[i,exitTrigger[j]] ) * 177 | ( 2 * as.numeric(p[i, exitTrigger[j]]) - effectivePrice ) ) 178 | - flatCommission 179 | } 180 | 181 | P[i+1, exitTrigger[j]] <- 0 182 | p[i+1, exitTrigger[j]] <- 0 183 | 184 | k <- k - 1 185 | 186 | } 187 | } 188 | 189 | 190 | # Step 10 191 | if( length(trigger) > 0 ){ 192 | for( j in 1:length(trigger) ){ 193 | 194 | entryPrice <- as.numeric(OPEN[i+1,trigger[j]]) 195 | 196 | effectivePrice <- entryPrice * (1 + triggerType[j] * slipFactor) + 197 | triggerType[j] * (perShareCommission + spreadAdjust) 198 | 199 | P[i+1,trigger[j]] <- triggerType[j] * 200 | floor( ( (C[i+1] - flatCommission) / (K - k) ) / effectivePrice ) 201 | 202 | p[i+1,trigger[j]] <- effectivePrice 203 | 204 | C[i+1] <- C[i+1] - 205 | ( triggerType[j] * as.numeric(P[i+1,trigger[j]]) * effectivePrice ) 206 | - flatCommission 207 | 208 | k <- k + 1 209 | 210 | } 211 | } 212 | 213 | 214 | # Step 11 215 | equity[i] <- C[i+1] 216 | for( s in S[which(P[i+1,] > 0)] ){ 217 | equity[i] <- equity[i] + 218 | as.numeric(P[i+1,s]) * 219 | as.numeric(OPEN[i+1,s]) 220 | } 221 | 222 | for( s in S[which(P[i+1,] < 0)] ){ 223 | equity[i] <- equity[i] - 224 | as.numeric(P[i+1,s]) * 225 | ( 2 * as.numeric(p[i+1,s]) - as.numeric(OPEN[i+1,s]) ) 226 | } 227 | 228 | if( equity[i] < failThresh ){ 229 | warning("\n*** Failure Threshold Breached ***\n") 230 | break 231 | } 232 | 233 | # Step 12 234 | if( verbose ){ 235 | if( i %% 21 == 0 ){ 236 | cat(paste0("################################## ", 237 | round(100 * (i - maxLookback) / 238 | (nrow(CLOSE) - 1 - maxLookback), 1), "%", 239 | " ##################################\n")) 240 | cat(paste("Date:\t",as.character(index(CLOSE)[i])), "\n") 241 | cat(paste0("Equity:\t", " $", signif(equity[i], 5), "\n")) 242 | cat(paste0("CAGR:\t ", 243 | round(100 * ((equity[i] / (equity[maxLookback]))^ 244 | (252/(i - maxLookback + 1)) - 1), 2), 245 | "%")) 246 | cat("\n") 247 | cat("Assets:\t", S[P[i+1,] != 0]) 248 | cat("\n\n") 249 | } 250 | } 251 | 252 | 253 | 254 | } 255 | 256 | # Step 13 257 | return(list(equity = equity, C = C, P = P, p = p)) 258 | 259 | } 260 | -------------------------------------------------------------------------------- /Listings/Chapter 7/7-2.R: -------------------------------------------------------------------------------- 1 | SUBDATA <- lapply(DATA, function(v) v[-(1:3500),]) 2 | SUBRETURN <- RETURN[-(1:3500),] 3 | 4 | n1 <- 5 5 | n2 <- 34 6 | nSharpe <- 20 7 | shThresh <- 0.80 8 | 9 | INDIC <- mcTimeSeries(SUBDATA[["Close"]], 10 | function(v) mean(v[(n2 - n1 + 1):n2]) - mean(v), 11 | TRUE, n2, workers) 12 | 13 | 14 | entryfunc <- function(v){ 15 | cols <- ncol(v) / 2 16 | as.numeric(v[1,1:cols] <= 0 & 17 | v[2,1:cols] > 0 & 18 | v[2,(cols+1):(2*cols)] > 19 | quantile(v[2,(cols+1):(2*cols)], shThresh, na.rm = TRUE) 20 | ) 21 | } 22 | 23 | FAVOR <- mcTimeSeries(SUBRETURN, 24 | function(v) mean(v, na.rm = TRUE)/sd(v, na.rm = TRUE), 25 | TRUE, nSharpe, workers) 26 | 27 | ENTRY <- mcTimeSeries(cbind(INDIC, FAVOR), 28 | entryfunc, 29 | FALSE, 2, workers) 30 | 31 | EXIT <- zoo(matrix(0, ncol=ncol(SUBDATA[["Close"]]), nrow=nrow(SUBDATA[["Close"]])), 32 | order.by = index(SUBDATA[["Close"]])) 33 | names(EXIT) <- names(SUBDATA[["Close"]]) 34 | 35 | K <- 10 36 | 37 | maxLookback <- max(n1, n2, nSharpe) + 1 38 | 39 | RESULTS <- simulate(SUBDATA[["Open"]], SUBDATA[["Close"]], 40 | ENTRY, EXIT, FAVOR, 41 | maxLookback, K, 100000, 42 | 0.0005, 0.01, 3.5, 0, 43 | TRUE, 0) 44 | 45 | -------------------------------------------------------------------------------- /Listings/Chapter 7/7-3.R: -------------------------------------------------------------------------------- 1 | SUBDATA <- lapply(DATA, function(v) v[-(1:3500),]) 2 | SUBRETURN <- RETURN[-(1:3500),] 3 | 4 | n1 <- 20 5 | n2 <- 100 6 | maxLookback <- max(n2, n1) + 1 7 | 8 | SD <- mcTimeSeries(SUBDATA[["Close"]], 9 | function(v) sd(v, na.rm = TRUE), 10 | TRUE, n1, workers) 11 | 12 | MOVAVG <- mcTimeSeries(SUBDATA[["Close"]], 13 | function(v) mean(v, na.rm = TRUE), 14 | TRUE, n1, workers) 15 | 16 | LONGMOVAVG <- mcTimeSeries(SUBDATA[["Close"]], 17 | function(v) mean(v, na.rm = TRUE), 18 | TRUE, n2, workers) 19 | 20 | bt <- (SUBDATA[["Close"]] - MOVAVG) / SD 21 | Bt <- (MOVAVG - LONGMOVAVG) / SD 22 | 23 | 24 | triggerfunc <- function(v, columns){ 25 | 26 | goLong <- as.numeric( 27 | ((v[2,1:columns] >= 1 & v[2,1:columns] < 3) | v[2,1:columns] <= -3) & 28 | (v[1,(columns+1):(2*columns)] >= -2 & v[2,(columns+1):(2*columns)] < -2) 29 | ) 30 | 31 | goShort <- as.numeric( 32 | ((v[2,1:columns] > -3 & v[2,1:columns] <= -1) | v[2,1:columns] >= 3) & 33 | (v[1,(columns+1):(2*columns)] <= 2 & v[2,(columns+1):(2*columns)] > 2) 34 | ) 35 | 36 | return( goLong - goShort ) 37 | 38 | } 39 | 40 | 41 | exitfunc <- function(v, columns){ 42 | 43 | exitLong <- as.numeric(v[2,(columns+1):(2*columns)] >= 2 & 44 | v[1,(columns+1):(2*columns)] < 2) 45 | 46 | exitShort <- -as.numeric(v[1,(columns+1):(2*columns)] >= -2 & 47 | v[2,(columns+1):(2*columns)] < -2) 48 | 49 | exitAll <- 999 * as.numeric( (v[1,1:columns] >= 0 & v[2,1:columns] < 0) | 50 | (v[1,1:columns] <= 0 & v[2,1:columns] > 0) ) 51 | 52 | out <- exitLong + exitShort + exitAll 53 | 54 | out[out > 1] <- 999 55 | out[!out %in% c(-1,0,1,999)] <- 0 56 | 57 | return( out ) 58 | 59 | } 60 | 61 | 62 | columns <- ncol(SUBDATA[["Close"]]) 63 | 64 | ENTRY <- mcTimeSeries(cbind(Bt, bt), function(v) triggerfunc(v, columns), 65 | FALSE, 2, workers) 66 | 67 | FAVOR <- mcTimeSeries(SUBRETURN, mean, TRUE, n1, workers) 68 | 69 | EXIT <- mcTimeSeries(cbind(Bt, bt), function(v) exitfunc(v, columns), 70 | FALSE, 2, workers) 71 | 72 | K <- 20 73 | 74 | RESULTS <- simulate(SUBDATA[["Open"]], SUBDATA[["Close"]], 75 | ENTRY, EXIT, FAVOR, 76 | maxLookback, K, 100000, 77 | 0.0005, 0.01, 3.5, 0, 78 | TRUE, 0) 79 | 80 | -------------------------------------------------------------------------------- /Listings/Chapter 7/7-4.R: -------------------------------------------------------------------------------- 1 | SUBDATA <- lapply(DATA, function(v) v[-(1:3500),]) 2 | SUBRETURN <- RETURN[-(1:3500),] 3 | 4 | truerangefunc <- function(v, cols){ 5 | pmax(v[2, (cols+1):(2*cols)] - v[2,1:cols], 6 | abs(v[2, 1:cols]-v[1, (2*cols + 1):(3*cols)]), 7 | abs(v[1, (cols+1):(2*cols)]-v[2, (2*cols + 1):(3*cols)])) 8 | } 9 | 10 | cols <- ncol(SUBDATA[["Close"]]) 11 | TR <- mcTimeSeries(cbind(SUBDATA[["Low"]], SUBDATA[["High"]], SUBDATA[["Close"]]), 12 | function(v) truerangefunc(v, cols), FALSE, 2, workers) 13 | 14 | # Calculate ATR with SMA method 15 | ATR <- mcTimeSeries(TR, mean, TRUE, 20, workers) 16 | 17 | ROLLMIN <- mcTimeSeries(SUBDATA[["Close"]], min, TRUE, 100, workers) 18 | ROLLMAX <- mcTimeSeries(SUBDATA[["Close"]], max, TRUE, 100, workers) 19 | 20 | m_plus <- (ROLLMAX - SUBDATA[["Close"]]) / ATR 21 | m_minus <- (SUBDATA[["Close"]] - ROLLMIN) / ATR 22 | 23 | 24 | RS <- mcTimeSeries(SUBRETURN, 25 | function(v) mean(v[v>0], na.rm = T) / mean(v[v<0], na.rm = T), 26 | TRUE, 20, workers) 27 | 28 | RSI <- mcTimeSeries( RS, function(v) 100 - (100 / (1 + v)), FALSE, 1, workers) 29 | 30 | 31 | 32 | entryfunc <- function(v, cols){ 33 | 34 | goshort <- v[2,1:cols] <= 2 & 35 | (v[1,(2*cols+1):(3*cols)] > 70 & 36 | v[2,(2*cols+1):(3*cols)] <= 70 ) 37 | 38 | golong <- v[2,(cols+1):(2*cols)] <= 2 & 39 | (v[1,(2*cols+1):(3*cols)] < 30 & 40 | v[2,(2*cols+1):(3*cols)] >= 30 ) 41 | 42 | return( as.numeric(golong) - as.numeric(goshort) ) 43 | 44 | } 45 | 46 | ENTRY <- mcTimeSeries(cbind(m_plus, m_minus, RSI), 47 | function(v) entryfunc(v, cols), FALSE, 2, workers) 48 | 49 | 50 | FAVOR <- mcTimeSeries(SUBRETURN, mean, TRUE, 20, workers) 51 | 52 | exitfunc <- function(v){ 53 | cols <- ncol(SUBDATA[["Close"]]) 54 | exitlong <- as.numeric(v > 70 | v < 15) 55 | exitshort <- as.numeric(v < 30 | v > 85) 56 | return( exitlong - exitshort ) 57 | } 58 | 59 | EXIT <- mcTimeSeries(RSI, exitfunc, FALSE, 1, workers) 60 | 61 | K <- 20 62 | 63 | RESULTS <- simulate(SUBDATA[["Open"]], SUBDATA[["Close"]], 64 | ENTRY, EXIT, FAVOR, 65 | maxLookback, K, 100000, 66 | 0.0005, 0.01, 3.5, 0, 67 | TRUE, 0) 68 | -------------------------------------------------------------------------------- /Listings/Chapter 7/7-5.R: -------------------------------------------------------------------------------- 1 | changeInEquity <- c(NA, RESULTS[["equity"]][-1] - 2 | RESULTS[["equity"]][-length(RESULTS[["equity"]])]) 3 | 4 | # Return Series as defined in Chapter 1 5 | R <- zoo(changeInEquity / (RESULTS[["equity"]]), order.by = index(SUBDATA[["Close"]])) 6 | 7 | plot(100 * R, type = "l", main = "Figure 7.1: Return Series for Long-Only MACD", 8 | ylab = "Percent Return", xlab = "") 9 | grid() 10 | abline( h = 0, col = 8 ) 11 | 12 | # Equity Cruve 13 | plot(y = RESULTS[["equity"]], x = index(SUBDATA[["Close"]]), 14 | type = "l", main = "Figure 7.2: Equity Curve for Long-Only MACD", 15 | ylab = "Account Equity ($)", xlab = "") 16 | abline(h = RESULTS[["C"]][1]) 17 | grid() 18 | 19 | 20 | 21 | # Sharpe Ratio 22 | sharpeRatio <- mean(R, na.rm = T) / sd(R, na.rm = T) 23 | 24 | 25 | # Daily percent portfolio turnover 26 | changeP <- RESULTS[["P"]] - lag(RESULTS[["P"]], k = -1) 27 | percentTurnover <- 100 * (sum(changeP > 0) / nrow(DATA[["Close"]])) / K 28 | -------------------------------------------------------------------------------- /Listings/Chapter 8/8-1.R: -------------------------------------------------------------------------------- 1 | y <- 2014 2 | 3 | minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01) 4 | maxVal <- c(n1 = 150, nFact = 5, nSharpe = 200, shThresh = .99) 5 | 6 | PARAM <- c(n1 = -2, nFact = -2, nSharpe = -2, shThresh = 0) 7 | 8 | # Declare entry function for use inside evaluator 9 | entryfunc <- function(v, shThresh){ 10 | cols <- ncol(v)/2 11 | as.numeric(v[1,1:cols] <= 0 & 12 | v[2,1:cols] > 0 & 13 | v[2,(cols+1):(2*cols)] > 14 | quantile(v[2,(cols+1):(2*cols)], 15 | shThresh, na.rm = TRUE) 16 | ) 17 | } 18 | 19 | 20 | 21 | evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014, 22 | transform = FALSE, verbose = FALSE, 23 | negative = FALSE, transformOnly = FALSE, 24 | returnData = FALSE, accountParams = NULL){ 25 | 26 | # Step 1 27 | # Convert and declare parameters if they exist on unbounded (-inf,inf) domain 28 | if( transform | transformOnly ){ 29 | PARAM <- minVal + 30 | (maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) )) 31 | if( transformOnly ){ 32 | return(PARAM) 33 | } 34 | } 35 | 36 | # Step 2 37 | # Declare n1 as itself, n2 as a multiple of n1 defined by nFact, 38 | # and declare the length and threshold in sharpe ratio for FAVOR. 39 | # This section should handle rounding and logical bounding 40 | # in moving 41 | n1 <- max(round(PARAM[["n1"]]), 2) 42 | n2 <- max(round(PARAM[["nFact"]] * PARAM[["n1"]]), 3, n1+1) 43 | nSharpe <- max(round(PARAM[["nSharpe"]]), 2) 44 | shThresh <- max(0, min(PARAM[["shThresh"]], .99)) 45 | maxLookback <- max(n1, n2, nSharpe) + 1 46 | 47 | 48 | # Step 3 49 | # Subset data according to range of years y 50 | period <- 51 | index(DATA[["Close"]]) >= strptime(paste0("01-01-", y[1]), "%d-%m-%Y") & 52 | index(DATA[["Close"]]) < strptime(paste0("01-01-", y[length(y)]+1), "%d-%m-%Y") 53 | 54 | period <- period | 55 | ((1:nrow(DATA[["Close"]]) > (which(period)[1] - maxLookback)) & 56 | (1:nrow(DATA[["Close"]]) <= (which(period)[sum(period)]) + 1)) 57 | 58 | 59 | # Step 4 60 | CLOSE <- DATA[["Close"]][period,] 61 | OPEN <- DATA[["Open"]][period,] 62 | SUBRETURN <- RETURN[period,] 63 | 64 | 65 | # Step 5 66 | # Compute inputs for long-only MACD as in Listing 7.2 67 | # Code is optimized for speed using functions from caTools and zoo 68 | require(caTools) 69 | 70 | INDIC <- zoo(runmean(CLOSE, n1, endrule = "NA", align = "right") - 71 | runmean(CLOSE, n2, endrule = "NA", align = "right"), 72 | order.by = index(CLOSE)) 73 | names(INDIC) <- names(CLOSE) 74 | 75 | 76 | RMEAN <- zoo(runmean(SUBRETURN, n1, endrule = "NA", align = "right"), 77 | order.by = index(SUBRETURN)) 78 | 79 | FAVOR <- RMEAN / runmean( (SUBRETURN - RMEAN)^2, nSharpe, 80 | endrule = "NA", align = "right" ) 81 | names(FAVOR) <- names(CLOSE) 82 | 83 | 84 | ENTRY <- rollapply(cbind(INDIC, FAVOR), 85 | FUN = function(v) entryfunc(v, shThresh), 86 | width = 2, 87 | fill = NA, 88 | align = "right", 89 | by.column = FALSE) 90 | names(ENTRY) <- names(CLOSE) 91 | 92 | EXIT <- zoo(matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)), 93 | order.by = index(CLOSE)) 94 | names(EXIT) <- names(CLOSE) 95 | 96 | 97 | # Step 6 98 | # Max shares to hold 99 | K <- 10 100 | 101 | # Simulate and store results 102 | if( is.null(accountParams) ){ 103 | RESULTS <- simulate(OPEN, CLOSE, 104 | ENTRY, EXIT, FAVOR, 105 | maxLookback, K, 100000, 106 | 0.001, 0.01, 3.5, 0, 107 | verbose, 0) 108 | } else { 109 | RESULTS <- simulate(OPEN, CLOSE, 110 | ENTRY, EXIT, FAVOR, 111 | maxLookback, K, accountParams[["C"]], 112 | 0.001, 0.01, 3.5, 0, 113 | verbose, 0, 114 | initP = accountParams[["P"]], initp = accountParams[["p"]]) 115 | } 116 | 117 | # Step 7 118 | if(!returnData){ 119 | 120 | # Compute and return sharpe ratio 121 | v <- RESULTS[["equity"]] 122 | returns <- ( v[-1] / v[-length(v)] ) - 1 123 | out <- mean(returns, na.rm = T) / sd(returns, na.rm = T) 124 | if(!is.nan(out)){ 125 | if( negative ){ 126 | return( -out ) 127 | } else { 128 | return( out ) 129 | } 130 | } else { 131 | return(0) 132 | } 133 | 134 | } else { 135 | return(RESULTS) 136 | } 137 | 138 | } 139 | 140 | # To test value of objective function 141 | objective <- evaluate(PARAM, minVal, maxVal, y) 142 | 143 | -------------------------------------------------------------------------------- /Listings/Chapter 8/8-2.R: -------------------------------------------------------------------------------- 1 | # Declare bounds and step size for optimization 2 | lowerBound <- c(n1 = 5, nFact = 3, nSharpe = 22, shThresh = 0.05) 3 | upperBound <- c(n1 = 80, nFact = 3, nSharpe = 22, shThresh = 0.95) 4 | stepSize <- c(n1 = 5, nFact = 1, nSharpe = 1, shThresh = 0.05) 5 | 6 | pnames <- names(stepSize) 7 | np <- length(pnames) 8 | 9 | # Declare list of all test points 10 | POINTS <- list() 11 | for( p in pnames ){ 12 | POINTS[[p]] <- seq(lowerBound[[p]], upperBound[[p]], stepSize[[p]]) 13 | } 14 | 15 | OPTIM <- data.frame(matrix(NA, nrow = prod(unlist(lapply(POINTS, length))), 16 | ncol = np + 1)) 17 | names(OPTIM)[1:np] <- names(POINTS) 18 | names(OPTIM)[np+1] <- "obj" 19 | 20 | # Store all possible combinations of parameters 21 | for( i in 1:np ){ 22 | each <- prod(unlist(lapply(POINTS, length))[-(1:i)]) 23 | times <- prod(unlist(lapply(POINTS, length))[-(i:length(pnames))]) 24 | OPTIM[,i] <- rep(POINTS[[pnames[i]]], each = each, times = times) 25 | } 26 | 27 | # Test each row of OPTIM 28 | timeLapse <- proc.time()[3] 29 | for( i in 1:nrow(OPTIM) ){ 30 | OPTIM[i,np+1] <- evaluate(OPTIM[i,1:np], transform = FALSE, y = 2014) 31 | cat(paste0("## ", floor( 100 * i / nrow(OPTIM)), "% complete\n")) 32 | cat(paste0("## ", 33 | round( ((proc.time()[3] - timeLapse) * 34 | ((nrow(OPTIM) - i)/ i))/60, 2), 35 | " minutes remaining\n\n")) 36 | } 37 | -------------------------------------------------------------------------------- /Listings/Chapter 8/8-3.R: -------------------------------------------------------------------------------- 1 | library(lattice) 2 | wireframe(obj ~ n1*shThresh, data = OPTIM, 3 | xlab = "n1", ylab = "shThresh", 4 | main = "Long-Only MACD Exhaustive Optimization", 5 | drape = TRUE, 6 | colorkey = TRUE, 7 | screen = list(z = 15, x = -60) 8 | ) 9 | 10 | levelplot(obj ~ n1*shThresh, data = OPTIM, 11 | xlab = "n1", ylab = "shThresh", 12 | main = "Long-Only MACD Exhaustive Optimization" 13 | ) 14 | -------------------------------------------------------------------------------- /Listings/Chapter 8/8-4.R: -------------------------------------------------------------------------------- 1 | # Maximum iterations 2 | # Max possible calls to evaluator is K * (4 * n + 1) 3 | K <- 100 4 | 5 | # Restart with random init when delta is below threshold 6 | deltaThresh <- 0.05 7 | 8 | # Set initial delta 9 | delta <- deltaNaught <- 1 10 | 11 | # Scale factor 12 | sigma <- 2 13 | 14 | 15 | # Vector theta_0 16 | PARAM <- PARAMNaught <- c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) 17 | 18 | # bounds 19 | minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01) 20 | maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99) 21 | 22 | np <- length(PARAM) 23 | 24 | OPTIM <- data.frame(matrix(NA, nrow = K * (4 * np + 1), ncol = np + 1)) 25 | names(OPTIM) <- c(names(PARAM), "obj"); o <- 1 26 | 27 | fmin <- fminNaught <- evaluate(PARAM, minVal, maxVal, negative = TRUE, y = y) 28 | OPTIM[o,] <- c(PARAM, fmin); o <- o + 1 29 | 30 | 31 | # Print function for reporting progress in loop 32 | printUpdate <- function(step){ 33 | if(step == "search"){ 34 | cat(paste0("Search step: ", k,"|",l,"|",m, "\n")) 35 | } else if (step == "poll"){ 36 | cat(paste0("Poll step: ", k,"|",l,"|",m, "\n")) 37 | } 38 | names(OPTIM) 39 | cat("\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n") 40 | cat("Best:\t", 41 | paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n") 42 | cat("Theta:\t", 43 | paste0(round(unlist(c(PARAM, fmin)),3), "\t"), "\n") 44 | cat("Trial:\t", 45 | paste0(round(as.numeric(OPTIM[o-1,]), 3), "\t"), "\n") 46 | cat(paste0("Delta: ", round(delta,3) , "\t"), "\n\n") 47 | } 48 | 49 | for( k in 1:K ){ 50 | 51 | # SEARCH subroutine 52 | for( l in 1:np ){ 53 | net <- (2 * rbinom(np, 1, .5) - 1) * runif(np, delta, sigma * delta) 54 | for( m in c(-1,1) ){ 55 | 56 | testpoint <- PARAM + m * net 57 | ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y) 58 | OPTIM[o,] <- c(testpoint, ftest); o <- o + 1 59 | printUpdate("search") 60 | 61 | } 62 | } 63 | 64 | if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){ 65 | 66 | minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)]) 67 | PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,] 68 | fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos] 69 | delta <- sigma * delta 70 | 71 | } else { 72 | 73 | # POLL Subroutine 74 | for( l in 1:np ){ 75 | net <- delta * as.numeric(1:np == l) 76 | for( m in c(-1,1) ){ 77 | 78 | testpoint <- PARAM + m * net 79 | ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y) 80 | OPTIM[o,] <- c(testpoint, ftest); o <- o + 1 81 | printUpdate("poll") 82 | 83 | } 84 | } 85 | 86 | if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){ 87 | 88 | minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)]) 89 | PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,] 90 | fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos] 91 | delta <- sigma * delta 92 | 93 | } else { 94 | 95 | delta <- delta / sigma 96 | 97 | } 98 | 99 | 100 | } 101 | 102 | cat(paste0("\nCompleted Full Iteration: ", k, "\n\n")) 103 | 104 | # Restart with random initiate 105 | if( delta < deltaThresh ) { 106 | 107 | delta <- deltaNaught 108 | fmin <- fminNaught 109 | PARAM <- PARAMNaught + runif(n = np, min = -delta * sigma, 110 | max = delta * sigma) 111 | 112 | ftest <- evaluate(PARAM, minVal, maxVal, 113 | negative = TRUE, y = y) 114 | OPTIM[o,] <- c(PARAM, ftest); o <- o + 1 115 | 116 | cat("\nDelta Threshold Breached, Restarting with Random Initiate\n\n") 117 | 118 | } 119 | 120 | } 121 | 122 | # Return the best optimization in untransformed parameters 123 | evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE) 124 | -------------------------------------------------------------------------------- /Listings/Chapter 8/8-5.R: -------------------------------------------------------------------------------- 1 | K <- maxIter <- 200 2 | 3 | # Vector theta_0 4 | initDelta <- 6 5 | deltaThresh <- 0.05 6 | PARAM <- PARAMNaught <- 7 | c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) - initDelta/2 8 | 9 | # bounds 10 | minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01) 11 | maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99) 12 | 13 | # Optimization parameters 14 | alpha <- 1 15 | gamma <- 2 16 | rho <- .5 17 | sigma <- .5 18 | 19 | 20 | randomInit <- FALSE 21 | 22 | np <- length(initVals) 23 | 24 | 25 | OPTIM <- data.frame(matrix(NA, ncol = np + 1, nrow = maxIter * (2 * np + 2))) 26 | o <- 1 27 | 28 | SIMPLEX <- data.frame(matrix(NA, ncol = np + 1, nrow = np + 1)) 29 | names(SIMPLEX) <- names(OPTIM) <- c(names(initVals), "obj") 30 | 31 | 32 | # Print function for reporting progress in loop 33 | printUpdate <- function(){ 34 | cat("Iteration: ", k, "of", K, "\n") 35 | cat("\t\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n") 36 | cat("Global Best:\t", 37 | paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n") 38 | cat("Simplex Best:\t", 39 | paste0(round(unlist(SIMPLEX[which.min(SIMPLEX$obj),]),3), "\t"), "\n") 40 | cat("Simplex Size:\t", 41 | paste0(max(round(simplexSize,3)), "\t"), "\n\n\n") 42 | } 43 | 44 | 45 | # Initialize SIMPLEX 46 | for( i in 1:(np+1) ) { 47 | 48 | SIMPLEX[i,1:np] <- PARAMNaught + initDelta * as.numeric(1:np == (i-1)) 49 | SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], minVal, maxVal, negative = TRUE, 50 | y = y) 51 | OPTIM[o,] <- SIMPLEX[i,] 52 | o <- o + 1 53 | 54 | } 55 | 56 | 57 | 58 | # Optimization loop 59 | for( k in 1:K ){ 60 | 61 | SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),] 62 | centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)]) 63 | 64 | cat("Computing Reflection...\n") 65 | reflection <- centroid + alpha * (centroid - SIMPLEX[np+1,-(np+1)]) 66 | 67 | reflectResult <- evaluate(reflection, minVal, maxVal, negative = TRUE, y = y) 68 | OPTIM[o,] <- c(reflection, obj = reflectResult) 69 | o <- o + 1 70 | 71 | if( reflectResult > SIMPLEX[1,np+1] & 72 | reflectResult < SIMPLEX[np, np+1] ){ 73 | 74 | SIMPLEX[np+1,] <- c(reflection, obj = reflectResult) 75 | 76 | } else if( reflectResult < SIMPLEX[1,np+1] ) { 77 | 78 | cat("Computing Expansion...\n") 79 | expansion <- centroid + gamma * (reflection - centroid) 80 | expansionResult <- evaluate(expansion, 81 | minVal, maxVal, negative = TRUE, y = y) 82 | 83 | OPTIM[o,] <- c(expansion, obj = expansionResult) 84 | o <- o + 1 85 | 86 | if( expansionResult < reflectResult ){ 87 | SIMPLEX[np+1,] <- c(expansion, obj = expansionResult) 88 | } else { 89 | SIMPLEX[np+1,] <- c(reflection, obj = reflectResult) 90 | } 91 | 92 | } else if( reflectResult > SIMPLEX[np, np+1] ) { 93 | 94 | cat("Computing Contraction...\n") 95 | contract <- centroid + rho * (SIMPLEX[np+1,-(np+1)] - centroid) 96 | contractResult <- evaluate(contract, minVal, maxVal, negative = TRUE, y = y) 97 | 98 | OPTIM[o,] <- c(contract, obj = contractResult) 99 | o <- o + 1 100 | 101 | if( contractResult < SIMPLEX[np+1, np+1] ){ 102 | 103 | SIMPLEX[np+1,] <- c(contract, obj = contractResult) 104 | 105 | } else { 106 | cat("Computing Shrink...\n") 107 | for( i in 2:(np+1) ){ 108 | SIMPLEX[i,1:np] <- SIMPLEX[1,-(np+1)] + 109 | sigma * (SIMPLEX[i,1:np] - SIMPLEX[1,-(np+1)]) 110 | SIMPLEX[i,np+1] <- c(obj = evaluate(SIMPLEX[i,1:np], 111 | minVal, maxVal, 112 | negative = TRUE, y = y)) 113 | } 114 | 115 | OPTIM[o:(o+np-1),] <- SIMPLEX[2:(np+1),] 116 | o <- o + np 117 | 118 | } 119 | 120 | } 121 | 122 | centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)]) 123 | simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, 124 | function(v) abs(v - centroid)))) 125 | 126 | if( max(simplexSize) < deltaThresh ){ 127 | 128 | cat("Size Threshold Breached: Restarting with Random Initiate\n\n") 129 | 130 | for( i in 1:(np+1) ) { 131 | 132 | SIMPLEX[i,1:np] <- (PARAMNaught * 0) + 133 | runif(n = np, min = -initDelta, max = initDelta) 134 | 135 | SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], 136 | minVal, maxVal, negative = TRUE, y = y) 137 | OPTIM[o,] <- SIMPLEX[i,] 138 | o <- o + 1 139 | 140 | SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),] 141 | centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)]) 142 | simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, function(v) abs(v - centroid)))) 143 | 144 | } 145 | 146 | } 147 | 148 | printUpdate() 149 | 150 | } 151 | 152 | 153 | # Return the best optimization in untransformed parameters 154 | evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE) 155 | -------------------------------------------------------------------------------- /Listings/Chapter 8/8-6.R: -------------------------------------------------------------------------------- 1 | minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01) 2 | maxVal <- c(n1 = 150, nFact = 5, nSharpe = 200, shThresh = .99) 3 | 4 | RESULTS <- list() 5 | accountParams <- list () 6 | 7 | testRange <- 2004:2015 8 | 9 | # As defined in heuristic with delta_O = delta_P = 1 year 10 | for( y in testRange ){ 11 | 12 | PARAM <- optimize(y = y, minVal = minVal, maxVal = maxVal) 13 | 14 | if( y == testRange[1] ){ 15 | 16 | RESULTS[[as.character(y+1)]] <- 17 | evaluate(PARAM, y = y + 1, minVal = minVal, maxVal = maxVal, 18 | transform = TRUE, returnData = TRUE, verbose = TRUE ) 19 | 20 | } else { 21 | 22 | # Pass account parameters to next simulation after first year 23 | strYear <- as.character(y) 24 | aLength <- length(RESULTS[[strYear]][["C"]]) 25 | accountParams[["C"]] <-(RESULTS[[strYear]][["C"]])[aLength] 26 | accountParams[["P"]] <- (RESULTS[[strYear]][["P"]])[aLength] 27 | accountParams[["p"]] <- (RESULTS[[strYear]][["p"]])[aLength] 28 | 29 | RESULTS[[as.character(y+1)]] <- 30 | evaluate(PARAM, y = y + 1, minVal = minVal, maxVal = maxVal, 31 | transform = TRUE, returnData = TRUE, verbose = TRUE, 32 | accountParams = accountParams) 33 | 34 | } 35 | 36 | } 37 | 38 | 39 | # extract equity curve 40 | for( y in (testRange + 1) ){ 41 | 42 | strYear <- as.character(y) 43 | inYear <- substr(index(RESULTS[[strYear]][["P"]]), 1, 4) == strYear 44 | 45 | equity <- (RESULTS[[strYear]][["equity"]])[inYear] 46 | date <- (index(RESULTS[[strYear]][["P"]]))[inYear] 47 | 48 | if( y == (testRange[1] + 1) ){ 49 | equitySeries <- zoo(equity, order.by = date) 50 | } else { 51 | equitySeries <- rbind(equitySeries, zoo(equity, order.by = date)) 52 | } 53 | 54 | } 55 | -------------------------------------------------------------------------------- /Listings/Chapter 8/sampleOptimizeWrapper.R: -------------------------------------------------------------------------------- 1 | 2 | optimize <- function(y, minVal, maxVal){ 3 | 4 | 5 | # Maximum iterations 6 | # Max possible calls to evaluator is K * (4 * n + 1) 7 | K <- 20 8 | 9 | # Restart with random init when delta is below threshold 10 | deltaThresh <- 0.05 11 | 12 | # Set initial delta 13 | delta <- deltaNaught <- 1 14 | 15 | # Scale factor 16 | sigma <- 2 17 | 18 | 19 | # Vector theta_0 20 | PARAM <- PARAMNaught <- c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) 21 | 22 | np <- length(PARAM) 23 | 24 | OPTIM <- data.frame(matrix(NA, nrow = K * (4 * np + 1), ncol = np + 1)) 25 | names(OPTIM) <- c(names(PARAM), "obj"); o <- 1 26 | 27 | fmin <- fminNaught <- evaluate(PARAM, minVal, maxVal, negative = TRUE, y = y) 28 | OPTIM[o,] <- c(PARAM, fmin); o <- o + 1 29 | 30 | 31 | # Print function for reporting progress in loop 32 | printUpdate <- function(step){ 33 | if(step == "search"){ 34 | cat(paste0("Search step: ", k,"|",l,"|",m, "\n")) 35 | } else if (step == "poll"){ 36 | cat(paste0("Poll step: ", k,"|",l,"|",m, "\n")) 37 | } 38 | names(OPTIM) 39 | cat("\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n") 40 | cat("Best:\t", paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n") 41 | cat("Theta:\t", paste0(round(unlist(c(PARAM, fmin)),3), "\t"), "\n") 42 | cat("Trial:\t", paste0(round(as.numeric(OPTIM[o-1,]), 3), "\t"), "\n") 43 | cat(paste0("Delta: ", round(delta,3) , "\t"), "\n\n") 44 | } 45 | 46 | for( k in 1:K ){ 47 | 48 | # SEARCH subroutine 49 | for( l in 1:np ){ 50 | net <- (2 * rbinom(np, 1, .5) - 1) * runif(np, delta, sigma * delta) 51 | for( m in c(-1,1) ){ 52 | 53 | testpoint <- PARAM + m * net 54 | ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y) 55 | OPTIM[o,] <- c(testpoint, ftest); o <- o + 1 56 | printUpdate("search") 57 | 58 | } 59 | } 60 | 61 | if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){ 62 | 63 | minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)]) 64 | PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,] 65 | fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos] 66 | delta <- sigma * delta 67 | 68 | } else { 69 | 70 | # POLL Subroutine 71 | for( l in 1:np ){ 72 | net <- delta * as.numeric(1:np == l) 73 | for( m in c(-1,1) ){ 74 | 75 | testpoint <- PARAM + m * net 76 | ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y) 77 | OPTIM[o,] <- c(testpoint, ftest); o <- o + 1 78 | printUpdate("poll") 79 | 80 | } 81 | } 82 | 83 | if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){ 84 | 85 | minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)]) 86 | PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,] 87 | fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos] 88 | delta <- sigma * delta 89 | 90 | } else { 91 | 92 | delta <- delta / sigma 93 | 94 | } 95 | 96 | 97 | } 98 | 99 | cat(paste0("\nCompleted Full Iteration: ", k, "\n\n")) 100 | 101 | # Restart with random initiate 102 | if( delta < deltaThresh ) { 103 | 104 | delta <- deltaNaught 105 | fmin <- fminNaught 106 | PARAM <- PARAMNaught + runif(n = np, min = -delta * sigma, 107 | max = delta * sigma) 108 | 109 | ftest <- evaluate(PARAM, minVal, maxVal, 110 | negative = TRUE, y = y) 111 | OPTIM[o,] <- c(PARAM, ftest); o <- o + 1 112 | 113 | cat(paste0("\nDelta Threshold Breached, Restarting with Random Initiate\n\n")) 114 | 115 | } 116 | 117 | } 118 | 119 | # Return the best optimization in untransformed parameters 120 | return( 121 | evaluate(OPTIM[which.min(OPTIM$obj),1:np], 122 | minVal, maxVal, transformOnly = TRUE) 123 | ) 124 | 125 | 126 | } 127 | 128 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-1.R: -------------------------------------------------------------------------------- 1 | # Normally declared by your strategy 2 | FAVOR <- rnorm(ncol(DATA[["Close"]])) 3 | ENTRY <- rbinom(ncol(DATA[["Close"]]), 1, .005) - 4 | rbinom(ncol(DATA[["Close"]]), 1, .005) 5 | EXIT <- rbinom(ncol(DATA[["Close"]]), 1, .8) - 6 | rbinom(ncol(DATA[["Close"]]), 1, .8) 7 | 8 | # Normally fetched from brokerage 9 | currentlyLong <- c("AA", "AAL", "AAPL") 10 | currentlyShort <- c("RAI", "RCL", "REGN") 11 | S <- names(DATA[["Close"]]) 12 | initP <- (S %in% currentlyLong) - (S %in% currentlyShort) 13 | 14 | names(initP) <- 15 | names(FAVOR) <- 16 | names(ENTRY) <- 17 | names(EXIT) <- 18 | names(DATA[["Close"]]) 19 | 20 | 21 | # At this point we have established everything normally 22 | # taken care of by your trading strategy. 23 | # Given named vectors of length ncol(DATA[["Close"]]) 24 | # initP, FAVOR, ENTRY, and EXIT, we proceed. 25 | 26 | maxAssets <- 10 27 | startingCash <- 100000 28 | 29 | K <- maxAssets 30 | k <- 0 31 | C <- c(startingCash, NA) 32 | S <- names(DATA[["Close"]]) 33 | P <- initP 34 | 35 | 36 | # Step 4 37 | longS <- S[which(P > 0)] 38 | shortS <- S[which(P < 0)] 39 | k <- length(longS) + length(shortS) 40 | 41 | # Step 5 42 | longTrigger <- setdiff(S[which(ENTRY == 1)], longS) 43 | shortTrigger <- setdiff(S[which(ENTRY == -1)], shortS) 44 | trigger <- c(longTrigger, shortTrigger) 45 | 46 | if( length(trigger) > K ) { 47 | 48 | keepTrigger <- trigger[order(c(as.numeric(FAVOR[longTrigger]), 49 | -as.numeric(FAVOR[shortTrigger])), 50 | decreasing = TRUE)][1:K] 51 | 52 | longTrigger <- longTrigger[longTrigger %in% keepTrigger] 53 | shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger] 54 | 55 | trigger <- c(longTrigger, shortTrigger) 56 | 57 | } 58 | 59 | triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger))) 60 | 61 | 62 | # Step 6 63 | longExitTrigger <- longS[longS %in% S[which(EXIT == 1 | EXIT == 999)]] 64 | 65 | shortExitTrigger <- shortS[shortS %in% S[which(EXIT == -1 | EXIT == 999)]] 66 | 67 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 68 | 69 | 70 | # Step 7 71 | needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0) 72 | 73 | if( needToExit > 0 ){ 74 | 75 | toExitLongS <- setdiff(longS, exitTrigger) 76 | toExitShortS <- setdiff(shortS, exitTrigger) 77 | 78 | toExit <- character(0) 79 | 80 | for( counter in 1:needToExit ){ 81 | if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){ 82 | if( min(FAVOR[toExitLongS]) < min(-FAVOR[toExitShortS]) ){ 83 | pullMin <- which.min(FAVOR[toExitLongS]) 84 | toExit <- c(toExit, toExitLongS[pullMin]) 85 | toExitLongS <- toExitLongS[-pullMin] 86 | } else { 87 | pullMin <- which.min(-FAVOR[toExitShortS]) 88 | toExit <- c(toExit, toExitShortS[pullMin]) 89 | toExitShortS <- toExitShortS[-pullMin] 90 | } 91 | } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){ 92 | pullMin <- which.min(FAVOR[toExitLongS]) 93 | toExit <- c(toExit, toExitLongS[pullMin]) 94 | toExitLongS <- toExitLongS[-pullMin] 95 | } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){ 96 | pullMin <- which.min(-FAVOR[toExitShortS]) 97 | toExit <- c(toExit, toExitShortS[pullMin]) 98 | toExitShortS <- toExitShortS[-pullMin] 99 | } 100 | } 101 | 102 | longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit]) 103 | shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit]) 104 | 105 | } 106 | 107 | # Step 8 108 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 109 | exitTriggerType <- c(rep(1, length(longExitTrigger)), 110 | rep(-1, length(shortExitTrigger))) 111 | 112 | 113 | 114 | 115 | 116 | 117 | # Output planned trades 118 | setwd(rootdir) 119 | 120 | # First exit these 121 | write.csv(file = "stocksToExit.csv", 122 | data.frame(list(sym = exitTrigger, type = exitTriggerType))) 123 | 124 | # Then enter these 125 | write.csv(file = "stocksToEnter.csv", 126 | data.frame(list(sym = trigger, type = triggerType))) 127 | 128 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-10.R: -------------------------------------------------------------------------------- 1 | # Example is not executable. 2 | # For example purposes only. 3 | library(ROAuth) 4 | 5 | 6 | # Requesting with key-secret and access-request pair 7 | reqURL <- "requestUrl" 8 | accessURL <- "accessUrl" 9 | authURL <- "authenticationUrl" 10 | cKey <- "consumerKey" 11 | cSecret <- "consumerSecret" 12 | 13 | 14 | credentials <- OAuthFactory$new(consumerKey=cKey, 15 | consumerSecret=cSecret, 16 | requestURL=reqURL, 17 | accessURL=accessURL, 18 | authURL=authURL, 19 | needsVerifier=FALSE) 20 | credentials$handshake() 21 | 22 | # Send GET Request to URL 23 | testURL <- "http://someurl.com/some parameters" 24 | credentials$OAuthRequest(testURL, "GET") 25 | 26 | 27 | # Send GET Request to URL 28 | testURL <- "http://someurl.com/some un-encoded parameters" 29 | credentials$OAuthRequest(testURL, "GET") 30 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-11.R: -------------------------------------------------------------------------------- 1 | oKey <- "oauthKey" 2 | oSecret <- "oauthSecret" 3 | cKey <- "consumerKey" 4 | cSecret <- "consumerSecret" 5 | 6 | credentials <- OAuthFactory$new(consumerKey = cKey, 7 | consumerSecret = cSecret, 8 | oauthKey = oKey, 9 | oauthSecret = oSecret, 10 | needsVerifier=FALSE) 11 | 12 | # Manually declare authentication as complete 13 | credentials$handshakeComplete <- TRUE 14 | 15 | # Send a FIXML message through OAuth to testURL with POST request 16 | aFIXMLmessage <- c("content") 17 | testURL <- "https://testurl.com/" 18 | credentials$OAuthRequest(testURL, "POST", aFIXMLmessage) 19 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-2.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 2016-01-12 7 | 30.58 8 | 30.969999 9 | 30.209999 10 | 30.690001 11 | 12635300 12 | 30.690001 13 | 14 | 15 | 2016-01-11 16 | 30.65 17 | 30.75 18 | 29.74 19 | 30.17 20 | 16676500 21 | 30.17 22 | 23 | 24 | 2016-01-12 25 | 100.550003 26 | 100.690002 27 | 98.839996 28 | 99.959999 29 | 49154200 30 | 98.818866 31 | 32 | 33 | 2016-01-11 34 | 98.970001 35 | 99.059998 36 | 97.339996 37 | 98.529999 38 | 49739400 39 | 97.40519 40 | 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-3.txt: -------------------------------------------------------------------------------- 1 | # Opening and closing XML tags, empty 2 | 3 | 4 | # Opening and closing XML tags, with value 5 | 2016-01-11 6 | 7 | # Opening and closing XML tags, with value and attribute 8 | 2016-01-11 9 | 10 | # Self-closing XML tag 11 | 12 | 13 | # Self-closing XML tag with attributes 14 | 15 | 16 | # XML Comment 17 | 18 | 19 | # XML Declaration 20 | 21 | 22 | # Processing Instruction 23 | 24 | 25 | # Character Data Entity (Escapes symbolic characters) 26 | sqrt(y) ]]> 27 | 28 | # Document Type Declaration 29 | 30 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-4.txt: -------------------------------------------------------------------------------- 1 | # Child node 2 | child::someNode 3 | someNode 4 | 5 | # Attribute value 6 | attribute::someAttr 7 | @someAttr 8 | 9 | # Parent node 10 | someNode/parent::*/someSibling 11 | someNode/../someSibling 12 | 13 | # Descendent-or-self 14 | someNode/descendent-or-self::node()/someDescendent 15 | someNode//someDescendent 16 | 17 | # Ancestor (has no abbreviation) 18 | someNode/ancestor::someAncestorNode 19 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-5.R: -------------------------------------------------------------------------------- 1 | # Descend the tree to each individual stock quote 2 | getNodeSet(doc, "/query/results/quote") 3 | 4 | # Get the second quote 5 | getNodeSet(doc, "/query/results/quote[2]") 6 | 7 | # Descend to the third level of the tree, get second element 8 | getNodeSet(doc, "/*/*/*[2]") 9 | 10 | # Get all nodes named "quote" regardless of level 11 | getNodeSet(doc, "//quote") 12 | 13 | # Get all node with Symbol = AAPL attribute 14 | getNodeSet(doc, "/query/results/quote[@Symbol = 'AAPL']") 15 | 16 | # Get the last quote 17 | getNodeSet(doc, "/query/results/quote[last()]") 18 | 19 | # Get the first 3 quotes 20 | getNodeSet(doc, "/query/results/quote[position() <= 3]") 21 | 22 | # Get all quotes with closing price less than 40 23 | getNodeSet(doc, "/query/results/quote[./Close < 40]") 24 | 25 | # Get all closing prices less than 40 26 | getNodeSet(doc, "/query/results/quote[./Close < 40]/Close") 27 | 28 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-6.R: -------------------------------------------------------------------------------- 1 | # Descend the tree to this point 2 | root <- "/query/results/quote" 3 | 4 | # Descend to each of these leaves for every node in root 5 | leaves <- c("./Date", "./Open", "./High", "./Low", 6 | "./Close", "./Volume", "./Adj_Close") 7 | 8 | # Get data in list 9 | df <- getNodeSet(doc, root, fun = function(v) xpathSApply(v, leaves, xmlValue)) 10 | 11 | # Get symbols as attributes 12 | sym <- getNodeSet(doc, root, fun = function(v) xpathSApply(v, ".", xmlAttrs)) 13 | 14 | # This is equivalent to the above line in this case 15 | # sym <- as.character(getNodeSet(doc, "/query/results/quote/@Symbol")) 16 | 17 | # Organize as data frame 18 | df <- data.frame(t(data.frame(df)), stringsAsFactors = FALSE) 19 | 20 | # Append stock symbols 21 | df <- cbind(unlist(sym), df) 22 | df[,3:8] <- lapply(df[3:8], as.numeric) 23 | df[,1] <- as.character(df[,1]) 24 | 25 | # Fix names 26 | rownames(df) <- NULL 27 | colnames(df) <- c("Symbol", substring(leaves, 3)) 28 | 29 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-7.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-8.R: -------------------------------------------------------------------------------- 1 | library(XML) 2 | 3 | # Generate the XML message in Listing 9.7 4 | out <- newXMLNode("FIXML", 5 | namespaceDefinitions = 6 | "http://www.fixprotocol.org/FIXML-5-0-SP2") 7 | 8 | newXMLNode("Order", 9 | attrs = c(TmInForce = 0, Typ = 1, Side = 1, Acct=999999), 10 | parent = out) 11 | 12 | newXMLNode("Instrmt", 13 | attrs = c(SecTyp = "CS", Sym = "AAPL"), 14 | parent = out["Order"]) 15 | 16 | newXMLNode("OrdQty", 17 | attrs = c(Qty = 100), 18 | parent = out["Order"]) 19 | 20 | print(out) 21 | 22 | 23 | # Extra example for how to insert content in non-self-closing nodes 24 | newXMLNode("extraInfo", "invalid content.", parent = out["Order"]) 25 | print(out) 26 | -------------------------------------------------------------------------------- /Listings/Chapter 9/9-9.R: -------------------------------------------------------------------------------- 1 | library(RJSONIO) 2 | 3 | base <- "http://query.yahooapis.com/v1/public/yql?" 4 | begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in " 5 | midQuery <- "('YHOO', 'AAPL') " 6 | endQuery <- "and startDate = '2016-01-11' and endDate = '2016-01-12'" 7 | 8 | # Supply "format=json" argument to URL 9 | endParams <- 10 | "&diagnostics=false&format=json&env=store://datatables.org/alltableswithkeys" 11 | 12 | urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams) 13 | 14 | # Encode URL before requesting 15 | # This is normally handled automatically by the XML package 16 | jdoc <- fromJSON(URLencode(urlstr)) 17 | 18 | # Format and output data frame as in Listing 9.6 19 | df <- data.frame(t(data.frame(jdoc[["query"]][["results"]][["quote"]])), 20 | stringsAsFactors = FALSE) 21 | df[,3:8] <- lapply(df[3:8], as.numeric) 22 | df[,1] <- as.character(df[,1]) 23 | rownames(df) <- NULL 24 | -------------------------------------------------------------------------------- /Platform/S.R: -------------------------------------------------------------------------------- 1 | S <- 2 | c("MMM", "ABT", "ABBV", "ACN", "ACE", "ATVI", "ADBE", "ADT", 3 | "AAP", "AES", "AET", "AFL", "AMG", "A", "GAS", "APD", "ARG", 4 | "AKAM", "AA", "AGN", "ALXN", "ALLE", "ADS", "ALL", "GOOGL", "GOOG", 5 | "ALTR", "MO", "AMZN", "AEE", "AAL", "AEP", "AXP", "AIG", "AMT", 6 | "AMP", "ABC", "AME", "AMGN", "APH", "APC", "ADI", "AON", "APA", 7 | "AIV", "AAPL", "AMAT", "ADM", "AIZ", "T", "ADSK", "ADP", "AN", 8 | "AZO", "AVGO", "AVB", "AVY", "BHI", "BLL", "BAC", "BK", "BCR", 9 | "BXLT", "BAX", "BBT", "BDX", "BBBY", "BRK-B", "BBY", "BIIB", 10 | "BLK", "HRB", "BA", "BWA", "BXP", "BSX", "BMY", "BRCM", "BF-B", 11 | "CHRW", "CA", "CVC", "COG", "CAM", "CPB", "COF", "CAH", "HSIC", 12 | "KMX", "CCL", "CAT", "CBG", "CBS", "CELG", "CNP", "CTL", "CERN", 13 | "CF", "SCHW", "CHK", "CVX", "CMG", "CB", "CI", "XEC", "CINF", 14 | "CTAS", "CSCO", "C", "CTXS", "CLX", "CME", "CMS", "COH", "KO", 15 | "CCE", "CTSH", "CL", "CPGX", "CMCSA", "CMCSK", "CMA", "CAG", 16 | "COP", "CNX", "ED", "STZ", "GLW", "COST", "CCI", "CSRA", "CSX", 17 | "CMI", "CVS", "DHI", "DHR", "DRI", "DVA", "DE", "DLPH", "DAL", 18 | "XRAY", "DVN", "DO", "DFS", "DISCA", "DISCK", "DG", "DLTR", "D", 19 | "DOV", "DOW", "DPS", "DTE", "DD", "DUK", "DNB", "ETFC", "EMN", 20 | "ETN", "EBAY", "ECL", "EIX", "EW", "EA", "EMC", "EMR", "ENDP", 21 | "ESV", "ETR", "EOG", "EQT", "EFX", "EQIX", "EQR", "ESS", "EL", 22 | "ES", "EXC", "EXPE", "EXPD", "ESRX", "XOM", "FFIV", "FB", "FAST", 23 | "FDX", "FIS", "FITB", "FSLR", "FE", "FISV", "FLIR", "FLS", "FLR", 24 | "FMC", "FTI", "F", "FOSL", "BEN", "FCX", "FTR", "GME", "GPS", 25 | "GRMN", "GD", "GE", "GGP", "GIS", "GM", "GPC", "GILD", "GS", 26 | "GT", "GWW", "HAL", "HBI", "HOG", "HAR", "HRS", "HIG", "HAS", 27 | "HCA", "HCP", "HP", "HES", "HPE", "HD", "HON", "HRL", "HST", 28 | "HPQ", "HUM", "HBAN", "ITW", "ILMN", "IR", "INTC", "ICE", "IBM", 29 | "IP", "IPG", "IFF", "INTU", "ISRG", "IVZ", "IRM", "JEC", "JBHT", 30 | "JNJ", "JCI", "JPM", "JNPR", "KSU", "K", "KEY", "GMCR", "KMB", 31 | "KIM", "KMI", "KLAC", "KSS", "KHC", "KR", "LB", "LLL", "LH", 32 | "LRCX", "LM", "LEG", "LEN", "LVLT", "LUK", "LLY", "LNC", "LLTC", 33 | "LMT", "L", "LOW", "LYB", "MTB", "MAC", "M", "MNK", "MRO", "MPC", 34 | "MAR", "MMC", "MLM", "MAS", "MA", "MAT", "MKC", "MCD", "MHFI", 35 | "MCK", "MJN", "WRK", "MDT", "MRK", "MET", "KORS", "MCHP", "MU", 36 | "MSFT", "MHK", "TAP", "MDLZ", "MON", "MNST", "MCO", "MS", "MOS", 37 | "MSI", "MUR", "MYL", "NDAQ", "NOV", "NAVI", "NTAP", "NFLX", "NWL", 38 | "NFX", "NEM", "NWSA", "NWS", "NEE", "NLSN", "NKE", "NI", "NBL", 39 | "JWN", "NSC", "NTRS", "NOC", "NRG", "NUE", "NVDA", "ORLY", "OXY", 40 | "OMC", "OKE", "ORCL", "OI", "PCAR", "PH", "PDCO", "PAYX", "PYPL", 41 | "PNR", "PBCT", "POM", "PEP", "PKI", "PRGO", "PFE", "PCG", "PM", 42 | "PSX", "PNW", "PXD", "PBI", "PCL", "PNC", "RL", "PPG", "PPL", 43 | "PX", "PCP", "PCLN", "PFG", "PG", "PGR", "PLD", "PRU", "PEG", 44 | "PSA", "PHM", "PVH", "QRVO", "PWR", "QCOM", "DGX", "RRC", "RTN", 45 | "O", "RHT", "REGN", "RF", "RSG", "RAI", "RHI", "ROK", "COL", 46 | "ROP", "ROST", "RCL", "R", "CRM", "SNDK", "SCG", "SLB", "SNI", 47 | "STX", "SEE", "SRE", "SHW", "SIG", "SPG", "SWKS", "SLG", "SJM", 48 | "SNA", "SO", "LUV", "SWN", "SE", "STJ", "SWK", "SPLS", "SBUX", 49 | "HOT", "STT", "SRCL", "SYK", "STI", "SYMC", "SYF", "SYY", "TROW", 50 | "TGT", "TEL", "TE", "TGNA", "THC", "TDC", "TSO", "TXN", "TXT", 51 | "HSY", "TRV", "TMO", "TIF", "TWX", "TWC", "TJX", "TMK", "TSS", 52 | "TSCO", "RIG", "TRIP", "FOXA", "FOX", "TSN", "TYC", "USB", "UA", 53 | "UNP", "UAL", "UNH", "UPS", "URI", "UTX", "UHS", "UNM", "URBN", 54 | "VFC", "VLO", "VAR", "VTR", "VRSN", "VRSK", "VZ", "VRTX", "VIAB", 55 | "V", "VNO", "VMC", "WMT", "WBA", "DIS", "WM", "WAT", "ANTM", 56 | "WFC", "HCN", "WDC", "WU", "WY", "WHR", "WFM", "WMB", "WEC", 57 | "WYN", "WYNN", "XEL", "XRX", "XLNX", "XL", "XYL", "YHOO", "YUM", 58 | "ZBH", "ZION", "ZTS") 59 | -------------------------------------------------------------------------------- /Platform/SPdates.R: -------------------------------------------------------------------------------- 1 | S <- 2 | structure(list(V1 = c("A", "AAL", "AAP", "AAPL", "ABBV", "ABC", 3 | "ACE", "ACN", "ADM", "ADP", "ADS", "ADSK", "ADT", "AEE", "AET", 4 | "AIG", "AIV", "AIZ", "AKAM", "ALLE", "ALTR", "ALXN", "AME", "AMG", 5 | "AMGN", "AMT", "AMZN", "AN", "APD", "APH", "ARG", "ATVI", "AVB", 6 | "AVGO", "AVY", "AXP", "BAC", "BAX", "BCR", "BDX", "BF-B", "BIIB", 7 | "BLK", "BLL", "BRCM", "BRK-B", "BWA", "BXLT", "BXP", "C", "CA", 8 | "CAG", "CAM", "CB", "CBS", "CCI", "CERN", "CF", "CHK", "CI", 9 | "CLX", "CMCSA", "CME", "CMG", "CMI", "CNP", "CNX", "COG", "COH", 10 | "COL", "COST", "CPGX", "CRM", "CSCO", "CSRA", "CSX", "CTAS", 11 | "CVC", "DAL", "DFS", "DG", "DGX", "DHI", "DIS", "DISCA", "DISCK", 12 | "DLPH", "DLTR", "DNB", "DO", "DOV", "DPS", "DUK", "DVA", "DVN", 13 | "EBAY", "ECL", "EL", "EMN", "EMR", "ENDP", "EOG", "EQIX", "EQR", 14 | "EQT", "ESRX", "ESS", "ESV", "EW", "EXPD", "EXPE", "FAST", "FB", 15 | "FDX", "FFIV", "FISV", "FLIR", "FLR", "FLS", "FMC", "FOSL", "FOX", 16 | "FOXA", "FSLR", "FTI", "GGP", "GILD", "GIS", "GM", "GMCR", "GME", 17 | "GOOG", "GOOGL", "GPC", "GPS", "GRMN", "GS", "GWW", "HAR", "HAS", 18 | "HBI", "HCA", "HCN", "HCP", "HD", "HES", "HOT", "HPE", "HPQ", 19 | "HRB", "HRL", "HRS", "HSIC", "HST", "ICE", "IFF", "ILMN", "INTC", 20 | "INTU", "IPG", "IR", "IRM", "ISRG", "ITW", "IVZ", "JBHT", "JCI", 21 | "JEC", "JNJ", "JNPR", "JPM", "JWN", "KEY", "KHC", "KIM", "KMI", 22 | "KMX", "KORS", "KSU", "LB", "LEN", "LH", "LLL", "LLTC", "LLY", 23 | "LM", "LMT", "LNC", "LOW", "LRCX", "LUK", "LUV", "LVLT", "LYB", 24 | "MA", "MAC", "MAS", "MAT", "MCD", "MCHP", "MCO", "MDLZ", "MDT", 25 | "MET", "MHK", "MJN", "MKC", "MLM", "MMC", "MNK", "MNST", "MON", 26 | "MOS", "MPC", "MRO", "MSFT", "MTB", "MU", "MUR", "MYL", "NAVI", 27 | "NBL", "NDAQ", "NEE", "NEM", "NFLX", "NFX", "NI", "NKE", "NLSN", 28 | "NOC", "NOV", "NRG", "NUE", "NVDA", "NWL", "NWS", "NWSA", "O", 29 | "OI", "OKE", "ORCL", "ORLY", "OXY", "PBCT", "PCAR", "PCL", "PCLN", 30 | "PCP", "PDCO", "PFG", "PH", "PHM", "PKI", "PLD", "PM", "PNC", 31 | "PNR", "POM", "PRGO", "PRU", "PSA", "PSX", "PVH", "PWR", "PX", 32 | "PXD", "PYPL", "QRVO", "R", "RCL", "REGN", "RF", "RHI", "RHT", 33 | "RIG", "RL", "ROP", "ROST", "RRC", "RSG", "SBUX", "SCG", "SHW", 34 | "SIG", "SJM", "SLB", "SLG", "SNA", "SNDK", "SNI", "SPG", "SRCL", 35 | "STI", "STJ", "STX", "STZ", "SWK", "SWKS", "SWN", "SYF", "SYK", 36 | "SYMC", "SYY", "T", "TAP", "TDC", "TE", "TEL", "TGNA", "TGT", 37 | "THC", "TIF", "TJX", "TMK", "TRIP", "TSCO", "TSN", "TSO", "TSS", 38 | "TWC", "TXT", "TYC", "UA", "UAL", "UHS", "UNH", "UNM", "UPS", 39 | "URBN", "URI", "V", "VAR", "VFC", "VLO", "VNO", "VRSK", "VRSN", 40 | "VRTX", "VTR", "VZ", "WAT", "WBA", "WDC", "WEC", "WFC", "WMB", 41 | "WMT", "WU", "WYN", "WYNN", "XEC", "XL", "XRAY", "XYL", "ZION", 42 | "ZTS", "MMM", "ABT", "ADBE", "AES", "AFL", "GAS", "AA", "AGN", 43 | "ALL", "MO", "AEP", "AMP", "APC", "ADI", "AON", "APA", "AMAT", 44 | "AZO", "BHI", "BK", "BBT", "BBBY", "BBY", "BA", "BSX", "BMY", 45 | "CHRW", "CPB", "COF", "CAH", "CCL", "CAT", "CBG", "CELG", "CTL", 46 | "SCHW", "CVX", "CINF", "CTXS", "CMS", "KO", "CCE", "CTSH", "CL", 47 | "CMCSK", "CMA", "COP", "ED", "GLW", "CVS", "DHR", "DRI", "DE", 48 | "D", "DOW", "DTE", "DD", "ETFC", "ETN", "EIX", "EA", "EMC", "ETR", 49 | "EFX", "ES", "EXC", "XOM", "FIS", "FITB", "FE", "F", "BEN", "FCX", 50 | "FTR", "GD", "GE", "GT", "HAL", "HOG", "HIG", "HP", "HON", "HUM", 51 | "HBAN", "IBM", "IP", "K", "KMB", "KLAC", "KSS", "KR", "LEG", 52 | "L", "M", "MAR", "MHFI", "MCK", "WRK", "MRK", "MS", "MSI", "NTAP", 53 | "NSC", "NTRS", "OMC", "PAYX", "PEP", "PFE", "PCG", "PNW", "PBI", 54 | "PPG", "PPL", "PG", "PGR", "PEG", "QCOM", "RTN", "RAI", "ROK", 55 | "SEE", "SRE", "SO", "SE", "SPLS", "STT", "TROW", "TXN", "HSY", 56 | "TRV", "TMO", "TWX", "USB", "UNP", "UTX", "VIAB", "VMC", "WM", 57 | "ANTM", "WY", "WHR", "WFM", "XEL", "XRX", "XLNX", "YHOO", "YUM", 58 | "ZBH"), V2 = c("6/2/2000", "3/23/2015", "7/9/2015", "11/30/1982", 59 | "12/31/2012", "8/29/2001", "7/15/2010", "7/6/2011", "7/29/1981", 60 | "3/31/1981", "12/23/2013", "12/1/1989", "10/1/2012", "9/19/1991", 61 | "6/30/1976", "3/31/1980", "3/13/2003", "4/10/2007", "7/12/2007", 62 | "12/2/2013", "4/17/2000", "5/25/2012", "9/23/2013", "7/1/2014", 63 | "1/2/1992", "11/19/2007", "11/18/2005", "2/21/2003", "4/30/1985", 64 | "9/30/2008", "9/9/2009", "8/28/2015", "1/1/2007", "5/8/2014", 65 | "12/31/1987", "6/30/1976", "6/30/1976", "9/30/1972", "6/30/1975", 66 | "9/30/1972", "10/31/1982", "11/12/2003", "4/4/2011", "10/31/1984", 67 | "6/30/2000", "2/16/2010", "12/16/2011", "7/1/2015", "3/31/2006", 68 | "5/31/1988", "7/31/1987", "8/31/1983", "1/29/2008", "6/30/1976", 69 | "9/1/1994", "3/14/2012", "4/30/2010", "8/27/2008", "3/2/2006", 70 | "6/30/1976", "3/31/1969", "11/18/2002", "8/10/2006", "4/28/2011", 71 | "3/31/1965", "7/31/1985", "6/27/2006", "6/23/2008", "8/31/2004", 72 | "6/29/2001", "10/1/1993", "7/2/2015", "9/15/2008", "12/1/1993", 73 | "12/1/2015", "9/30/1967", "2/28/2001", "12/20/2010", "9/11/2013", 74 | "7/2/2007", "12/3/2012", "12/11/2002", "7/1/2005", "6/30/1976", 75 | "3/1/2010", "8/7/2014", "12/21/2012", "12/16/2011", "12/2/2008", 76 | "2/26/2009", "10/31/1985", "10/7/2008", "6/30/1976", "7/31/2008", 77 | "8/29/2000", "7/19/2002", "1/31/1989", "1/4/2006", "1/1/1994", 78 | "3/31/1965", "1/27/2015", "11/1/2000", "3/23/2015", "11/30/2001", 79 | "12/19/2008", "9/25/2003", "4/2/2014", "7/31/2012", "3/31/2011", 80 | "10/10/2007", "10/2/2007", "9/15/2009", "12/21/2013", "12/31/1980", 81 | "12/17/2010", "3/30/2001", "1/2/2009", "12/21/2000", "10/2/2008", 82 | "8/19/2009", "4/4/2012", "7/1/2013", "6/28/2013", "10/16/2009", 83 | "6/5/2009", "12/10/2013", "6/30/2004", "3/31/1969", "6/6/2013", 84 | "3/21/2014", "12/14/2007", "3/31/2006", "4/3/2014", "12/31/1973", 85 | "8/31/1986", "12/11/2012", "7/19/2002", "6/30/1981", "1/31/2006", 86 | "9/30/1984", "3/23/2015", "1/27/2015", "1/30/2009", "3/31/2008", 87 | "3/31/1988", "5/31/1984", "11/16/2000", "11/2/2015", "12/31/1974", 88 | "11/30/1986", "3/4/2009", "9/22/2008", "3/18/2015", "3/20/2007", 89 | "9/26/2007", "3/31/1976", "11/19/2015", "12/31/1976", "12/8/2000", 90 | "10/1/1992", "11/17/2010", "1/6/2009", "6/2/2008", "2/28/1986", 91 | "8/21/2008", "7/1/2015", "5/31/1986", "10/25/2007", "6/30/1973", 92 | "6/1/2006", "6/30/1975", "8/31/1986", "3/1/1994", "10/2/2012", 93 | "3/31/2006", "5/25/2012", "6/28/2010", "11/13/2013", "5/24/2013", 94 | "9/30/1983", "10/3/2005", "10/29/2004", "11/30/2004", "3/31/2000", 95 | "12/31/1970", "4/21/2006", "7/31/1984", "6/30/1976", "2/29/1984", 96 | "6/5/2012", "8/27/2007", "7/1/1994", "11/5/2014", "9/5/2012", 97 | "7/18/2008", "5/8/2013", "6/30/1981", "3/31/1982", "6/30/1970", 98 | "9/7/2007", "10/2/2000", "10/2/2012", "10/31/1986", "12/8/2000", 99 | "12/21/2013", "12/21/2009", "3/20/2003", "7/2/2014", "8/31/1987", 100 | "8/19/2014", "6/28/2012", "8/13/2002", "9/23/2011", "6/30/2011", 101 | "5/1/1991", "6/1/1994", "2/26/2004", "9/27/1994", "8/12/2005", 102 | "4/22/2004", "5/1/2014", "10/8/2007", "10/22/2008", "6/30/1976", 103 | "6/30/1969", "12/17/2010", "12/17/2010", "11/1/2000", "11/30/1988", 104 | "7/8/2013", "6/30/1985", "3/11/2005", "1/29/2010", "4/30/1985", 105 | "11/29/2001", "4/30/1989", "8/1/2013", "8/1/2013", "4/7/2015", 106 | "1/2/2009", "3/15/2010", "8/31/1989", "3/27/2009", "12/31/1982", 107 | "11/13/2008", "12/31/1980", "1/16/2002", "11/3/2009", "6/1/2007", 108 | "10/10/2005", "7/19/2002", "11/30/1985", "4/30/1984", "5/31/1985", 109 | "7/16/2003", "3/31/2008", "4/30/1988", "10/1/2012", "11/9/2007", 110 | "12/16/2011", "7/19/2002", "8/18/2005", "4/23/2012", "2/15/2013", 111 | "7/1/2009", "7/1/1992", "9/24/2008", "7/20/2015", "6/11/2015", 112 | "12/31/1982", "12/5/2014", "4/30/2013", "6/30/2004", "12/4/2000", 113 | "7/27/2009", "10/21/2013", "2/2/2007", "12/23/2009", "12/21/2009", 114 | "12/20/2007", "12/5/2008", "6/7/2000", "1/2/2009", "6/30/1964", 115 | "7/29/2015", "11/6/2008", "3/31/1965", "3/23/2015", "9/30/1982", 116 | "4/19/2006", "7/1/2008", "6/25/2002", "11/19/2008", "5/31/1988", 117 | "11/30/1989", "7/2/2012", "7/1/2005", "9/30/1982", "3/12/2015", 118 | "6/6/2008", "11/18/2015", "12/11/2000", "3/28/2003", "12/31/1986", 119 | "11/30/1983", "2/8/2005", "10/1/2007", "10/9/2001", "10/14/2011", 120 | "12/31/1975", "12/31/1976", "3/31/1979", "6/20/2000", "9/30/1985", 121 | "4/30/1989", "12/20/2011", "1/24/2014", "8/10/2005", "9/27/2007", 122 | "1/2/2008", "3/30/2009", "12/31/1978", "8/26/2010", "5/1/2014", 123 | "9/2/2015", "9/20/2014", "7/1/1994", "3/1/1994", "7/19/2002", 124 | "2/8/2010", "9/20/2014", "12/21/2009", "2/12/2007", "6/30/1979", 125 | "4/28/2004", "8/11/2005", "10/7/2015", "1/31/2006", "9/20/2013", 126 | "3/4/2009", "11/30/1983", "12/31/2001", "12/31/1979", "7/1/2009", 127 | "10/31/2008", "6/30/1976", "3/31/1975", "8/31/1982", "9/29/2006", 128 | "7/31/2006", "11/14/2008", "6/20/2014", "8/31/2001", "11/14/2008", 129 | "10/31/2011", "6/22/2001", "6/21/2013", "1/1/1900", "1/1/1900", 130 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 131 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 132 | "4/17/1996", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 133 | "1/1/1900", "12/3/1997", "1/1/1900", "1/1/1900", "1/1/1900", 134 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 135 | "12/15/1994", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 136 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 137 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "7/5/1985", 138 | "1/1/1900", "1/1/1900", "1/1/1900", "08/28/2015", "1/1/1900", 139 | "6/30/2015", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 140 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 141 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 142 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/3/1983", "1/1/1900", 143 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 144 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 145 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 146 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 147 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 148 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 149 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "7/8/1999", 150 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 151 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 152 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 153 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 154 | "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", "1/1/1900", 155 | "1/1/1900")), .Names = c("V1", "V2"), class = "data.frame", row.names = c(NA, 156 | -505L)) 157 | -------------------------------------------------------------------------------- /Platform/compute/MCinit.R: -------------------------------------------------------------------------------- 1 | if( CONFIG[["isUNIX"]] ){ 2 | library(doMC) 3 | workers <- CONFIG[["workers"]] 4 | registerDoMC( cores = workers ) 5 | } else { 6 | library(doParallel) 7 | workers <- CONFIG[["workers"]] 8 | registerDoParallel( cores = workers ) 9 | } 10 | -------------------------------------------------------------------------------- /Platform/compute/functions.R: -------------------------------------------------------------------------------- 1 | # Listings 6.9, 6.12, and 7.1 2 | library(foreach) 3 | 4 | 5 | delegate <- function( i = i, n = n, k = k, p = workers ){ 6 | nOut <- n - k + 1 7 | nProc <- ceiling( nOut / p ) 8 | return( (( i - 1 ) * nProc + 1) : min(i * nProc + k - 1, n) ) 9 | } 10 | 11 | 12 | mcTimeSeries <- function( data, tsfunc, byColumn, windowSize, workers, ... ){ 13 | 14 | args <- names(mget(ls())) 15 | export <- ls(.GlobalEnv) 16 | export <- export[!export %in% args] 17 | 18 | SERIES <- foreach( i = 1:workers, .combine = rbind, 19 | .packages = loadedNamespaces(), .export = export) %dopar% { 20 | 21 | jRange <- delegate( i = i, n = nrow(data), k = windowSize, p = workers) 22 | 23 | rollapply(data[jRange,], 24 | width = windowSize, 25 | FUN = tsfunc, 26 | align = "right", 27 | by.column = byColumn) 28 | 29 | } 30 | 31 | names(SERIES) <- gsub("\\..+", "", names(SERIES)) 32 | 33 | if( windowSize > 1){ 34 | PAD <- zoo(matrix(nrow = windowSize-1, ncol = ncol(SERIES), NA), 35 | order.by = index(data)[1:(windowSize-1)]) 36 | names(PAD) <- names(SERIES) 37 | SERIES <- rbind(PAD, SERIES) 38 | } 39 | 40 | if(is.null(names(SERIES))){ 41 | names(SERIES) <- gsub("\\..+", "", names(data)[1:ncol(SERIES)]) 42 | } 43 | 44 | return(SERIES) 45 | 46 | } 47 | 48 | 49 | 50 | equNA <- function(v){ 51 | o <- which(!is.na(v))[1] 52 | return(ifelse(is.na(o), length(v)+1, o)) 53 | } 54 | 55 | simulate <- function(OPEN, CLOSE, 56 | ENTRY, EXIT, FAVOR, 57 | maxLookback, maxAssets, startingCash, 58 | slipFactor, spreadAdjust, flatCommission, perShareCommission, 59 | verbose = FALSE, failThresh = 0, 60 | initP = NULL, initp = NULL){ 61 | 62 | 63 | # Step 1 64 | if( any( dim(ENTRY) != dim(EXIT) ) | 65 | any( dim(EXIT) != dim(FAVOR) ) | 66 | any( dim(FAVOR) != dim(CLOSE) ) | 67 | any( dim(CLOSE) != dim(OPEN)) ) 68 | stop( "Mismatching dimensions in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.") 69 | 70 | if( any( names(ENTRY) != names(EXIT)) | 71 | any( names(EXIT) != names(FAVOR) ) | 72 | any( names(FAVOR) != names(CLOSE) ) | 73 | any( names(CLOSE) != names(OPEN) ) | 74 | is.null(names(ENTRY)) | is.null(names(EXIT)) | 75 | is.null(names(FAVOR)) | is.null(names(CLOSE)) | 76 | is.null(names(OPEN)) ) 77 | stop( "Mismatching or missing column names in ENTRY, EXIT, FAVOR, CLOSE, or OPEN.") 78 | 79 | 80 | FAVOR <- zoo(t(apply(FAVOR, 1, function(v) ifelse(is.nan(v) | is.na(v), 0, v) )), 81 | order.by = index(CLOSE)) 82 | 83 | 84 | # Step 2 85 | K <- maxAssets 86 | k <- 0 87 | C <- rep(startingCash, times = nrow(CLOSE)) 88 | S <- names(CLOSE) 89 | 90 | P <- p <- zoo( matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)), 91 | order.by = index(CLOSE) ) 92 | 93 | if( !is.null( initP ) & !is.null( initp ) ){ 94 | P[1:maxLookback,] <- 95 | matrix(initP, ncol=length(initP), nrow=maxLookback, byrow = TRUE) 96 | p[1:maxLookback,] <- 97 | matrix(initp, ncol=length(initp), nrow=maxLookback, byrow = TRUE) 98 | } 99 | 100 | names(P) <- names(p) <- S 101 | 102 | equity <- rep(NA, nrow(CLOSE)) 103 | 104 | 105 | 106 | rmNA <- pmax(unlist(lapply(FAVOR, equNA)), 107 | unlist(lapply(ENTRY, equNA)), 108 | unlist(lapply(EXIT, equNA))) 109 | 110 | for( j in 1:ncol(ENTRY) ){ 111 | toRm <- rmNA[j] 112 | if( toRm > (maxLookback + 1) & 113 | toRm < nrow(ENTRY) ){ 114 | FAVOR[1:(toRm-1),j] <- NA 115 | ENTRY[1:(toRm-1),j] <- NA 116 | EXIT[1:(toRm-1),j] <- NA 117 | } 118 | } 119 | 120 | 121 | # Step 3 122 | for( i in maxLookback:(nrow(CLOSE)-1) ){ 123 | 124 | # Step 4 125 | C[i+1] <- C[i] 126 | P[i+1,] <- as.numeric(P[i,]) 127 | p[i+1,] <- as.numeric(p[i,]) 128 | 129 | longS <- S[which(P[i,] > 0)] 130 | shortS <- S[which(P[i,] < 0)] 131 | k <- length(longS) + length(shortS) 132 | 133 | # Step 5 134 | longTrigger <- setdiff(S[which(ENTRY[i,] == 1)], longS) 135 | shortTrigger <- setdiff(S[which(ENTRY[i,] == -1)], shortS) 136 | trigger <- c(longTrigger, shortTrigger) 137 | 138 | if( length(trigger) > K ) { 139 | 140 | keepTrigger <- trigger[order(c(as.numeric(FAVOR[i,longTrigger]), 141 | -as.numeric(FAVOR[i,shortTrigger])), 142 | decreasing = TRUE)][1:K] 143 | 144 | longTrigger <- longTrigger[longTrigger %in% keepTrigger] 145 | shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger] 146 | 147 | trigger <- c(longTrigger, shortTrigger) 148 | 149 | } 150 | 151 | triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger))) 152 | 153 | 154 | # Step 6 155 | longExitTrigger <- longS[longS %in% 156 | S[which(EXIT[i,] == 1 | EXIT[i,] == 999)]] 157 | 158 | shortExitTrigger <- shortS[shortS %in% 159 | S[which(EXIT[i,] == -1 | EXIT[i,] == 999)]] 160 | 161 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 162 | 163 | 164 | # Step 7 165 | needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0) 166 | 167 | if( needToExit > 0 ){ 168 | 169 | toExitLongS <- setdiff(longS, exitTrigger) 170 | toExitShortS <- setdiff(shortS, exitTrigger) 171 | 172 | toExit <- character(0) 173 | 174 | for( counter in 1:needToExit ){ 175 | if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){ 176 | if( min(FAVOR[i,toExitLongS]) < min(-FAVOR[i,toExitShortS]) ){ 177 | pullMin <- which.min(FAVOR[i,toExitLongS]) 178 | toExit <- c(toExit, toExitLongS[pullMin]) 179 | toExitLongS <- toExitLongS[-pullMin] 180 | } else { 181 | pullMin <- which.min(-FAVOR[i,toExitShortS]) 182 | toExit <- c(toExit, toExitShortS[pullMin]) 183 | toExitShortS <- toExitShortS[-pullMin] 184 | } 185 | } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){ 186 | pullMin <- which.min(FAVOR[i,toExitLongS]) 187 | toExit <- c(toExit, toExitLongS[pullMin]) 188 | toExitLongS <- toExitLongS[-pullMin] 189 | } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){ 190 | pullMin <- which.min(-FAVOR[i,toExitShortS]) 191 | toExit <- c(toExit, toExitShortS[pullMin]) 192 | toExitShortS <- toExitShortS[-pullMin] 193 | } 194 | } 195 | 196 | longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit]) 197 | shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit]) 198 | 199 | } 200 | 201 | # Step 8 202 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 203 | exitTriggerType <- c(rep(1, length(longExitTrigger)), 204 | rep(-1, length(shortExitTrigger))) 205 | 206 | 207 | # Step 9 208 | if( length(exitTrigger) > 0 ){ 209 | for( j in 1:length(exitTrigger) ){ 210 | 211 | exitPrice <- as.numeric(OPEN[i+1,exitTrigger[j]]) 212 | 213 | effectivePrice <- exitPrice * (1 - exitTriggerType[j] * slipFactor) - 214 | exitTriggerType[j] * (perShareCommission + spreadAdjust) 215 | 216 | if( exitTriggerType[j] == 1 ){ 217 | 218 | C[i+1] <- C[i+1] + 219 | ( as.numeric( P[i,exitTrigger[j]] ) * effectivePrice ) 220 | - flatCommission 221 | 222 | } else { 223 | 224 | C[i+1] <- C[i+1] - 225 | ( as.numeric( P[i,exitTrigger[j]] ) * 226 | ( 2 * as.numeric(p[i, exitTrigger[j]]) - effectivePrice ) ) 227 | - flatCommission 228 | } 229 | 230 | P[i+1, exitTrigger[j]] <- 0 231 | p[i+1, exitTrigger[j]] <- 0 232 | 233 | k <- k - 1 234 | 235 | } 236 | } 237 | 238 | 239 | # Step 10 240 | if( length(trigger) > 0 ){ 241 | for( j in 1:length(trigger) ){ 242 | 243 | entryPrice <- as.numeric(OPEN[i+1,trigger[j]]) 244 | 245 | effectivePrice <- entryPrice * (1 + triggerType[j] * slipFactor) + 246 | triggerType[j] * (perShareCommission + spreadAdjust) 247 | 248 | P[i+1,trigger[j]] <- triggerType[j] * 249 | floor( ( (C[i+1] - flatCommission) / (K - k) ) / effectivePrice ) 250 | 251 | p[i+1,trigger[j]] <- effectivePrice 252 | 253 | C[i+1] <- C[i+1] - 254 | ( triggerType[j] * as.numeric(P[i+1,trigger[j]]) * effectivePrice ) 255 | - flatCommission 256 | 257 | k <- k + 1 258 | 259 | } 260 | } 261 | 262 | 263 | # Step 11 264 | equity[i] <- C[i+1] 265 | for( s in S[which(P[i+1,] > 0)] ){ 266 | equity[i] <- equity[i] + 267 | as.numeric(P[i+1,s]) * 268 | as.numeric(OPEN[i+1,s]) 269 | } 270 | 271 | for( s in S[which(P[i+1,] < 0)] ){ 272 | equity[i] <- equity[i] - 273 | as.numeric(P[i+1,s]) * 274 | ( 2 * as.numeric(p[i+1,s]) - as.numeric(OPEN[i+1,s]) ) 275 | } 276 | 277 | if( equity[i] < failThresh ){ 278 | warning("\n*** Failure Threshold Breached ***\n") 279 | break 280 | } 281 | 282 | # Step 12 283 | if( verbose ){ 284 | if( i %% 21 == 0 ){ 285 | cat(paste0("################################## ", 286 | round(100 * (i - maxLookback) / 287 | (nrow(CLOSE) - 1 - maxLookback), 1), "%", 288 | " ##################################\n")) 289 | cat(paste("Date:\t",as.character(index(CLOSE)[i])), "\n") 290 | cat(paste0("Equity:\t", " $", signif(equity[i], 5), "\n")) 291 | cat(paste0("CAGR:\t ", 292 | round(100 * ((equity[i] / (equity[maxLookback]))^ 293 | (252/(i - maxLookback + 1)) - 1), 2), 294 | "%")) 295 | cat("\n") 296 | cat("Assets:\t", S[P[i+1,] != 0]) 297 | cat("\n\n") 298 | } 299 | } 300 | 301 | 302 | 303 | } 304 | 305 | # Step 13 306 | return(list(equity = equity, C = C, P = P, p = p)) 307 | 308 | } 309 | 310 | -------------------------------------------------------------------------------- /Platform/config.R: -------------------------------------------------------------------------------- 1 | DIR <- list() 2 | DIR[["root"]] <- "~/Platform/" 3 | DIR[["data"]] <- "~/Platform/stockdata/" 4 | DIR[["function"]] <- "~/Platform/functions/" 5 | DIR[["load"]] <- "~/Platform/load/" 6 | DIR[["compute"]] <- "~/Platform/compute/" 7 | DIR[["plan"]] <- "~/Platform/plan/" 8 | DIR[["model"]] <- "~/Platform/model/" 9 | 10 | CONFIG <- list() 11 | 12 | # Windows users should set to FALSE 13 | CONFIG[["isUNIX"]] <- TRUE 14 | 15 | # Set to the desired number of multicore 16 | # processes. Windows users need to be conscious 17 | # of memory requirements of these processes. 18 | CONFIG[["workers"]] <- 4 19 | 20 | # Max assets to be held in simulation, optimization, 21 | # and potentially trade execution. 22 | CONFIG[["maxAssets"]] <- 10 23 | 24 | # Max iterations in optimization function 25 | # for MODEL job. All users need to be conscious of 26 | # time constraints. 27 | CONFIG[["maxIter"]] <- 100 28 | 29 | # Range or scalar value of years 30 | # to train strategy on for MODEL job 31 | CONFIG[["y"]] <- 2016 32 | 33 | CONFIG[["minVal"]] <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = .01) 34 | CONFIG[["maxVal"]] <- c(n1 = 150, nFact = 5, nSharpe = 200, shThresh = .99) 35 | 36 | CONFIG[["PARAMnaught"]] <- c(n1 = -2, nFact = -2, nSharpe = -2, shThresh = 0) 37 | 38 | 39 | setwd(DIR[["root"]]) 40 | 41 | -------------------------------------------------------------------------------- /Platform/functions/quandl.R: -------------------------------------------------------------------------------- 1 | # Source : https://docs.quandl.com/docs/time-series-1 2 | # Examples 3 | # You can get the same data in a dataframe: data <- Quandl("FRED/GDP", type="raw") 4 | # In ts format: data_ts <- Quandl("FRED/GDP", type="ts") 5 | # In xts format: data_xts <- Quandl("FRED/GDP", type="xts") 6 | # In zoo format: data_zoo <- Quandl("FRED/GDP", type="zoo") 7 | # data <- Quandl(c("FRED/GDP.1", "WIKI/AAPL.4")) 8 | # AAPL <- Quandl("WIKI/AAPL") 9 | # data <- Quandl("WIKI/AAPL.4") 10 | # data_NSE_OIL <- Quandl('NSE/OIL', type = "raw") 11 | # data_gdp_aapl <- Quandl(c("FRED/GDP.1", "WIKI/AAPL.4")) 12 | # data_acn_aapl <- Quandl(c("WIKI/ACN", "WIKI/AAPL.4")) 13 | # mydata = Quandl("FRED/GDP", start_date="2001-12-31", end_date="2005-12-31") 14 | # mydata_columns <- Quandl(c("WIKI/AAPL.8", "WIKI/AAPL.9"), start_date="2017-01-01") 15 | 16 | #quandl API 17 | quandl_api = "MYAPIKEY" 18 | 19 | #add my key 20 | Quandl.api_key(quandl_api) 21 | 22 | quandl_get <- 23 | function(sym, start_date = "2017-01-01") { 24 | require(devtools) 25 | require(Quandl) 26 | # create a vector with all lines 27 | tryCatch(Quandl(c( 28 | paste0("WIKI/", sym, ".8"), # Adj. Open 29 | paste0("WIKI/", sym, ".9"), # Adj. High 30 | paste0("WIKI/", sym, ".10"), # Adj. Low 31 | paste0("WIKI/", sym, ".11"), # Adj. Close 32 | paste0("WIKI/", sym, ".12")), # Adj. Volume 33 | start_date = start_date, 34 | type = "zoo" 35 | )) 36 | } 37 | -------------------------------------------------------------------------------- /Platform/functions/yahoo.R: -------------------------------------------------------------------------------- 1 | # Listing 2.2 2 | yahoo <- function(sym, current = TRUE, 3 | a = 0, b = 1, c = 2000, d, e, f, 4 | g = "d") 5 | { 6 | 7 | if(current){ 8 | f <- as.numeric(substr(as.character(Sys.time()), start = 1, stop = 4)) 9 | d <- as.numeric(substr(as.character(Sys.time()), start = 6, stop = 7)) - 1 10 | e <- as.numeric(substr(as.character(Sys.time()), start = 9, stop = 10)) 11 | } 12 | 13 | require(data.table) 14 | 15 | tryCatch( 16 | suppressWarnings( 17 | fread(paste0("http://ichart.yahoo.com/table.csv", 18 | "?s=", sym, 19 | "&a=", a, 20 | "&b=", b, 21 | "&c=", c, 22 | "&d=", d, 23 | "&e=", e, 24 | "&f=", f, 25 | "&g=", g, 26 | "&ignore=.csv"), sep = ",")), 27 | error = function(e) NULL 28 | ) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /Platform/invalid.R: -------------------------------------------------------------------------------- 1 | invalid <- 2 | character(0) 3 | -------------------------------------------------------------------------------- /Platform/load.R: -------------------------------------------------------------------------------- 1 | setwd(DIR[["load"]]) 2 | cat("initial.R\n\n") 3 | source("initial.R") 4 | 5 | setwd(DIR[["load"]]) 6 | cat("loadToMemory.R\n\n") 7 | source("loadToMemory.R") 8 | 9 | setwd(DIR[["load"]]) 10 | cat("updateStocks.R\n\n") 11 | source("updateStocks.R") 12 | 13 | setwd(DIR[["load"]]) 14 | cat("dateUnif.R\n\n") 15 | source("dateUnif.R") 16 | 17 | setwd(DIR[["load"]]) 18 | cat("spClean.R\n\n") 19 | source("spClean.R") 20 | 21 | setwd(DIR[["load"]]) 22 | cat("adjustClose.R\n\n") 23 | source("adjustClose.R") 24 | 25 | setwd(DIR[["load"]]) 26 | cat("return.R\n\n") 27 | source("return.R") 28 | 29 | setwd(DIR[["load"]]) 30 | cat("fillInactive.R\n\n") 31 | source("fillInactive.R") 32 | 33 | cat("\n") 34 | -------------------------------------------------------------------------------- /Platform/load/adjustClose.R: -------------------------------------------------------------------------------- 1 | # Listing 3.6 2 | MULT <- DATA[["Adj Close"]] / DATA[["Close"]] 3 | 4 | DATA[["Price"]] <- DATA[["Close"]] 5 | DATA[["OpenPrice"]] <- DATA[["Open"]] 6 | 7 | DATA[["Open"]] <- DATA[["Open"]] * MULT 8 | DATA[["High"]] <- DATA[["High"]] * MULT 9 | DATA[["Low"]] <- DATA[["Low"]] * MULT 10 | DATA[["Close"]] <- DATA[["Adj Close"]] 11 | 12 | DATA[["Adj Close"]] <- NULL 13 | -------------------------------------------------------------------------------- /Platform/load/dateUnif.R: -------------------------------------------------------------------------------- 1 | # Listing 2.8 2 | library(zoo) 3 | 4 | datetemp <- sort(unique(unlist(sapply(DATA, function(v) v[["Date"]])))) 5 | datetemp <- data.frame(datetemp, stringsAsFactors = FALSE) 6 | names(datetemp) <- "Date" 7 | 8 | DATA <- lapply(DATA, function(v) unique(v[order(v$Date),])) 9 | 10 | DATA[["Open"]] <- DATA[["High"]] <- DATA[["Low"]] <- 11 | DATA[["Close"]] <- DATA[["Adj Close"]] <- DATA[["Volume"]] <- datetemp 12 | 13 | for(s in S){ 14 | for(i in rev(c("Open", "High", "Low", "Close", "Adj Close", "Volume"))){ 15 | temp <- data.frame(cbind(DATA[[s]][["Date"]], DATA[[s]][[i]]), 16 | stringsAsFactors = FALSE) 17 | names(temp) <- c("Date", s) 18 | temp[,2] <- as.numeric(temp[,2]) 19 | 20 | if(!any(!DATA[[i]][["Date"]][(nrow(DATA[[i]]) - nrow(temp)+1):nrow(DATA[[i]])] 21 | == temp[,1])){ 22 | temp <- rbind(t(matrix(nrow = 2, ncol = nrow(DATA[[i]]) - nrow(temp), 23 | dimnames = list(names(temp)))), temp) 24 | DATA[[i]] <- cbind(DATA[[i]], temp[,2]) 25 | } else { 26 | DATA[[i]] <- merge(DATA[[i]], temp, all.x = TRUE, by = "Date") 27 | } 28 | 29 | names(DATA[[i]]) <- c(names(DATA[[i]])[-(ncol(DATA[[i]]))], s) 30 | } 31 | DATA[[s]] <- NULL 32 | 33 | # Update user on progress 34 | if( which( S == s ) %% 25 == 0 ){ 35 | cat( paste0(round(100 * which( S == s ) / length(S), 1), "% Complete\n") ) 36 | } 37 | 38 | } 39 | 40 | DATA <- lapply(DATA, function(v) zoo(v[,2:ncol(v)], strptime(v[,1], "%Y-%m-%d"))) 41 | 42 | rm(list = setdiff(ls(), c("DATA", "DIR", "CONFIG"))) 43 | gc() 44 | -------------------------------------------------------------------------------- /Platform/load/fillInactive.R: -------------------------------------------------------------------------------- 1 | # Listing 3.7 2 | for( s in names(DATA[["Close"]]) ){ 3 | if(is.na(DATA[["Close"]][nrow(DATA[["Close"]]), s])){ 4 | maxInd <- max(which(!is.na(DATA[["Close"]][,s]))) 5 | for( i in c("Close", "Open", "High", "Low")){ 6 | DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Close"]][maxInd,s] 7 | } 8 | for( i in c("Price", "OpenPrice") ){ 9 | DATA[[i]][(maxInd+1):nrow(DATA[["Close"]]),s] <- DATA[["Price"]][maxInd,s] 10 | } 11 | DATA[["Volume"]][(maxInd+1):nrow(DATA[["Close"]]),s] <- 0 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /Platform/load/initial.R: -------------------------------------------------------------------------------- 1 | # Listing 2.4 2 | setwd(DIR[["function"]]) 3 | source("yahoo.R") 4 | 5 | setwd(DIR[["root"]]) 6 | if("S.R" %in% list.files()) { 7 | source("S.R") 8 | } else { 9 | url <- "http://trading.chrisconlan.com/SPstocks.csv" 10 | S <- as.character(read.csv(url, header = FALSE)[,1]) 11 | dump(list = "S", "S.R") 12 | } 13 | 14 | invalid <- character(0) 15 | if("invalid.R" %in% list.files()) source("invalid.R") 16 | 17 | setwd(DIR[["data"]]) 18 | toload <- setdiff(S[!paste0(S, ".csv") %in% list.files()], invalid) 19 | 20 | if(length(toload) != 0){ 21 | for(i in 1:length(toload)){ 22 | 23 | df <- yahoo(toload[i]) 24 | 25 | if(!is.null(df)) { 26 | write.csv(df[nrow(df):1], file = paste0(toload[i], ".csv"), 27 | row.names = FALSE) 28 | } else { 29 | invalid <- c(invalid, toload[i]) 30 | } 31 | 32 | } 33 | } 34 | 35 | setwd(DIR[["root"]]) 36 | dump(list = c("invalid"), "invalid.R") 37 | 38 | rm(list = setdiff(ls(), c("CONFIG", "DIR", "yahoo"))) 39 | gc() 40 | -------------------------------------------------------------------------------- /Platform/load/loadToMemory.R: -------------------------------------------------------------------------------- 1 | # Listing 2.5 2 | setwd(DIR[["data"]]) 3 | S <- sub(".csv", "", list.files()) 4 | 5 | library(data.table) 6 | 7 | DATA <- list() 8 | for(i in S){ 9 | suppressWarnings( 10 | DATA[[i]] <- fread(paste0(i, ".csv"), sep = ",")) 11 | DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)] 12 | } 13 | -------------------------------------------------------------------------------- /Platform/load/return.R: -------------------------------------------------------------------------------- 1 | # Listing 3.8 2 | NAPAD <- zoo(matrix(NA, nrow = 1, ncol = ncol(DATA[["Close"]])), order.by = index(DATA[["Close"]])[1]) 3 | names(NAPAD) <- names(DATA[["Close"]]) 4 | 5 | RETURN <- rbind( NAPAD, ( DATA[["Close"]] / lag(DATA[["Close"]], k = -1) ) - 1 ) 6 | 7 | OVERNIGHT <- rbind( NAPAD, ( DATA[["Open"]] / lag(DATA[["Close"]], k = -1) ) - 1 ) 8 | -------------------------------------------------------------------------------- /Platform/load/spClean.R: -------------------------------------------------------------------------------- 1 | # Listing 3.1 2 | setwd(DIR[["root"]]) 3 | 4 | if( "SPdates.R" %in% list.files() ){ 5 | source("SPdates.R") 6 | } else { 7 | url <- "http://trading.chrisconlan.com/SPdates.csv" 8 | S <- read.csv(url, header = FALSE, stringsAsFactors = FALSE) 9 | dump(list = "S", "SPdates.R") 10 | } 11 | 12 | names(S) <- c("Symbol", "Date") 13 | S$Date <- strptime(S$Date, "%m/%d/%Y") 14 | 15 | for(s in names(DATA[["Close"]])){ 16 | for(i in c("Open", "High", "Low", "Close", "Adj Close", "Volume")){ 17 | Sindex <- which(S[,1] == s) 18 | if(S[Sindex, "Date"] != "1900-01-01 EST" & 19 | S[Sindex, "Date"] >= "2000-01-01 EST"){ 20 | DATA[[i]][index(DATA[[i]]) <= S[Sindex, "Date"], s] <- NA 21 | } 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /Platform/load/updateStocks.R: -------------------------------------------------------------------------------- 1 | # Listings 2.6 and 2.7 2 | setwd(DIR[["data"]]) 3 | library(XML) 4 | 5 | batchsize <- 51 6 | 7 | redownload <- character(0) 8 | 9 | for(i in 1:(ceiling(length(S) / batchsize)) ){ 10 | 11 | midQuery <- " (" 12 | maxdate <- character(0) 13 | 14 | startIndex <- ((i - 1) * batchsize + 1) 15 | endIndex <- min(i * batchsize, length(S)) 16 | 17 | 18 | for(s in S[startIndex:(endIndex - 1)]){ 19 | maxdate <- c(maxdate, DATA[[s]][[1]][nrow(DATA[[s]])]) 20 | midQuery <- paste0(midQuery, "'", s, "', ") 21 | } 22 | 23 | 24 | maxdate <- c(maxdate, DATA[[S[endIndex]]][[1]] 25 | [nrow(DATA[[S[endIndex]]])]) 26 | 27 | startDate <- max(maxdate) 28 | 29 | useCSV <- FALSE 30 | if( startDate < 31 | substr(strptime(substr(Sys.time(), 0, 10), "%Y-%m-%d") 32 | - 20 * 86400, 0, 10) ){ 33 | cat("Query is greater than 20 days. Updating with csv method.") 34 | useCSV <- TRUE 35 | break 36 | } 37 | 38 | startDate <- substr(as.character(strptime(startDate, "%Y-%m-%d") + 86400), 0, 10) 39 | endDate <- substr(Sys.time(), 0, 10) 40 | 41 | 42 | isUpdated <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) >= 40.25 43 | 44 | weekend <- sum(c("Saturday", "Sunday") %in% 45 | weekdays(c(strptime(endDate, "%Y-%m-%d"), 46 | c(strptime(startDate, "%Y-%m-%d"))))) == 2 47 | 48 | 49 | span <- as.numeric(difftime(Sys.time(), startDate, units = "hours")) < 48 50 | 51 | runXMLupdate <- startDate <= endDate & !weekend & !span & isUpdated 52 | 53 | # Push back query date to validate extra days against adj. close 54 | startDateQuery <- substr(as.character( 55 | strptime(startDate, "%Y-%m-%d") - 7 * 86400 56 | ), 0, 10) 57 | 58 | 59 | 60 | if( runXMLupdate ){ 61 | 62 | base <- "http://query.yahooapis.com/v1/public/yql?" 63 | begQuery <- "q=select * from yahoo.finance.historicaldata where symbol in " 64 | midQuery <- paste0(midQuery, "'", S[min(i * batchsize, length(S))], "') ") 65 | endQuery <- paste0("and startDate = '", startDateQuery, 66 | "' and endDate = '", endDate, "'") 67 | endParams <- "&diagnostics=true&env=store://datatables.org/alltableswithkeys" 68 | 69 | urlstr <- paste0(base, begQuery, midQuery, endQuery, endParams) 70 | 71 | doc <- xmlParse(urlstr) 72 | 73 | df <- getNodeSet(doc, c("//query/results/quote"), 74 | fun = function(v) xpathSApply(v, 75 | c("./Date", 76 | "./Open", 77 | "./High", 78 | "./Low", 79 | "./Close", 80 | "./Volume", 81 | "./Adj_Close"), 82 | xmlValue)) 83 | 84 | if(length(df) != 0){ 85 | 86 | symbols <- unname(sapply( 87 | getNodeSet(doc, c("//query/results/quote")), xmlAttrs)) 88 | 89 | df <- cbind(symbols, data.frame(t(data.frame(df, stringsAsFactors = FALSE)), 90 | stringsAsFactors = FALSE, row.names = NULL)) 91 | 92 | names(df) <- c("Symbol", "Date", 93 | "Open", "High", "Low", "Close", "Volume", "Adj Close") 94 | 95 | df[,3:8] <- lapply(df[,3:8], as.numeric) 96 | df <- df[order(df[,1], decreasing = FALSE),] 97 | 98 | sym <- as.character(unique(df$Symbol)) 99 | 100 | for(s in sym){ 101 | 102 | temp <- df[df$Symbol == s, 2:8] 103 | temp <- temp[order(temp[,1], decreasing = FALSE),] 104 | 105 | # Check if the Adj. Close data is equal for matching dates 106 | # if not, save symbol to redownload later 107 | if(any( !DATA[[s]][DATA[[s]][["Date"]] %in% temp[,1]]$"Adj Close" == 108 | temp[temp[,1] %in% DATA[[s]][["Date"]],7] )) 109 | { 110 | 111 | redownload <- c(redownload, s) 112 | 113 | } else { 114 | 115 | startDate <- DATA[[s]][["Date"]][nrow(DATA[[s]])] 116 | 117 | DATA[[s]] <- DATA[[s]][order(DATA[[s]][[1]], decreasing = FALSE)] 118 | DATA[[s]] <- rbind(DATA[[s]], temp[temp$Date > startDate,]) 119 | write.table(DATA[[s]][DATA[[s]][["Date"]] > startDate], 120 | file = paste0(s, ".csv"), sep = ",", 121 | row.names = FALSE, col.names = FALSE, append = TRUE) 122 | } 123 | 124 | 125 | } 126 | } 127 | } 128 | } 129 | 130 | if( useCSV ){ 131 | for(i in S){ 132 | maxdate <- DATA[[i]][["Date"]][nrow(DATA[[i]])] 133 | isUpdated <- as.numeric(difftime(Sys.time(), maxdate, units = "hours")) >= 40.25 134 | if( isUpdated ){ 135 | 136 | maxdate <- strptime(maxdate, "%Y-%m-%d") + 86400 137 | 138 | weekend <- sum(c("Saturday", "Sunday") %in% 139 | weekdays(c(maxdate, Sys.time()))) == 2 140 | 141 | span <- FALSE 142 | if( weekend ){ 143 | span <- as.numeric(difftime(Sys.time(), maxdate, units = "hours")) < 48 144 | } 145 | 146 | # Push back query date to validate extra days against adj. close 147 | startDateQuery <- maxdate - 7 * 86400 148 | 149 | if(!weekend & !span){ 150 | c <- as.numeric(substr(startDateQuery, start = 1, stop = 4)) 151 | a <- as.numeric(substr(startDateQuery, start = 6, stop = 7)) - 1 152 | b <- as.numeric(substr(startDateQuery, start = 9, stop = 10)) 153 | df <- yahoo(i, a = a, b = b, c = c) 154 | if(!is.null(df)){ 155 | if(all(!is.na(df)) & nrow(df) > 0){ 156 | 157 | df <- df[nrow(df):1] 158 | 159 | if( any(!DATA[[i]][DATA[[i]][["Date"]] %in% df[["Date"]]]$"Adj Close" == 160 | df[["Adj Close"]][df[["Date"]] %in% DATA[[i]][["Date"]]]) ) 161 | { 162 | 163 | redownload <- c(redownload, i) 164 | 165 | } else { 166 | write.table(df, file = paste0(i, ".csv"), sep = ",", 167 | row.names = FALSE, col.names = FALSE, append = TRUE) 168 | DATA[[i]] <- rbind(DATA[[i]], df) 169 | } 170 | 171 | } 172 | } 173 | } 174 | } 175 | } 176 | } 177 | 178 | 179 | 180 | # Re-download, store, and load into memory the symbols with 181 | # altered adj. close data 182 | setwd(DIR[["data"]]) 183 | if(length(redownload) != 0){ 184 | for( i in redownload ){ 185 | 186 | df <- yahoo(i) 187 | if(!is.null(df)) { 188 | write.csv(df[nrow(df):1], file = paste0(i, ".csv"), 189 | row.names = FALSE) 190 | } 191 | 192 | suppressWarnings( 193 | DATA[[i]] <- fread(paste0(i, ".csv"), sep = ",")) 194 | DATA[[i]] <- (DATA[[i]])[order(DATA[[i]][["Date"]], decreasing = FALSE)] 195 | 196 | } 197 | } 198 | 199 | 200 | rm(list = setdiff(ls(), c("S", "DATA", "DIR", "CONFIG"))) 201 | gc() 202 | -------------------------------------------------------------------------------- /Platform/model.R: -------------------------------------------------------------------------------- 1 | source("~/Platform/config.R") 2 | 3 | setwd(DIR[["root"]]) 4 | cat("load.R\n\n") 5 | source("load.R") 6 | 7 | setwd(DIR[["compute"]]) 8 | cat("MCinit.R\n\n") 9 | source("MCinit.R") 10 | 11 | cat("functions.R\n\n") 12 | source("functions.R") 13 | 14 | 15 | setwd(DIR[["model"]]) 16 | cat("optimize.R\n\n") 17 | source("optimize.R") 18 | 19 | 20 | cat("\n") 21 | -------------------------------------------------------------------------------- /Platform/model/evaluateFunc.R: -------------------------------------------------------------------------------- 1 | 2 | # Listng 8.1 3 | 4 | # Declare entry function for use inside evaluator 5 | entryfunc <- function(v, shThresh){ 6 | cols <- ncol(v) / 2 7 | as.numeric(v[1,1:cols] <= 0 & 8 | v[2,1:cols] > 0 & 9 | v[2,(cols+1):(2*cols)] > 10 | quantile(v[2,(cols+1):(2*cols)], 11 | shThresh, na.rm = TRUE) 12 | ) 13 | } 14 | 15 | evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014, 16 | transform = TRUE, verbose = FALSE, 17 | negative = FALSE, transformOnly = FALSE, 18 | returnData = FALSE, accountParams = NULL){ 19 | 20 | # Convert and declare parameters if they exist on domain (-inf,inf) domain 21 | if( transform | transformOnly ){ 22 | PARAM <- minVal + 23 | (maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) )) 24 | if( transformOnly ){ 25 | return(PARAM) 26 | } 27 | } 28 | 29 | # Max shares to hold 30 | K <- CONFIG[["maxAssets"]] 31 | 32 | # Declare n1 as itself, n2 as a multiple of n1 defined by nFact, 33 | # and declare the length and threshold in sharpe ratio for FAVOR 34 | n1 <- max(round(PARAM[["n1"]]), 2) 35 | n2 <- max(round(PARAM[["nFact"]] * PARAM[["n1"]]), 3, n1+1) 36 | nSharpe <- max(round(PARAM[["nSharpe"]]), 2) 37 | shThresh <- max(0, min(PARAM[["shThresh"]], .99)) 38 | maxLookback <- max(n1, n2, nSharpe) + 1 39 | 40 | 41 | 42 | # Subset data according to year, y 43 | period <- 44 | index(DATA[["Close"]]) >= strptime(paste0("01-01-", y[1]), "%d-%m-%Y") & 45 | index(DATA[["Close"]]) < strptime(paste0("01-01-", y[length(y)]+1), "%d-%m-%Y") 46 | 47 | period <- period | 48 | ((1:nrow(DATA[["Close"]]) > (which(period)[1] - maxLookback)) & 49 | (1:nrow(DATA[["Close"]]) <= (which(period)[sum(period)]) + 1)) 50 | 51 | CLOSE <- DATA[["Close"]][period,] 52 | OPEN <- DATA[["Open"]][period,] 53 | SUBRETURN <- RETURN[period,] 54 | 55 | 56 | # Compute inputs for long-only MACD as in Listing 7.2 57 | # Code is optimized for speed using functions from caTools and zoo 58 | require(caTools) 59 | 60 | INDIC <- zoo(runmean(CLOSE, n1, endrule = "NA", align = "right") - 61 | runmean(CLOSE, n2, endrule = "NA", align = "right"), 62 | order.by = index(CLOSE)) 63 | names(INDIC) <- names(CLOSE) 64 | 65 | 66 | RMEAN <- zoo(runmean(SUBRETURN, n1, endrule = "NA", align = "right"), 67 | order.by = index(SUBRETURN)) 68 | 69 | FAVOR <- RMEAN / runmean( (SUBRETURN - RMEAN)^2, nSharpe, 70 | endrule = "NA", align = "right" ) 71 | names(FAVOR) <- names(CLOSE) 72 | 73 | 74 | ENTRY <- rollapply(cbind(INDIC, FAVOR), 75 | FUN = function(v) entryfunc(v, shThresh), 76 | width = 2, 77 | fill = NA, 78 | align = "right", 79 | by.column = FALSE) 80 | names(ENTRY) <- names(CLOSE) 81 | 82 | EXIT <- zoo(matrix(0, ncol=ncol(CLOSE), nrow=nrow(CLOSE)), 83 | order.by = index(CLOSE)) 84 | names(EXIT) <- names(CLOSE) 85 | 86 | 87 | 88 | # Simulate and store results 89 | if( is.null(accountParams) ){ 90 | RESULTS <- simulate(OPEN, CLOSE, 91 | ENTRY, EXIT, FAVOR, 92 | maxLookback, K, 100000, 93 | 0.001, 0.01, 3.5, 0, 94 | verbose, 0) 95 | } else { 96 | RESULTS <- simulate(OPEN, CLOSE, 97 | ENTRY, EXIT, FAVOR, 98 | maxLookback, K, accountParams[["C"]], 99 | 0.001, 0.01, 3.5, 0, 100 | verbose, 0, 101 | initP = accountParams[["P"]], initp = accountParams[["p"]]) 102 | } 103 | 104 | 105 | if(!returnData){ 106 | 107 | # Compute and return sharpe ratio 108 | v <- RESULTS[["equity"]] 109 | returns <- ( v[-1] / v[-length(v)] ) - 1 110 | out <- mean(returns, na.rm = T) / sd(returns, na.rm = T) 111 | if(!is.nan(out)){ 112 | if( negative ){ 113 | return( -out ) 114 | } else { 115 | return( out ) 116 | } 117 | } else { 118 | return(0) 119 | } 120 | 121 | } else { 122 | return(RESULTS) 123 | } 124 | 125 | } 126 | -------------------------------------------------------------------------------- /Platform/model/optimize.R: -------------------------------------------------------------------------------- 1 | setwd(DIR[["model"]]) 2 | 3 | minVal <- CONFIG[["minVal"]] 4 | maxVal <- CONFIG[["maxVal"]] 5 | PARAM <- CONFIG[["PARAMnaught"]] 6 | 7 | source("evaluateFunc.R") 8 | source("optimizeFunc.R") 9 | 10 | PARAMout <- optimize(y = CONFIG[["y"]], minVal, maxVal) 11 | 12 | setwd(DIR[["plan"]]) 13 | 14 | write.csv(data.frame(PARAMout), "stratParams.csv") 15 | -------------------------------------------------------------------------------- /Platform/model/optimizeFunc.R: -------------------------------------------------------------------------------- 1 | # Example optimization function coded for 2 | # Generalized pattern search (Listing 8.4) 3 | optimize <- function(y, minVal, maxVal){ 4 | 5 | 6 | # Maximum iterations 7 | # Max possible calls to evaluator is K * (4 * n + 1) 8 | K <- CONFIG[["maxIter"]] 9 | 10 | # Restart with random init when delta is below threshold 11 | deltaThresh <- 0.05 12 | 13 | # Set initial delta 14 | delta <- deltaNaught <- 1 15 | 16 | # Scale factor 17 | sigma <- 2 18 | 19 | 20 | # Vector theta_0 21 | PARAM <- PARAMNaught <- CONFIG[["PARAMnaught"]] 22 | 23 | np <- length(PARAM) 24 | 25 | OPTIM <- data.frame(matrix(NA, nrow = K * (4 * np + 1), ncol = np + 1)) 26 | names(OPTIM) <- c(names(PARAM), "obj"); o <- 1 27 | 28 | fmin <- fminNaught <- evaluate(PARAM, minVal, maxVal, negative = TRUE, y = y) 29 | OPTIM[o,] <- c(PARAM, fmin); o <- o + 1 30 | 31 | 32 | # Print function for reporting progress in loop 33 | printUpdate <- function(step){ 34 | if(step == "search"){ 35 | cat(paste0("Search step: ", k,"|",l,"|",m, "\n")) 36 | } else if (step == "poll"){ 37 | cat(paste0("Poll step: ", k,"|",l,"|",m, "\n")) 38 | } 39 | names(OPTIM) 40 | cat("\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n") 41 | cat("Best:\t", paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n") 42 | cat("Theta:\t", paste0(round(unlist(c(PARAM, fmin)),3), "\t"), "\n") 43 | cat("Trial:\t", paste0(round(as.numeric(OPTIM[o-1,]), 3), "\t"), "\n") 44 | cat(paste0("Delta: ", round(delta,3) , "\t"), "\n\n") 45 | } 46 | 47 | for( k in 1:K ){ 48 | 49 | # SEARCH subroutine 50 | for( l in 1:np ){ 51 | net <- (2 * rbinom(np, 1, .5) - 1) * runif(np, delta, sigma * delta) 52 | for( m in c(-1,1) ){ 53 | 54 | testpoint <- PARAM + m * net 55 | ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y) 56 | OPTIM[o,] <- c(testpoint, ftest); o <- o + 1 57 | printUpdate("search") 58 | 59 | } 60 | } 61 | 62 | if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){ 63 | 64 | minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)]) 65 | PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,] 66 | fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos] 67 | delta <- sigma * delta 68 | 69 | } else { 70 | 71 | # POLL Subroutine 72 | for( l in 1:np ){ 73 | net <- delta * as.numeric(1:np == l) 74 | for( m in c(-1,1) ){ 75 | 76 | testpoint <- PARAM + m * net 77 | ftest <- evaluate(testpoint, minVal, maxVal, negative = TRUE, y = y) 78 | OPTIM[o,] <- c(testpoint, ftest); o <- o + 1 79 | printUpdate("poll") 80 | 81 | } 82 | } 83 | 84 | if( any(OPTIM$obj[(o-(2*np)):(o-1)] < fmin ) ){ 85 | 86 | minPos <- which.min(OPTIM$obj[(o-(2*np)):(o-1)]) 87 | PARAM <- (OPTIM[(o-(2*np)):(o-1),1:np])[minPos,] 88 | fmin <- (OPTIM[(o-(2*np)):(o-1),np+1])[minPos] 89 | delta <- sigma * delta 90 | 91 | } else { 92 | 93 | delta <- delta / sigma 94 | 95 | } 96 | 97 | 98 | } 99 | 100 | cat(paste0("\nCompleted Full Iteration: ", k, "\n\n")) 101 | 102 | # Restart with random initiate 103 | if( delta < deltaThresh ) { 104 | 105 | delta <- deltaNaught 106 | fmin <- fminNaught 107 | PARAM <- PARAMNaught + runif(n = np, min = -delta * sigma, 108 | max = delta * sigma) 109 | 110 | ftest <- evaluate(PARAM, minVal, maxVal, 111 | negative = TRUE, y = y) 112 | OPTIM[o,] <- c(PARAM, ftest); o <- o + 1 113 | 114 | cat(paste0("\nDelta Threshold Breached, Restarting with Random Initiate\n\n")) 115 | 116 | } 117 | 118 | } 119 | 120 | # Return the best optimization in untransformed parameters 121 | return( 122 | evaluate(OPTIM[which.min(OPTIM$obj),1:np], 123 | minVal, maxVal, transformOnly = TRUE) 124 | ) 125 | 126 | 127 | } 128 | -------------------------------------------------------------------------------- /Platform/plan.R: -------------------------------------------------------------------------------- 1 | source("~/Platform/config.R") 2 | 3 | 4 | setwd(DIR[["root"]]) 5 | cat("load.R\n\n") 6 | source("load.R") 7 | 8 | 9 | setwd(DIR[["compute"]]) 10 | cat("MCinit.R\n\n") 11 | source("MCinit.R") 12 | 13 | cat("functions.R\n\n") 14 | source("functions.R") 15 | 16 | setwd(DIR[["plan"]]) 17 | cat("decisionGen.R\n\n") 18 | source("decisionGen.R") 19 | 20 | 21 | cat("\n") 22 | -------------------------------------------------------------------------------- /Platform/plan/decisionGen.R: -------------------------------------------------------------------------------- 1 | # Listing 9.1 2 | setwd(DIR[["plan"]]) 3 | 4 | 5 | # Normally declared by your strategy. 6 | # Long-only MACD is computed with rollapply() 7 | # here for sake of example. 8 | n1 <- 5 9 | n2 <- 34 10 | nSharpe <- 20 11 | shThresh <- 0.50 12 | 13 | INDIC <- rollapply(DATA[["Close"]][nrow(DATA[["Close"]]) - n2:0, ], 14 | width = n2, 15 | FUN = function(v) mean(v[(n2 - n1 + 1):n2]) - mean(v), 16 | by.column = TRUE, 17 | align = "right") 18 | 19 | 20 | 21 | FAVOR <- rollapply(DATA[["Close"]][nrow(DATA[["Close"]]) - nSharpe:0, ], 22 | FUN = function(v) mean(v, na.rm = TRUE)/sd(v, na.rm = TRUE), 23 | by.column = TRUE, 24 | width = nSharpe, 25 | align = "right") 26 | 27 | 28 | entryfunc <- function(v, shThresh){ 29 | cols <- ncol(v) / 2 30 | as.numeric(v[1,1:cols] <= 0 & 31 | v[2,1:cols] > 0 & 32 | v[2,(cols+1):(2*cols)] > 33 | quantile(v[2,(cols+1):(2*cols)], 34 | shThresh, na.rm = TRUE) 35 | ) 36 | } 37 | 38 | 39 | cols <- ncol(INDIC) 40 | 41 | ENTRY <- rollapply(cbind(INDIC, FAVOR), 42 | function(v) entryfunc(v, cols), 43 | by.column = FALSE, 44 | width = 2, 45 | align = "right") 46 | 47 | 48 | # ***IMPORTANT*** 49 | # The quick version used in the PLAN job accepts named vectors 50 | # respresenting the most recent single row of ENTRY, FAVOR, and EXIT. 51 | # These lines convert the zoo/data frame/matrix objects computed 52 | # in the above lines to named vectors of the last row of data. 53 | 54 | FAVOR <- as.numeric(FAVOR[nrow(FAVOR),]) 55 | names(FAVOR) <- names(DATA[["Close"]]) 56 | 57 | ENTRY <- as.numeric(ENTRY[nrow(ENTRY),]) 58 | names(ENTRY) <- names(DATA[["Close"]]) 59 | 60 | EXIT <- zoo(matrix(0, ncol=ncol(DATA[["Close"]]), nrow = 1), 61 | order.by = index(DATA[["Close"]])) 62 | names(EXIT) <- names(DATA[["Close"]]) 63 | 64 | 65 | 66 | # Normally fetched from brokerage. 67 | # These are arbitrarily declared here. 68 | # Users need to fetch this information from the brokerage 69 | # for production use. 70 | currentlyLong <- c("AA", "AAL", "AAPL") 71 | currentlyShort <- c("") 72 | S <- names(DATA[["Close"]]) 73 | initP <- (S %in% currentlyLong) - (S %in% currentlyShort) 74 | cashOnHand <- 54353.54 75 | 76 | 77 | 78 | names(initP) <- 79 | names(FAVOR) <- 80 | names(ENTRY) <- 81 | names(EXIT) <- 82 | names(DATA[["Close"]]) 83 | 84 | 85 | # At this point we have established everything normally 86 | # taken care of by your strategy. 87 | # Given named vectors of length ncol(DATA[["Close"]]) 88 | # initP, FAVOR, ENTRY, and EXIT 89 | 90 | maxAssets <- CONFIG[["maxAssets"]] 91 | 92 | K <- maxAssets 93 | k <- 0 94 | C <- c(cashOnHand, NA) 95 | S <- names(DATA[["Close"]]) 96 | P <- initP 97 | 98 | 99 | # Normally declared by your strategy 100 | FAVOR <- rnorm(ncol(DATA[["Close"]])) 101 | ENTRY <- rbinom(ncol(DATA[["Close"]]), 1, .005) - 102 | rbinom(ncol(DATA[["Close"]]), 1, .005) 103 | EXIT <- rbinom(ncol(DATA[["Close"]]), 1, .8) - 104 | rbinom(ncol(DATA[["Close"]]), 1, .8) 105 | 106 | # Normally fetched from brokerage 107 | currentlyLong <- c("AA", "AAL", "AAPL") 108 | currentlyShort <- c("RAI", "RCL", "REGN") 109 | S <- names(DATA[["Close"]]) 110 | initP <- (S %in% currentlyLong) - (S %in% currentlyShort) 111 | 112 | names(initP) <- 113 | names(FAVOR) <- 114 | names(ENTRY) <- 115 | names(EXIT) <- 116 | names(DATA[["Close"]]) 117 | 118 | 119 | # At this point we have established everything normally 120 | # taken care of by your strategy. 121 | # Given named vectors of length ncol(DATA[["Close"]]) 122 | # initP, FAVOR, ENTRY, and EXIT 123 | 124 | maxAssets <- 10 125 | startingCash <- 100000 126 | 127 | K <- maxAssets 128 | k <- 0 129 | C <- c(startingCash, NA) 130 | S <- names(DATA[["Close"]]) 131 | P <- initP 132 | 133 | 134 | # Step 4 135 | longS <- S[which(P > 0)] 136 | shortS <- S[which(P < 0)] 137 | k <- length(longS) + length(shortS) 138 | 139 | # Step 5 140 | longTrigger <- setdiff(S[which(ENTRY == 1)], longS) 141 | shortTrigger <- setdiff(S[which(ENTRY == -1)], shortS) 142 | trigger <- c(longTrigger, shortTrigger) 143 | 144 | if( length(trigger) > K ) { 145 | 146 | keepTrigger <- trigger[order(c(as.numeric(FAVOR[longTrigger]), 147 | -as.numeric(FAVOR[shortTrigger])), 148 | decreasing = TRUE)][1:K] 149 | 150 | longTrigger <- longTrigger[longTrigger %in% keepTrigger] 151 | shortTrigger <- shortTrigger[shortTrigger %in% keepTrigger] 152 | 153 | trigger <- c(longTrigger, shortTrigger) 154 | 155 | } 156 | 157 | triggerType <- c(rep(1, length(longTrigger)), rep(-1, length(shortTrigger))) 158 | 159 | 160 | # Step 6 161 | longExitTrigger <- longS[longS %in% S[which(EXIT == 1 | EXIT == 999)]] 162 | 163 | shortExitTrigger <- shortS[shortS %in% S[which(EXIT == -1 | EXIT == 999)]] 164 | 165 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 166 | 167 | 168 | # Step 7 169 | needToExit <- max( (length(trigger) - length(exitTrigger)) - (K - k), 0) 170 | 171 | if( needToExit > 0 ){ 172 | 173 | toExitLongS <- setdiff(longS, exitTrigger) 174 | toExitShortS <- setdiff(shortS, exitTrigger) 175 | 176 | toExit <- character(0) 177 | 178 | for( counter in 1:needToExit ){ 179 | if( length(toExitLongS) > 0 & length(toExitShortS) > 0 ){ 180 | if( min(FAVOR[toExitLongS]) < min(-FAVOR[toExitShortS]) ){ 181 | pullMin <- which.min(FAVOR[toExitLongS]) 182 | toExit <- c(toExit, toExitLongS[pullMin]) 183 | toExitLongS <- toExitLongS[-pullMin] 184 | } else { 185 | pullMin <- which.min(-FAVOR[toExitShortS]) 186 | toExit <- c(toExit, toExitShortS[pullMin]) 187 | toExitShortS <- toExitShortS[-pullMin] 188 | } 189 | } else if( length(toExitLongS) > 0 & length(toExitShortS) == 0 ){ 190 | pullMin <- which.min(FAVOR[toExitLongS]) 191 | toExit <- c(toExit, toExitLongS[pullMin]) 192 | toExitLongS <- toExitLongS[-pullMin] 193 | } else if( length(toExitLongS) == 0 & length(toExitShortS) > 0 ){ 194 | pullMin <- which.min(-FAVOR[toExitShortS]) 195 | toExit <- c(toExit, toExitShortS[pullMin]) 196 | toExitShortS <- toExitShortS[-pullMin] 197 | } 198 | } 199 | 200 | longExitTrigger <- c(longExitTrigger, longS[longS %in% toExit]) 201 | shortExitTrigger <- c(shortExitTrigger, shortS[shortS %in% toExit]) 202 | 203 | } 204 | 205 | # Step 8 206 | exitTrigger <- c(longExitTrigger, shortExitTrigger) 207 | exitTriggerType <- c(rep(1, length(longExitTrigger)), 208 | rep(-1, length(shortExitTrigger))) 209 | 210 | 211 | setwd(DIR[["plan"]]) 212 | 213 | # First exit these 214 | write.csv(file = "stocksToExit.csv", 215 | data.frame(list(sym = exitTrigger, type = exitTriggerType))) 216 | 217 | # Then enter these 218 | write.csv(file = "stocksToEnter.csv", 219 | data.frame(list(sym = trigger, type = triggerType))) 220 | -------------------------------------------------------------------------------- /Platform/trade.R: -------------------------------------------------------------------------------- 1 | # First exit these 2 | toExit <- read.csv(file = "stocksToExit.csv") 3 | 4 | # Then enter these 5 | toEnter <- read.csv(file = "stocksToEnter.csv") 6 | 7 | # This is open-ended... 8 | # This may be done inside or outside R depending on choice of brokerage and AP 9 | -------------------------------------------------------------------------------- /Platform/update.R: -------------------------------------------------------------------------------- 1 | source("~/Platform/config.R") 2 | 3 | setwd(DIR[["load"]]) 4 | cat("initial.R\n\n") 5 | source("initial.R") 6 | 7 | setwd(DIR[["load"]]) 8 | cat("loadToMemory.R\n\n") 9 | source("loadToMemory.R") 10 | 11 | setwd(DIR[["load"]]) 12 | cat("updateStocks.R\n\n") 13 | source("updateStocks.R") 14 | 15 | cat("\n") 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Automated Trading with R 2 | ### Community Platform, forked by Author from Original Source 3 | 4 | This is the community version of the complete automated trading platform accompanying the text, *Automated Trading with R: Quantitative Research and Platform Development*, by Christopher Conlan. The original source code can be found under the "Source Code" tab here: [www.apress.com/9781484221778](http://www.apress.com/9781484221778). 5 | 6 | Visit [r.chrisconlan.com](http://r.chrisconlan.com) to participate in discussion and development of the platform. 7 | 8 | Happy trading! 9 | --------------------------------------------------------------------------------