Nothing
#' Generic method to chart risk contribution
#'
#' This function is the generic method to chart risk budget objectives for
#' \code{optimize.portfolio}, \code{optimize.portfolio.rebalancing}, and
#' \code{opt.list} objects. This function charts the contribution or percent
#' contribution of the resulting objective measures of a
#' \code{risk_budget_objective}. The risk contributions for \code{optimize.portfolio.rebalancing}
#' objects are plotted through time with \code{\link[PerformanceAnalytics]{chart.StackedBar}}.
#'
#' @details
#' \code{neighbors} may be specified in three ways.
#' The first is as a single number of neighbors. This will extract the
#' \code{neighbors} closest to the portfolios in terms of the \code{out}
#' numerical statistic.
#' The second method consists of a numeric vector for \code{neighbors}.
#' This will extract the \code{neighbors} with portfolio index numbers that
#' correspond to the vector contents.
#' The third method for specifying \code{neighbors} is to pass in a matrix.
#' This matrix should look like the output of \code{\link{extractStats}}, and
#' should contain properly named contribution and pct_contrib columns.
#'
#' @param object optimal portfolio object created by \code{\link{optimize.portfolio}}
#' or \code{\link{optimize.portfolio.rebalancing}}
#' @param \dots any other passthru parameters to \code{\link{plot}}
#' @param neighbors risk contribution or pct_contrib of neighbor portfolios to be plotted, see Details.
#' @param match.col string of risk column to match. The \code{opt.list} object
#' may contain risk budgets for ES or StdDev and this will match the proper
#' column names of the objectives list outp (e.g. ES.contribution).
#' @param risk.type "absolute" or "percentage" to plot risk contribution in absolute terms or percentage contribution.
#' @param regime integer of the regime number. For use with
#' \code{\link{optimize.portfolio.rebalancing}} run with regime switching portfolios.
#' @param main main title for the chart.
#' @param plot.type "line" or "barplot".
#' @param ylab label for the y-axis.
#' @param xlab label for the x-axis.
#' @param cex.axis the magnification to be used for axis annotation relative to the current setting of \code{cex}.
#' @param cex.lab the magnification to be used for axis annotation relative to the current setting of \code{cex}.
#' @param element.color provides the color for drawing less-important chart elements, such as the box lines, axis lines, etc.
#' @param las numeric in \{0,1,2,3\}; the style of axis labels
#' \describe{
#' \item{0:}{always parallel to the axis [\emph{default}],}
#' \item{1:}{always horizontal,}
#' \item{2:}{always perpendicular to the axis,}
#' \item{3:}{always vertical.}
#' }
#' @param ylim set the y-axis limit, same as in \code{\link{plot}}
#' @param colorset color palette or vector of colors to use
#' @param legend.loc legend.loc NULL, "topright", "right", or "bottomright". If legend.loc is NULL, the legend will not be plotted
#' @param cex.legend The magnification to be used for the legend relative to the current setting of \code{cex}
#' @seealso \code{\link{optimize.portfolio}} \code{\link{optimize.portfolio.rebalancing}} \code{\link[PerformanceAnalytics]{chart.StackedBar}}
#' @export
chart.RiskBudget <- function(object, ...){
UseMethod("chart.RiskBudget")
}
#' @rdname chart.RiskBudget
#' @method chart.RiskBudget optimize.portfolio
#' @export
chart.RiskBudget.optimize.portfolio <- function(object, ..., neighbors=NULL, risk.type="absolute", main="Risk Contribution", ylab="", xlab=NULL, cex.axis=0.8, cex.lab=0.8, element.color="darkgray", las=3, ylim=NULL){
if(!inherits(object, "optimize.portfolio")) stop("object must be of class optimize.portfolio")
portfolio <- object$portfolio
# class of each objective
obj_class <- sapply(portfolio$objectives, function(x) class(x)[1])
if(!("risk_budget_objective" %in% obj_class)) print("no risk_budget_objective")
# Get the index number of the risk_budget_objectives
rb_idx <- which(obj_class == "risk_budget_objective")
if(length(rb_idx) > 1) message(paste(length(rb_idx), "risk_budget_objectives, generating multiple plots."))
# list to store $contribution values
contrib <- list()
# list to store $pct_contrib values
pct_contrib <- list()
idx <- NULL
for(i in 1:length(object$objective_measures)){
if(length(object$objective_measures[[i]]) > 1){
# we have an objective measure with contribution and pct_contrib
contrib[[i]] <- object$objective_measures[[i]][2]
pct_contrib[[i]] <- object$objective_measures[[i]][3]
idx <- c(idx, i)
}
}
columnnames <- names(object$weights)
numassets <- length(columnnames)
if(is.null(xlab))
minmargin = 3
else
minmargin = 5
if(main=="") topmargin=1 else topmargin=4
if(las > 1) {# set the bottom border to accommodate labels
bottommargin = max(c(minmargin, (strwidth(columnnames,units="in"))/par("cin")[1])) * cex.lab
if(bottommargin > 10 ) {
bottommargin<-10
columnnames<-substr(columnnames,1,19)
# par(srt=45) #TODO figure out how to use text() and srt to rotate long labels
}
}
else {
bottommargin = minmargin
}
par(mar = c(bottommargin, 4, topmargin, 2) +.1)
if(risk.type == "absolute"){
for(ii in 1:length(idx)){
if(is.null(ylim)){
ylim <- range(contrib[[idx[ii]]][[1]])
ylim[1] <- min(0, ylim[1])
ylim[2] <- ylim[2] * 1.15
}
objname <- portfolio$objectives[[rb_idx[i]]]$name
# Plot values of contribution
plot(contrib[[idx[ii]]][[1]], type="n", axes=FALSE, xlab="", ylim=ylim, ylab=paste(objname, "Contribution", sep=" "), main=main, cex.lab=cex.lab, ...)
# neighbors needs to be in the loop if there is more than one risk_budget_objective
if(!is.null(neighbors)){
if(is.vector(neighbors)){
xtract <- extractStats(object)
riskcols <- grep(paste(objname, "contribution", sep="."), colnames(xtract))
if(length(riskcols) == 0) stop("Could not extract risk column")
if(length(neighbors) == 1){
# overplot nearby portfolios defined by 'out'
orderx <- order(xtract[,"out"])
subsetx <- head(xtract[orderx,], n=neighbors)
for(i in 1:neighbors) points(subsetx[i, riskcols], type="b", col="lightblue")
} else {
# assume we have a vector of portfolio numbers
subsetx <- xtract[neighbors, riskcols]
for(i in 1:length(neighbors)) points(subsetx[i,], type="b", col="lightblue")
}
} # end if neighbors is a vector
if(is.matrix(neighbors) | is.data.frame(neighbors)){
# the user has likely passed in a matrix containing calculated values for contrib or pct_contrib
nbriskcol <- grep(paste(objname, "contribution", sep="."), colnames(neighbors))
if(length(nbriskcol) == 0) stop(paste("must have '", objname,".contribution' as column name in neighbors",sep=""))
if(length(nbriskcol) != numassets) stop("number of 'contribution' columns must equal number of assets")
for(i in 1:nrow(neighbors)) points(as.numeric(neighbors[i, nbriskcol]), type="b", col="lightblue")
# note that here we need to get risk cols separately from the matrix, not from xtract
# also note the need for as.numeric. points() doesn't like matrix inputs
} # end neighbors plot for matrix or data.frame
} # end if neighbors is not null
points(contrib[[idx[ii]]][[1]], type="b", ...)
axis(2, cex.axis = cex.axis, col = element.color)
axis(1, labels=columnnames, at=1:numassets, las=las, cex.axis = cex.axis, col = element.color)
box(col = element.color)
} # end for loop of risk_budget_objective
} # end plot for absolute risk.type
if(risk.type %in% c("percent", "percentage", "pct_contrib")){
for(ii in 1:length(rb_idx)){
min_prisk <- portfolio$objectives[[rb_idx[ii]]]$min_prisk
max_prisk <- portfolio$objectives[[rb_idx[ii]]]$max_prisk
if(is.null(ylim)){
#ylim <- range(c(max_prisk, pct_contrib[[i]][[1]]))
#ylim[1] <- min(0, ylim[1])
#ylim[2] <- ylim[2] * 1.15
ylim <- c(0, 1)
}
objname <- portfolio$objectives[[rb_idx[i]]]$name
# plot percentage contribution
plot(pct_contrib[[idx[ii]]][[1]], type="n", axes=FALSE, xlab='', ylim=ylim, ylab=paste(objname, " % Contribution", sep=" "), main=main, cex.lab=cex.lab, ...)
# Check for minimum percentage risk (min_prisk) argument
if(!is.null(min_prisk)){
points(min_prisk, type="b", col="darkgray", lty="solid", lwd=2, pch=24)
}
if(!is.null(max_prisk)){
points(max_prisk, type="b", col="darkgray", lty="solid", lwd=2, pch=25)
}
# neighbors needs to be in the loop if there is more than one risk_budget_objective
if(!is.null(neighbors)){
if(is.vector(neighbors)){
xtract <- extractStats(object)
if(risk.type == "absolute"){
riskcols <- grep(paste(objname, "contribution", sep="."), colnames(xtract))
} else if(risk.type %in% c("percent", "percentage", "pct_contrib")){
riskcols <- grep(paste(objname, "pct_contrib", sep="."), colnames(xtract))
}
if(length(riskcols) == 0) stop("Could not extract risk column")
if(length(neighbors) == 1){
# overplot nearby portfolios defined by 'out'
orderx <- order(xtract[,"out"])
subsetx <- head(xtract[orderx,], n=neighbors)
for(i in 1:neighbors) points(subsetx[i, riskcols], type="b", col="lightblue")
} else {
# assume we have a vector of portfolio numbers
subsetx <- xtract[neighbors, riskcols]
for(i in 1:length(neighbors)) points(subsetx[i,], type="b", col="lightblue")
}
} # end if neighbors is a vector
if(is.matrix(neighbors) | is.data.frame(neighbors)){
# the user has likely passed in a matrix containing calculated values for contrib or pct_contrib
nbriskcol <- grep(paste(objname, "pct_contrib", sep="."), colnames(neighbors))
if(length(nbriskcol) == 0) stop(paste("must have '", objname,".pct_contrib' as column name in neighbors",sep=""))
if(length(nbriskcol) != numassets) stop("number of 'pct_contrib' columns must equal number of assets")
for(i in 1:nrow(neighbors)) points(as.numeric(neighbors[i, nbriskcol]), type="b", col="lightblue")
# note that here we need to get risk cols separately from the matrix, not from xtract
# also note the need for as.numeric. points() doesn't like matrix inputs
} # end neighbors plot for matrix or data.frame
} # end if neighbors is not null
points(pct_contrib[[idx[ii]]][[1]], type="b", ...)
axis(2, cex.axis = cex.axis, col = element.color)
axis(1, labels=columnnames, at=1:numassets, las=las, cex.axis = cex.axis, col = element.color)
box(col = element.color)
} # end for loop of risk_budget_objective
} # end plot for pct_contrib risk.type
}
#' @rdname chart.RiskBudget
#' @method chart.RiskBudget optimize.portfolio.rebalancing
#' @export
chart.RiskBudget.optimize.portfolio.rebalancing <- function(object, ..., match.col="ES", risk.type="absolute", regime=NULL, main="Risk Contribution"){
# Get the objective measures at each rebalance period
rebal.obj <- extractObjectiveMeasures(object)
if(inherits(object$portfolio, "regime.portfolios")){
# If the optimize.portfolio.rebalancing object is run with regime switching,
# the output of extractObjectiveMeasures is a list of length N where each
# element is the objective measures of the corresponding regime. (i.e.
# rebal.obj[[1]] is the objective measures for portfolio 1 with regime 1)
if(is.null(regime)) regime=1
rebal.obj <- rebal.obj[[regime]]
}
if(risk.type == "absolute"){
rbcols <- grep(paste(match.col, "contribution", sep="."), colnames(rebal.obj))
if(length(rbcols) < 1) stop(paste("No ", match.col, ".contribution columns.", sep=""))
rbdata <- rebal.obj[, rbcols]
colnames(rbdata) <- gsub("^.*\\.", "", colnames(rbdata))
chart.StackedBar(w=rbdata, ylab=paste(match.col, "Contribution", sep=" "), main=main, ...)
}
if(risk.type %in% c("percent", "percentage", "pct_contrib")){
rbcols <- grep(paste(match.col, "pct_contrib", sep="."), colnames(rebal.obj))
if(length(rbcols) < 1) stop(paste("No ", match.col, ".pct_contrib columns.", sep=""))
rbdata <- rebal.obj[, rbcols]
colnames(rbdata) <- gsub("^.*\\.", "", colnames(rbdata))
chart.StackedBar(w=rbdata, ylab=paste(match.col, "% Contribution", sep=" "), main=main, ...)
}
}
#' @rdname chart.RiskBudget
#' @method chart.RiskBudget opt.list
#' @export
chart.RiskBudget.opt.list <- function(object, ..., match.col="ES", risk.type="absolute", main="Risk Budget", plot.type="line", cex.axis=0.8, cex.lab=0.8, element.color="darkgray", las=3, ylim=NULL, colorset=NULL, legend.loc=NULL, cex.legend=0.8){
if(!inherits(object, "opt.list")) stop("object must be of class 'opt.list'")
if(plot.type %in% c("bar", "barplot")){
barplotRiskBudget(object=object, ...=..., match.col=match.col, risk.type=risk.type, main=main, ylim=ylim, cex.axis=cex.axis, cex.lab=cex.lab, element.color=element.color, las=las, colorset=colorset, legend.loc=legend.loc, cex.legend=cex.legend)
} else if(plot.type == "line"){
xtract <- extractObjectiveMeasures(object)
if(risk.type == "absolute"){
# get the index of columns with risk budget
rbcols <- grep(paste(match.col, "contribution", sep="."), colnames(xtract))
dat <- na.omit(xtract[, rbcols])
if(ncol(dat) < 1) stop("No data to plot after na.omit")
opt_names <- rownames(dat)
# remove everything up to the last dot (.) to extract the names
colnames(dat) <- gsub("(.*)\\.", "", colnames(dat))
# set the colors
if(is.null(colorset)) colorset <- 1:nrow(dat)
columnnames <- colnames(dat)
numassets <- length(columnnames)
xlab <- NULL
if(is.null(xlab))
minmargin <- 3
else
minmargin <- 5
if(main=="") topmargin=1 else topmargin=4
if(las > 1) {# set the bottom border to accommodate labels
bottommargin = max(c(minmargin, (strwidth(columnnames,units="in"))/par("cin")[1])) * cex.lab
if(bottommargin > 10 ) {
bottommargin <- 10
columnnames<-substr(columnnames,1,19)
# par(srt=45) #TODO figure out how to use text() and srt to rotate long labels
}
}
else {
bottommargin = minmargin
}
par(mar = c(bottommargin, 4, topmargin, 2) +.1)
if(is.null(ylim)) ylim <- range(dat)
plot(dat[1,], type="n", ylim=ylim, xlab='', ylab=paste(match.col, "Contribution", sep=" "), main=main, cex.lab=cex.lab, axes=FALSE)
for(i in 1:nrow(dat)){
points(dat[i, ], type="b", col=colorset[i], ...) # add dots here
}
# set the axis
axis(2, cex.axis=cex.axis, col=element.color)
axis(1, labels=columnnames, at=1:numassets, las=las, cex.axis=cex.axis, col=element.color)
box(col=element.color)
# Add a legend
if(!is.null(legend.loc)) legend(legend.loc, legend=opt_names, col=colorset, lty=1, bty="n", cex=cex.legend)
}
if(risk.type %in% c("percent", "percentage", "pct_contrib")){
# get the index of columns with risk budget
rbcols <- grep(paste(match.col, "pct_contrib", sep="."), colnames(xtract))
dat <- na.omit(xtract[, rbcols])
if(ncol(dat) < 1) stop("No data to plot after na.omit")
opt_names <- rownames(dat)
# remove everything up to the last dot (.) to extract the names
colnames(dat) <- gsub("(.*)\\.", "", colnames(dat))
# set the colors
if(is.null(colorset)) colorset <- 1:nrow(dat)
columnnames <- colnames(dat)
numassets <- length(columnnames)
xlab <- NULL
if(is.null(xlab))
minmargin <- 3
else
minmargin <- 5
if(main=="") topmargin=1 else topmargin=4
if(las > 1) {# set the bottom border to accommodate labels
bottommargin = max(c(minmargin, (strwidth(columnnames,units="in"))/par("cin")[1])) * cex.lab
if(bottommargin > 10 ) {
bottommargin <- 10
columnnames<-substr(columnnames,1,19)
# par(srt=45) #TODO figure out how to use text() and srt to rotate long labels
}
}
else {
bottommargin = minmargin
}
par(mar = c(bottommargin, 4, topmargin, 2) +.1)
if(is.null(ylim)) ylim <- range(dat)
plot(dat[1,], type="n", ylim=ylim, xlab='', ylab=paste(match.col, "% Contribution", sep=" "), main=main, cex.lab=cex.lab, axes=FALSE)
for(i in 1:nrow(dat)){
points(dat[i, ], type="b", col=colorset[i], ...) # add dots here
}
axis(2, cex.axis=cex.axis, col=element.color)
axis(1, labels=columnnames, at=1:numassets, las=las, cex.axis=cex.axis, col=element.color)
box(col=element.color)
# Add a legend
if(!is.null(legend.loc)) legend(legend.loc, legend=opt_names, col=colorset, lty=1, bty="n", cex=cex.legend)
}
}
}
# This function is called inside chart.RiskBudget.opt.list when plot.type == "bar" or "barplot"
barplotRiskBudget <- function(object, ..., match.col="ES", risk.type="absolute", main="Risk Budget", cex.axis=0.8, cex.lab=0.8, element.color="darkgray", las=3, colorset=NULL, legend.loc=NULL, cex.legend=0.8){
if(!inherits(object, "opt.list")) stop("object must be of class 'opt.list'")
xtract <- extractObjectiveMeasures(object)
if(risk.type == "absolute"){
# get the index of columns with risk budget
rbcols <- grep(paste(match.col, "contribution", sep="."), colnames(xtract))
dat <- na.omit(xtract[, rbcols])
if(ncol(dat) < 1) stop("No data to plot after na.omit")
opt_names <- rownames(dat)
# remove everything up to the last dot (.) to extract the names
colnames(dat) <- gsub("(.*)\\.", "", colnames(dat))
columnnames <- colnames(dat)
numassets <- length(columnnames)
xlab <- NULL
if(is.null(xlab))
minmargin <- 3
else
minmargin <- 5
if(main=="") topmargin=1 else topmargin=4
if(las > 1) {# set the bottom border to accommodate labels
bottommargin = max(c(minmargin, (strwidth(columnnames,units="in"))/par("cin")[1])) * cex.lab
if(bottommargin > 10 ) {
bottommargin <- 10
columnnames<-substr(columnnames,1,19)
# par(srt=45) #TODO figure out how to use text() and srt to rotate long labels
}
}
else {
bottommargin = minmargin
}
par(mar = c(bottommargin, 4, topmargin, 2) +.1)
# set the colors
if(is.null(colorset)) colorset <- 1:nrow(dat)
# plot the data
barplot(dat, names.arg=columnnames, las=las, cex.names=cex.axis, xlab='', col=colorset, main=main, ylab=paste(match.col, "Contribution", sep=" "), cex.lab=cex.lab, cex.axis=cex.axis, beside=TRUE, ...)
# set the axis
#axis(2, cex.axis=cex.axis, col=element.color)
#axis(1, labels=columnnames, at=1:numassets, las=las, cex.axis=cex.axis, col=element.color)
box(col=element.color)
# Add a legend
if(!is.null(legend.loc)) legend(legend.loc, legend=opt_names, fill=colorset, bty="n", cex=cex.legend)
}
if(risk.type %in% c("percent", "percentage", "pct_contrib")){
# get the index of columns with risk budget
rbcols <- grep(paste(match.col, "pct_contrib", sep="."), colnames(xtract))
dat <- na.omit(xtract[, rbcols])
if(ncol(dat) < 1) stop("No data to plot after na.omit")
opt_names <- rownames(dat)
# remove everything up to the last dot (.) to extract the names
colnames(dat) <- gsub("(.*)\\.", "", colnames(dat))
columnnames <- colnames(dat)
numassets <- length(columnnames)
xlab <- NULL
if(is.null(xlab))
minmargin <- 3
else
minmargin <- 5
if(main=="") topmargin=1 else topmargin=4
if(las > 1) {# set the bottom border to accommodate labels
bottommargin = max(c(minmargin, (strwidth(columnnames,units="in"))/par("cin")[1])) * cex.lab
if(bottommargin > 10 ) {
bottommargin <- 10
columnnames<-substr(columnnames,1,19)
# par(srt=45) #TODO figure out how to use text() and srt to rotate long labels
}
}
else {
bottommargin = minmargin
}
par(mar = c(bottommargin, 4, topmargin, 2) +.1)
# set the colors
if(is.null(colorset)) colorset <- 1:nrow(dat)
# plot the data
barplot(dat, names.arg=columnnames, las=las, cex.names=cex.axis, col=colorset, main=main, ylab=paste(match.col, "% Contribution", sep=" "), cex.lab=cex.lab, cex.axis=cex.axis, beside=TRUE, ...)
#axis(2, cex.axis=cex.axis, col=element.color)
#axis(1, labels=columnnames, at=1:numassets, las=las, cex.axis=cex.axis, col=element.color)
box(col=element.color)
# Add a legend
if(!is.null(legend.loc)) legend(legend.loc, legend=opt_names, fill=colorset, bty="n", cex=cex.legend)
}
}
###############################################################################
# R (https://r-project.org/) Numeric Methods for Optimization of Portfolios
#
# Copyright (c) 2004-2021 Brian G. Peterson, Peter Carl, Ross Bennett, Kris Boudt
#
# This library is distributed under the terms of the GNU Public License (GPL)
# for full details see the file COPYING
#
# $Id$
#
###############################################################################
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.