Reporting Good Enough to Share

Sorry to all my faithful readers for my absence recently. I started a new job at a new firm, so my blogging has moved down the priority list but only temporarily. I am still committed to documenting my thoughts, especially finance and R thoughts as discussed in Why Talk My Book? .

So far, I have used R primarily for my own use without the intention of sharing with clients <> R stats finance geeks. However, R is so powerful that I would like to leverage it for more general communication.

Our shop uses Advent Axys, which I believe is still the industry standard despite its extremely poor and inflexible reporting capabilities. At one point in a previous life, I believed some of the inflexibility could be overcome through its replang scripting, and I endured a very painful journey documenting and experimenting http://www.axysreporting.com. I now believe the best solution is to use Axys only to export its information to better, more capable reporting engines.

In this example, I amended the Axys 631 report to export performance to a .csv file. I'm concerned that sharing my amended report might violate the very aggressive IP attorneys at Advent. I will try to write from scratch at some point to share while still avoiding this ire.  Please let me know if you have already done this to save me some time and effort.  Click on the screenshot to get the .csv file from Google Docs.

For now, I will share a sample performance file generated from my 631 exporter, and change the fine PerformanceAnalytics charts.PerformanceSummary report.  In later posts I will add some ggplot2 charts.  I think the chart is now good enough to share with clients, but unfortunately, my code is nowhere near as clean or robust as I would like.  I combined all the code into one R script, and here is the result.  I would love input and thoughts.

The original charts.PerformanceSummary with no modifications.

From TimelyPortfolio

My new version

From TimelyPortfolio

R code (click to download from Google Docs):

#this report uses the PerformanceAnalytics charts.PerformanceSummary
#as the base for a new one-pager
#99% of the code is from the PerformanceAnalytics package
#all credit should be given to the PerformanceAnalytics team
#all errors should be assigned to me
 
 
#this is almost entirely from the PerformanceAnalytics
#chart.CumReturns function
#I only change to label the endpoints
na.skip <- function (x, FUN=NULL, ...) # maybe add a trim capability?
{ # @author Brian Peterson
 
    # DESCRIPTION:
 
    # Time series data often contains NA's, either due to missing days, 
    # noncontiguous series, or merging multiple series,
    # 
    # Some Calulcations, such as return calculations, require data that 
    # looks like a vector, and needs the output of na.omit
    # 
    # It is often convenient to apply these vector-like functions, but 
    # you still need to keep track of the structure of the oridginal data.
 
    # Inputs
    # x		the time series to apply FUN too
    # FUN	function to apply
    # ...	any additonal parameters to FUN
 
    # Outputs:
    # An xts time series that has the same index and NA's as the data 
    # passed in, after applying FUN
 
    nx <- na.omit(x)
    fx <- FUN(nx, ... = ...)
    if (is.vector(fx)) {
        result <- .xts(fx, .index(x), .indexCLASS = indexClass(x))
    }
    else {
        result <- merge(fx, .xts(, .index(x)))
    }
    return(result)
}
 
 
 
