Evolving Neural Networks through Augmenting Topologies – Part 4 of 4 – Trading Strategy

This post explores applying NEAT to trading the S&P. The learned strategy significantly out performs buying and holding both in and out of sample.

Features:

A key part of any machine learning problem is defining the features and ensuring that they’re normalised in some fashion.
The features will be rolling percentiles of the following economic data, a rolling percentile takes the last n data points and calculates what % of data point the latest data point is greater than.

  • Non-farm payrolls
  • Unemployment Rate
  • GDP

 

Fitness Function

The fitness function is final equity, and aims to maximise the final equity

Termination Function

Any genome that has a 20% draw down, or attempts to use a leverage greater than +/- 2 is terminated. In practise you wouldn’t want to make your system machine learn the risk controls as there is potential that they don’t get learned. The reason they are embedded inside the strategy is to speed up the learning process as we can kill genomes early before the simulation is complete based upon breaking the risk rules.

Plot of all data / features

It appears that when non-farms fall to their lower percentiles / unemployment reaches it’s highest percentiles the day to day returns in the S&P become more volatile. It is hoped that the learning can take advantage of this.

neat-trading-features

Training Results

The learning has identified a strategy that out performs simply buying and holding. The proposed strategy has a max drawdown around 20% vs the buy and hold having a draw down of 40%. Additionally the strategy shorted the index between 2000-2003 as it was selling off before going long to 2007. Generating a return of 80% vs buy and hold of 7%!

neat-trading-fitness neat-trading-trainingdata-fitness-maxequity

Out of sample results

In the out of sample data (not used during the training) the strategy significantly out performed buying and holding, approx 250% return vs 50% with a max drawdown close to 20% vs buy and hold draw down of 50%.

neat-trading-outofsample-fitness-maxequity

Onto the code:

?View Code RSPLUS
install.packages("devtools")
library("devtools")
install_github("RNeat","ahunteruk") #Install from github as not yet on CRAN
library("RNeat")
library("quantmod")
 
marketSymbol <- "^GSPC"
econmicDataSymbols <- c("UNRATE","PAYEMS","GDP")
 
mktData <- new.env() #Make a new environment for quantmod to store data in
economicData <- new.env() #Make a new environment for quantmod to store data in
 
#Specify dates for downloading data, training models and running simulation
dataDownloadStartDate <- as.Date("2000-06-01")
 
trainingStartDate = as.Date("2001-01-01") #Specify the date to start training (yyyy-mm-dd)
trainingEndDate = as.Date("2006-12-31") #Specify the date to end training
 
outOfSampleStartDate = as.Date("2007-01-01")
outOfSampleEndDate = as.Date("2016-07-15")
 
#Download Data
getSymbols(marketSymbol,env=mktData,from=dataDownloadStartDate) #S&P 500
getSymbols(econmicDataSymbols,src="FRED",env=economicData,from=dataDownloadStartDate) #Payems is non-farms payrolls 
 
nEconomicDataPercentileLookbackShort <- 20
nEconomicDataPercentileLookbackMedium <- 50
nEconomicDataPercentileLookbackLong <- 100
 
rollingPercentile <- function(data,n){
  percentile <- function(dataBlock){
    last(rank(dataBlock)/length(dataBlock))
  }
  return (as.zoo(rollapply(as.zoo(data),width=n,percentile,align="right",by.column=TRUE)))
}
 
stockCleanNameFunc <- function(name){
  return(sub("^","",name,fixed=TRUE))
}
 
clClRet <- as.zoo((lag(Cl(get(stockCleanNameFunc(marketSymbol),mktData)),-1)/Cl(get(stockCleanNameFunc(marketSymbol),mktData))-1))
 
payemsShortPercentile <- rollingPercentile(economicData$PAYEMS,nEconomicDataPercentileLookbackShort)
payemsMediumPercentile <- rollingPercentile(economicData$PAYEMS,nEconomicDataPercentileLookbackMedium)
payemsLongPercentile <- rollingPercentile(economicData$PAYEMS,nEconomicDataPercentileLookbackLong)
 
