[Returnanalytics-commits] r3561 - pkg/PerformanceAnalytics/sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Nov 23 15:29:57 CET 2014
Author: peter_carl
Date: 2014-11-23 15:29:57 +0100 (Sun, 23 Nov 2014)
New Revision: 3561
Added:
pkg/PerformanceAnalytics/sandbox/CDaR.R
pkg/PerformanceAnalytics/sandbox/CED.R
pkg/PerformanceAnalytics/sandbox/MaxQL.R
pkg/PerformanceAnalytics/sandbox/Normalize.R
pkg/PerformanceAnalytics/sandbox/chart.RankBars.R
Log:
- function stubs and drafts from QWAFAFEW presentation
Added: pkg/PerformanceAnalytics/sandbox/CDaR.R
===================================================================
--- pkg/PerformanceAnalytics/sandbox/CDaR.R (rev 0)
+++ pkg/PerformanceAnalytics/sandbox/CDaR.R 2014-11-23 14:29:57 UTC (rev 3561)
@@ -0,0 +1,57 @@
+#' Calculates Conditional Drawdown at Risk (CDaR)
+#'
+#' @description Conditional Drawdown at Risk (CDaR) is part of a one-parameter
+#' family of risk measures called Conditional Drawdown (CDD). These measures of
+#' risk are functionals of the portfolio drawdown (underwater) curve. For some
+#' value of the tolerance parameter, in the case of
+#' a single sample path, drawdown functional is defineed as the mean of the
+#' worst (1 - \eqn{\alpha})% drawdowns.
+#' @details
+#' The \bold{CDD} is related to Value-at-Risk (VaR) and Conditional
+#' Value-at-Risk (CVaR) measures studied by Rockafellar and Uryasev . By
+#' definition, with respect to a specified probability level \eqn{\alpha}, the
+#' \bold{\eqn{\alpha}-VaR} of a portfolio is the lowest amount \eqn{\epsilon},
+#' \eqn{\alpha} such that, with probability \eqn{\alpha}, the loss will not
+#' exceed \eqn{\epsilon}, \eqn{\alpha} in a specified time T, whereas the
+#' \bold{\eqn{\alpha}-CVaR} is the conditional expectation of losses above that
+#' amount \eqn{\epsilon}.
+#' The CDD is similar to CVaR and can be viewed as a modification of the CVaR
+#' to the case when the loss-function is defined as a drawdown. CDD and CVaR are
+#' conceptually related percentile-based risk performance functionals.
+#'
+#' Like CVaR and ETL, CDaR is defined as the mean of the worst drawdowns above
+#' a quantile. For example, the 0.90 CDaR is the average of the worst 10%
+#' drawdowns over the period.
+#' Convex measure, so useful in optimization
+#' @param R an xts, vector, matrix, data frame, timeSeries or zoo object of asset returns
+#' @param p confidence level for calculation, default p=.95
+#' @return
+#' @author Peter Carl, Shubhankit Mohan
+#' @references Chekhlov, A., Uryasev, S. and Zabarankin, M. (2000). \emph{Portfolio Optimization with Drawdown Constraints.} Research Report #2000-5. Available at SSRN: \url{http://ssrn.com/abstract=223323}
+#' @references Chekhlov, A., Uryasev, S. and Zabarankin, M. (2003) \emph{Drawdown Measure in Portfolio Optimization}. Paper available at SSRN: \url{http://ssrn.com/abstract=544742}
+#' @export
+CDaR <- function(R, p=0.95, ...){
+ # Peter Carl
+ # @TODO this is just the interior function; needs multi-col framework
+ R = checkData(R)
+ R = na.omit(R)
+ nr = nrow(R)
+ dd = coredata(-PerformanceAnalytics:::Drawdowns(R))
+ dd = dd[order(dd),increasing = TRUE]
+ # result = -(1/((1-p)*nr))*sum(dd[((p)*nr):nr])
+ dar = quantile(dd, p=0.90, type=8)
+ result = -1*mean(dd[dd>dar])
+ result
+}
+
+###############################################################################
+# R (http://r-project.org/) Econometrics for Performance and Risk Analysis
+#
+# Copyright (c) 2004-2014 Peter Carl and Brian G. Peterson
+#
+# This R package is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: $
+#
+###############################################################################
\ No newline at end of file
Added: pkg/PerformanceAnalytics/sandbox/CED.R
===================================================================
--- pkg/PerformanceAnalytics/sandbox/CED.R (rev 0)
+++ pkg/PerformanceAnalytics/sandbox/CED.R 2014-11-23 14:29:57 UTC (rev 3561)
@@ -0,0 +1,40 @@
+
+#' Calculates Conditional Expected Drawdown (CED)
+#'
+#' Defined as the tail mean of a distribution of maximum drawdowns
+#' Analagous to ETL, but accounts for autocorrelation
+#' Convex and supports risk attribution, but isn't monetary
+#' Calculated from the distribution of the rolling maximum drawdowns
+#' @param R an xts, vector, matrix, data frame, timeSeries or zoo object of asset returns
+#' @param p confidence level for calculation, default p=.95
+#' @return
+#' @references Goldberg, L. and Mahmoud, O. (2014). On a Convex Measure of Drawdown Risk. Available at SSRN: http://ssrn.com/abstract=2430918
+
+CED <- function(R, p=0.95, ...){
+ # @TODO this is an interior function only; add multi-col support
+ # Rolling 12-month max DD
+ x.rMDD = NULL # initialize rolling maximum drawdown results
+ for(i in colnames(x.R)){
+ x.rMDD1 <- rollapply(na.omit(x.R[,i]), width = 12, align="right", FUN=maxDrawdown)
+ x.rMDD = cbind(x.rMDD, x.rMDD1)
+ }
+ x.qrMDD=apply(x.rMDD["1998::",], MARGIN=2, FUN=quantile, probs=0.90, na.rm=TRUE) # this is the quantile
+ x.CED = NULL # Calculate the CED from the rolling MDD obs > quantile MDD
+ for(i in 1:NCOL(x.R)){
+ .CED = mean(x.rMDD[x.rMDD[,i] > x.qrMDD[i], i])
+ x.CED = c(x.CED, .CED)
+ }
+ return(.CED)
+}
+
+###############################################################################
+# R (http://r-project.org/) Econometrics for Performance and Risk Analysis
+#
+# Copyright (c) 2004-2014 Peter Carl and Brian G. Peterson
+#
+# This R package is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: $
+#
+###############################################################################
\ No newline at end of file
Added: pkg/PerformanceAnalytics/sandbox/MaxQL.R
===================================================================
--- pkg/PerformanceAnalytics/sandbox/MaxQL.R (rev 0)
+++ pkg/PerformanceAnalytics/sandbox/MaxQL.R 2014-11-23 14:29:57 UTC (rev 3561)
@@ -0,0 +1,130 @@
+#' @name
+#' Max Quartile Loss at Confidence level MLdP
+#'
+#' @param R an xts, vector, matrix, data frame, timeSeries or zoo object of asset returns
+#' @param p confidence level for calculation, default p=.95
+#' @param method Either "ac" (default) or "normal", see details.
+#'
+#' Up to how much could a particular strategy lose with a given confidence level, and regardless of time horizon/number of bets involved?
+#' Closed-form expressions of quantile-loss potential associated with a significance level. The function provides two methods. The first, "normal," assumes iid returns and the second, "ac," incorporates first-order autoregressive conditions.
+#' As a parametric function, this is computationally efficient, and useful for optimization.
+#' Analagous to VaR
+#' @references Bailey, D. and Lopez de Prado, M. (2014). Stop-Outs Under Serial Correlation and 'The Triple Penance Rule'. Journal of Risk, Forthcoming. Available at SSRN: http://ssrn.com/abstract=2201302
+
+#' @export
+MaxQL<-function(R, p = 0.95, method = c("ac","normal"), ...) {
+ # @TODO Handle multi-column output
+ if(!is.vector(R))
+ x = checkData(R[,1])
+ else
+ x = checkData(R)
+ x = na.omit(x)
+ if(type[1]=="ac"){
+ mu = mean(x, na.rm = TRUE)
+ sigma_infinity = StdDev(x)
+ phi = cov(x[-1],x[-length(x)])/(cov(x[-length(x)]))
+ phi=.5
+ sigma = sigma_infinity*((1-phi^2)^0.5)
+ dPi0 = 0
+ minQ = minQ(phi, mu, sigma, dPi0, confidence)
+ }
+ if(type[1]=="normal"){
+ minQ = minQ_norm(x, confidence)
+ }
+ MaxQL=min(0,minQ[[1]])
+ # rownames(MaxQL) = paste0("MaxQL (", confidence*100, "%)") #,"t*")
+ return(MaxQL)
+}
+
+# --------------------------------------------------------------------
+# Max Quartile Loss at Confidence level - First-order AC
+# --------------------------------------------------------------------
+getQ <- function(bets, phi, mu, sigma, dPi0, confidence) {
+ # Compute analytical solution to quantile
+ #1) Mean (eq 15)
+ mean=(phi^(bets+1)-phi)/(1-phi)*(dPi0-mu)+mu*bets # wrong?
+ #2) Variance (eq 15)
+ var=sigma^2/(phi-1)^2
+ var=var*((phi^(2*(bets+1))-1)/(phi^2-1)-2*(phi^(bets+1)-1)/(phi-1)+bets+1)
+ #3) Quantile
+ q=mean+qnorm(1-confidence)*(var^0.5)
+ #print(sprintf("bets %g, mean %g, var %g, var1 %g, var2 %g, var3 %g, q %g", bets, mean, var, var1, var2, var3, q))
+ q
+}
+
+goldenSection<-function(a, b, FUN, minimum = TRUE, ...) {
+ FUN = match.fun(FUN)
+ tol = 10^-9
+ sign = 1
+
+ if(minimum) sign = -1
+ N = round(ceiling(-2.078087*log(tol/abs(b-a))))
+ r = 0.618033989
+ c = 1.0 - r
+ x1 = r*a + c*b
+ x2 = c*a + r*b
+ f1 = sign * FUN(x1,...=...)
+ f2 = sign * FUN(x2,...=...)
+ #print(f1); print(f2)
+ for(i in 1:N){
+ if(f1>f2){
+ a = x1
+ x1 = x2
+ f1 = f2
+ x2 = c*a+r*b
+ f2 = sign*FUN(x2,...=...)
+ } else {
+ b = x2
+ x2 = x1
+ f2 = f1
+ x1 = r*a + c*b
+ f1 = sign*FUN(x1,...=...)
+ }
+ }
+ if(f1 < f2){
+ return(list(minQ=sign*f1, t=x1))
+ } else {
+ return(list(minQ=sign*f2, t=x2))
+ }
+}
+
+minQ <- function(phi, mu, sigma, dPi0, confidence) {
+ q = 0
+ bets = 0
+ while (q <= 0) {
+ bets = bets + 1
+ q = getQ(bets, phi, mu, sigma, dPi0, confidence)
+ }
+ #print(sprintf("bets %g, q %g", bets, q))
+ goldenSection(0,bets,getQ,FALSE,phi=phi,mu=mu,sigma=sigma,dPi0=dPi0,confidence=confidence)
+}
+
+# minQ(0.5, 1, 2, 1, 0.95)
+# MinQ = -9.15585580378
+# Time at MinQ = 12.4832517718
+
+# --------------------------------------------------------------------
+# Max Quartile Loss at Confidence level - Assuming IID (eq. 5)
+# --------------------------------------------------------------------
+
+minQ_norm<-function(x, confidence){
+ # Calculate the maximum drawdown for a normal distribution, assuming iid returns
+ x = na.omit(x)
+ sd = StdDev(x)
+ mu = mean(x, na.rm = TRUE)
+ minQ = -((qnorm(1-confidence)*sd)^2)/(4*mu)
+ t = ((qnorm(1-confidence)*sd)/(2*mu))^2
+ return(list(minQ=minQ,t=t))
+}
+
+###############################################################################
+# R (http://r-project.org/) Econometrics for Performance and Risk Analysis
+#
+# Copyright (c) 2004-2014 Peter Carl and Brian G. Peterson
+#
+# This R package is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: $
+#
+###############################################################################
\ No newline at end of file
Added: pkg/PerformanceAnalytics/sandbox/Normalize.R
===================================================================
--- pkg/PerformanceAnalytics/sandbox/Normalize.R (rev 0)
+++ pkg/PerformanceAnalytics/sandbox/Normalize.R 2014-11-23 14:29:57 UTC (rev 3561)
@@ -0,0 +1,51 @@
+# Two functions:
+# Return.normalize
+# chart.NDD
+
+#' Calculate mean and volatility normalized time series
+#'
+#'
+#' @param R
+#' @param targetMean
+#' @param targetVol
+#' @param ... passes arguments to par
+#' @return xts or other time series
+#' @author Peter Carl
+#' @references Burghardt, G. Duncan, R., and Liu, L. (2003). Deciphering Drawdowns. Risk Magazine. Available at: http://www.risk.net/data/risk/pdf/investor/0903_risk.pdf
+#' @rdname Return.normalize
+#' @export Return.normalize
+#' @export chart.NDD
+Return.normalize <- (R, targetMean=0, targetVol=0, ...){
+ # Peter Carl
+ x=checkData(R)
+ x.Mean=apply(x, MARGIN=2, FUN="mean", na.rm = TRUE)
+ x.SD=StdDev(x)
+ # @TODO wil this work for vector? checkData as matrix?
+ # Apply z-score
+ x.Z = apply(x, MARGIN=2, FUN=function(x){ (x - mean(x, na.rm = TRUE))/sd(x, na.rm = TRUE) }) # x.Z has mean=0, sd=1
+ x.N= targetMean + x.Z * (rep(1, nrow(x.R)) %o% rep(targetVol,NCOL(x.R)))
+ x.N = as.xts(x.N, by=index(x.R))
+ x.N = reclass(x.N, R)
+ return(x.N)
+}
+
+chart.NDD <- function(R, targetMean=0, targetVol=0){
+ # Peter Carl
+ x.N = Return.normalize(x)
+ x.NDD = PerformanceAnalytics:::Drawdowns(x.N)
+ par(mar = c(3, 5, 2, 3)+0.1) #c(bottom, left, top, right)
+ chart.TimeSeries(x.NDD[start.date,c(manager.col, index.cols, peer.cols)], colorset=colorset, lwd=lwdset, legend.loc=NULL, lty=lineset, main="", cex.axis=1.2, cex.lab=1.5)
+ par(op)
+}
+
+###############################################################################
+# R (http://r-project.org/) Econometrics for Performance and Risk Analysis
+#
+# Copyright (c) 2004-2014 Peter Carl and Brian G. Peterson
+#
+# This R package is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: $
+#
+###############################################################################
\ No newline at end of file
Added: pkg/PerformanceAnalytics/sandbox/chart.RankBars.R
===================================================================
--- pkg/PerformanceAnalytics/sandbox/chart.RankBars.R (rev 0)
+++ pkg/PerformanceAnalytics/sandbox/chart.RankBars.R 2014-11-23 14:29:57 UTC (rev 3561)
@@ -0,0 +1,28 @@
+# Generalize this to take any function, determine the rankings, and draw a bar plot in order of the ranking
+# Peter Carl
+chart.RankBars <- function(R, FUN="mean", ...){
+ # @todo split dots between the function and par
+ if(!is.function(FUN))
+ FUN = match.fun("FUN",...)
+ t.AC = table.Autocorrelation(last(x.R[,c(manager.col, index.cols, peer.cols)],36))
+ y=colSums(t.AC[1:6,])
+ layout(matrix(1:2,ncol=1), heights=c(3,2))
+ par(mar = c(1, 5, 3, 3)+0.1) #c(bottom, left, top, right)
+ barplot(y[order(y)], col=colorset[order(y)], border = NA, axisnames=FALSE, ylim=range(pretty(y)), cex.axis=1.2, cex.lab=1.5, cex.main=2, ylab="Sum of Lag 1-6 AC", main="Trailing 36-month Autocorrelation")
+ box()
+ barplot(as.numeric(t.AC[7,order(y)]), col=colorset[order(y)], ylim=range(pretty(c(0,1))), axisnames=FALSE, border=NA, cex.axis=1.2, cex.lab=1.5, ylab="Q(6) p-value")
+ box()
+ par(op)
+}
+
+###############################################################################
+# R (http://r-project.org/) Econometrics for Performance and Risk Analysis
+#
+# Copyright (c) 2004-2014 Peter Carl and Brian G. Peterson
+#
+# This R package is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: $
+#
+###############################################################################
\ No newline at end of file
More information about the Returnanalytics-commits
mailing list