chart.CumReturnsX <-
function (R, wealth.index = FALSE, geometric = TRUE, legend.loc = NULL, colorset = (1:12), begin = c("first","axis"), ...)
{ # @author Peter Carl
 
    # DESCRIPTION:
    # Cumulates the returns given and draws a line graph of the results as
    # a cumulative return or a "wealth index".
 
    # Inputs:
    # R: a matrix, data frame, or timeSeries of returns
    # wealth.index:  if true, shows the "value of $1", starting the cumulation
    #    of returns at 1 rather than zero
    # legend.loc: use this to locate the legend, e.g., "topright"
    # colorset: use the name of any of the palattes above
    # method: "none"
 
    # Outputs:
    # A timeseries line chart of the cumulative return series
 
    # FUNCTION:
 
    # Transform input data to a matrix
    begin = begin[1]
    x = checkData(R)
 
    # Get dimensions and labels
    columns = ncol(x)
    columnnames = colnames(x)
 
    # Calculate the cumulative return
    one = 0
    if(!wealth.index)
        one = 1
 
    ##find the longest column, calc cum returns and use it for starting values
 
    if(begin == "first") {
        length.column.one = length(x[,1])
        # find the row number of the last NA in the first column
        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(geometric)
            reference.index = na.skip(x[,1],FUN=function(x) {cumprod(1+x)})
        else
            reference.index = na.skip(x[,1],FUN=function(x) {cumsum(x)})
    }
    for(column in 1:columns) {
        if(begin == "axis") {
            start.index = FALSE
		} else {
    		# find the row number of the last NA in the target column
            start.row = 1
            while(is.na(x[start.row,column])){
                start.row = start.row + 1
            }
            start.index=ifelse(start.row > 1,TRUE,FALSE)
        }
        if(start.index){
	        # we need to "pin" the beginning of the shorter series to the (start date - 1 period) 
	        # value of the reference index while preserving NA's in the shorter series
            if(geometric)
                z = na.skip(x[,column],FUN = function(x,index=reference.index[(start.row - 1)]) {rbind(index,1+x)})
            else
                z = na.skip(x[,column],FUN = function(x,index=reference.index[(start.row - 1)]) {rbind(1+index,1+x)})
        } else {
            z = 1+x[,column] 
        }
        column.Return.cumulative = na.skip(z,FUN = function(x, one, geometric) {if(geometric) cumprod(x)-one else (1-one) + cumsum(x-1)},one=one, geometric=geometric)
        if(column == 1)
            Return.cumulative = column.Return.cumulative
        else
            Return.cumulative = merge(Return.cumulative,column.Return.cumulative)
    }
    if(columns == 1)
        Return.cumulative = as.xts(Return.cumulative)
    colnames(Return.cumulative) = columnnames
 
    # Chart the cumulative returns series
    chart.TimeSeries(Return.cumulative, col = colorset, legend.loc = legend.loc, ...)
	for (i in 1:NCOL(Return.cumulative)) {
		text(x=NROW(Return.cumulative),
		y=coredata(Return.cumulative)[NROW(Return.cumulative),i],
		sprintf("%1.0f%%",round(coredata(Return.cumulative)[NROW(Return.cumulative),i],2)*100),
		adj = c(0, 0.5),lwd=0.5,col=colorset[i])
	}
}
 
#this function shows bar plot side-by-side comparisons for rolling annualized
#returns
#please proceed with caution as function is not robust
#and does not perform adequate error checking
chart.SideBar <- function (w,  auto.grid = TRUE, xaxis = TRUE, yaxis = TRUE, yaxis.right = FALSE, 
    type = "l", lty = 1, lwd = 2, main = NULL, ylab = "Annualized Returns", xlab = NULL, 
    xlim = NULL, ylim = NULL, element.color = "darkgray", event.lines = NULL, 
    event.labels = NULL, period.areas = NULL, event.color = "darkgray", 
    period.color = "aliceblue", colorset = (1:12), pch = (1:12), 
    legend.loc = NULL, cex.axis = 0.8, cex.legend = 0.8, 
    cex.lab = 1, cex.labels = 0.8, cex.main = 1, major.ticks = "auto", 
    minor.ticks = TRUE, grid.color = "lightgray", grid.lty = "dotted", 
    xaxis.labels = NULL, ...) 
{
        barplot(w, beside=TRUE, col = colorset[1:NROW(w)], 
            xlab = xlab, ylab = ylab, axes = FALSE,
            ylim = c(min(0,min(w)),max(w)+0.05),...)
 
    if (auto.grid) {
        abline(v=0, col = element.color, lty = grid.lty)
        grid(NA, NULL, col = grid.color)
    }
    abline(h = 0, col = grid.color)
 
	axis(2, cex.axis = cex.axis, col = element.color)
	title(ylab = ylab, cex = cex.lab)
 
 
 
    if (!is.null(legend.loc)) {
        legend(legend.loc, inset = 0.02, text.col = colorset, 
            col = colorset, cex = cex.legend, border.col = grid.color, 
            lty = lty, lwd = 2, bg = "white", legend = rownames(w))
    }
 
	box(col = element.color)
}
 
 
charts.PerformanceSummaryX <-
function (R, Rf = 0, main = NULL, submain=NULL, geometric=TRUE, methods = "none", width = 0, event.labels = NULL, ylog = FALSE, wealth.index = FALSE, gap = 12, begin=c("first","axis"), legend.loc="bottomright", p=0.95, maxdraw = TRUE,...)
{ # @author Peter Carl
 
    # DESCRIPTION:
    # A wrapper to create a wealth index chart, bars for monthly peRformance,
    # and underwater chart for drawdown.
 
    # Inputs:
    # R: a matrix, data frame, or timeSeries, usually a set of monthly returns.
    #   The first column is assumed to be the returns of interest, the next
    #   columns are assumed to be relevant benchmarks for comparison.
    # Rf: this is the risk free rate.  Remember to set this to the same
    #   periodicity as the data being passed in.
    # method: Used to select the risk parameter to use in the chart.BarVaR.  May
    #   be any of:
    #     modVaR - uses CF modified VaR
    #     VaR - uses traditional Value at Risk
    #     StdDev - monthly standard deviation of trailing 12 month returns
    #
 
    # Outputs:
    # A stack of three related timeseries line charts
 
    # FUNCTION:
    begin = begin[1]
    x = checkData(R)
    colnames = colnames(x)
    ncols = ncol(x)
 
# This repeats a bit of code from chart.CumReturns, but it's intended
# to align the start dates of all three charts.  Basically, it assumes
# that the first column in the list is the column of interest, and 
# starts everything from that start date
 
    length.column.one = length(x[,1])
# find the row number of the last NA in the first column
    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)
 
    # First, we lay out the graphic as a three row, one column format