unrateShortPercentile <- rollingPercentile(economicData$UNRATE,nEconomicDataPercentileLookbackShort)
unrateMediumPercentile <- rollingPercentile(economicData$UNRATE,nEconomicDataPercentileLookbackMedium)
unrateLongPercentile <- rollingPercentile(economicData$UNRATE,nEconomicDataPercentileLookbackLong)
 
gdpShortPercentile <- rollingPercentile(economicData$GDP,nEconomicDataPercentileLookbackShort)
gdpMediumPercentile <- rollingPercentile(economicData$GDP,nEconomicDataPercentileLookbackMedium)
gdpLongPercentile <- rollingPercentile(economicData$GDP,nEconomicDataPercentileLookbackLong)
 
#join the data sets, fill in any missing dates with the previous none NA value
mergedData <- na.locf(merge(economicData$PAYEMS,merge(Cl(get(stockCleanNameFunc(marketSymbol),mktData)),
                      economicData$PAYEMS,payemsShortPercentile,payemsMediumPercentile,payemsLongPercentile,                                       economicData$UNRATE,unrateShortPercentile,unrateMediumPercentile,unrateLongPercentile,
                      economicData$GDP,gdpShortPercentile,gdpMediumPercentile,gdpLongPercentile                    
                                                                      ,all.x=T),all=T))                                         
mergedData <- mergedData[,-1]           
ClClRet <- as.zoo(lag(mergedData[,1],-1)/mergedData[,1]-1)
ClTZero <- as.zoo(mergedData[,1])
ClTOne <- as.zoo(lag(mergedData[,1],-1))
mergedData <- merge(ClClRet,ClTOne,ClTZero,mergedData)                                                           
mergedData <- window(mergedData,start=dataDownloadStartDate)
 
colnames(mergedData) <- c("ClClRet","ClTOne","ClTZero","Price","Payems","Payems.short","Payems.medium","Payems.long",
                                  "Unrate","Unrate.short","Unrate.medium","Unrate.long",
                                  "Gdp","Gdp.short","Gdp.medium","Gdp.long","all.x")   
 
 
dev.new()
par(mfrow=c(4,2))
plot(mergedData[,"Price"], main="S&P Close Price",ylab="Close Price")
plot(mergedData[,"ClClRet"], main="S&P Close Price",ylab="Close Price")
 
plot(mergedData[,"Payems"], main="Non-Farm Payrolls",ylab="Thousands of Persons")
plot(mergedData[,"Payems.short"], main="Non-Farm Payrolls Rolling Percentile",ylab="Percentile")
lines(mergedData[,"Payems.medium"], col="red")
lines(mergedData[,"Payems.long"], col="blue")
 legend(x='bottomright', c(paste(nEconomicDataPercentileLookbackShort,"Points"),
                          paste(nEconomicDataPercentileLookbackMedium,"Points"),
                          paste(nEconomicDataPercentileLookbackLong,"Points")), fill=c("black","red","blue"), bty='n')
 
plot(mergedData[,"Unrate"], main="Unemployment Rate",ylab="Percent")
plot(mergedData[,"Unrate.short"], main="Unemployment Rate Rolling Percentile",ylab="Percentile")
lines(mergedData[,"Unrate.medium"], col="red")
lines(mergedData[,"Unrate.long"], col="blue")
legend(x='bottomright', c(paste(nEconomicDataPercentileLookbackShort,"Points"),
                          paste(nEconomicDataPercentileLookbackMedium,"Points"),
                          paste(nEconomicDataPercentileLookbackLong,"Points")), fill=c("black","red","blue"), bty='n')
plot(mergedData[,"Gdp"], main="GDP",ylab="Billions of USD")
plot(mergedData[,"Gdp.short"], main="GBP Rolling Percentile",ylab="Percentile")
lines(mergedData[,"Gdp.medium"], col="red")
lines(mergedData[,"Gdp.long"], col="blue")
legend(x='bottomright', c(paste(nEconomicDataPercentileLookbackShort,"Points"),
                          paste(nEconomicDataPercentileLookbackMedium,"Points"),
                          paste(nEconomicDataPercentileLookbackLong,"Points")), fill=c("black","red","blue"), bty='n')
 
