#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()