#    plot.new()
    layout(matrix(c(1,2,3)),height=c(2,1,1.3),width=1)
    # to see the resulting layout, use layout.show(3)
 
    # mar: a numerical vector of the form c(bottom, left, top, right) which
    # gives the number of lines of margin to be specified on the four sides
    # of the plot. The default is c(5, 4, 4, 2) + 0.1
 
    # The first row is the cumulative returns line plot
	par(oma=c(2,2,4,2))	
    par(mar=c(1,6,8,4))
    chart.CumReturnsX(x, main = "", xaxis = FALSE, legend.loc = legend.loc, cex.legend = 1, event.labels = event.labels, ylog = ylog, wealth.index = wealth.index, begin = begin, geometric = geometric, ylab="Cumulative Return",...)
 
#	title(main=main, sub=submain, cex.main=2, cex.sub=1.5, adj=0, outer =FALSE)
mtext(text=main, line = -2, outer = TRUE, adj = 0.1, cex=2)
mtext(text=submain, line = -4, outer = TRUE, adj = 0.075, cex=1.5)
 
 
 
    # The second row is the monthly returns bar plot
#    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 = methods, event.labels = NULL, ylog=FALSE, gap = gap, p=p, ...)
 
    # The third row is the underwater plot
    par(mar=c(3,6,0,4))
    chart.Drawdown(x, geometric = geometric, main = "", xlab=NA, ylab = "Drawdown", event.labels = NULL, ylog=FALSE, ...)
	if (maxdraw) {
		abline(h=-0.1,col="tomato3",lwd=3,lty="dashed")
		text(x=2,y=-0.1,"maximum acceptable drawdown",adj = c(0, 0.5))
	}
 
#     If we wanted to add a fourth row with the table of monthly returns
#    par(mar=c(0,0,0,0))
#    textplot(table.Returns(as.matrix(R)),cex=.7,cmar=1.5,rmar=0.5,halign="center", valign="center")
 
par(mar=c(6,6,0,4))
 
returnTable <- returnTable <- table.TrailingPeriods(x,
	periods=c(12,24,36,NROW(x)),
	FUNCS="Return.annualized")
rownames(returnTable) <- c(paste(c(1:3)," Year",sep=""),"Since Inception")[1:NROW(returnTable)]
 
chart.SideBar(t(as.matrix(returnTable)),...)
 
par(op)
 
}
 
 
 
 
#now let's use the amended report to look at performance
require(quantmod)
require(PerformanceAnalytics)
 
clientPerf <- read.csv("clientperf.csv",stringsAsFactors=FALSE)
clientPerf[,2:NCOL(clientPerf)] <- lapply(clientPerf[,2:NCOL(clientPerf)],as.numeric)
clientPerf <- as.xts(clientPerf[,2:NCOL(clientPerf)]/100,
	order.by = as.Date(clientPerf[,1],format="%m-%d-%y"))
colnames(clientPerf) <- c("Client","BarclaysAgg","SP500")
 
jpeg(filename="performance summary.jpg",quality=100,width=6, height = 7,  units="in",res=96)
charts.PerformanceSummary(clientPerf)
dev.off()
 
jpeg(filename="performance one-pager.jpg",quality=100,width=6, height = 7,  units="in",res=96)
charts.PerformanceSummaryX(clientPerf,main="Client Performance",
	submain=paste("Since Inception - ",format(seq(index(clientPerf)[1], length=2, by="-1 months")[2],"%B %Y"),sep=""),legend.loc="bottomright",maxdraw=FALSE,
	colorset=c("cadetblue4","darkgray","bisque3"),lwd=c(3,2,2))
dev.off()

Created by Pretty R at inside-R.org