[Blotter-commits] r1562 - in pkg/quantstrat: . R src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Nov 2 19:04:32 CET 2013
Author: bodanker
Date: 2013-11-02 19:04:32 +0100 (Sat, 02 Nov 2013)
New Revision: 1562
Added:
pkg/quantstrat/src/
pkg/quantstrat/src/firstThreshold.c
Modified:
pkg/quantstrat/NAMESPACE
pkg/quantstrat/R/rules.R
pkg/quantstrat/R/signals.R
Log:
- replace which(sigThreshold(...))[1] with C-based .firstThreshold function
- only sort dindex if necessary; xts::isOrdered provides a quick check
Modified: pkg/quantstrat/NAMESPACE
===================================================================
--- pkg/quantstrat/NAMESPACE 2013-11-01 15:51:45 UTC (rev 1561)
+++ pkg/quantstrat/NAMESPACE 2013-11-02 18:04:32 UTC (rev 1562)
@@ -52,3 +52,4 @@
export(updateOrders)
export(updateStrategy)
export(walk.forward)
+useDynLib(quantstrat)
Modified: pkg/quantstrat/R/rules.R
===================================================================
--- pkg/quantstrat/R/rules.R 2013-11-01 15:51:45 UTC (rev 1561)
+++ pkg/quantstrat/R/rules.R 2013-11-02 18:04:32 UTC (rev 1562)
@@ -269,7 +269,9 @@
#remove.Data <- function(x) remove(x, .Data)
get.dindex <- function() get("dindex",pos=.Data) # inherits=TRUE)
assign.dindex <- function(dindex) {
- dindex<-sort(unique(dindex))
+ dindex <- unique(dindex)
+ if(!isOrdered(dindex))
+ dindex <- sort(dindex)
#print(dindex)
assign("dindex", dindex, .Data)
}
@@ -409,11 +411,11 @@
}
if (is.na(col)) stop("no price discernable for stoplimit in applyRules")
}
- cross<-sigThreshold(label='tmpstop',data=mktdata,column=col,threshold=tmpprice,relationship=relationship)
- cross <- cross[timespan][-1] # don't look for crosses on curIndex
- if(any(cross)){
+ # use .firstThreshold to find the location of the first tmpprice that crosses mktdata[,col]
+ cross <- .firstThreshold(data=mktdata, col, tmpprice, relationship, start=curIndex+1) # don't look for crosses on curIndex
+ if(cross < nrow(mktdata)){
# find first index that would cross after this index
- newidx <- curIndex + which(cross)[1]
+ newidx <- cross
# insert that into dindex
assign.dindex(c(get.dindex(),newidx))
}
@@ -457,10 +459,9 @@
}
if (is.na(col)) stop("no price discernable for limit in applyRules")
}
- # use sigThreshold
- cross<-sigThreshold(label='tmplimit',data=mktdata,column=col,threshold=tmpprice,relationship=relationship)
- cross <- cross[timespan][-1] # don't look for crosses on curIndex
- if(any(cross)){
+ # use .firstThreshold to find the location of the first tmpprice that crosses mktdata[,col]
+ cross <- .firstThreshold(data=mktdata, col, tmpprice, relationship, start=curIndex+1) # don't look for crosses on curIndex
+ if(cross < nrow(mktdata)){
# find first index that would cross after this index
#
# current index = which(cross[timespan])[1]
@@ -468,7 +469,7 @@
# need to subtract 1 index==1 means current position
#
# newidx <- curIndex + which(cross[timespan])[1] #- 1 #curIndex/timestamp was 1 in the subset, we need a -1 offset?
- newidx <- curIndex + which(cross)[1]
+ newidx <- cross
#if there are is no cross curIndex will be incremented on line 496
# with curIndex<-min(dindex[dindex>curIndex]).
@@ -529,11 +530,11 @@
relationship="lte"
}
# check if order will be filled
- cross <- sigThreshold(data=mkt_price_series, label='tmptrail',column=col,threshold=tmpprice,relationship=relationship)
-
+ # use .firstThreshold to find the location of the first tmpprice that crosses mktdata[,col]
+ cross <- .firstThreshold(data=mktdata, col, tmpprice, relationship, start=curIndex+1) # don't look for crosses on curIndex
# update dindex if order is moved or filled
- if(any(move_order) || any(cross)){
- moveidx <- curIndex + min(which(move_order)[1], which(cross)[1], na.rm=TRUE)
+ if(any(move_order) || cross < nrow(mktdata)){
+ moveidx <- curIndex + min(which(move_order)[1], cross, na.rm=TRUE)
assign.dindex(c(get.dindex(), moveidx))
}
} # end loop over open trailing orders
Modified: pkg/quantstrat/R/signals.R
===================================================================
--- pkg/quantstrat/R/signals.R 2013-11-01 15:51:45 UTC (rev 1561)
+++ pkg/quantstrat/R/signals.R 2013-11-02 18:04:32 UTC (rev 1562)
@@ -272,10 +272,29 @@
'le' = {ret_sig = data[,colNum] <= threshold}
)
if(isTRUE(cross)) ret_sig <- diff(ret_sig)==1
- colnames(ret_sig)<-label
+ if(!missing(label)) # colnames<- copies; avoid if possible
+ colnames(ret_sig)<-label
return(ret_sig)
}
+#' @useDynLib quantstrat
+.firstThreshold <- function(data=mktdata, column, threshold=0, relationship, start=1) {
+ colNum <- match.names(column, colnames(data))
+ rel <- switch(relationship[1],
+ '>' = ,
+ 'gt' = 1,
+ '<' = ,
+ 'lt' = 2,
+ 'eq' = 3, #FIXME any way to specify '='?
+ 'gte' = ,
+ 'gteq' = ,
+ 'ge' = 4, #FIXME these fail with an 'unexpected =' error if you use '>='
+ 'lte' = ,
+ 'lteq' = ,
+ 'le' = 5)
+ .Call('firstThreshold', data[,colNum], threshold, rel, start)
+}
+
#' generate a signal from a formula
#'
#' This code takes advantage of some base R functionality that can treat an R object (in this case the internal mktdata object in quantstrat) as an environment or 'frame' using \code{\link{parent.frame}}.
Added: pkg/quantstrat/src/firstThreshold.c
===================================================================
--- pkg/quantstrat/src/firstThreshold.c (rev 0)
+++ pkg/quantstrat/src/firstThreshold.c 2013-11-02 18:04:32 UTC (rev 1562)
@@ -0,0 +1,55 @@
+#include <R.h>
+#include <Rinternals.h>
+
+SEXP firstThreshold(SEXP x, SEXP th, SEXP rel, SEXP start)
+{
+ int i, int_rel, int_start;
+ double *real_x=NULL, real_th;
+
+ if(ncols(x) > 1)
+ error("only univariate data allowed");
+
+ /* this currently only works for real x and th arguments
+ * support for other types may be added later */
+ real_th = asReal(th);
+ int_rel = asInteger(rel);
+ int_start = asInteger(start)-1;
+
+ switch(int_rel) {
+ case 1: /* > */
+ real_x = REAL(x);
+ for(i=int_start; i<nrows(x); i++)
+ if(real_x[i] > real_th)
+ return(ScalarInteger(i+1));
+ break;
+ case 2: /* < */
+ real_x = REAL(x);
+ for(i=int_start; i<nrows(x); i++)
+ if(real_x[i] < real_th)
+ return(ScalarInteger(i+1));
+ break;
+ case 3: /* == */
+ real_x = REAL(x);
+ for(i=int_start; i<nrows(x); i++)
+ if(real_x[i] == real_th)
+ return(ScalarInteger(i+1));
+ break;
+ case 4: /* >= */
+ real_x = REAL(x);
+ for(i=int_start; i<nrows(x); i++)
+ if(real_x[i] >= real_th)
+ return(ScalarInteger(i+1));
+ break;
+ case 5: /* <= */
+ real_x = REAL(x);
+ for(i=int_start; i<nrows(x); i++)
+ if(real_x[i] <= real_th)
+ return(ScalarInteger(i+1));
+ break;
+ default:
+ error("unsupported relationship operator");
+ }
+ /* return number of observations if relationship is never TRUE */
+ return(ScalarInteger(nrows(x)));
+}
+
More information about the Blotter-commits
mailing list