[Returnanalytics-commits] r2762 - in pkg/PortfolioAnalytics: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Aug 10 16:15:12 CEST 2013
Author: rossbennett34
Date: 2013-08-10 16:15:12 +0200 (Sat, 10 Aug 2013)
New Revision: 2762
Modified:
pkg/PortfolioAnalytics/R/applyFUN.R
pkg/PortfolioAnalytics/R/charts.RP.R
pkg/PortfolioAnalytics/man/chart.Scatter.RP.Rd
Log:
Modified applyFUN to accept a single set of weights in addition to a matrix of weights. Modified chart.Scatter.RP to calculate risk or return metric that is not included in the objective_measures or extractStats output.
Modified: pkg/PortfolioAnalytics/R/applyFUN.R
===================================================================
--- pkg/PortfolioAnalytics/R/applyFUN.R 2013-08-10 12:07:34 UTC (rev 2761)
+++ pkg/PortfolioAnalytics/R/applyFUN.R 2013-08-10 14:15:12 UTC (rev 2762)
@@ -53,17 +53,31 @@
}
) # end switch block
- out <- rep(0, nrow(weights))
- .formals <- formals(fun)
- onames <- names(.formals)
- for(i in 1:nrow(weights)){
- nargs$weights <- as.numeric(weights[i,])
- nargs$x <- R %*% as.numeric(weights[i,])
+ if(!is.null(nrow(weights))){
+ # case for matrix of weights
+ out <- rep(0, nrow(weights))
+ .formals <- formals(fun)
+ onames <- names(.formals)
+ for(i in 1:nrow(weights)){
+ nargs$weights <- as.numeric(weights[i,])
+ nargs$x <- R %*% as.numeric(weights[i,])
+ dargs <- nargs
+ pm <- pmatch(names(dargs), onames, nomatch = 0L)
+ names(dargs[pm > 0L]) <- onames[pm]
+ .formals[pm] <- dargs[pm > 0L]
+ out[i] <- try(do.call(fun, .formals))
+ }
+ } else {
+ # case for single vector of weights
+ .formals <- formals(fun)
+ onames <- names(.formals)
+ nargs$weights <- as.numeric(weights)
+ nargs$x <- R %*% as.numeric(weights)
dargs <- nargs
pm <- pmatch(names(dargs), onames, nomatch = 0L)
names(dargs[pm > 0L]) <- onames[pm]
.formals[pm] <- dargs[pm > 0L]
- out[i] <- try(do.call(fun, .formals))
+ out <- try(do.call(fun, .formals))
}
- return(out)
+ return(out)
}
\ No newline at end of file
Modified: pkg/PortfolioAnalytics/R/charts.RP.R
===================================================================
--- pkg/PortfolioAnalytics/R/charts.RP.R 2013-08-10 12:07:34 UTC (rev 2761)
+++ pkg/PortfolioAnalytics/R/charts.RP.R 2013-08-10 14:15:12 UTC (rev 2762)
@@ -95,6 +95,9 @@
#' classic risk return scatter of random portfolios
#'
#' @param RP set of portfolios created by \code{\link{optimize.portfolio}}
+#' @param R an optional an xts, vector, matrix, data frame, timeSeries or zoo
+#' object of asset returns, used to recalulate the objective function when
+#' return.col or risk.col is not part of the extractStats output.
#' @param neighbors set of 'neighbor' portfolios to overplot, see Details
#' @param return.col string matching the objective of a 'return' objective, on vertical axis
#' @param risk.col string matching the objective of a 'risk' objective, on horizontal axis
@@ -103,7 +106,7 @@
#' @param element.color color for the default plot scatter points
#' @seealso \code{\link{optimize.portfolio}}
#' @export
-chart.Scatter.RP <- function(RP, neighbors = NULL, return.col='mean', risk.col='ES', ..., element.color = "darkgray", cex.axis=0.8){
+chart.Scatter.RP <- function(RP, R=NULL, neighbors = NULL, return.col='mean', risk.col='ES', ..., element.color = "darkgray", cex.axis=0.8){
# more or less specific to the output of the random portfolio code with constraints
# will work to a point with other functions, such as optimize.porfolio.parallel
# there's still a lot to do to improve this.
@@ -122,10 +125,45 @@
risk.column = pmatch(risk.col,columnnames)
}
- if(is.na(return.column) | is.na(risk.column)) stop(return.col,' or ',risk.col, ' do not match extractStats output')
+ # if(is.na(return.column) | is.na(risk.column)) stop(return.col,' or ',risk.col, ' do not match extractStats output')
+ # If the user has passed in return.col or risk.col that does not match extractStats output
+ # This will give the flexibility of passing in return or risk metrics that are not
+ # objective measures in the optimization. This may cause issues with the "neighbors"
+ # functionality since that is based on the "out" column
+ if(is.na(return.column) | is.na(risk.column)){
+ return.col <- gsub("\\..*", "", return.col)
+ risk.col <- gsub("\\..*", "", risk.col)
+ warning(return.col,' or ', risk.col, ' do not match extractStats output of $objective_measures slot')
+ # Get the matrix of weights for applyFUN
+ wts_index <- grep("w.", columnnames)
+ wts <- xtract[, wts_index]
+ if(is.na(return.column)){
+ tmpret <- applyFUN(R=R, weights=wts, FUN=return.col)
+ xtract <- cbind(tmpret, xtract)
+ colnames(xtract)[which(colnames(xtract) == "tmpret")] <- return.col
+ }
+ if(is.na(risk.column)){
+ tmprisk <- applyFUN(R=R, weights=wts, FUN=risk.col)
+ xtract <- cbind(tmprisk, xtract)
+ colnames(xtract)[which(colnames(xtract) == "tmprisk")] <- risk.col
+ }
+ columnnames = colnames(xtract)
+ return.column = pmatch(return.col,columnnames)
+ if(is.na(return.column)) {
+ return.col = paste(return.col,return.col,sep='.')
+ return.column = pmatch(return.col,columnnames)
+ }
+ risk.column = pmatch(risk.col,columnnames)
+ if(is.na(risk.column)) {
+ risk.col = paste(risk.col,risk.col,sep='.')
+ risk.column = pmatch(risk.col,columnnames)
+ }
+ }
+ # print(colnames(head(xtract)))
+
plot(xtract[,risk.column],xtract[,return.column], xlab=risk.col, ylab=return.col, col="darkgray", axes=FALSE, ...)
-
+
if(!is.null(neighbors)){
if(is.vector(neighbors)){
if(length(neighbors)==1){
@@ -178,8 +216,19 @@
risk.col = paste(risk.col,risk.col,sep='.')
risk.column = pmatch(risk.col,names(objcols))
}
- if(is.na(return.column) | is.na(risk.column)) warning(return.col,' or ',risk.col, ' do not match extractStats output of $objective_measures slot')
- points(objcols[risk.column], objcols[return.column], col="blue", pch=16) # optimal
+ # risk and return metrics for the optimal weights if the RP object does not
+ # contain the metrics specified by return.col or risk.col
+ if(is.na(return.column) | is.na(risk.column)){
+ return.col <- gsub("\\..*", "", return.col)
+ risk.col <- gsub("\\..*", "", risk.col)
+ # warning(return.col,' or ', risk.col, ' do not match extractStats output of $objective_measures slot')
+ opt_weights <- RP$weights
+ ret <- as.numeric(applyFUN(R=R, weights=opt_weights, FUN=return.col))
+ risk <- as.numeric(applyFUN(R=R, weights=opt_weights, FUN=risk.col))
+ points(risk, ret, col="blue", pch=16) #optimal
+ } else {
+ points(objcols[risk.column], objcols[return.column], col="blue", pch=16) # optimal
+ }
axis(1, cex.axis = cex.axis, col = element.color)
axis(2, cex.axis = cex.axis, col = element.color)
box(col = element.color)
Modified: pkg/PortfolioAnalytics/man/chart.Scatter.RP.Rd
===================================================================
--- pkg/PortfolioAnalytics/man/chart.Scatter.RP.Rd 2013-08-10 12:07:34 UTC (rev 2761)
+++ pkg/PortfolioAnalytics/man/chart.Scatter.RP.Rd 2013-08-10 14:15:12 UTC (rev 2762)
@@ -2,7 +2,7 @@
\alias{chart.Scatter.RP}
\title{classic risk return scatter of random portfolios}
\usage{
- chart.Scatter.RP(RP, neighbors = NULL,
+ chart.Scatter.RP(RP, R = NULL, neighbors = NULL,
return.col = "mean", risk.col = "ES", ...,
element.color = "darkgray", cex.axis = 0.8)
}
@@ -10,6 +10,11 @@
\item{RP}{set of portfolios created by
\code{\link{optimize.portfolio}}}
+ \item{R}{an optional an xts, vector, matrix, data frame,
+ timeSeries or zoo object of asset returns, used to
+ recalulate the objective function when return.col or
+ risk.col is not part of the extractStats output.}
+
\item{neighbors}{set of 'neighbor' portfolios to
overplot, see Details}
More information about the Returnanalytics-commits
mailing list