[Returnanalytics-commits] r3202 - in pkg/PortfolioAnalytics: R demo
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Oct 3 17:17:33 CEST 2013
Author: rossbennett34
Date: 2013-10-03 17:17:32 +0200 (Thu, 03 Oct 2013)
New Revision: 3202
Modified:
pkg/PortfolioAnalytics/R/charts.risk.R
pkg/PortfolioAnalytics/R/extractstats.R
pkg/PortfolioAnalytics/demo/demo_opt_combine.R
Log:
Modifying extractObjectiveMeasures for opt.list objects to evaluate each portfolio at all objectives. Modified barplot for risk budgets. Modified demo_opt_combine for more complete demo.
Modified: pkg/PortfolioAnalytics/R/charts.risk.R
===================================================================
--- pkg/PortfolioAnalytics/R/charts.risk.R 2013-10-03 14:28:16 UTC (rev 3201)
+++ pkg/PortfolioAnalytics/R/charts.risk.R 2013-10-03 15:17:32 UTC (rev 3202)
@@ -406,7 +406,7 @@
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, ...)
+ 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)
Modified: pkg/PortfolioAnalytics/R/extractstats.R
===================================================================
--- pkg/PortfolioAnalytics/R/extractstats.R 2013-10-03 14:28:16 UTC (rev 3201)
+++ pkg/PortfolioAnalytics/R/extractstats.R 2013-10-03 15:17:32 UTC (rev 3202)
@@ -407,28 +407,73 @@
#' @method extractObjectiveMeasures opt.list
#' @S3method extractObjectiveMeasures opt.list
extractObjectiveMeasures.opt.list <- function(object){
+ # The idea is that these portfolios in all have different objectives.
+ # Need a function to evaluate *all* objective measures for each portfolio.
+ # Challenges:
+ # - allow for different R objects across portfolios
+ # - Done
+ # - detect and remove duplicate objectives
+ # - Done based on name and objective type
+ # - handle duplicate objective names, but different arguments (i.e. different p for ES)
+ # - TODO
+ # - risk budget objectives need to be entered last
+ # - Done
if(!inherits(object, "opt.list")) stop("object must be of class 'opt.list'")
- # get/set the names in the object
- opt_names <- names(object)
- if(is.null(opt_names)) opt_names <- paste("opt", 1:length(object))
+ # Get the names of the list
+ opt.names <- names(object)
+ if(is.null(opt.names)) opt.names <- paste("portfolio", 1:length(object))
- obj_list <- list()
+ # Initialize a tmp.obj list to store all of the objectives from each
+ tmp.obj <- list()
+ tmp.budget <- list()
+
+ # Step 1: Loop through object and get the objectives from each portfolio
for(i in 1:length(object)){
- tmp <- unlist(object[[i]]$objective_measures)
- names(tmp) <- PortfolioAnalytics:::name.replace(names(tmp))
- obj_list[[opt_names[i]]] <- tmp
- }
- obj_list
+ tmp.portf <- object[[i]]$portfolio
+ for(j in 1:length(tmp.portf$objectives)){
+ if(inherits(tmp.portf$objectives[[j]], "risk_budget_objective")){
+ # tmp.budget <- c(tmp.budget, tmp.portf$objectives[[j]])
+ num.budget <- length(tmp.budget) + 1
+ tmp.budget[[num.budget]] <- tmp.portf$objectives[[j]]
+ } else {
+ # tmp.obj <- c(tmp.obj, tmp.portf$objectives[[j]])
+ num.obj <- length(tmp.obj) + 1
+ tmp.obj[[num.obj]] <- tmp.portf$objectives[[j]]
+ }
+ } # end inner loop of objectives
+ } # end outer loop of object
- obj_names <- unique(unlist(lapply(obj_list, names)))
+ # This will make sure that "risk_budget_objectives" are entered last, but doesn't
+ # address duplicate names with different arguments in the arguments list
+ # e.g. different arguments for p, clean, etc.
+ tmp.obj <- c(tmp.obj, tmp.budget)
- obj_mat <- matrix(NA, nrow=length(obj_list), ncol=length(obj_names),
- dimnames=list(opt_names, obj_names))
+ # Remove any duplicates
+ # The last objective will be the one that is kept
+ out.obj <- list()
+ obj.names <- sapply(tmp.obj, function(x) paste(x$name, class(x)[1], sep="."))
+ if(any(duplicated(obj.names))){
+ idx <- which(!duplicated(obj.names, fromLast=TRUE))
+ for(i in 1:length(idx)){
+ out.obj[[i]] <- tmp.obj[[idx[i]]]
+ }
+ }
+ out.obj
- for(i in 1:length(obj_list)){
- pm <- pmatch(x=names(obj_list[[i]]), table=obj_names)
- obj_mat[i, pm] <- obj_list[[i]]
+ # Loop through object and insert the new objectives list into each portfolio
+ # and run constrained_objective on each portfolio to extract the
+ # objective_measures for each portfolio
+ out <- list()
+ for(i in 1:length(object)){
+ object[[i]]$portfolio$objectives <- tmp.obj
+ tmp.weights <- object[[i]]$weights
+ tmp.R <- object[[i]]$R
+ tmp.portf <- object[[i]]$portfolio
+ tmp <- unlist(constrained_objective(w=tmp.weights, R=tmp.R, portfolio=tmp.portf, trace=TRUE)$objective_measures)
+ names(tmp) <- PortfolioAnalytics:::name.replace(names(tmp))
+ out[[opt.names[i]]] <- tmp
}
- return(obj_mat)
+ out <- do.call(rbind, out)
+ return(out)
}
Modified: pkg/PortfolioAnalytics/demo/demo_opt_combine.R
===================================================================
--- pkg/PortfolioAnalytics/demo/demo_opt_combine.R 2013-10-03 14:28:16 UTC (rev 3201)
+++ pkg/PortfolioAnalytics/demo/demo_opt_combine.R 2013-10-03 15:17:32 UTC (rev 3202)
@@ -1,47 +1,58 @@
-
library(PortfolioAnalytics)
-library(ROI)
-library(ROI.plugin.glpk)
-library(ROI.plugin.quadprog)
-
-# We should be able to compare portfolios with different constraints,
-# objectives, and number of assets
-
+library(DEoptim)
data(edhec)
-R <- edhec[, 1:4]
+R <- edhec[, 1:5]
funds <- colnames(R)
-##### Construct Portfolios #####
-# GMV long only
-port.gmv.lo <- portfolio.spec(assets=funds)
-port.gmv.lo <- add.constraint(portfolio=port.gmv.lo, type="full_investment")
-port.gmv.lo <- add.constraint(portfolio=port.gmv.lo, type="long_only")
-port.gmv.lo <- add.objective(portfolio=port.gmv.lo, type="risk", name="var")
+# Test different portfolios to test combining optimizations
-# GMV with shorting
-port.gmv.short <- portfolio.spec(assets=funds)
-port.gmv.short <- add.constraint(portfolio=port.gmv.short, type="full_investment")
-port.gmv.short <- add.constraint(portfolio=port.gmv.short, type="box", min=-0.3, max=1)
-port.gmv.short <- add.objective(portfolio=port.gmv.short, type="risk", name="var")
+# Add some basic constraints
+init.portf <- portfolio.spec(assets=funds)
+init.portf <- add.constraint(portfolio=init.portf, type="leverage", min_sum=0.99, max_sum=1.01)
+init.portf <- add.constraint(portfolio=init.portf, type="long_only")
-# QU box constraints
-port.qu <- portfolio.spec(assets=funds)
-port.qu <- add.constraint(portfolio=port.qu, type="full_investment")
-port.qu <- add.constraint(portfolio=port.qu, type="box", min=0.05, max=0.6)
-port.qu <- add.objective(portfolio=port.qu, type="risk", name="var", risk_aversion=0.25)
-port.qu <- add.objective(portfolio=port.qu, type="return", name="mean")
+# Objective to maximize portfolio mean return per unit ES
+MeanES.portf <- add.objective(portfolio=init.portf, type="return", name="mean")
+MeanES.portf <- add.objective(portfolio=MeanES.portf, type="risk", name="ES")
-##### Run Optimizations #####
-opt.gmv.lo <- optimize.portfolio(R=R, portfolio=port.gmv.lo, optimize_method="ROI", trace=TRUE)
-opt.gmv.short <- optimize.portfolio(R=R, portfolio=port.gmv.short, optimize_method="ROI", trace=TRUE)
-opt.qu <- optimize.portfolio(R=R, portfolio=port.qu, optimize_method="ROI", trace=TRUE)
+# Objective to maximize mean with risk budget percent contribution limit
+MeanSD.portf <- add.objective(portfolio=init.portf, type="return", name="mean")
+MeanSD.portf <- add.objective(portfolio=MeanSD.portf, type="risk_budget", name="StdDev", max_prisk=0.35)
+# Objective to minimize portfolio expected shortfall with equal ES component contribution
+ESRB.portf <- add.objective(portfolio=init.portf, type="risk", name="ES")
+ESRB.portf <- add.objective(portfolio=ESRB.portf, type="risk_budget", name="ES", min_concentration=TRUE)
-opt <- combine.optimizations(list(GMV.LO=opt.gmv.lo, GMV.SHORT=opt.gmv.short, QU=opt.qu))
-class(opt)
-chart.Weights(opt, legend.loc="topleft", cex.legend=0.8, ylim=c(-0.3, 1))
+# MeanES optimization
+MeanES.opt <- optimize.portfolio(R=R, portfolio=MeanES.portf, optimize_method="DEoptim", search_size=2000,, trace=TRUE)
-chart.Weights(opt, plot.type="bar", cex.lab=0.8, legend.loc="topleft", cex.legend=0.8, ylim=c(-0.3, 1))
+# MeanSD optimization
+MeanSD.opt <- optimize.portfolio(R=R, portfolio=MeanSD.portf, optimize_method="DEoptim", search_size=2000, trace=TRUE)
-extractWeights(opt)
+# ESRB optimization
+ESRB.opt <- optimize.portfolio(R=R, portfolio=ESRB.portf, optimize_method="DEoptim", search_size=2000, trace=TRUE)
+
+# Combine the optimizations
+opt <- combine.optimizations(list(MeanES=MeanES.opt, MeanSD=MeanSD.opt, ESRB=ESRB.opt))
+
+# Extract the objective measures from each optimize.portfolio object evaluated at all objectives
+obj <- extractObjectiveMeasures(opt)
+
+# Extract the optimal weights from each optimize.portfolio object
+weights <- extractWeights(opt)
+
+# Chart the risk contributions for StdDev and ES
+chart.RiskBudget(opt, match.col="StdDev", risk.type="percentage", ylim=c(0,1), legend.loc="topright")
+chart.RiskBudget(opt, match.col="ES", risk.type="percentage", ylim=c(-0.2,1), legend.loc="topright")
+chart.RiskBudget(opt, match.col="ES", risk.type="percentage", plot.type="bar", ylim=c(-0.2,1), legend.loc="topright")
+
+# Chart the optimal weights from each optimize.portfolio object
+chart.Weights(opt, ylim=c(0,1))
+chart.Weights(opt, plot.type="bar", ylim=c(0,1))
+
+# Chart the optimal portfolios in risk-reward space
+chart.RiskReward(opt, main="Optimal Portfolios")
+chart.RiskReward(opt, risk.col="StdDev", main="Optimal Portfolios")
+
+
More information about the Returnanalytics-commits
mailing list