my: R tools for quant research

#' transform format of trades log
#' 
#' show the trade log in the format of trade cycle/round in order to check PnL per cycle/round
#' @param vol
#' @param trdLog data fame. returned from signalExecute
#' @param contractDetail
#' @return matrix
#' @export
trdSummaryByVol <- function(vol, trdLog, contractDetail)
{
    if(!is.matrix(trdLog)) trdLog <- as.matrix(trdLog)
    if(contractDetail$feeFixed)
    {
        trdLog[,'trdPrice'] <- trdLog[,'trdPrice']+contractDetail$fee*trdLog[,'trdType']
    } else
    {
        trdLog[,'trdPrice'] <- trdLog[,'trdPrice']*(1+contractDetail$fee*trdLog[,'trdType'])
    }
    
    n <- nrow(trdLog)
    trdLogInx <- array(0, dim=c(n, 2), dimnames = list(NULL, c('trdType','trdOC')))
    trdLogVol <- array(0, dim=c(n, vol, 3), dimnames=list(NULL, 1:vol, c('vol','pos','price'))) #(vol, pos, price)
    
    round <- 1
    i <- 1
    trdLogInx[round, ] = trdLog[i, c('trdType', 'trdOC')]
    trdLogVol[round, 1:trdLog[1, 'trdVol'], 1] <- 1
    trdLogVol[round, 1:trdLog[1, 'trdVol'], 2] <- trdLog[i, 'trdType']
    trdLogVol[round, 1:trdLog[1, 'trdVol'], 3] <- trdLog[i, 'trdPrice']
    
    for(i in 2:n)
    {
        if(diff(trdLog[i-1:0,'trdType'])!=0 || diff(trdLog[i-1:0, 'trdOC']!=0)) 
        {
            round <- round+1
#             vol2trd <- abs(trdLog[i, 'trdType']*trdLog[i,'trdOC']-trdLogVol[round-1, , 2])
#             nfill <- which(cumsum(vol2trd)<=trdLog[i,'trdVol'])
            
            vol2trd <- trdLog[i, 'trdType']*trdLog[i,'trdOC']-trdLogVol[round-1, , 2]
            nfill <- which((cumsum(vol2trd)-trdLog[i,'trdVol']*trdLog[i,'trdType'])*trdLog[i,'trdType']<=0)
            if(length(nfill))
            {
                nfill <- max(nfill)
                if(nfill<vol)
                {
                    vol2trd[nfill+1] <- (trdLog[i,'trdVol']-abs(sum(head(vol2trd, nfill))))*sign(vol2trd[nfill+1])
                    if(nfill+1<vol) vol2trd[(nfill+2):vol] <- 0
                }
            } else
            {
                vol2trd[-1] <- 0
                vol2trd[1] <- trdLog[i,'trdVol']*trdLog[i,'trdType']
            }
            trdLogVol[round, , 2] <- trdLogVol[round-1, ,2]+vol2trd
        } else {
#             vol2trd <- abs(trdLog[i, 'trdType']*trdLog[i,'trdOC']-trdLogVol[round, , 2])
#             nfill <- which(cumsum(vol2trd)<=trdLog[i,'trdVol'])
            vol2trd <- trdLog[i, 'trdType']*trdLog[i,'trdOC']-trdLogVol[round, , 2]
            nfill <- which((cumsum(vol2trd)-trdLog[i,'trdType']*trdLog[i,'trdVol'])*trdLog[i,'trdType']<=0)
            if(sum(vol2trd[nfill]))
            {
                nfill <- max(nfill)
                if(nfill<vol)
                {
                    vol2trd[nfill+1] <- (trdLog[i,'trdVol']-abs(sum(head(vol2trd, nfill))))*sign(vol2trd[nfill+1])
                    if(nfill+1<vol) vol2trd[(nfill+2):vol] <- 0
                }
            } else 
            {
                nfill <- max(nfill)
                vol2trd[nfill+1] <- trdLog[i,'trdVol']*trdLog[i,'trdType']
                vol2trd[-(nfill+1)] <- 0
            }
            trdLogVol[round, , 2] <- trdLogVol[round, ,2]+vol2trd
        }
        
#         trdLogVol[round,,3] <- ifelse(vol2trd==0, trdLogVol[round,,3], (trdLogVol[round,,3]*trdLogVol[round,,1]+abs(vol2trd)*trdLog[i,'trdPrice'])/(trdLogVol[round,,1]+abs(vol2trd)))
        trdLogVol[round, , 1] <- abs(vol2trd)+trdLogVol[round, , 1]
        trdLogInx[round,] <- trdLog[i, c('trdType','trdOC')]
        trdLogVol[round, which(vol2trd!=0), 3] <- trdLog[i,'trdPrice']
    }
    
# View(trdLogVol[,,1])
    trdLogInx <- head(trdLogInx, round)
    v <- diff(trdLogVol[round-1:0,,2])
    if(sum(v)!=sum(abs(v))){
        trdLogInx[round,1] <- NA
    }
    trdLogVol <- trdLogVol[1:round,,]
    
    round <- colSums(trdLogVol[,,1])/2
    pos <- tail(trdLogVol[,,'pos'],1)
    pnl <- -colSums(trdLogVol[,,'price']*trdLogVol[,,'vol']*sign(rbind(trdLogVol[1,,2], diff(trdLogVol[,,2]))), na.rm=TRUE)+ifelse(sum(abs(pos))==0, 0,tail(trdLogVol[,,'pos'],1)*sum(abs(pos)*tail(trdLogVol[,,'price'],1))/sum(abs(pos)))

    return(cbind(pnl=pnl,rounds=round))
}

