###############################################################################
# R (http://r-project.org/) Quantitative Strategy Model Framework
#
# Copyright (c) 2009-2012
# Peter Carl, Dirk Eddelbuettel, Brian G. Peterson, Jeffrey Ryan, and Joshua Ulrich
#
# This library is distributed under the terms of the GNU Public License (GPL)
# for full details see the file COPYING
#
# $Id$
#
###############################################################################
#
# Authors: Jan Humme, Brian Peterson
#
# This code is a based on earlier work by Yu Chen
#
###############################################################################
#
# This code uses the following terminology:
#
# component.type: indicator, signal or order/enter/exit/chain-type rule, identified by a component.label
#
# constraint: a restriction applying to 2 distributions
#
# distribution: a range of values to be applied to a particular strategy parameter, identified by the tuple
# (component.type, component.label, variable.name)
#
# parameter: a variable argument in a strategy component
#
# paramset: a set of parameter distributions and constraints, identified by a paramset.label
#
# param.combo: an expanded distribution
#
# param.values: the set of values to be applied to a parameter
#
###############################################################################
# TODO: fix put.portfolio() to use environments
# TODO: fix expand.grid
# TODO: "and" multiple constraints i.o. "or"
#require(foreach, quietly=TRUE)
require('foreach')
#require(iterators, quietly=TRUE)
require('iterators')
# creates a copy of a portfolio, stripping all history (transactions etc)
clone.portfolio <- function(portfolio.st, cloned.portfolio.st, strip.history=TRUE)
{
#must.have.args(match.call(), c('portfolio.st', 'cloned.portfolio.st'))
portfolio <- .getPortfolio(portfolio.st)
if(strip.history==TRUE)
{
for(symbol in ls(portfolio$symbols))
{
portfolio$symbols[[symbol]]$txn <- portfolio$symbols[[symbol]]$txn[1,]
xts.tables <- grep('(^posPL|txn)',names(portfolio$symbols[[symbol]]))
for(xts.table in xts.tables)
portfolio$symbols[[symbol]][[xts.table]] <- portfolio$symbols[[symbol]][[xts.table]][1,]
}
portfolio$summary <- portfolio$summary[1,]
}
put.portfolio(as.character(cloned.portfolio.st), portfolio)
return(cloned.portfolio.st)
}
# creates a copy of an orderbook, stripping all orders
clone.orderbook <- function(portfolio.st, cloned.portfolio.st, strip.history=TRUE)
{
#must.have.args(match.call(), c('portfolio.st', 'cloned.portfolio.st'))
orderbook <- getOrderBook(portfolio.st)
i <- 1 # TODO: find index number by name
names(orderbook)[i] <- cloned.portfolio.st
if(strip.history == TRUE)
{
for(symbol in names(orderbook[[portfolio.st]]))
orderbook[[portfolio.st]][[symbol]] <- orderbook[[portfolio.st]][[symbol]][1,]
}
put.orderbook(cloned.portfolio.st, orderbook)
}
### local functions ############################################################
must.be.paramset <- function(strategy, paramset)
{
if(!(paramset %in% names(strategy$paramsets)))
stop(paste(paramset, ': no such paramset in strategy', strategy$name))
}
create.paramset <- function(strategy, paramset.label)
{
strategy$paramsets[[paramset.label]] <- list()
strategy$paramsets[[paramset.label]]$distributions <- list()
strategy$paramsets[[paramset.label]]$constraints <- list()
strategy
}
expand.distributions <- function(distributions)
{
param.values <- list()
for(distribution.name in names(distributions))
{
variable.name <- names(distributions[[distribution.name]]$variable)
param.values[[distribution.name]] <-
distributions[[distribution.name]]$variable[[variable.name]]
}
expand.grid(param.values)
}
apply.constraints <- function(constraints, distributions, param.combos)
{
for(constraint in constraints)
{
operator <- constraint$operator
distribution.name.1 <- constraint$distributions[[1]]
distribution.name.2 <- constraint$distributions[[2]]
variable.name.1 <- names(distributions[[distribution.name.1]]$variable)
variable.name.2 <- names(distributions[[distribution.name.2]]$variable)
result <- do.call(operator, list(param.combos[,distribution.name.1], param.combos[,distribution.name.2]))
param.combos <- param.combos[which(result),]
}
param.combos
}
select.samples <- function(nsamples, param.combos)
{
nsamples <- min(nsamples, nrow(param.combos))
param.combos <- param.combos[sample(nrow(param.combos), size=nsamples),]
if(NCOL(param.combos) == 1)
param.combos <- param.combos[order(param.combos)]
else
param.combos <- param.combos[with(param.combos,order(param.combos[,1],param.combos[,2])),]
data.frame(param.combos)
}
install.param.combo <- function(strategy, param.combo, paramset.label)
{
for(param.label in names(param.combo))
{
distribution <- strategy$paramsets[[paramset.label]]$distributions[[param.label]]
component.type <- distribution$component.type
component.label <- distribution$component.label
variable.name <- names(distribution$variable)
found <- FALSE
switch(component.type,
indicator =,
signal =
{
# indicator and signal slots in strategy list use plural name for some reason:
components.type <- paste(component.type,'s',sep='')
n <- length(strategy[[components.type]])
for(index in 1:n)
{
if(strategy[[components.type]][[index]]$label == component.label)
{
strategy[[components.type]][[index]]$arguments[[variable.name]] <- param.combo[[param.label]]
found <- TRUE
break
}
}
},
order =,
enter =,
exit =,
chain =
{
n <- length(strategy$rules[[component.type]])
for(index in 1:n)
{
if(strategy$rules[[component.type]][[index]]$label == component.label)
{
if(variable.name %in% c('timespan'))
strategy$rules[[component.type]][[index]][[variable.name]] <- as.character(param.combo[[param.label]])
else
strategy$rules[[component.type]][[index]]$arguments[[variable.name]] <- param.combo[[param.label]]
found <- TRUE
break
}
}
}
)
if(!found) stop(paste(component.label, ': no such ', component.type, ' rule in strategy ', strategy$name, sep=''))
}
return(strategy)
}
### exported functions ############################################################
#' Delete a paramset from a strategy
#'
#' Delete a paramset from a strategy, including its distributions and constraints.
#'
#' @param strategy the name of the strategy object
#' @param paramset.label a label uniquely identifying the paramset within the strategy
#' @param store indicates whether to store the strategy in the .strategy environment
#'
#' @author Jan Humme
#' @export
#' @seealso \code{\link{add.distibution}}, \code{\link{add.distribution.constraint}}, \code{\link{apply.paramset}}
delete.paramset <- function(strategy, paramset.label, store=TRUE)
{
must.have.args(match.call(), c('strategy', 'paramset.label'))
if(!is.strategy(strategy))
{
strategy <- must.be.strategy(strategy)
store <- TRUE
}
if(!is.null(strategy$paramsets[[paramset.label]]))
strategy$paramsets[[paramset.label]] <- NULL
if(store)
{
put.strategy(strategy)
return(strategy$name)
}
return(strategy)
}
#' Adds a distribution to a paramset in a strategy
#'
#' Creates a distribution in paramset, where a distribution consists of the name of a variable in
#' a strategy component plus a range of values for this variable.
#'
#' @param strategy the name of the strategy object to add the distribution to
#' @param paramset.label a label uniquely identifying the paramset within the strategy
#' @param component.type one of c('indicator', 'signal', 'order', 'enter', 'exit', 'chain')
#' @param component.label a label identifying the component. must be unique per component type
#' @param variable the name of the variable in the component
#' @param label a label uniquely identifying the distribution within the paramset
#' @param weight vector
#' @param store indicates whether to store the strategy in the .strategy environment
#'
#' @author Jan Humme
#' @export
#' @seealso \code{\link{add.distribution.constraint}}, \code{\link{delete.paramset}}, \code{\link{apply.paramset}}
add.distribution <- function(strategy, paramset.label, component.type, component.label, variable, weight=NULL, label, store=TRUE)
{
must.have.args(match.call(), c('strategy', 'paramset.label', 'component.type', 'component.label', 'variable', 'label'))
if(!is.strategy(strategy))
{
strategy <- must.be.strategy(strategy)
store <- TRUE
}
new_distribution <- list()
new_distribution$component.type <- component.type
new_distribution$component.label <- component.label
new_distribution$variable <- variable
new_distribution$weight <- weight
if(!(paramset.label %in% names(strategy$paramsets)))
strategy <- create.paramset(strategy, paramset.label)
strategy$paramsets[[paramset.label]]$distributions[[label]] <- new_distribution
if(store)
{
put.strategy(strategy)
return(strategy$name)
}
return(strategy)
}
#' Adds a constraint on 2 distributions within a paramset
#'
#' Creates a constraint on 2 distributions in a paramset, i.e. a restriction limiting the allowed
#' combinations from the ranges for distribution 1 and distribution 2.
#'
#' @param strategy the name of the strategy object to add the constraint to
#' @param paramset.label a label uniquely identifying the paramset within the strategy
#' @param distribution.label.1 a label identifying the first distribution
#' @param distribution.label.2 a label identifying the second distribution
#' @param operator an operator specifying the relational constraint between the 2 distributions
#' @param label a label uniquely identifying the constraint within the paramset
#' @param store indicates whether to store the strategy in the .strategy environment
#'
#' @author Jan Humme
#' @export
#' @seealso \code{\link{add.distribution}}, \code{\link{delete.paramset}}, \code{\link{apply.paramset}}
add.distribution.constraint <- function(strategy, paramset.label, distribution.label.1, distribution.label.2, operator, label, store=TRUE)
{
must.have.args(match.call(), c('strategy', 'paramset.label', 'distribution.label.1', 'distribution.label.2', 'operator', 'label'))
if(!is.strategy(strategy))
{
strategy <- must.be.strategy(strategy)
store <- TRUE
}
new_constraint <- list()
new_constraint$distributions <- list(distribution.label.1, distribution.label.2)
new_constraint$operator <- operator
if(!(paramset.label %in% names(strategy$paramsets)))
strategy <- create.paramset(strategy, paramset.label)
strategy$paramsets[[paramset.label]]$constraints[[label]] <- new_constraint
if(store)
{
put.strategy(strategy)
return(strategy$name)
}
return(strategy)
}
#' Apply a paramset to the strategy
#'
#' This function will run applyStrategy() on portfolio.st, once for each parameter combination as specified by
#' the parameter distributions and constraints in the paramset. Results are gathered and returned as a list
#' containing a slot for each parameter combination.
#'
#' apply.paramset uses the foreach package to start the runs for each parameter combination, and as such allows
#' for parallel processing. It is up to the caller to load and register an appropriate backend, eg. doMC,
#' doParallel or doRedis.
#'
#' @param strategy.st the name of the strategy object
#' @param paramset.label a label uniquely identifying the paramset within the strategy
#' @param portfolio.st the name of the portfolio
#' @param account.st the name of the account
#' @param mktdata optional xts mktdata object, will be passed unchanged to applyStrategy
#' @param nsamples if > 0 then take a sample of only size nsamples from the paramset
#' @param user.func an optional user-supplied function to be run for each param.combo at the end, either on the slave or on the master (see calc)
#' @param user.args user-supplied list of arguments for user.func
#' @param calc 'slave' to run updatePortfolio() and tradesStats() on the slave and return all portfolios and orderbooks as a list: higher parallelization but more data transfer between master and slave; 'master' to have updatePortf() and tradeStats() run at the master and return all portfolios and orderbooks in the .blotter and .strategy environments resp: less parallelization but also less data transfer between slave and master; default is 'slave'
#' @param packages a vector specifying names of R packages to be loaded by the slave, default NULL
#' @param audit a user-specified environment to store a copy of all portfolios, orderbooks and other data from the tests, or NULL to trash this information
#' @param verbose return full information, in particular the .blotter environment, default FALSE
#' @param paramsets a user-sepcified (sub)set of paramsets to run
#' @param ... any other passthru parameters
#'
#' @author Jan Humme
#' @export
#' @seealso \code{\link{add.distribution.constraint}}, \code{\link{add.distribution.constraint}}, \code{\link{delete.paramset}}
apply.paramset <- function(strategy.st, paramset.label, portfolio.st, account.st, mktdata=NULL, nsamples=0, user.func=NULL, user.args=NULL, calc='slave', audit=NULL, packages=NULL, verbose=FALSE, paramsets, ...)
{
must.have.args(match.call(), c('strategy.st', 'paramset.label', 'portfolio.st'))
strategy <- must.be.strategy(strategy.st)
must.be.paramset(strategy, paramset.label)
if(!is.null(audit)) must.be.environment(audit)
portfolio <- .getPortfolio(portfolio.st)
account <- getAccount(account.st)
orderbook <- getOrderBook(portfolio.st)
distributions <- strategy$paramsets[[paramset.label]]$distributions
constraints <- strategy$paramsets[[paramset.label]]$constraints
if(missing(paramsets))
{
param.combos <- expand.distributions(distributions)
param.combos <- apply.constraints(constraints, distributions, param.combos)
rownames(param.combos) <- NULL # reset rownames
if(nsamples > 0)
param.combos <- select.samples(nsamples, param.combos)
} else {
param.combos <- paramsets
}
env.functions <- c('clone.portfolio', 'clone.orderbook', 'install.param.combo')
env.instrument <- as.list(FinancialInstrument:::.instrument)
if(is.null(audit))
.audit <- new.env()
else
.audit <- audit
combine <- function(...)
{
args <- list(...)
results <- list()
for(i in 1:length(args))
{
r <- args[[i]]
# move portfolio from slave returned list into .blotter environment
put.portfolio(r$portfolio.st, r$portfolio, envir=.audit)
r$portfolio <- NULL
# move orderbook from slave returned list into .strategy environment
put.orderbook(r$portfolio.st, r$orderbook, envir=.audit)
r$orderbook <- NULL
if(calc == 'master')
{
# calculate tradeStats on portfolio
updatePortf(r$portfolio.st, ...)
r$tradeStats <- tradeStats(r$portfolio.st)
# run user specified function, if they provided one
if(!is.null(user.func) && !is.null(user.args))
r$user.func <- do.call(user.func, user.args)
}
results[[r$portfolio.st]] <- r
# add copy of tradeStats to summary list for convenience
if(!is.null(r$tradeStats))
results$tradeStats <- rbind(results$tradeStats, cbind(r$param.combo, r$tradeStats))
# add copy of user.func results to summary list for convenience
if(!is.null(r$user.func))
results$user.func <- rbind(results$user.func, cbind(r$param.combo, r$user.func))
}
return(results)
}
# create foreach object
fe <- foreach(param.combo=iter(param.combos,by='row'),
.verbose=verbose, .errorhandling='pass',
.packages=c('quantstrat', packages),
.combine=combine, .multicombine=TRUE, .maxcombine=max(2,nrow(param.combos)),
.export=c(env.functions, 'env.instrument'), ...)
# remove all but the param.combo iterator before calling %dopar%
# this allows us to pass '...' through foreach to the expression
fe$args <- fe$args[1]
fe$argnames <- fe$argnames[1]
# now call %dopar%
results <- fe %dopar%
{
print(param.combo)
# doSEQ and doMC make all environments available to the slave, but
# doRedis only provides the .GlobalEnv, so we erase both .blotter
# and .strategy environments to make sure that envs are clean
# regardless of backend
#
# also, environments persist in each slave, so data may be accumulating
# for each transition through the foreach loop
#
if(!getDoSeqRegistered())
{
rm(list=ls(pos=.blotter), pos=.blotter)
rm(list=ls(pos=.strategy), pos=.strategy)
}
list2env(env.instrument, envir=FinancialInstrument:::.instrument)
put.portfolio(portfolio.st, portfolio)
put.account(account.st, account)
put.orderbook(portfolio.st, orderbook)
put.strategy(strategy)
result <- list()
result$param.combo <- param.combo
result$portfolio.st <- paste(portfolio.st, rownames(param.combo), sep='.')
clone.portfolio(portfolio.st, result$portfolio.st)
clone.orderbook(portfolio.st, result$portfolio.st)
if(exists('redisGetContext'))
{
# assume we are using a doRedis parallel backend
# store the context, and close the connection
# patch to prevent timeout on large data sets
#
# thanks to Kent Hoxsey for this workaround
redisContext <- redisGetContext()
redisClose()
}
strategy <- install.param.combo(strategy, param.combo, paramset.label)
applyStrategy(strategy, portfolios=result$portfolio.st, mktdata=mktdata, ...)
if(exists('redisContext'))
{
# assume redisContext contains preserved context
# restore doRedis connection
#
# thanks to Kent Hoxsey for this workaround
redisConnect(host=redisContext$host)
}
if(calc == 'slave')
{
updatePortf(result$portfolio.st, ...)
result$tradeStats <- tradeStats(result$portfolio.st)
if(!is.null(user.func) && !is.null(user.args))
result$user.func <- do.call(user.func, user.args)
}
result$portfolio <- getPortfolio(result$portfolio.st)
result$orderbook <- getOrderBook(result$portfolio.st)
return(result)
}
#results$distributions <- distributions
#results$constraints <- constraints
if(is.null(audit))
.audit <- NULL
else
{
assign('distributions', distributions, envir=.audit)
assign('constraints', constraints, envir=.audit)
assign('paramset.label', paramset.label, envir=.audit)
assign('param.combos', param.combos, envir=.audit)
assign('tradeStats', results$tradeStats, envir=.audit)
assign('user.func', results$user.func, envir=.audit)
}
return(results)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.