[Blotter-commits] r664 - pkg/quantstrat/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 8 03:03:26 CEST 2011
Author: cyrforge
Date: 2011-07-08 03:03:26 +0200 (Fri, 08 Jul 2011)
New Revision: 664
Modified:
pkg/quantstrat/R/parameters.R
Log:
add parameter sample uniqueness check.
add parameter constraint functionality and check.
add regenerate sample to total sample size as some samples will be filtered out.
Modified: pkg/quantstrat/R/parameters.R
===================================================================
--- pkg/quantstrat/R/parameters.R 2011-07-08 01:01:52 UTC (rev 663)
+++ pkg/quantstrat/R/parameters.R 2011-07-08 01:03:26 UTC (rev 664)
@@ -9,49 +9,49 @@
#' @param store
# @export
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)
}
@@ -63,10 +63,10 @@
#' @param parameter
#' @param ...
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
@@ -76,7 +76,7 @@
#' @param paramTable
# @export
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
@@ -86,19 +86,19 @@
#' @param name
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)
}
@@ -116,7 +116,7 @@
###############################################################################
-# TODO: Add comment
+# Functions for parameter generating and testing.
#
# Author: CCD
###############################################################################
@@ -147,11 +147,11 @@
tmp_paramTable[[nofi]]$paramEnabled<-indicator$enabled
tmp_paramTable[[nofi]]$indexnum=indexnum
}
- #browser()
+
indexnum=0
for (signal in strategy$signals ){
- #browser()
+
nofi=nofi+1
indexnum=indexnum+1
@@ -166,8 +166,8 @@
indexnum=0
for (trule in rule){
- #browser()
+
nofi=nofi+1
indexnum=indexnum+1
@@ -207,19 +207,27 @@
#' @return
#' @author Yu Chen
#' @export
-setParameterDistribution<-function(paramDist=NULL,type=NULL,indexnum=0,distribution=NULL,weight,psindex=NULL){#All is needed, set to illegal values
+setParameterDistribution<-function(paramDist=NULL,type=NULL,indexnum=0,distribution=NULL,weight,label,psindex=NULL){#All is needed, set to illegal values
if(!hasArg(paramDist)){
paramDist<-list()
}
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
@@ -245,14 +253,10 @@
#' @return
#' @author Yu Chen
#' @export
-applyParameter<-function(strategy,portfolios,parameterPool,method,sampleSize){
+applyParameter<-function(strategy,portfolios,parameterPool,parameterConstrains,method,sampleSize){
#need to create combination of distribution values in each slot of the parameterPool
tmp_strategy<-strategy
- tmp_strategy<-stratBBands
- portfolios<-'bbands'
- parameterPool<-tPD
-
testPackList<-list()
testPackList$stats<-NULL
testPack<-list()
@@ -263,10 +267,12 @@
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]]
@@ -274,10 +280,19 @@
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)
@@ -286,22 +301,73 @@
{
if (missing(sampleSize)) {stop ("sampleSize is needed")}
#paramTable<-data.frame()
- paramTable<-NULL
- for( i in 1:length(paramdist))
+
+ #genSample update the paramTable with more sample rows.
+ genSample<-function(iparamTable,paramdist,tsampleSize,remainSize)
{
- ireplace<-(length(paramdist[i])<sampleSize)
- #browser()
- paramTable<-(cbind(paramTable,sample(paramdist[[i]],sampleSize,prob=paramweight[[i]],replace=ireplace)))
- }
+ 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)
+
+ #TODO put constraint test on tparamTable, before rbind
+ for (k in 1:length(parameterConstrains))
+ {
+
+ #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),]
+ }
- paramTable<-data.frame(paramTable)
- names(paramTable)<-names(paramdist)
+
+ iparamTable<-rbind(iparamTable,tparamTable)
+
+ iparamTable<-unique(iparamTable)
+
+ print("nnnnnnnnnnnnnnnnnnnnnnn")
+ 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()
@@ -317,9 +383,9 @@
#print(tmp_arg)
tmp_index<-parameterPool[[j]]$indexnum
- #browser()
+
switch(parameterPool[[j]]$type,
'indicator'={
#merge.list uses another package. tmp_strategy$indicators[[tmp_index]]$arguments<-merge.list(targ1,tmp_arg)
@@ -328,7 +394,7 @@
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[pmatch(names(targ1),names(tmp_arg))>0]=tmp_arg[[1]]
+ tmp_strategy$signal[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
}
else{
tmp_strategy$indicators[[tmp_index]]$arguments<-append(targ1,tmp_arg)
@@ -339,15 +405,17 @@
#tmp_strategy <- add.indicator(strategy = tmp_strategy,name=tmp_strategy$indicators[[tmp_index]]$name, arguments = pass_arg,indexnum=tmp_index)
},
'signal'={
- targ1<-tmp_strategy$signal[[tmp_index]]$arguments
+ 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$signal[[tmp_index]]$arguments[pmatch(names(targ1),names(tmp_arg))>0]=tmp_arg[[1]]
+
+ tmp_strategy$signals[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
}
else{
- tmp_strategy$signal[[tmp_index]]$arguments<-append(targ1,tmp_arg)
+ tmp_strategy$signals[[tmp_index]]$arguments<-append(targ1,tmp_arg)
}
@@ -361,7 +429,7 @@
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[pmatch(names(targ1),names(tmp_arg))>0]=tmp_arg[[1]]
+ tmp_strategy$signal[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
}
else{
tmp_strategy$rules$order[[tmp_index]]$arguments<-append(targ1,tmp_arg)
@@ -374,7 +442,7 @@
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[pmatch(names(targ1),names(tmp_arg))>0]=tmp_arg[[1]]
+ tmp_strategy$signal[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
}
else{
tmp_strategy$rules$enter[[tmp_index]]$arguments<-append(targ1,tmp_arg)
@@ -387,7 +455,7 @@
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[pmatch(names(targ1),names(tmp_arg))>0]=tmp_arg[[1]]
+ tmp_strategy$signal[[tmp_index]]$arguments[which(pnamepos>0)]<-tmp_arg[1]
}
else{
tmp_strategy$rules$exit[[tmp_index]]$arguments<-append(targ1,tmp_arg)
@@ -406,7 +474,7 @@
testPack$portfolio.st=paste(portfolios,'t',i,sep='.')
testPack$account.st=paste(portfolios,'t',i,sep='.')
-# browser()
+#
rmpstr=paste('portfolio',testPack$portfolio.st,sep=".")
rmastr=paste('account',testPack$account.st,sep=".")
@@ -422,8 +490,15 @@
initOrders(portfolio=testPack$portfolio.st,initDate=initDate)
})
-# Apply strategy ######################################################################################
+# 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
@@ -460,3 +535,91 @@
return(testPackList)
}
+
+
+
+
+#' Basicly is the same as sigComparison function in signal.R wrote by Brian, with miner change.
+#'
+#' Currently, this function compares two columns.
+#' Patches to compare an arbitrary number of columns would be gladly accepted.
+#'
+#' Comparison will be applied from the first to the second column in the \code{columns} vector.
+#'
+#' Relationship 'op' means 'opposite' side. Reasonable attempt will be made to match.
+#'
+#' @param label text label to apply to the output
+#' @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
+
+ if (length(columns)==2){
+ ret_sig=NULL
+ if (relationship=='op'){
+ # (How) can this support "Close"? --jmu
+ if(columns[1] %in% c("Close","Cl","close"))
+ stop("Close not supported with relationship=='op'")
+ switch(columns[1],
+ Low =,
+ low =,
+ bid = { relationship = 'lt' },
+ Hi =,
+ High=,
+ high=,
+ ask = {relationship = 'gt'}
+ )
+ }
+
+ colNums <- match.names(columns,colnames(data))
+
+ opr <- switch( relationship,
+ gt = , '>' = '>',
+ lt =, '<' = '<',
+ eq =, "==" =, "=" = "==",
+ gte =, gteq =, ge =, ">=" = ">=",
+ lte =, lteq =, le =, "<=" = "<="
+ )
+
+ ret_sig$tname <- do.call( opr, list(data[,colNums[1]], data[,colNums[2]]))
+
+ } else {
+ stop("comparison of more than two columns not supported, see sigFormula")
+ }
+ names(ret_sig)<-label
+ return(data.frame(ret_sig))
+}
+
+
+#' construct parameter constraint object
+#' @param constrainlabel
+#' @param paramList
+#' @param relationship
+#' @returnType
+#' @return
+#' @author CCD
+#' @export
+setParameterConstraint<-function(paramConstraintObj=list(),constraintLabel,paramList,relationship)
+{
+ if(!hasArg(paramConstraintObj)){
+ paramConstraintObj<-list()
+
+ }
+ 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
+ #names(paramList)<-"label"
+ tmp_PC$paramList$label<-paramList
+ tmp_PC$relationship<-relationship
+
+ paramConstraintObj[[paste(constraintLabel)]]<-tmp_PC
+ return(paramConstraintObj)
+}
+
More information about the Blotter-commits
mailing list