featuresTrainingData <- window(mergedData,start=trainingStartDate,end=trainingEndDate)
featuresOutOfSampleData <- window(mergedData,start=outOfSampleStartDate,end=outOfSampleEndDate)
 
 
#Genetic algo setup
simulationData <- featuresTrainingData
 
trading.InitialState <- function(){
  state <- list()
  state[1] <- 100 #Equity
  state[2] <- 0 #% of Equity allocated to share (-ve for shorts)
  state[3] <- state[1] #Maximum equity achieved
  state[4] <- 1 #Trading day number
  state[5] <- simulationData[1,"Price"]
  state[6] <- simulationData[1,"Payems.short"]
  state[7] <- simulationData[1,"Payems.medium"]
  state[8] <- simulationData[1,"Payems.long"]
  state[9] <- simulationData[1,"Unrate.short"]
  state[10] <- simulationData[1,"Unrate.medium"]
  state[11] <- simulationData[1,"Unrate.long"]
  state[12] <- simulationData[1,"Gdp.short"]
  state[13] <- simulationData[1,"Gdp.medium"]
  state[14] <- simulationData[1,"Gdp.long"]
  return(state)
}
 
trading.ConvertStateToNeuralNetInputs <- function(currentState){
  return (currentState)
}
 
trading.UpdateState <- function(currentState,neuralNetOutputs){
  #print(currentState)
  equity <- currentState[[1]]
  equityAllocation <- neuralNetOutputs[[1]]
  maxEquityAchieved <- currentState[[3]]
  tradingDay <- currentState[[4]]
 
  pctChange <- as.double((simulationData[tradingDay+1,"Price"]))/as.double((simulationData[tradingDay,"Price"]))-1
  #print(paste("pctChange",pctChange))
  #print(paste("equityAllocation",equityAllocation))
 
  pnl <- equity * equityAllocation * pctChange
 
  equity <- equity + pnl
  maxEquityAchieved <- max(maxEquityAchieved,equity)
 
  tradingDay <- tradingDay + 1
  currentState[1] <- equity
  currentState[2] <- equityAllocation
  currentState[3] <- maxEquityAchieved
  currentState[4] <- tradingDay
  currentState[5] <- simulationData[tradingDay,"Price"]
  currentState[6] <- simulationData[tradingDay,"Payems.short"]
  currentState[7] <- simulationData[tradingDay,"Payems.medium"]
  currentState[8] <- simulationData[tradingDay,"Payems.long"]
  currentState[9] <- simulationData[tradingDay,"Unrate.short"]
  currentState[10] <- simulationData[tradingDay,"Unrate.medium"]
  currentState[11] <- simulationData[tradingDay,"Unrate.long"]
  currentState[12] <- simulationData[tradingDay,"Gdp.short"]
  currentState[13] <- simulationData[tradingDay,"Gdp.medium"]
  currentState[14] <- simulationData[tradingDay,"Gdp.long"]
  return (currentState)
}
 
 
 
trading.UpdateFitness <- function(oldState,updatedState,oldFitness){
  return (as.double(updatedState[1])) #equity achieved
}
 
trading.CheckForTermination <- function(frameNum,oldState,updatedState,oldFitness,newFitness){
  equity <- updatedState[[1]]
  equityAllocation <- updatedState[[2]]
  maxEquityAchieved <- updatedState[[3]]
  tradingDay <- updatedState[[4]]
  if(tradingDay >= nrow(simulationData)){
    return(T)
  }
 
  if(abs(equityAllocation) > 2){ #Too much leverage
    return(T)
  }
 
  if(equity/maxEquityAchieved < 0.8){    #20% draw down
    return(T)
  } else {
    return (F)
  }
}
 
trading.PlotState <-function(updatedState){
  equity <- currentState[[1]]
  equityAllocation <- currentState[[2]]
  maxEquityAchieved <- currentState[[3]]
  plot(updatedState)
}
 
