[Blotter-commits] r688 - pkg/quantstrat/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 20 23:27:25 CEST 2011
Author: cyrforge
Date: 2011-07-20 23:27:24 +0200 (Wed, 20 Jul 2011)
New Revision: 688
Modified:
pkg/quantstrat/R/parameters.R
Log:
Add comments
Try to implement parallel execution in applyParameter , but still need to solve the error.
Modified: pkg/quantstrat/R/parameters.R
===================================================================
--- pkg/quantstrat/R/parameters.R 2011-07-20 21:26:22 UTC (rev 687)
+++ pkg/quantstrat/R/parameters.R 2011-07-20 21:27:24 UTC (rev 688)
@@ -118,17 +118,27 @@
# Functions for parameter generating and testing.
#
-# Author: CCD
+# Author: Yu Chen
###############################################################################
#retreave the needed parameters and existing values after add*
#' Extract the parameter structure from a strategy object.
+#'
+#' This function is not required for user to specify the distribution of parameters,
+#' Users can use this function to extract the parameters used in a strategy, and as a reminder/ cheatsheet
+#' when they create the parameter distribution.
+#'
+#' In the returned object:
+#' $paramNameList is the list of parameters used in the strategy, easy for print and view as a table.
+#' $strategyName is the name of the strategy itself.
+#' $structure is the detailed paramter structure, can be ignored.
+#'
#' @param strategy The name of the strategy
-#' @param staticSwitch
-#' @author CCD
+#' @author Yu Chen
#' @export
-getParameterTable<-function (strategy,staticSwitch){
+getParameterTable<-function (strategy) #,staticSwitch)
+{
tmp_paramTable<-list()
nofi=0
@@ -140,10 +150,14 @@
indexnum=indexnum+1
#
fun<-match.fun(indicator$name) #yc here get the function of the indicator
- tmp_paramTable[[nofi]]<-formals(fun)
+ tmp_paramTable[[nofi]]<-list()
+ #tmp_paramTable[[nofi]]<-formals(fun)
tmp_paramTable[[nofi]]$paramType<-'indicator'
tmp_paramTable[[nofi]]$paramEnabled<-indicator$enabled
tmp_paramTable[[nofi]]$indexnum=indexnum
+ tmp_paramTable[[nofi]]$label<-indicator$label
+ tmp_paramTable[[nofi]]$args<-formals(fun)
+
}
indexnum=0
@@ -153,11 +167,15 @@
nofi=nofi+1
indexnum=indexnum+1
- fun<-match.fun(signal$name)
- tmp_paramTable[[nofi]]<-formals(fun)
+ fun<-match.fun(signal$name)
+ tmp_paramTable[[nofi]]<-list()
+
tmp_paramTable[[nofi]]$paramType<-'signal'
tmp_paramTable[[nofi]]$paramEnabled<-signal$enabled
tmp_paramTable[[nofi]]$indexnum=indexnum
+ tmp_paramTable[[nofi]]$label<-signal$label
+ tmp_paramTable[[nofi]]$args<-formals(fun)
+
}
for (rule in strategy$rules ){
@@ -170,49 +188,65 @@
indexnum=indexnum+1
fun<-match.fun(trule$name)
- tmp_paramTable[[nofi]]<-formals(fun)
+ tmp_paramTable[[nofi]]<-list()
+
tmp_paramTable[[nofi]]$paramType<-trule$type
tmp_paramTable[[nofi]]$paramEnabled<-trule$enabled
tmp_paramTable[[nofi]]$indexnum=indexnum
+ tmp_paramTable[[nofi]]$label<-trule$label
+ tmp_paramTable[[nofi]]$args<-formals(fun)
+
}
}
+ #data.frame(c(paramStructure[[6]][1:4],param.name.=names(paramStructure[[6]]$args)))
+ paramPack<-list()
+ for (i in 1:length(tmp_paramTable)){
+
+ paramPack$paramNameList[[i]]<-data.frame(c(tmp_paramTable[[i]][1:4],param.=names(tmp_paramTable[[i]]$args)))
+
+ }
- tmp_paramTable$strategyName<-strategy$name
- return(tmp_paramTable)
+ #tmp_paramTable$strategyName<-strategy$name
+ paramPack$strategyName<-strategy$name
+ paramPack$structure<-tmp_paramTable
-}
-
-
-getParameterInfo<-function(paramStructure){
- paramInfo<-list()
- for(paraLine in paramStructure){
- paraInfo[[1]]<-paraLine$paramType
- }
-}
-getParameterMatrix<-function(paraStructure){
+ return(paramPack)
}
+#
+#
+#getParameterInfo<-function(paramStructure){
+# paramInfo<-list()
+# for(paraLine in paramStructure){
+# paraInfo[[1]]<-paraLine$paramType
+# }
+#}
+#getParameterMatrix<-function(paraStructure){
+#
+#}
+#' Function used to set distribution of a parameter in a strategy.
#'
+#'
#' @param paramDist the object name that store the parameter list
-#' @param type indicator/signal/
-#' @param indexnum
-#' @param distribution
-#' @param weight
-#' @param psindex
+#' @param type indicator/signal/enter/exit/order
+#' @param indexnum tells the sequence within the type, (if the type is signal, indexnum =2 means the 2nd signal in the strategy)
+#' @param distribution distribution of the parameter, can be any function that return a vector. (example: 1:10 or sample(1:20,6)
+#' @param weight the weight of each value in the distribution, default value will be all equally weighted.
+#' @param psindex specify the index within the parameter distribution object, it is used to make change/ repalce a parameter distribution in the object.
#' @author Yu Chen
#' @export
setParameterDistribution<-function(paramDist=NULL,type=NULL,indexnum=0,distribution=NULL,weight,label,psindex=NULL){#All is needed, set to illegal values
- if(!hasArg(paramDist)){
+ if(!hasArg(paramDist)||!exists(as.character(substitute(paramDist))) ){
paramDist<-list()
+ print('Object for parameter distribution initialized...')
}
else{
if (!is.list(distribution)|length(distribution)!=1) stop("distribution must be passed as a named list of length 1")
if (!type %in% c("indicator","signal","enter","exit","order")) stop("Type must be a string in: indicator, signal, enter, exit, order")
-
tmp_paramDist<-list()
tmp_paramDist$type<-type
tmp_paramDist$indexnum<-indexnum
@@ -239,16 +273,29 @@
-#' Generate parameter sets and apply each parameter set to an existing strategy.
+#' Test different parameter sets on a strategy.
+#'
+#' Given a parameter distribution object generated by setParameterDistribution function,
+#' generate parameter sets and test each set on specified strategy.
+#'
+#'
#' @param strategy name of the strategy to apply paramters to.
#' @param portfolios name of the portfolio to apply to.
-#' @param parameterPool a paramter set object include all the parameter legal values and distribution/weights.
-#' @param method string 'expand' or 'random' how to generate samples of parameters.
-#' @param sampleSize
+#' @param parameterPool a paramter distribution object that created by setParameterDistribution function, which includes all the parameter legal values and distribution/weights.
+#' @param parameterConstrains the object created by setParameterConstraint function that specifies the constrains between each parameters,
+#' @param method takes string 'expand' or 'random', specify how to generate samples of parameters. 'expand' will do all possible combinations of the parameter sets,
+#' @param sampleSize used when method=='random', specify how many parameter sets to generate and run test of.
#' @author Yu Chen
#' @export
+
+
applyParameter<-function(strategy,portfolios,parameterPool,parameterConstrains,method,sampleSize){
#need to create combination of distribution values in each slot of the parameterPool
+
+ initialPortf<-getPortfolio(portfolios)
+ stock.str<-names(initialPortf$symbols)
+ initDate<-time(first(initialPortf$symbols[[1]]$posPL))
+
tmp_strategy<-strategy
testPackList<-list()
@@ -267,6 +314,9 @@
paramweight<-list()
paramLabel<-list()
lvmatch<-list()
+
+
+
for (i in 1:length(parameterPool)){
distr<-parameterPool[[i]]
@@ -324,18 +374,18 @@
{
#tt<-ParamConstrain(label="pc",data=tparamTable,columns=c("Param.indicator.1.sd","Param.indicator.1.n"),relationship="gt")
-
+
constrintfill<-paramConstraint(label=parameterConstrains[[k]]$constraintLabel,
data=tparamTable,
columns=merge(paramLabel,data.frame(parameterConstrains[[k]]$paramList),by="label")$varName, #has to keep the order.
relationship=parameterConstrains[[k]]$relationship)
-
+
#only keep the samples fulfill the constraints.
tparamTable<-tparamTable[which(constrintfill==TRUE),]
}
-
+
iparamTable<-rbind(iparamTable,tparamTable)
iparamTable<-unique(iparamTable)
@@ -364,166 +414,178 @@
testPackList$paramLabel<-paramLabel
strategyList<-list()
+ print("ParamTable generated")
- for (i in 1:nrow(paramTable)){
- print(paramTable[i,])
- for (j in 1:ncol(paramTable)){
-
- tmp_arg<-parameterPool[[j]]$distribution[1] #Just get the list form with name
- #tmp_arg<-list(tmp_argName=paramTable[i,j])
- tmp_arg[[1]]<-paramTable[i,j]
-
-
- #print(tmp_arg)
-
- tmp_index<-parameterPool[[j]]$indexnum
-
-
-
- switch(parameterPool[[j]]$type,
- 'indicator'={
- #merge.list uses another package. tmp_strategy$indicators[[tmp_index]]$arguments<-merge.list(targ1,tmp_arg)
- targ1<-tmp_strategy$indicators[[tmp_index]]$arguments
-
- pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
- if( any(pnamepos>0)){
- #just change the argument value itself will do ?or still need add.indicator??
- tmp_strategy$indicators[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- tmp_strategy$indicators[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- #OR still need add.*??
- #pass_arg<-append(,tmp_arg)
- #tmp_strategy <- add.indicator(strategy = tmp_strategy,name=tmp_strategy$indicators[[tmp_index]]$name, arguments = pass_arg,indexnum=tmp_index)
- },
- 'signal'={
-
- targ1<-tmp_strategy$signals[[tmp_index]]$arguments
-
- pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
- if( any(pnamepos>0)){
- #just change the argument value itself will do ?or still need add.indicator??
-
- tmp_strategy$signals[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- tmp_strategy$signals[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
-
+
+ psize=nrow(paramTable)
+ print(psize)
+ #for (i in 1:nrow(paramTable)){
+ foreach (i = 1:psize) %do%
+ #TODO check %dopar problem updateportf
+ {
+ for (j in 1:ncol(paramTable)){
+
+ tmp_arg<-parameterPool[[j]]$distribution[1] #Just get the list form with name
+ #tmp_arg<-list(tmp_argName=paramTable[i,j])
+ tmp_arg[[1]]<-paramTable[i,j]
+
+
+ #print(tmp_arg)
+
+ tmp_index<-parameterPool[[j]]$indexnum
+
+
+
+ switch(parameterPool[[j]]$type,
+ 'indicator'={
+ #merge.list uses another package. tmp_strategy$indicators[[tmp_index]]$arguments<-merge.list(targ1,tmp_arg)
+ targ1<-tmp_strategy$indicators[[tmp_index]]$arguments
+
+ pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
+ if( any(pnamepos>0)){
+ #just change the argument value itself will do ?or still need add.indicator??
+ tmp_strategy$indicators[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
+ }
+ else{
+ tmp_strategy$indicators[[tmp_index]]$arguments<-append(targ1,tmp_arg)
+
+ }
+ #OR still need add.*??
+ #pass_arg<-append(,tmp_arg)
+ #tmp_strategy <- add.indicator(strategy = tmp_strategy,name=tmp_strategy$indicators[[tmp_index]]$name, arguments = pass_arg,indexnum=tmp_index)
+ },
+ 'signal'={
+
+ targ1<-tmp_strategy$signals[[tmp_index]]$arguments
+
+ pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
+ if( any(pnamepos>0)){
+ #just change the argument value itself will do ?or still need add.indicator??
+
+ tmp_strategy$signals[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
+ }
+ else{
+ tmp_strategy$signals[[tmp_index]]$arguments<-append(targ1,tmp_arg)
+
+ }
+
# pass_arg<-append(tmp_strategy$signal[[tmp_index]]$arguments,tmp_arg)
# tmp_strategy <- add.signal(strategy = tmp_strategy,name=tmp_strategy$signal[[tmp_index]]$name,arguments = tmp_arg,indexnum=tmp_index)
-
- },
- 'order'={
- targ1<-tmp_strategy$rules$order[[tmp_index]]$arguments
-
- pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
- if( any(pnamepos>0)){
- #just change the argument value itself will do ?or still need add.indicator??
- tmp_strategy$rules$order[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- tmp_strategy$rules$order[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- },
- 'enter'={
- targ1<-tmp_strategy$rules$enter[[tmp_index]]$arguments
-
- pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
- if( any(pnamepos>0)){
- #just change the argument value itself will do ?or still need add.indicator??
- tmp_strategy$rules$enter[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- tmp_strategy$rules$enter[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- },
- 'exit'={
- targ1<-tmp_strategy$rules$exit[[tmp_index]]$arguments
-
- pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
- if( any(pnamepos>0)){
- #just change the argument value itself will do ?or still need add.indicator??
- tmp_strategy$rules$exit[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- tmp_strategy$rules$exit[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- }
- )
- } #loop j
-
+
+ },
+ 'order'={
+ targ1<-tmp_strategy$rules$order[[tmp_index]]$arguments
+
+ pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
+ if( any(pnamepos>0)){
+ #just change the argument value itself will do ?or still need add.indicator??
+ tmp_strategy$rules$order[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
+ }
+ else{
+ tmp_strategy$rules$order[[tmp_index]]$arguments<-append(targ1,tmp_arg)
+
+ }
+ },
+ 'enter'={
+ targ1<-tmp_strategy$rules$enter[[tmp_index]]$arguments
+
+ pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
+ if( any(pnamepos>0)){
+ #just change the argument value itself will do ?or still need add.indicator??
+ tmp_strategy$rules$enter[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
+ }
+ else{
+ tmp_strategy$rules$enter[[tmp_index]]$arguments<-append(targ1,tmp_arg)
+
+ }
+ },
+ 'exit'={
+ targ1<-tmp_strategy$rules$exit[[tmp_index]]$arguments
+
+ pnamepos<-pmatch(names(targ1),names(tmp_arg),nomatch=0L)
+ if( any(pnamepos>0)){
+ #just change the argument value itself will do ?or still need add.indicator??
+ tmp_strategy$rules$exit[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
+ }
+ else{
+ tmp_strategy$rules$exit[[tmp_index]]$arguments<-append(targ1,tmp_arg)
+
+ }
+ }
+ )
+ } #loop j
+
#Initial portfolio for each test
- #######################################################################################
-
+ #######################################################################################
+
+ library(blotter)
+
#TODO will move out later, as parameter or put in a obj of TestPack.
- initDate='2010-12-31'
- initEq=1000000
-
- testPack$portfolio.st=paste(portfolios,'t',i,sep='.')
- testPack$account.st=paste(portfolios,'t',i,sep='.')
+ #initDate='2010-12-31'
+ #initEq=1000000
+
+
+ testPack$portfolio.st=paste(portfolios,'t',i,sep='.')
+ testPack$account.st=paste(portfolios,'t',i,sep='.')
#
-
- rmpstr=paste('portfolio',testPack$portfolio.st,sep=".")
- rmastr=paste('account',testPack$account.st,sep=".")
-
- try(rm(list = rmpstr, pos = .blotter),silent=FALSE)
- try(rm(list = rmastr, pos = .blotter),silent=FALSE)
- try(rm(list=paste("order_book",testPack$account.st,sep="."),pos=.strategy),silent=FALSE)
-
-
- try({
- initPortf(testPack$portfolio.st,symbols=stock.str, initDate=initDate)
- initAcct(testPack$account.st,testPack$portfolio.st, initDate=initDate)
- initOrders(portfolio=testPack$portfolio.st,initDate=initDate)
- })
-
+
+ rmpstr=paste('portfolio',testPack$portfolio.st,sep=".")
+ rmastr=paste('account',testPack$account.st,sep=".")
+
+ try(rm(list = rmpstr, pos = .blotter),silent=FALSE)
+ try(rm(list = rmastr, pos = .blotter),silent=FALSE)
+ try(rm(list=paste("order_book",testPack$account.st,sep="."),pos=.strategy),silent=FALSE)
+
+ print('Initial portf')
+
+ initPortf(testPack$portfolio.st,symbols=stock.str, initDate=initDate)
+
+ try({
+ initAcct(testPack$account.st,testPack$portfolio.st, initDate=initDate)
+ initOrders(portfolio=testPack$portfolio.st,initDate=initDate)
+ })
+
# Apply strategy ######################################################################################
- print("Apply strategy...")
-
- try(rm("tmp_strategy",pos=.strategy),silent=TRUE)
-
- print(tmp_strategy$signals[[2]])
-
- assign("tmp_strategy1",tmp_strategy,envir=as.environment(.strategy))
-
- testPack$out<-try(applyStrategy(strategy=tmp_strategy , portfolios=testPack$portfolio.st ))
- testPack$strategy<-tmp_strategy
-
+ print("Apply strategy...")
+
+ try(rm("tmp_strategy",pos=.strategy),silent=TRUE)
+
+ print(tmp_strategy$signals[[2]])
+
+ assign("tmp_strategy1",tmp_strategy,envir=as.environment(.strategy))
+
+ testPack$out<-try(applyStrategy(strategy=tmp_strategy , portfolios=testPack$portfolio.st ))
+ testPack$strategy<-tmp_strategy
+
# Update portfolio ######################################################################################
-
-#out<-try(applyStrategy(strategy=stratBBands , portfolios=portfolios ))
-# try({
-# updatePortf(testPack$portfolio.st,Date=initDate)
-# updateAcct(testPack$account.st,Date=initDate)
-# updateOrders(portfolio=testPack$portfolio.st)
-# })
-
-
- updatePortf(Portfolio=testPack$portfolio.st,Dates=paste('::',as.Date(Sys.time()),sep=''))
-#? what to do with account?
-#updateAcct(account.st,Dates=paste(startDate,endDate,sep="::"))
-#updateEndEq(account.st,Dates=paste(startDate,endDate,sep="::"))
-#getEndEq(account.st,Sys.time())
-
- testPack$parameters<-paramTable[i,]
-
- testPack$stats<-tradeStats(Portfolios=testPack$portfolio.st)
-
- testPackList$stats<-rbind(testPackList$stats,cbind(testPack$parameters,testPack$stats))
-
-
+
+ #out<-try(applyStrategy(strategy=stratBBands , portfolios=portfolios ))
+ # try({
+ # updatePortf(testPack$portfolio.st,Date=initDate)
+ # updateAcct(testPack$account.st,Date=initDate)
+ # updateOrders(portfolio=testPack$portfolio.st)
+ # })
+
+
+ updatePortf(Portfolio=testPack$portfolio.st,Dates=paste('::',as.Date(Sys.time()),sep=''))
+
+
+ #? what to do with account?
+ #updateAcct(account.st,Dates=paste(startDate,endDate,sep="::"))
+ #updateEndEq(account.st,Dates=paste(startDate,endDate,sep="::"))
+ #getEndEq(account.st,Sys.time())
+
+ testPack$parameters<-paramTable[i,]
+
+ testPack$stats<-tradeStats(Portfolios=testPack$portfolio.st)
+
+ testPackList$stats<-rbind(testPackList$stats,cbind(testPack$parameters,testPack$stats))
+
+
# replaced -- testPackList[[i]]<-testPack
- testPackList[[paste(testPack$portfolio.st)]]<-testPack
-
-
- } # Loop i
+ testPackList[[paste(testPack$portfolio.st)]]<-testPack
+
+ } # Loop i
return(testPackList)
@@ -546,7 +608,7 @@
#' @param data data to apply comparison to
#' @param columns named columns to apply comparison to
#' @param relationship one of c("gt","lt","eq","gte","lte","op") or reasonable alternatives
-#' @export
+
paramConstraint <- function(label,data=mktdata, columns, relationship=c("gt","lt","eq","gte","lte")) {
relationship=relationship[1] #only use the first one
@@ -587,23 +649,24 @@
}
-#' construct parameter constraint object
-#' @param constrainlabel
-#' @param paramList
-#' @param relationship
-#' @author CCD
+#' Function to construct parameter constraint object.
+#'
+#' @param constrainlabel give a label to the constraint.
+#' @param paramList the two name of the prameters as a list contains two strings.
+#' @param relationship relationship between the 1st parameter and 2nd one. ('gt' means 1st parameter > 2nd parameter)
+#' @author Yu Chen
#' @export
setParameterConstraint<-function(paramConstraintObj=list(),constraintLabel,paramList,relationship)
{
- if(!hasArg(paramConstraintObj)){
+ if(!hasArg(paramConstraintObj)||!exists(as.character(substitute(paramConstraintObj)))){
paramConstraintObj<-list()
-
+ print('Parameter constraint object initialized...')
}
else{
if (!is.list(paramConstraintObj)|length(paramConstraintObj)!=1) stop("Parameter constrain object must be passed as a named list of length 1")
+
+ }
- }
-
if (missing(constraintLabel)) {constraintLabel<-paste("parameterConstraint",length(paramConstraintObj)+1)}
tmp_PC<-list()
tmp_PC$constraintLabel<-constraintLabel
More information about the Blotter-commits
mailing list