[Returnanalytics-commits] r2984 - in pkg/PortfolioAnalytics: . R man sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 4 06:31:31 CEST 2013
Author: rossbennett34
Date: 2013-09-04 06:31:31 +0200 (Wed, 04 Sep 2013)
New Revision: 2984
Added:
pkg/PortfolioAnalytics/man/HHI.Rd
pkg/PortfolioAnalytics/man/weight_concentration_objective.Rd
pkg/PortfolioAnalytics/sandbox/testing_weight_conc.R
Modified:
pkg/PortfolioAnalytics/NAMESPACE
pkg/PortfolioAnalytics/R/constraints.R
pkg/PortfolioAnalytics/R/generics.R
pkg/PortfolioAnalytics/R/objective.R
pkg/PortfolioAnalytics/R/objectiveFUN.R
pkg/PortfolioAnalytics/R/optFUN.R
pkg/PortfolioAnalytics/R/optimize.portfolio.R
pkg/PortfolioAnalytics/man/diversification_constraint.Rd
pkg/PortfolioAnalytics/man/gmv_opt.Rd
Log:
Adding functionality for weight_concentration objective as penalty in quadratic objective for QP problems based on King paper.
Modified: pkg/PortfolioAnalytics/NAMESPACE
===================================================================
--- pkg/PortfolioAnalytics/NAMESPACE 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/NAMESPACE 2013-09-04 04:31:31 UTC (rev 2984)
@@ -131,4 +131,5 @@
export(update_constraint_v1tov2)
export(update.constraint)
export(var.portfolio)
+export(weight_concentration_objective)
export(weight_sum_constraint)
Modified: pkg/PortfolioAnalytics/R/constraints.R
===================================================================
--- pkg/PortfolioAnalytics/R/constraints.R 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/R/constraints.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -784,8 +784,6 @@
#'
#' @param type character type of the constraint
#' @param div_target diversification target value
-#' @param conc_aversion concentration aversion parameter. Penalizes over
-#' concentration for quadratic utility and minimum variance problems.
#' @param enabled TRUE/FALSE
#' @param message TRUE/FALSE. The default is message=FALSE. Display messages if TRUE.
#' @param \dots any other passthru parameters to specify box and/or group constraints
@@ -799,10 +797,9 @@
#'
#' pspec <- add.constraint(portfolio=pspec, type="diversification", div_target=0.7)
#' @export
-diversification_constraint <- function(type="diversification", div_target=NULL, conc_aversion=NULL, enabled=TRUE, message=FALSE, ...){
+diversification_constraint <- function(type="diversification", div_target=NULL, enabled=TRUE, message=FALSE, ...){
Constraint <- constraint_v2(type, enabled=enabled, constrclass="diversification_constraint", ...)
Constraint$div_target <- div_target
- Constraint$conc_aversion <- conc_aversion
return(Constraint)
}
Modified: pkg/PortfolioAnalytics/R/generics.R
===================================================================
--- pkg/PortfolioAnalytics/R/generics.R 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/R/generics.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -256,6 +256,18 @@
for(i in 1:length(objective_measures)){
print(tmp_obj[i], digits=4)
cat("\n")
+ if(length(objective_measures[[i]]) > 1){
+ # This will be the case for any objective measures with HHI for QP problems
+ for(j in 2:length(objective_measures[[i]])){
+ tmpl <- objective_measures[[i]][j]
+ cat(names(tmpl), ":\n")
+ tmpv <- unlist(tmpl)
+ # names(tmpv) <- names(x$weights)
+ print(tmpv)
+ cat("\n")
+ }
+ }
+ cat("\n")
}
cat("\n")
}
Modified: pkg/PortfolioAnalytics/R/objective.R
===================================================================
--- pkg/PortfolioAnalytics/R/objective.R 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/R/objective.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -106,6 +106,12 @@
arguments=arguments,
...=...)
},
+ weight_conc=, weight_concentration =
+ {tmp_objective = weight_concentration_objective(name=name,
+ enabled=enabled,
+ arguments=arguments,
+ ...=...)
+ },
null =
{return(constraints)} # got nothing, default to simply returning
@@ -182,6 +188,12 @@
portfolio$objectives <- c(portfolio$objectives, tmp_objective)
return(portfolio)
},
+ weight_conc=, weight_concentration =
+ {tmp_objective = weight_concentration_objective(name=name,
+ enabled=enabled,
+ arguments=arguments,
+ ...=...)
+ },
null =
{return(portfolio)} # got nothing, default to simply returning
) # end objective type switch
@@ -410,6 +422,51 @@
return(qu)
} # end quadratic utility objective constructor
+#' Constructor for weight concentration objective
+#'
+#' This function penalizes weight concentration using the Herfindahl-Hirschman Index
+#' as a measure of concentration.
+#'
+#' The \code{conc_aversion} argument can be a scalar or vector of concentration
+#' aversion values If \code{conc_aversion} is a scalar and \code{conc_groups} is
+#' \code{NULL}, then the concentration aversion value will be applied to the overall
+#' weights.
+#'
+#' If \code{conc_groups} is specified as an argument, then the concentration
+#' aversion value(s) will be applied to each group.
+#'
+#' @param name name of concentration measure, currently only "HHI" is supported.
+#' @param conc_aversion concentration aversion value(s)
+#' @param conc_groups list of vectors specifying the groups of the assets. Similar
+#' to \code{groups} in \code{\link{group_constraint}}
+#' @param arguments default arguments to be passed to an objective function when executed
+#' @param enabled TRUE/FALSE
+#' @param \dots any other passthru parameters
+#' @author Ross Bennett
+#' @export
+weight_concentration_objective <- function(name, conc_aversion, conc_groups=NULL, arguments=NULL, enabled=TRUE, ...){
+ # TODO: write HHI function to be used by global solvers in constrained_objective
+
+ # check if conc_groups is specified as an argument
+ if(!is.null(conc_groups)){
+ arguments$groups <- conc_groups
+ if(!is.list(conc_groups)) stop("conc_groups must be passed in as a list")
+
+ if(length(conc_aversion) == 1){
+ # if conc_aversion is a scalar, replicate to the number of groups
+ conc_aversion <- rep(conc_aversion, length(conc_groups))
+ }
+ # length of conc_aversion must be equal to the length of conc_groups
+ if(length(conc_aversion) != length(conc_groups)) stop("length of conc_aversion must be equal to length of groups")
+ } else if(is.null(conc_groups)){
+ if(length(conc_aversion) != 1) stop("conc_aversion must be a scalar value when conc_groups are not specified")
+ }
+ Objective <- objective(name=name, enabled=enabled, arguments=arguments, objclass=c("weight_concentration_objective","objective"), ... )
+ Objective$conc_aversion <- conc_aversion
+ Objective$conc_groups <- conc_groups
+ return(Objective)
+}
+
#' Insert a list of objectives into the objectives slot of a portfolio object
#'
#' @param portfolio object of class 'portfolio'
Modified: pkg/PortfolioAnalytics/R/objectiveFUN.R
===================================================================
--- pkg/PortfolioAnalytics/R/objectiveFUN.R 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/R/objectiveFUN.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -36,3 +36,29 @@
weights <- matrix(weights, ncol=1)
return(as.numeric(t(weights) %*% var(R) %*% weights))
}
+
+#' Function to calculate weight concentration
+#'
+#' This function calculates the concentration of weights using the
+#' Herfindahl–Hirschman Index as a measure of concentration
+#'
+#' @param weights
+#' @param groups
+#' @author Ross Bennett
+HHI <- function(weights, groups=NULL){
+
+ # calculate overall HHI
+ hhi <- sum(weights^2)
+
+ # calculate group HHI
+ if(!is.null(groups)){
+ ngroups <- length(groups)
+ group_hhi <- rep(0, ngroups)
+ for(i in 1:ngroups){
+ group_hhi[i] <- sum(weights[groups[[i]]]^2)
+ }
+ return(list(hhi=hhi, group_hhi=group_hhi))
+ } else {
+ return(hhi)
+ }
+}
\ No newline at end of file
Modified: pkg/PortfolioAnalytics/R/optFUN.R
===================================================================
--- pkg/PortfolioAnalytics/R/optFUN.R 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/R/optFUN.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -10,9 +10,10 @@
#' @param lambda risk_aversion parameter
#' @param target target return value
#' @param lambda_hhi concentration aversion parameter
+#' @param conc_groups list of vectors specifying the groups of the assets.
#' @author Ross Bennett
-gmv_opt <- function(R, constraints, moments, lambda, target, lambda_hhi){
-
+gmv_opt <- function(R, constraints, moments, lambda, target, lambda_hhi, conc_groups){
+
N <- ncol(R)
# Applying box constraints
bnds <- list(lower=list(ind=seq.int(1L, N), val=as.numeric(constraints$min)),
@@ -59,8 +60,24 @@
}
# set up the quadratic objective
- if(!is.null(constraints$conc_aversion)){
- ROI_objective <- Q_objective(Q=2*lambda*moments$var + lambda_hhi * diag(N), L=-moments$mean)
+ if(!is.null(lambda_hhi)){
+ if(length(lambda_hhi) == 1 & is.null(conc_groups)){
+ ROI_objective <- Q_objective(Q=2*lambda*moments$var + lambda_hhi * diag(N), L=-moments$mean)
+ } else if(!is.null(conc_groups)){
+ # construct the matrix with concentration aversion values by group
+ hhi_mat <- matrix(0, nrow=N, ncol=N)
+ vec <- 1:N
+ for(i in 1:length(conc_groups)){
+ tmpI <- diag(N)
+ tmpvec <- conc_groups[[i]]
+ zerovec <- setdiff(vec, tmpvec)
+ for(j in 1:length(zerovec)){
+ tmpI[zerovec[j], ] <- rep(0, N)
+ }
+ hhi_mat <- hhi_mat + lambda_hhi[i] * tmpI
+ }
+ ROI_objective <- Q_objective(Q=2*lambda*moments$var + hhi_mat, L=-moments$mean)
+ }
} else {
ROI_objective <- Q_objective(Q=2*lambda*moments$var, L=-moments$mean)
}
Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R
===================================================================
--- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -704,15 +704,17 @@
} else {
target <- NA
}
- if(!is.null(constraints$conc_aversion)){
- lambda_hhi <- constraints$conc_aversion
- } else {
- lambda_hhi <- 0
- }
+ # comment out so concentration aversion can only be specified as an objective
+ # because it is added to the quadratic objective term for QP problems (minvar and qu)
+ # if(!is.null(constraints$conc_aversion)){
+ # lambda_hhi <- constraints$conc_aversion
+ #} else {
+ # lambda_hhi <- 0
+ #}
lambda <- 1
for(objective in portfolio$objectives){
if(objective$enabled){
- if(!any(c(objective$name == "mean", objective$name == "var", objective$name == "CVaR", objective$name == "ES", objective$name == "ETL")))
+ if(!any(c(objective$name == "HHI", objective$name == "mean", objective$name == "var", objective$name == "CVaR", objective$name == "ES", objective$name == "ETL")))
stop("ROI only solves mean, var, or sample ETL/ES/CVaR type business objectives, choose a different optimize_method.")
# I'm not sure what changed, but moments$mean used to be a vector of the column means
# now it is a scalar value of the mean of the entire R object
@@ -724,6 +726,8 @@
target <- ifelse(!is.null(objective$target), objective$target, target)
alpha <- ifelse(!is.null(objective$alpha), objective$alpha, alpha)
lambda <- ifelse(!is.null(objective$risk_aversion), objective$risk_aversion, lambda)
+ if(!is.null(objective$conc_aversion)) lambda_hhi <- objective$conc_aversion else lambda_hhi <- NULL
+ if(!is.null(objective$conc_groups)) conc_groups <- objective$conc_groups else conc_groups <- NULL
}
}
if("var" %in% names(moments)){
@@ -735,7 +739,7 @@
obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=roi_result$out, call=call)
} else {
- roi_result <- gmv_opt(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, lambda_hhi=lambda_hhi)
+ roi_result <- gmv_opt(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
weights <- roi_result$weights
obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=roi_result$out, call=call)
Added: pkg/PortfolioAnalytics/man/HHI.Rd
===================================================================
--- pkg/PortfolioAnalytics/man/HHI.Rd (rev 0)
+++ pkg/PortfolioAnalytics/man/HHI.Rd 2013-09-04 04:31:31 UTC (rev 2984)
@@ -0,0 +1,20 @@
+\name{HHI}
+\alias{HHI}
+\title{Function to calculate weight concentration}
+\usage{
+ HHI(weights, groups = NULL)
+}
+\arguments{
+ \item{weights}{}
+
+ \item{groups}{}
+}
+\description{
+ This function calculates the concentration of weights
+ using the Herfindahl–Hirschman Index as a measure of
+ concentration
+}
+\author{
+ Ross Bennett
+}
+
Modified: pkg/PortfolioAnalytics/man/diversification_constraint.Rd
===================================================================
--- pkg/PortfolioAnalytics/man/diversification_constraint.Rd 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/man/diversification_constraint.Rd 2013-09-04 04:31:31 UTC (rev 2984)
@@ -3,18 +3,14 @@
\title{constructor for diversification_constraint}
\usage{
diversification_constraint(type = "diversification",
- div_target = NULL, conc_aversion = NULL,
- enabled = TRUE, message = FALSE, ...)
+ div_target = NULL, enabled = TRUE, message = FALSE,
+ ...)
}
\arguments{
\item{type}{character type of the constraint}
\item{div_target}{diversification target value}
- \item{conc_aversion}{concentration aversion parameter.
- Penalizes over concentration for quadratic utility and
- minimum variance problems.}
-
\item{enabled}{TRUE/FALSE}
\item{message}{TRUE/FALSE. The default is message=FALSE.
Modified: pkg/PortfolioAnalytics/man/gmv_opt.Rd
===================================================================
--- pkg/PortfolioAnalytics/man/gmv_opt.Rd 2013-09-04 00:29:08 UTC (rev 2983)
+++ pkg/PortfolioAnalytics/man/gmv_opt.Rd 2013-09-04 04:31:31 UTC (rev 2984)
@@ -3,7 +3,7 @@
\title{Optimization function to solve minimum variance or maximum quadratic utility problems}
\usage{
gmv_opt(R, constraints, moments, lambda, target,
- lambda_hhi)
+ lambda_hhi, conc_groups)
}
\arguments{
\item{R}{xts object of asset returns}
@@ -19,6 +19,9 @@
\item{target}{target return value}
\item{lambda_hhi}{concentration aversion parameter}
+
+ \item{conc_groups}{list of vectors specifying the groups
+ of the assets.}
}
\description{
This function is called by optimize.portfolio to solve
Added: pkg/PortfolioAnalytics/man/weight_concentration_objective.Rd
===================================================================
--- pkg/PortfolioAnalytics/man/weight_concentration_objective.Rd (rev 0)
+++ pkg/PortfolioAnalytics/man/weight_concentration_objective.Rd 2013-09-04 04:31:31 UTC (rev 2984)
@@ -0,0 +1,44 @@
+\name{weight_concentration_objective}
+\alias{weight_concentration_objective}
+\title{Constructor for weight concentration objective}
+\usage{
+ weight_concentration_objective(name, conc_aversion,
+ conc_groups = NULL, arguments = NULL, enabled = TRUE,
+ ...)
+}
+\arguments{
+ \item{name}{name of concentration measure, currently only
+ "HHI" is supported.}
+
+ \item{conc_aversion}{concentration aversion value(s)}
+
+ \item{conc_groups}{list of vectors specifying the groups
+ of the assets. Similar to \code{groups} in
+ \code{\link{group_constraint}}}
+
+ \item{arguments}{default arguments to be passed to an
+ objective function when executed}
+
+ \item{enabled}{TRUE/FALSE}
+
+ \item{\dots}{any other passthru parameters}
+}
+\description{
+ This function penalizes weight concentration using the
+ Herfindahl-Hirschman Index as a measure of concentration.
+}
+\details{
+ The \code{conc_aversion} argument can be a scalar or
+ vector of concentration aversion values If
+ \code{conc_aversion} is a scalar and \code{conc_groups}
+ is \code{NULL}, then the concentration aversion value
+ will be applied to the overall weights.
+
+ If \code{conc_groups} is specified as an argument, then
+ the concentration aversion value(s) will be applied to
+ each group.
+}
+\author{
+ Ross Bennett
+}
+
Added: pkg/PortfolioAnalytics/sandbox/testing_weight_conc.R
===================================================================
--- pkg/PortfolioAnalytics/sandbox/testing_weight_conc.R (rev 0)
+++ pkg/PortfolioAnalytics/sandbox/testing_weight_conc.R 2013-09-04 04:31:31 UTC (rev 2984)
@@ -0,0 +1,50 @@
+library(PortfolioAnalytics)
+library(ROI)
+library(ROI.plugin.quadprog)
+
+# data(edhec)
+# R <- edhec[, 1:4]
+# colnames(R) <- c("CA", "CTAG", "DS", "EM")
+# funds <- colnames(R)
+
+load("~/Desktop/Testing/crsp.short.Rdata")
+R <- cbind(microcap.ts[, 1:2],
+ smallcap.ts[, 1:2],
+ midcap.ts[, 1:2],
+ largecap.ts[, 1:2])
+
+funds <- colnames(R)
+
+cap_labels <- c(rep("MICRO", 2), rep("SMALL", 2),
+ rep("MID", 2), rep("LARGE", 2))
+
+# Create initial portfolio object with category_labels
+init <- portfolio.spec(assets=funds, category_labels=cap_labels)
+# Add some weight constraints
+init <- add.constraint(portfolio=init, type="full_investment")
+init <- add.constraint(portfolio=init, type="long_only")
+# Add objective to minimize variance
+init <- add.objective(portfolio=init, type="risk", name="var")
+
+# Run the optimization with var as the only objective
+opt1 <- optimize.portfolio(R=R, portfolio=init, optimize_method="ROI", trace=TRUE)
+opt1
+
+# Add the weight_concentration objective
+# Set the conc_aversion values to 0 so that we should get the same value as min var
+conc <- add.objective(portfolio=init, type="weight_concentration", name="HHI",
+ conc_aversion=0, conc_groups=init$category_labels)
+
+opt2 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE)
+opt2
+all.equal(opt1$weights, opt2$weights)
+
+# Now change the conc_aversion values to give highest penalty to small cap stocks
+conc$objectives[[2]]$conc_aversion <- c(0.05, 1, 0.1, 0)
+opt3 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE)
+opt3
+
+# If all the conc_aversion values are very high, this should result in an equal weight portfolio
+conc$objectives[[2]]$conc_aversion <- rep(1e6, 4)
+opt4 <- optimize.portfolio(R=R, portfolio=conc, optimize_method="ROI", trace=TRUE)
+opt4
More information about the Returnanalytics-commits
mailing list