plotStateAndInputDataFunc <- function(stateData, inputData, titleText){
   buyandholdret <- inputData[,"Price"]/coredata(inputData[1,"Price"])
   strategyret <- stateData[,"Equity"]/100
 
   maxbuyandholdret <- cummax(buyandholdret)
 
   buyandholddrawdown <- (buyandholdret/maxbuyandholdret-1)
   strategydrawdown <- (stateData[,"Equity"]/stateData[,"MaxEquity"]-1)
 
  dev.new()
  par(mfrow=c(4,2),oma = c(0, 0, 2, 0))
  plot(stateData[,"Price"],main="Price",ylab="Price")
  plot(buyandholdret,main="Performance (Return on Initial Equity)", ylab="Return", ylim=c(min(buyandholdret,strategyret),max(buyandholdret,strategyret)))
  lines(strategyret,col="red")
  legend(x='bottomright', c('Buy & Hold','Strategy'), fill=c("black","red"),  bty='n')
  plot(inputData[,"ClClRet"],main="Stock Returns", ylab="Return")
  plot(maxbuyandholdret*100,main="Max Equity", ylim=c(min(maxbuyandholdret*100,stateData[,"MaxEquity"]),max(maxbuyandholdret*100,stateData[,"MaxEquity"])),ylab="Equity $")
  lines(stateData[,"MaxEquity"],col="red")
  legend(x='bottomright', c('Buy & Hold','Strategy'), fill=c("black","red"), bty='n')
  plot(inputData[,"Payems.short"], main="Payrolls Rolling Percentile",ylab="Percentile")
  lines(inputData[,"Payems.medium"], col="red")
  lines(inputData[,"Payems.long"], col="blue")
  legend(x='bottomright', c(paste(nEconomicDataPercentileLookbackShort,"Points"),
                          paste(nEconomicDataPercentileLookbackMedium,"Points"),
                          paste(nEconomicDataPercentileLookbackLong,"Points")), fill=c("black","red","blue"), bty='n')
 
  plot(buyandholddrawdown,main="Draw Down",ylab="Percent (%)")
  lines(strategydrawdown,col="red")
  legend(x='bottomright', c('Buy & Hold','Strategy'), fill=c("black","red"), bty='n')
  plot(stateData[,"Allocation"],main="Allocation",ylab="Allocation")
 
 
  mtext(titleText, outer = TRUE, cex = 1.5)
}
 
 
config <- newConfigNEAT(14,1,500,50)
tradingSimulation <- newNEATSimulation(config, trading.InitialState,
                                    trading.UpdateState,
                                    trading.ConvertStateToNeuralNetInputs,
                                    trading.UpdateFitness,
                                    trading.CheckForTermination,
                                    trading.PlotState)
 
tradingSimulation <- NEATSimulation.RunSingleGeneration(tradingSimulation)
 
for(i in seq(1,35)){
      save.image(file="tradingSim.RData")  #So we can recover if we crash for any reason
      tradingSimulation <- NEATSimulation.RunSingleGeneration(tradingSimulation)
}
 
dev.new()
plot(tradingSimulation)
 
stateHist <- NEATSimulation.GetStateHistoryForGenomeAndSpecies(tradingSimulation)
 
 
colnames(stateHist) <- c("Equity","Allocation","MaxEquity","TradingDay","Price",
                          "Payems.short","Payems.medium","Payems.long",
                          "Unrate.short","Unrate.medium","Unrate.long",
                          "Gdp.short","Gdp.medium","Gdp.long")
 
row.names(stateHist)<-row.names(as.data.frame(simulationData[1:nrow(stateHist),]))
stateHist <- as.zoo(stateHist)
plotStateAndInputDataFunc(stateHist,simulationData,"Training Data")
 
 
simulationData <- featuresOutOfSampleData
stateHist <- NEATSimulation.GetStateHistoryForGenomeAndSpecies(tradingSimulation)
 
colnames(stateHist) <- c("Equity","Allocation","MaxEquity","TradingDay","Price",
                          "Payems.short","Payems.medium","Payems.long",
                          "Unrate.short","Unrate.medium","Unrate.long",
                          "Gdp.short","Gdp.medium","Gdp.long")
 
row.names(stateHist)<-row.names(as.data.frame(simulationData[1:nrow(stateHist),]))
stateHist <- as.zoo(stateHist)
 
plotStateAndInputDataFunc(stateHist,simulationData,"Out of Sample Data")