#' example zoomplot of trdSummary
#' 
#' @export
trdSummaryShow.zoomplot <- function(dta, n, ...)
{
    if(nrow(dta)>=n)
    {
        layout(1:2)
        par(mar=c(0, 3.5, 3.5,2), col.axis = grey(.35), cex.axis = .75)
        plot(dta[,'PnL'],type='l',lwd=1.5, ylab='',xlab='', axes=FALSE)
        axis(2)
        axis(4)
        box()
        
        par(mar=c(3.5,3.5,0, 2))
        plot(dta[,'Price'],type='l', col=grey(.5), ylab='',xlab='', axes=T, ...)
        # add sig point
        att <- which(!is.na(dta[,'sig']))
        points(att, dta[att, 'Price'], col=ifelse(dta[att,'sig']==1, rgb(1,0,0,.5), rgb(0,1,0,.5)))
        # add trade point
        att <- which(!is.na(dta[,'trdI']))
        points(att, dta[att,'trdPrice'], col=ifelse(dta[att, 'trdOC']==0, 1, ifelse(dta[att,'trdType']==1, rgb(1,0,0,1), rgb(0,1,0,1))), pch=19, cex=.5)
    } else if(nrow(dta)<500)
    {
        layout(matrix(1:2))
        par(col.axis = grey(.35), cex.axis = .75)
        par(mar=c(0, 3, 2, 2))
        matplot(dta[,c('Volume','BV1','SV1')],type='s',lty=1,col=c(rgb(0,0,0,.5),rgb(1,0,0,.5), rgb(0,1,0,.5)),lwd=2,axes=FALSE,ylab='')
        axis(2,las=2)
        box()

        att1 <- which(!is.na(dta[,'sig']))
        # add trade point
        att2 <- which(!is.na(dta[,'trdI']))
        
        col <- dta[,c(sprintf('BV%i',1:5), sprintf('SV%i',1:5))]
        col <- col/max(col)
        col[,1:5] <- apply(col[,1:5],2, function(alpha) rgb(1,0,0,alpha))
        col[,6:10] <- apply(col[,6:10],2, function(alpha) rgb(0,0,1,alpha))
        par(mar=c(2, 3, 0, 2))
        matplot(dta[,c('SP1','BP1')],type='s', lty=1, col=grey(.9),ylab='', ylim=range(dta[,c('BP5','SP5')]))
        for(i in 1:5)
        {
            points(1:nrow(dta), dta[, sprintf('BP%i',i)], col=col[,sprintf('BV%i',i)],pch=15)
            points(1:nrow(dta), dta[, sprintf('SP%i',i)], col=col[,sprintf('SV%i',i)],pch=15)
        }
        points(att1, dta[att1, 'Price'], col=ifelse(dta[att1,'sig']==1, rgb(1,0,0,1), rgb(0,1,0,1)), cex=1.5)
        points(att2, dta[att2,'trdPrice'], col=ifelse(dta[att2, 'trdOC']==0,1,ifelse(dta[att2,'trdType']==1, rgb(1,0,0,1), rgb(0,1,0,1))), pch=19, cex=1.5)
    } else
    {
        # add sig point
        att1 <- which(!is.na(dta[,'sig']))
        # add trade point
        att2 <- which(!is.na(dta[,'trdI']))
        
        layout(matrix(1:2))
        par(col.axis = grey(.35), cex.axis = .75)
        par(mar=c(0, 3, 2, 2))
        matplot(dta[,c('Volume','BV1','SV1')],type='s',lty=1,col=c(rgb(0,0,0,.5),rgb(1,0,0,.5), rgb(0,1,0,.5)),lwd=2,axes=FALSE,ylab='')
        axis(2,las=2)
        box()
        grid()
        par(mar=c(2,3,0,2))
        matplot(dta[,c('BP1','SP1')],col=c(rgb(1,0,0,.5), rgb(0,1,0,.5)),lty=1,type='s',ylab='',axes=FALSE)
        points(att1, dta[att1, 'Price'], col=ifelse(dta[att1,'sig']==1, rgb(1,0,0,1), rgb(0,1,0,1)))
        points(att2, dta[att2,'trdPrice'], col=ifelse(dta[att2,'trdOC']==0, 1, ifelse(dta[att2,'trdType']==1, rgb(1,0,0,1), rgb(0,1,0,1))), pch=19, cex=.9)
        axis(1)
        axis(2,las=2)
        box()
        grid()
    }
    
    ans <- dta$BP1
    attr(ans, 'note') <- ''
    return(ans)
}

