[Blotter-commits] r1117 - pkg/quantstrat/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Aug 4 01:31:40 CEST 2012
Author: opentrades
Date: 2012-08-04 01:31:40 +0200 (Sat, 04 Aug 2012)
New Revision: 1117
Modified:
pkg/quantstrat/R/parameters.R
Log:
parameters.R now also deals with params outside of the argument param, in particular timespan; introduced function set.param.value()
Modified: pkg/quantstrat/R/parameters.R
===================================================================
--- pkg/quantstrat/R/parameters.R 2012-08-02 15:32:33 UTC (rev 1116)
+++ pkg/quantstrat/R/parameters.R 2012-08-03 23:31:40 UTC (rev 1117)
@@ -1,80 +1,80 @@
## add parameters to strategy objects: ALPHA CODE USE WITH CARE
#add.parameter <-
-# function (strategy,
-# type = c('indicator','signal'),
-# add.to.name,
-# method = c('lookup','lookup.range','calc'),
-# arguments = NULL,
-# label = NULL,
-# ...,
-# store=FALSE)
+# function (strategy,
+# type = c('indicator','signal'),
+# add.to.name,
+# method = c('lookup','lookup.range','calc'),
+# arguments = NULL,
+# label = NULL,
+# ...,
+# store=FALSE)
#{
-# if(!is.strategy(strategy)) stop("You must pass in a strategy object to manipulate")
-# # perhaps I should add parameters and parameter.args as arguments to the constructors...
-#
-# tmp.param<-list()
-#
-# type=type[1] #this should probably come out eventually
-#
-# method = method[1] #only use the first if the user didn't specify, or over-specified
-#
-# if(is.null(label)) {
-# label<-method
-# }
-# tmp.param$label <- label
-# tmp.param$method <- method
-# tmp.param$call <- match.call()
-# tmp.param$arguments <- arguments
-# class(tmp.param)<-'quantstrat.parameter'
-#
-# switch(type,
-# indicator = {type='indicators'},
-# signal = {type='signals'},
-# rule = {type='rules'}) #NOTE rules not supported yet, since they need a rule type too
-#
-# # need to think about how to create a 'parameters' list, and whether
-# # it should be at the strategy level or lower down, on the individual
-# # signal/indicator/rule
-#
-# if(!is.list(strategy[[type]][[add.to.name]]$parameters)){
-# strategy[[type]][[add.to.name]]$parameters <- list()
-# }
-# strategy[[type]][[add.to.name]][['parameters']][[method]] <- tmp.param
-#
-# if (store) assign(strategy$name,strategy,envir=as.environment(.strategy))
-# else return(strategy)
+# if(!is.strategy(strategy)) stop("You must pass in a strategy object to manipulate")
+# # perhaps I should add parameters and parameter.args as arguments to the constructors...
+#
+# tmp.param<-list()
+#
+# type=type[1] #this should probably come out eventually
+#
+# method = method[1] #only use the first if the user didn't specify, or over-specified
+#
+# if(is.null(label)) {
+# label<-method
+# }
+# tmp.param$label <- label
+# tmp.param$method <- method
+# tmp.param$call <- match.call()
+# tmp.param$arguments <- arguments
+# class(tmp.param)<-'quantstrat.parameter'
+#
+# switch(type,
+# indicator = {type='indicators'},
+# signal = {type='signals'},
+# rule = {type='rules'}) #NOTE rules not supported yet, since they need a rule type too
+#
+# # need to think about how to create a 'parameters' list, and whether
+# # it should be at the strategy level or lower down, on the individual
+# # signal/indicator/rule
+#
+# if(!is.list(strategy[[type]][[add.to.name]]$parameters)){
+# strategy[[type]][[add.to.name]]$parameters <- list()
+# }
+# strategy[[type]][[add.to.name]][['parameters']][[method]] <- tmp.param
+#
+# if (store) assign(strategy$name,strategy,envir=as.environment(.strategy))
+# else return(strategy)
#}
#
#
## add parameters to strategy objects: ALPHA CODE USE WITH CARE
#paramLookup <- function(strategy, symbol , type, name, parameter, ...) {
-# # should take in a strategy and parameter object, and return an argument list for 'symbol'
-# #as.pairlist(paramTable[,symbol]
-# paramTable<-get(paste(strategy,type,name,'table',pos=.strategy))
-# as.pairlist(paramTable[,symbol])
+# # should take in a strategy and parameter object, and return an argument list for 'symbol'
+# #as.pairlist(paramTable[,symbol]
+# paramTable<-get(paste(strategy,type,name,'table',pos=.strategy))
+# as.pairlist(paramTable[,symbol])
#}
#
## add parameters to strategy objects: ALPHA CODE USE WITH CARE
#add.paramLookupTable <- function(strategy, type, name, paramTable){
-# assign(paste(strategy,type,name,'table',pos=.strategy),paramTable)
+# assign(paste(strategy,type,name,'table',pos=.strategy),paramTable)
#}
#
## get parameterized arguments list out of the strategy environment
#getParams <- function (strategy, symbol, type, name)
#{
-#
-# params <- strategy[[type]][[name]]$parameters
-# param.ret<-list()
-# for (param in params) {
-# switch(param$method,
-# lookup = {param.ret<-c(param.ret,paramLookup(strategy,symbol,parameter=param))},
-# lookup.range = {},
-# calc = {},
-# {warning("parameter method",param$method,'not recognized for',type,name); next()}
-# )
-# }
-# # return an arguments list back to the 'apply*' fn
-# return(param.ret)
+#
+# params <- strategy[[type]][[name]]$parameters
+# param.ret<-list()
+# for (param in params) {
+# switch(param$method,
+# lookup = {param.ret<-c(param.ret,paramLookup(strategy,symbol,parameter=param))},
+# lookup.range = {},
+# calc = {},
+# {warning("parameter method",param$method,'not recognized for',type,name); next()}
+# )
+# }
+# # return an arguments list back to the 'apply*' fn
+# return(param.ret)
#}
@@ -122,91 +122,92 @@
#' @export
getParameterTable<-function (strategy) #,staticSwitch)
{
-
- tmp_paramTable<-list()
- nofi=0
- indexnum=0
- for (indicator in strategy$indicators ){
- # .formals <- formals(fun) #yc here get the prameters needed for that function.
- # print(.formals)
- nofi=nofi+1
- indexnum=indexnum+1
- #
- fun<-match.fun(indicator$name) #yc here get the function of the indicator
- 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
- for (signal in strategy$signals ){
-
-
- nofi=nofi+1
- indexnum=indexnum+1
-
- 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 ){
- indexnum=0
- for (trule in rule){
-
-
-
- nofi=nofi+1
- indexnum=indexnum+1
-
- fun<-match.fun(trule$name)
- 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
- paramPack$strategyName<-strategy$name
- paramPack$structure<-tmp_paramTable
-
- return(paramPack)
-
+
+ tmp_paramTable<-list()
+ nofi=0
+ indexnum=0
+ for (indicator in strategy$indicators ){
+ # .formals <- formals(fun) #yc here get the prameters needed for that function.
+ # print(.formals)
+ nofi=nofi+1
+ indexnum=indexnum+1
+ #
+ fun<-match.fun(indicator$name) #yc here get the function of the indicator
+ 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
+ for (signal in strategy$signals ){
+
+
+ nofi=nofi+1
+ indexnum=indexnum+1
+
+ 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 ){
+ indexnum=0
+ for (trule in rule){
+
+
+
+ nofi=nofi+1
+ indexnum=indexnum+1
+
+ fun<-match.fun(trule$name)
+ 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)
+ tmp_paramTable[[nofi]]$timespan<-trule$timespan
+
+ }
+
+ }
+ #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
+ paramPack$strategyName<-strategy$name
+ paramPack$structure<-tmp_paramTable
+
+ return(paramPack)
+
}
#
#
#getParameterInfo<-function(paramStructure){
-# paramInfo<-list()
-# for(paraLine in paramStructure){
-# paraInfo[[1]]<-paraLine$paramType
-# }
+# paramInfo<-list()
+# for(paraLine in paramStructure){
+# paraInfo[[1]]<-paraLine$paramType
+# }
#}
#getParameterMatrix<-function(paraStructure){
-#
+#
#}
#' Function used to create an object that contains the distribution of parameters to be generated from, before testing parameters of a strategy.
@@ -225,11 +226,11 @@
#' \dontrun{
#' #(For complete demo see parameterTestMACD.R)
#' tPD2<-setParameterDistribution(tPD2,'indicator',indexnum=1,
-#' distribution=list(nFast=(10:30)),label='nFast')
+#' distribution=list(nFast=(10:30)),label='nFast')
#' tPD2<-setParameterDistribution(tPD2,'indicator',indexnum=1,
-#' distribution=list(nSlow=(20:40)),label='nSlow')
+#' distribution=list(nSlow=(20:40)),label='nSlow')
#' tPD2<-setParameterDistribution(tPD2,'signal',indexnum=1,
-#' distribution=list(relationship=c('gt','gte')),label='sig1.gtgte')
+#' distribution=list(relationship=c('gt','gte')),label='sig1.gtgte')
#' }
#'
#' @param paramDist The object that store the parameter list, if this parameter is missing, or object does not exist, the function will return a new object.
@@ -243,38 +244,38 @@
#' @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)||!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
- tmp_paramDist$distribution<-distribution
-
- if (missing(label)) {
- tmp_paramDist$label<-paste('Param',type,indexnum,names(distribution),sep='.')
- }
- else {tmp_paramDist$label<-label}
-
-
- if(!hasArg(weight)) weight<-sample(1/length(distribution[[1]]),length(distribution[[1]]),replace=TRUE)
-
- tmp_paramDist$weight<-weight
-
- if(!hasArg(psindex) | (hasArg(psindex) & is.null(psindex))) psindex = length(paramDist)+1
- #class(tmp_paramDist)<-'parameter_distribution'
-
- #TODO put an check to see if the type/indexnum exist already.
- paramDist[[psindex]]<-tmp_paramDist
-# }
- return(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
+ tmp_paramDist$distribution<-distribution
+
+ if (missing(label)) {
+ tmp_paramDist$label<-paste('Param',type,indexnum,names(distribution),sep='.')
+ }
+ else {tmp_paramDist$label<-label}
+
+
+ if(!hasArg(weight)) weight<-sample(1/length(distribution[[1]]),length(distribution[[1]]),replace=TRUE)
+
+ tmp_paramDist$weight<-weight
+
+ if(!hasArg(psindex) | (hasArg(psindex) & is.null(psindex))) psindex = length(paramDist)+1
+ #class(tmp_paramDist)<-'parameter_distribution'
+
+ #TODO put an check to see if the type/indexnum exist already.
+ paramDist[[psindex]]<-tmp_paramDist
+# }
+ return(paramDist)
}
#' Generate parameter sets for a specific strategy, test the strategy on each set of parameters, output result package.
@@ -311,11 +312,11 @@
#' registerDoSMP(workers)
#'
#' #PUT ALL CODE RELATED TO QUANTSTRAT HERE
-#' #Example to call the function: (For complete demo see parameterTestMACD.R)
-#' x<-applyParameter(strategy=stratMACD,portfolios=portfolio.st,parameterPool=tPD2,
+#' #Example to call the function: (For complete demo see parameterTestMACD.R)
+#' x<-applyParameter(strategy=stratMACD,portfolios=portfolio.st,parameterPool=tPD2,
#' method='random',sampleSize=20,parameterConstraints=pConstraint2)
-#' #or
-#' x<-applyParameter(strategy=stratMACD,portfolios=portfolio.st,parameterPool=tPD2,
+#' #or
+#' x<-applyParameter(strategy=stratMACD,portfolios=portfolio.st,parameterPool=tPD2,
#' method='expand',parameterConstraints=pConstraint2)
#'
#' stopWorkers(workers)
@@ -335,358 +336,324 @@
#' @author Yu Chen
#' @export
applyParameter<-function(strategy,portfolios,parameterPool,parameterConstraints,method,sampleSize,verbose=FALSE,...){
- #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()
- testPackList$stats<-NULL
-
- testPackListPRLStructure<-list()
- testPackListPRLStructure$stats<-NULL
-
-
-
- if (!is.strategy(tmp_strategy)) {
- tmp_strategy<-try(getStrategy(tmp_strategy))
- if(inherits(tmp_strategy,"try-error"))
- stop ("You must supply an object of type 'strategy'.")
- }
-
-
- out<-list()
- paramdist<-list()
- paramweight<-list()
- paramLabel<-list()
- lvmatch<-list()
-
-
-
- for (i in 1:length(parameterPool)){
-
- distr<-parameterPool[[i]]
- #paramdist[[i]]<-distr$distribution[[1]]
- paramdist[[paste('Param',distr$type,distr$indexnum,names(distr$distribution),sep='.')]]<-distr$distribution[[1]]
- paramweight[[paste('ParamWt',distr$type,distr$indexnum,names(distr$distribution),sep='.')]]<-distr$weight
- #paramdist[[paste(i)]]<-distr$distribution[[1]]
-
- #Build label<->var name match.
- lvmatch$label[i]<-distr$label
- lvmatch$varName[i]<-paste('Param',distr$type,distr$indexnum,names(distr$distribution),sep='.')
-
- }
-
- paramLabel<-data.frame(lvmatch,stringsAsFactors=FALSE)
-
- #TODO make it take sample size etc.
-
-
-
- if (method=='expand')
- {
- paramTable<-expand.grid(paramdist, stringsAsFactors=FALSE)
- }
- else if (method=='random')
- {
- if (missing(sampleSize)) {stop ("sampleSize is needed")}
- #paramTable<-data.frame()
-
- #genSample update the paramTable with more sample rows.
- genSample<-function(iparamTable,paramdist,tsampleSize,remainSize)
- {
- if (missing(remainSize) ) remainSize=tsampleSize
-
- tparamTable<-data.frame()
-
- for( i in 1:length(paramdist))
- {
- ireplace<-(length(paramdist[i])<tsampleSize)
-
- if (nrow(tparamTable)==0)
- {
- tparamTable<-data.frame(sample(paramdist[[i]],remainSize,prob=paramweight[[i]],replace=ireplace),stringsAsFactors=FALSE)
-
- }
- else{
- tparamTable<-cbind(tparamTable,data.frame(sample(paramdist[[i]],remainSize,prob=paramweight[[i]],replace=ireplace),stringsAsFactors=FALSE))
- }
- }
-
- names(tparamTable)<-names(paramdist)
-
- # put constraint test on tparamTable, before rbind
- for (k in 1:length(parameterConstraints))
- {
- constrintfill<-paramConstraint(label=parameterConstraints[[k]]$constraintLabel,
- data=tparamTable,
- columns=merge(paramLabel,data.frame(parameterConstraints[[k]]$paramList),by="label")$varName, #has to keep the order.
- relationship=parameterConstraints[[k]]$relationship)
-
-
- #only keep the samples fulfill the constraints.
- tparamTable<-tparamTable[which(constrintfill==TRUE),]
- }
-
-
- iparamTable<-rbind(iparamTable,tparamTable)
-
- iparamTable<-unique(iparamTable)
-
-# if(verbose >=1) print("nnnnnnnnnnnnnnnnnnnnnnn")
-# if(verbose >=1) print(nrow(iparamTable))
-
- if (nrow(iparamTable)<tsampleSize)
- {
- iparamTable<-genSample(iparamTable,paramdist,tsampleSize,remainSize=tsampleSize-nrow(iparamTable))
- }
-
- names(iparamTable)<-names(paramdist)
- return(iparamTable)
- } #end define function
-
- paramTable<-NULL
- paramTable<-genSample(paramTable,paramdist,sampleSize)
-
- }
-
-
- testPackList$paramTable<-paramTable
- testPackList$paramdist<-paramdist
- testPackList$paramweight<-paramweight
- testPackList$paramLabel<-paramLabel
-
- strategyList<-list()
- if(verbose >=1) print("ParamTable generated")
-
-
- psize=nrow(paramTable)
- if(verbose >=1) print(psize)
-
-
-
- instruments<-as.list(FinancialInstrument:::.instrument)
- getSymbols<-as.list(.getSymbols)
- blotter<-as.list(.blotter)
-
- #Pack all symbols downloaded in .GlobalEnv
- symbols<-names(.getSymbols)
-
- testPackListPRL<-foreach (i = 1:psize, .export=c('instruments',symbols,'getSymbols','blotter','tmp_strategy'),.verbose=TRUE,...=...) %dopar%
-
- {
- if(verbose) print(paste('===> now starting parameter test', i))
+ #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()
+ testPackList$stats<-NULL
+
+ testPackListPRLStructure<-list()
+ testPackListPRLStructure$stats<-NULL
+
+
+
+ if (!is.strategy(tmp_strategy)) {
+ tmp_strategy<-try(getStrategy(tmp_strategy))
+ if(inherits(tmp_strategy,"try-error"))
+ stop ("You must supply an object of type 'strategy'.")
+ }
+
+
+ out<-list()
+ paramdist<-list()
+ paramweight<-list()
+ paramLabel<-list()
+ lvmatch<-list()
+
+
+
+ for (i in 1:length(parameterPool)){
+
+ distr<-parameterPool[[i]]
+ #paramdist[[i]]<-distr$distribution[[1]]
+ paramdist[[paste('Param',distr$type,distr$indexnum,names(distr$distribution),sep='.')]]<-distr$distribution[[1]]
+ paramweight[[paste('ParamWt',distr$type,distr$indexnum,names(distr$distribution),sep='.')]]<-distr$weight
+ #paramdist[[paste(i)]]<-distr$distribution[[1]]
+
+ #Build label<->var name match.
+ lvmatch$label[i]<-distr$label
+ lvmatch$varName[i]<-paste('Param',distr$type,distr$indexnum,names(distr$distribution),sep='.')
+
+ }
+
+ paramLabel<-data.frame(lvmatch,stringsAsFactors=FALSE)
+
+ #TODO make it take sample size etc.
+
+
+
+ if (method=='expand')
+ {
+ paramTable<-expand.grid(paramdist, stringsAsFactors=FALSE)
+ }
+ else if (method=='random')
+ {
+ if (missing(sampleSize)) {stop ("sampleSize is needed")}
+ #paramTable<-data.frame()
+
+ #genSample update the paramTable with more sample rows.
+ genSample<-function(iparamTable,paramdist,tsampleSize,remainSize)
+ {
+ if (missing(remainSize) ) remainSize=tsampleSize
+
+ tparamTable<-data.frame()
+
+ for( i in 1:length(paramdist))
+ {
+ ireplace<-(length(paramdist[i])<tsampleSize)
+
+ if (nrow(tparamTable)==0)
+ {
+ tparamTable<-data.frame(sample(paramdist[[i]],remainSize,prob=paramweight[[i]],replace=ireplace),stringsAsFactors=FALSE)
+
+ }
+ else{
+ tparamTable<-cbind(tparamTable,data.frame(sample(paramdist[[i]],remainSize,prob=paramweight[[i]],replace=ireplace),stringsAsFactors=FALSE))
+ }
+ }
+
+ names(tparamTable)<-names(paramdist)
+
+ # put constraint test on tparamTable, before rbind
+ for (k in 1:length(parameterConstraints))
+ {
+ constrintfill<-paramConstraint(label=parameterConstraints[[k]]$constraintLabel,
+ data=tparamTable,
+ columns=merge(paramLabel,data.frame(parameterConstraints[[k]]$paramList),by="label")$varName, #has to keep the order.
+ relationship=parameterConstraints[[k]]$relationship)
+
+
+ #only keep the samples fulfill the constraints.
+ tparamTable<-tparamTable[which(constrintfill==TRUE),]
+ }
+
+
+ iparamTable<-rbind(iparamTable,tparamTable)
+
+ iparamTable<-unique(iparamTable)
+
+# if(verbose >=1) print("nnnnnnnnnnnnnnnnnnnnnnn")
+# if(verbose >=1) print(nrow(iparamTable))
+
+ if (nrow(iparamTable)<tsampleSize)
+ {
+ iparamTable<-genSample(iparamTable,paramdist,tsampleSize,remainSize=tsampleSize-nrow(iparamTable))
+ }
+
+ names(iparamTable)<-names(paramdist)
+ return(iparamTable)
+ } #end define function
+
+ paramTable<-NULL
+ paramTable<-genSample(paramTable,paramdist,sampleSize)
+
+ }
+
+
+ testPackList$paramTable<-paramTable
+ testPackList$paramdist<-paramdist
+ testPackList$paramweight<-paramweight
+ testPackList$paramLabel<-paramLabel
+
+ strategyList<-list()
+ if(verbose >=1) print("ParamTable generated")
+
+
+ psize=nrow(paramTable)
+ if(verbose >=1) print(psize)
+
+
+
+ instruments<-as.list(FinancialInstrument:::.instrument)
+ getSymbols<-as.list(.getSymbols)
+ blotter<-as.list(.blotter)
+
+ #Pack all symbols downloaded in .GlobalEnv
+ symbols<-names(.getSymbols)
+
+ testPackListPRL<-foreach (i = 1:psize, .export=c('instruments',symbols,'getSymbols','blotter','tmp_strategy'),.verbose=TRUE,...=...) %dopar%
+
+ {
+ #if(verbose)
+ print(paste('===> now starting parameter test', i))
- require(quantstrat, quietly=TRUE)
-
- # loops must be run with an empty .blotter environment each, or .blotter appears to accumulate portfolios and accounts
- # and passes them from one loop to the next on each CPU - JH July 2012
- if (getDoParRegistered() && getDoParWorkers()>1)
- {
- rm(list=ls(pos=.blotter), pos=.blotter)
- gc(verbose=verbose)
- }
+ require(quantstrat, quietly=TRUE)
+
+ # loops must be run with an empty .blotter environment each, or .blotter appears to accumulate portfolios and accounts
+ # and passes them from one loop to the next on each CPU - JH July 2012
+ if (getDoParRegistered() && getDoParWorkers()>1)
+ {
+ rm(list=ls(pos=.blotter), pos=.blotter)
+ gc(verbose=verbose)
+ }
- testPack<-list()
-
- #Pass environments needed.
- loadInstruments(instruments)
- .getSymbols<-as.environment(getSymbols)
-
- #Unpack symbols to worker. change later.
- #seems need to go through assign, rather than just .export the names...
-
- for (sym in symbols) {
- assign(sym, eval(as.name(sym)), .GlobalEnv)
- }
-
- #Create a copy of strategy object, so not to lock up on the sameone.
- PLtmp_strategy<-tmp_strategy
-
- #Extract parameter from table and construct PLtmp_strategy.
- 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]
-
- tmp_index<-parameterPool[[j]]$indexnum
-
- switch(parameterPool[[j]]$type,
- 'indicator'={
- #merge.list uses another package. PLtmp_strategy$indicators[[tmp_index]]$arguments<-merge.list(targ1,tmp_arg)
- targ1<-PLtmp_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??
- PLtmp_strategy$indicators[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- PLtmp_strategy$indicators[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- #OR still need add.*??
- #pass_arg<-append(,tmp_arg)
- #PLtmp_strategy <- add.indicator(strategy = PLtmp_strategy,name=PLtmp_strategy$indicators[[tmp_index]]$name, arguments = pass_arg,indexnum=tmp_index)
- },
- 'signal'={
-
- targ1<-PLtmp_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??
-
- PLtmp_strategy$signals[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- PLtmp_strategy$signals[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
-
-# pass_arg<-append(PLtmp_strategy$signal[[tmp_index]]$arguments,tmp_arg)
-# PLtmp_strategy <- add.signal(strategy = PLtmp_strategy,name=PLtmp_strategy$signal[[tmp_index]]$name,arguments = tmp_arg,indexnum=tmp_index)
-
- },
- 'order'={
- targ1<-PLtmp_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??
- PLtmp_strategy$rules$order[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- PLtmp_strategy$rules$order[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- },
- 'enter'={
- targ1<-PLtmp_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??
- PLtmp_strategy$rules$enter[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- PLtmp_strategy$rules$enter[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- },
- 'exit'={
- targ1<-PLtmp_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??
- PLtmp_strategy$rules$exit[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
- }
- else{
- PLtmp_strategy$rules$exit[[tmp_index]]$arguments<-append(targ1,tmp_arg)
-
- }
- }
- )
- } #loop j
-
-#Initial portfolio for each test
- #######################################################################################
-
- testPack$portfolio.st<-paste(portfolios,'p',i,sep='.')
- testPack$account.st<-paste(portfolios,'p',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)
-
- if(verbose >=1) print('Initial portf')
-
-# Decide not to remove the main obj from .blotter, incase of non-parallel run.
-# try(rm(list=paste("order_book",portfolios,sep='.'),pos=.strategy),silent=TRUE)
-## try(rm(paste("account",portfolio.st,sep='.'),paste("portfolio",portfolio.st,sep='.'),pos=.blotter),silent=TRUE)
-# try(rm(list=paste("account",portfolios,sep='.'),pos=.blotter))
-# try(rm(list=paste("portfolio",portfolios,sep='.'),pos=.blotter))
-
- try({initPortf(testPack$portfolio.st,symbols=stock.str, initDate=initDate)})
- try({initAcct(testPack$account.st,testPack$portfolio.st, initDate=initDate)})
- try({initOrders(portfolio=testPack$portfolio.st,initDate=initDate)})
-
+ testPack<-list()
+
+ #Pass environments needed.
+ loadInstruments(instruments)
+ .getSymbols<-as.environment(getSymbols)
+
+ #Unpack symbols to worker. change later.
+ #seems need to go through assign, rather than just .export the names...
+
+ for (sym in symbols) {
+ assign(sym, eval(as.name(sym)), .GlobalEnv)
+ }
+
+ #Create a copy of strategy object, so not to lock up on the sameone.
+ PLtmp_strategy<-tmp_strategy
+
+ #Extract parameter from table and construct PLtmp_strategy.
+ for (j in 1:ncol(paramTable))
+ {
+ set.param.values <- function(param.list, new.values)
+ {
+ pnamepos<-pmatch(names(param.list),names(new.values),nomatch=0L)
+
+ if( any(pnamepos>0))
+ {
+ #FIXME: any matching args will be set to 1st param
+ param.list[which(pnamepos>0)]<-new.values[1]
+ }
+ else
+ {
+ param.list<-append(param.list, new.values)
+ }
+ param.list
+ }
+
+ tmp_arg<-parameterPool[[j]]$distribution[1] #Just get the list form with name
+ tmp_arg[[1]]<-paramTable[i,j]
+
+ tmp_index<-parameterPool[[j]]$indexnum
+
+ switch(parameterPool[[j]]$type,
+ 'indicator'=
+ {
+ PLtmp_strategy$indicators[[tmp_index]] = set.param.values(PLtmp_strategy$indicators[[tmp_index]], tmp_arg)
+ PLtmp_strategy$indicators[[tmp_index]]$arguments = set.param.values(PLtmp_strategy$indicators[[tmp_index]]$arguments, tmp_arg)
+ },
+ 'signal'=
+ {
+ PLtmp_strategy$signals[[tmp_index]] = set.param.values(PLtmp_strategy$signals[[tmp_index]], tmp_arg)
+ PLtmp_strategy$signals[[tmp_index]]$arguments = set.param.values(PLtmp_strategy$signals[[tmp_index]]$arguments, tmp_arg)
+ },
+ 'order'=
+ {
+ PLtmp_strategy$rules$order[[tmp_index]] = set.param.values(PLtmp_strategy$rules$order[[tmp_index]], tmp_arg)
+ PLtmp_strategy$rules$order[[tmp_index]]$arguments = set.param.values(PLtmp_strategy$rules$order[[tmp_index]]$arguments, tmp_arg)
+ },
+ 'enter'=
+ {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/blotter -r 1117
More information about the Blotter-commits
mailing list