[Blotter-commits] r1522 - in pkg/blotter: . R src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 9 17:54:44 CEST 2013
Author: bodanker
Date: 2013-10-09 17:54:44 +0200 (Wed, 09 Oct 2013)
New Revision: 1522
Added:
pkg/blotter/src/
pkg/blotter/src/calcPosAvgCost.c
Modified:
pkg/blotter/NAMESPACE
pkg/blotter/R/addTxn.R
pkg/blotter/R/calcPosAvgCost.R
Log:
- Vectorized addTxns and created vectorized .calcPosAvgCost_C
Modified: pkg/blotter/NAMESPACE
===================================================================
--- pkg/blotter/NAMESPACE 2013-10-08 22:01:24 UTC (rev 1521)
+++ pkg/blotter/NAMESPACE 2013-10-09 15:54:44 UTC (rev 1522)
@@ -1,3 +1,4 @@
+useDynLib(blotter)
export(PortfReturns)
export(addDiv)
export(addPortfInstr)
Modified: pkg/blotter/R/addTxn.R
===================================================================
--- pkg/blotter/R/addTxn.R 2013-10-08 22:01:24 UTC (rev 1521)
+++ pkg/blotter/R/addTxn.R 2013-10-09 15:54:44 UTC (rev 1522)
@@ -168,50 +168,36 @@
}
}
- for (row in 1:nrow(TxnData)) {
- if(row==1) {
- PrevPosQty <- getPosQty(pname, Symbol, index(TxnData[row,]))
- PrevPosAvgCost <- .getPosAvgCost(pname, Symbol, index(TxnData[row,]))
- }
- #TODO create vectorized versions of all these functions so we don't have to loop
- TxnQty <- as.numeric(TxnData[row,'TxnQty'])
- TxnPrice <- as.numeric(TxnData[row,'TxnPrice'])
- # If TxnFees are to be used, it must be a column in TxnData
- TxnFees <- if (any(grepl("TxnFees", colnames(TxnData)))) {
- as.numeric(TxnData[row, "TxnFees"])
- } else 0
- #TxnFees <- ifelse( is.function(TxnFees), TxnFees(TxnQty, TxnPrice), TxnFees)
- TxnValue <- .calcTxnValue(TxnQty, TxnPrice, TxnFees, ConMult)
- TxnAvgCost <- .calcTxnAvgCost(TxnValue, TxnQty, ConMult)
- #PrevPosQty <- getPosQty(pname, Symbol, index(TxnData[row,]))
- PosQty <- PrevPosQty+TxnQty
- PosAvgCost <- .calcPosAvgCost(PrevPosQty, PrevPosAvgCost, 0, PosQty, ConMult) # lag this over the data?
- GrossTxnRealizedPL = TxnQty * ConMult * (PrevPosAvgCost - TxnAvgCost)
- NetTxnRealizedPL = GrossTxnRealizedPL - TxnFees
- PrevPosQty <- PosQty
- PrevPosAvgCost <- PosAvgCost
-
- NewTxn = xts(t(c(TxnQty,
- TxnPrice,
- TxnValue,
- TxnAvgCost,
- PosQty,
- PosAvgCost,
- GrossTxnRealizedPL,
- TxnFees,
- NetTxnRealizedPL,
- ConMult)),
- order.by=index(TxnData[row,]))
+ # initialize new transaction object
+ NewTxns <- xts(matrix(NA_real_, nrow(TxnData), 10L), index(TxnData))
+ colnames(NewTxns) <- c('Txn.Qty', 'Txn.Price', 'Txn.Value', 'Txn.Avg.Cost', 'Pos.Qty', 'Pos.Avg.Cost', 'Gross.Txn.Realized.PL', 'Txn.Fees', 'Net.Txn.Realized.PL', 'Con.Mult')
- if(row==1){
- NewTxns <- NewTxn
- colnames(NewTxns) = c('Txn.Qty', 'Txn.Price', 'Txn.Value', 'Txn.Avg.Cost', 'Pos.Qty', 'Pos.Avg.Cost', 'Gross.Txn.Realized.PL', 'Txn.Fees', 'Net.Txn.Realized.PL', 'Con.Mult')
- } else {
- NewTxns<-rbind(NewTxns, NewTxn)
- }
+ NewTxns$Txn.Qty <- as.numeric(TxnData$TxnQty)
+ NewTxns$Txn.Price <- as.numeric(TxnData$TxnPrice)
+ if("TxnFees" %in% colnames(TxnData)) {
+ NewTxns$Txn.Fees <- as.numeric(TxnData$TxnFees)
+ } else {
+ NewTxns$Txn.Fees <- 0
}
- Portfolio$symbols[[Symbol]]$txn<-rbind(Portfolio$symbols[[Symbol]]$txn,NewTxns)
+ NewTxns$Txn.Value <- .calcTxnValue(NewTxns$Txn.Qty, NewTxns$Txn.Price, NewTxns$Txn.Fees, ConMult)
+ NewTxns$Txn.Avg.Cost <- .calcTxnAvgCost(NewTxns$Txn.Value, NewTxns$Txn.Qty, ConMult)
+ # intermediate objects to aid in vectorization; only first element is non-zero
+ initPosQty <- initPosAvgCost <- numeric(nrow(TxnData))
+ initPosQty[1] <- getPosQty(pname, Symbol, start(TxnData))
+ initPosAvgCost[1] <- .getPosAvgCost(pname, Symbol, start(TxnData))
+ # cumulative sum of transaction qty + initial position qty
+ NewTxns$Pos.Qty <- cumsum(initPosQty + NewTxns$Txn.Qty)
+ # only pass non-zero initial position qty and average cost
+ NewTxns$Pos.Avg.Cost <- .calcPosAvgCost_C(initPosQty[1], initPosAvgCost[1], NewTxns$Txn.Value, NewTxns$Pos.Qty, ConMult)
+ # need lagged position average cost
+ lagPosAvgCost <- c(initPosAvgCost[1], NewTxns$Pos.Avg.Cost[-nrow(NewTxns)])
+ NewTxns$Gross.Txn.Realized.PL <- NewTxns$Txn.Qty * ConMult * (lagPosAvgCost - NewTxns$Txn.Avg.Cost)
+ NewTxns$Net.Txn.Realized.PL <- NewTxns$Gross.Txn.Realized.PL - NewTxns$Txn.Fees
+ NewTxns$Con.Mult <- ConMult
+ # update portfolio with new transactions
+ Portfolio$symbols[[Symbol]]$txn <- rbind(Portfolio$symbols[[Symbol]]$txn, NewTxns)
+
if(verbose) print(NewTxns)
#portfolio is already an environment, it's been updated in place
Modified: pkg/blotter/R/calcPosAvgCost.R
===================================================================
--- pkg/blotter/R/calcPosAvgCost.R 2013-10-08 22:01:24 UTC (rev 1521)
+++ pkg/blotter/R/calcPosAvgCost.R 2013-10-09 15:54:44 UTC (rev 1522)
@@ -22,6 +22,9 @@
return(PosAvgCost)
}
+.calcPosAvgCost_C <- function(PrevPosQty, PrevPosAvgCost, TxnValue, PosQty, ConMult=1)
+ .Call("calcPosAvgCost", PrevPosQty, PrevPosAvgCost, TxnValue, PosQty, ConMult, PACKAGE="blotter")
+
###############################################################################
# Blotter: Tools for transaction-oriented trading systems development
# for R (see http://r-project.org/)
Added: pkg/blotter/src/calcPosAvgCost.c
===================================================================
--- pkg/blotter/src/calcPosAvgCost.c (rev 0)
+++ pkg/blotter/src/calcPosAvgCost.c 2013-10-09 15:54:44 UTC (rev 1522)
@@ -0,0 +1,56 @@
+#include <R.h>
+#include <Rinternals.h>
+
+SEXP calcPosAvgCost (SEXP PrevPosQty, SEXP PrevPosAvgCost, SEXP TxnValue, SEXP PosQty, SEXP ConMult)
+{
+ /* "vectorized" version of .calcPosAvgCost for use in addTxns
+ * Author: Joshua Ulrich
+ */
+ int i, P=0;
+ if(length(TxnValue) != length(PosQty))
+ error("TxnValue and PosQty must be the same length");
+
+ double d_PrevPosQty = asReal(PrevPosQty);
+ double d_PrevPosAvgCost = asReal(PrevPosAvgCost);
+ PROTECT(TxnValue = coerceVector(TxnValue, REALSXP)); P++;
+ double *d_TxnValue = REAL(TxnValue);
+ PROTECT(PosQty = coerceVector(PosQty, REALSXP)); P++;
+ double *d_PosQty = REAL(PosQty);
+ double d_ConMult = asReal(ConMult);
+
+ int n = length(PosQty);
+
+ SEXP PosAvgCost;
+ PROTECT(PosAvgCost = allocVector(REALSXP, n)); P++;
+ double *d_PosAvgCost = REAL(PosAvgCost);
+
+ for(i = 0; i < n; i++) {
+ if(d_PosQty[i] == 0.0) {
+ d_PosAvgCost[i] = 0.0;
+ } else
+ if(abs(d_PrevPosQty) > abs(d_PosQty[i])){
+ /* position is decreasing, pos avg cost for the open position remains the same */
+ d_PosAvgCost[i] = d_PrevPosAvgCost;
+ } else {
+ if(d_PrevPosAvgCost<0)
+ d_TxnValue[i]= -1.0 * d_TxnValue[i]; /* fix bug with negative average cost */
+ d_PosAvgCost[i] = (d_PrevPosQty * d_PrevPosAvgCost * d_ConMult + d_TxnValue[i])/(d_PosQty[i]*d_ConMult);
+ }
+ d_PrevPosQty <- d_PosQty[i];
+ d_PrevPosAvgCost <- d_PosAvgCost[i];
+ }
+ UNPROTECT(P);
+ return(PosAvgCost);
+}
+
+/*############################################################################
+# Blotter: Tools for transaction-oriented trading systems development
+# for R (see http://r-project.org/)
+# Copyright (c) 2008-2011 Peter Carl and Brian G. Peterson
+#
+# This library is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: calcPosAvgCost.c 1051 2012-06-15 15:39:44Z braverock $
+#
+#############################################################################*/
More information about the Blotter-commits
mailing list