#' trace trades and signals
#' 
#' @param sig signal Vector/matrix. (1-long, -1-short, 0-cover, NA-nothing)
#' @param trdLog matrix. trading log from signalExecute function
#' @param dta matrix/data.frame. market data source
#' @param zoom.plot logical. whether zoom-in functionality valid
#' @return location of last zoomin view
#' @export

trdSummaryShow <- function(sig, trdLog, dta, zoom.plot=FALSE, fee, feeFixed=FALSE, ...)
{
    
    if(missing(fee)) fee <- .265e-4
    dta <- cbind(dta[,c('Price','Volume',grep('(BP)|(BV)|(SP)|(SV)', colnames(dta), val=TRUE))], sig=NA, trdI=NA, trdPrice=NA, trdType=NA, trdOC=NA, PnL=NA)
    dta[trdLog[,'trdI'],'trdI'] <- trdLog[,'trdI']
    dta[trdLog[,'trdI'],'trdPrice'] <- trdLog[,'trdPrice']
    dta[trdLog[,'trdI'],'trdType'] <- trdLog[,'trdType']
    dta[trdLog[,'trdI'],'trdOC'] <- trdLog[,'trdOC']
    if(feeFixed) {
        dta[trdLog[,'trdI'], 'PnL'] <- c(0, cumsum(diff(trdLog[,'trdPrice'])*head(trdLog[,'trdPos'],-1)))-cumsum(fee*trdLog[,'trdVol'])
    } else {
        dta[tail(trdLog[,'trdI'],-1), 'PnL'] <- cumsum(diff(trdLog[,'trdPrice']*(1+trdLog[,'trdType']*fee))*head(trdLog[,'trdPos'],-1))
    }
    
    dta[1,'PnL'] <- 0
    dta[,'PnL'] <- na.locf(dta[,'PnL'], na.rm=FALSE)
    dta[,'sig'] <- sig
    
    
    if(zoom.plot)
    {
        loc <- zoom(dta, trdSummaryShow.zoomplot, n=nrow(dta), ...)
    } else
    {
        loc <- 1:nrow(dta)
        trdSummaryShow.zoomplot(dta, nrow(dta))
    }
    return(invisible(loc))
}
    
    

drawd <- function(x,geometric = TRUE, legend.loc = NULL, colorset = (1:12), 
                  ...)
{
    if(NCOL(x)==1)
    {
        x <- cumsum(x)
        return(reclass(x-pmax(0,cummax(x)),x))
    } else {
        x <- apply(x,2, cumsum)
        return(reclass(apply(x, 2, function(xx)xx-pmax(0,cummax(xx))),x))
    }
}

chart.dd <- function (R, geometric = TRUE, legend.loc = NULL, colorset = (1:12), 
                      ...) 
{
    drawdown = drawd(R, geometric)
    if (NCOL(R) == 1) {
        drawdown <- as.xts(drawdown)
        colnames(drawdown) <- colnames(R)
    }
    chart.TimeSeries(drawdown, colorset = colorset, legend.loc = legend.loc, 
                     ...)
}

#' Performance Analysis
#' @param R
#' @param rounds
#' @param main
#' @param event.labels
#' @param legend.loc
#' @export
charts.performanceSummary <- function (x, rounds, main = NULL, event.labels = NULL, legend.loc = "topleft", ...) 
{
    ylog=FALSE
    Rf <- 0
    geometric = FALSE
    wealth.index=FALSE
    colnames = colnames(x)
    ncols = ncol(x)
    length.column.one = length(x[, 1])
    begin = "first"
    start.row = 1
    start.index = 0
    while (is.na(x[start.row, 1])) {
        start.row = start.row + 1
    }
    x = x[start.row:length.column.one, ]
    if (ncols > 1) 
        legend.loc = legend.loc
    else legend.loc = NULL
    if (is.null(main)) 
        main = paste(colnames[1], "Performance", sep = " ")
    if (ylog) 
        wealth.index = TRUE
    op <- par(no.readonly = TRUE)
    if(!missing(rounds)) layout(matrix(c(1, 2, 3,4)), heights = c(2, 1, 1,1.3), widths = 1) else layout(matrix(c(1, 2, 3)), heights = c(2, 1, 1.3), widths = 1)
    par(mar = c(1, 4, 4, 2))
    chart.CumReturns(x, main = main, xaxis = FALSE, legend.loc = legend.loc, 
                     event.labels = event.labels, ylog = ylog, wealth.index = wealth.index, 
                     begin = begin, geometric = FALSE, ylab = "Cumulative Return", 
                     ...)
    par(mar = c(1, 4, 0, 2))
    freq = periodicity(x)
    switch(freq$scale, seconds = {
        date.label = "Second"
    }, minute = {
        date.label = "Minute"
    }, hourly = {
        date.label = "Hourly"
    }, daily = {
        date.label = "Daily"
    }, weekly = {
        date.label = "Weekly"
    }, monthly = {
        date.label = "Monthly"
    }, quarterly = {
        date.label = "Quarterly"
    }, yearly = {
        date.label = "Annual"
    })
    chart.BarVaR(x, main = "", xaxis = FALSE, width = width, 
                 ylab = paste(date.label, "Return"), methods = 'none', 
                 event.labels = NULL, ylog = FALSE, gap = gap, p = p, ...)
    if(!missing(rounds)){
        par(mar = c(1, 4, 0, 2))
        rounds <- as.xts(rounds, index(x))
        chart.BarVaR(rounds, main = "", xaxis = FALSE, width = width, 
                     ylab = paste(date.label, "Rounds"), methods = 'none', 
                     event.labels = NULL, ylog = FALSE, gap = gap, p = p, ...)
    }
    par(mar = c(5, 4, 0, 2))
    chart.dd(x, geometric = FALSE, main = "", ylab = "Drawdown", 
             event.labels = NULL, ylog = FALSE, ...)
    par(op)
}

#' log parser
#' @param Log Log, with each line of original log file as an element of vector
#' @param sep pattern of seperator between fields
#' @param names names of fields, fields seperated by ','
#' @param class class of fields, fields seperated by ','. i-integer, c-character, n-numeric, d-double
#' @return data.frame 
#' @export

logParser <- function(Log, sep=',', names=NULL, classes=NULL)
{
  require('stringr')
  Log <- do.call('rbind', strsplit(Log, sep))
  Log <- as.data.frame(Log, stringsAsFactors = FALSE)
  
  n <- NCOL(Log)
  if(is.null(names)) 
  {
    names <- paste('V', 0:(n-1), sep='')
  } else 
  {
    names <- str_trim(unlist(strsplit(names, ',')))
    if(length(names)>0) 
    {
      nn <- min(n, length(names))
      names(Log)[1:nn] <- names[1:nn]
    }
  }

  if(!is.null(classes))
  {
    classes <- str_trim(unlist(strsplit(classes, ',')))
    ndup <- as.integer(gsub('[a-z]','',classes))
    ndup <- ifelse(is.na(ndup), 1, ndup)
    
    classes <- substr(classes, 1, 1)
    classes <- rep(classes, ndup)
    
    classes <- tolower(classes)
    classes <- ifelse(classes=='i', 'integer', classes)
    classes <- ifelse(classes=='c', 'character', classes)
    classes <- ifelse(classes=='n', 'numeric', classes)
    classes <- ifelse(classes=='d', 'double', classes)
    if(length(classes)) 
    {
      nn <- min(n, length(classes))
      for(i in 1:nn)
      {
        storage.mode(Log[,i]) <- classes[i]
        if(classes[i]=='character') Log[,i] <- str_trim(Log[,i])
      }
    }
  }

  return(Log)
}

#' reGroup timeseries according to perticular data
#' @param x timeseries to reGroup
#' @param by timeseries to indicate groups
#' @return matrix
#' @export
reGroup <- function(x, by)
{
  require('reshape2')
  stopifnot(NCOL(x)==1 && NCOL(by)==1)
  id <- seq_along(x)
  x <- data.frame(id=id, x=x, by=by)
  
  xx <- reshape(x, v.names = 'x', timevar = 'by',idvar = 'id',dir='wide')[,-1]
  xx <- xx[, order(as.integer(gsub('x.','',colnames(xx))))]
  return(as.matrix(xx))
}

require('compiler')