[Returnanalytics-commits] r3240 - pkg/PortfolioAnalytics/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Oct 25 19:05:03 CEST 2013
Author: rossbennett34
Date: 2013-10-25 19:05:02 +0200 (Fri, 25 Oct 2013)
New Revision: 3240
Modified:
pkg/PortfolioAnalytics/R/extract.efficient.frontier.R
pkg/PortfolioAnalytics/R/optFUN.R
pkg/PortfolioAnalytics/R/optimize.portfolio.R
Log:
Modifications for max Sharpe Ratio, max STARR, and efficient frontiers.
Modified: pkg/PortfolioAnalytics/R/extract.efficient.frontier.R
===================================================================
--- pkg/PortfolioAnalytics/R/extract.efficient.frontier.R 2013-10-23 17:54:52 UTC (rev 3239)
+++ pkg/PortfolioAnalytics/R/extract.efficient.frontier.R 2013-10-25 17:05:02 UTC (rev 3240)
@@ -100,7 +100,7 @@
if(objnames == "mean"){
# The user has only passed in a mean objective, add a var objective to the portfolio
portfolio <- add.objective(portfolio=portfolio, type="risk", name="var")
- } else if(objnames == "var"){
+ } else if(objnames %in% c("var", "sd", "StdDev")){
# The user has only passed in a var objective, add a mean objective
portfolio <- add.objective(portfolio=portfolio, type="return", name="mean")
}
Modified: pkg/PortfolioAnalytics/R/optFUN.R
===================================================================
--- pkg/PortfolioAnalytics/R/optFUN.R 2013-10-23 17:54:52 UTC (rev 3239)
+++ pkg/PortfolioAnalytics/R/optFUN.R 2013-10-25 17:05:02 UTC (rev 3240)
@@ -353,14 +353,15 @@
if(all(moments$mean == 0)){
moments$mean <- colMeans(R)
}
+ } else {
+ moments$mean <- rep(0, N)
+ target <- 0
}
- Rmin <- ifelse(is.na(target), 0, target)
-
Amat <- cbind(rbind(1, 1, moments$mean, coredata(R)), rbind(0, 0, 0, cbind(diag(T), 1)))
dir.vec <- c(">=","<=",">=",rep(">=",T))
- rhs.vec <- c(constraints$min_sum, constraints$max_sum, Rmin ,rep(0, T))
-
+ rhs.vec <- c(constraints$min_sum, constraints$max_sum, target ,rep(0, T))
+
if(try(!is.null(constraints$groups), silent=TRUE)){
n.groups <- length(constraints$groups)
Amat.group <- matrix(0, nrow=n.groups, ncol=N)
@@ -833,6 +834,7 @@
ub_etl <- as.numeric(ub_etl$out)
# starr at the upper bound
ub_starr <- ub_mean / ub_etl
+ if(is.infinite(ub_starr)) stop("Inf value for STARR, objective value is 0")
# Find the starr at the minimum etl portfolio
if(!is.null(constraints$max_pos)){
@@ -840,20 +842,29 @@
} else {
lb_etl <- etl_opt(R=R, constraints=constraints, moments=moments, target=NA, alpha=alpha)
}
- lb_weights <- matrix(lb_etl$weights)
- lb_mean <- as.numeric(t(lb_weights) %*% fmean)
+ lb_weights <- matrix(lb_etl$weights)
+ lb_mean <- as.numeric(t(lb_weights) %*% fmean)
lb_etl <- as.numeric(lb_etl$out)
+
# starr at the lower bound
lb_starr <- lb_mean / lb_etl
+ # if(is.infinite(lb_starr)) stop("Inf value for STARR, objective value is 0")
+ # set lb_starr equal to 0, should this be a negative number like -1e6?
+ # the lb_* values will be 0 for a dollar-neutral strategy so we need to reset the values
+ if(is.na(lb_starr) | is.infinite(lb_starr)) lb_starr <- 0
+
+ # cat("ub_starr", ub_starr, "\n")
+ # cat("lb_starr", lb_starr, "\n")
+
# want to find the return that maximizes mean / etl
i <- 1
while((abs(ub_starr - lb_starr) > tol) & (i < maxit)){
# bisection method to find the maximum mean / etl
# print(i)
- # print(ub_starr)
- # print(lb_starr)
+ # cat("ub_starr", ub_starr, "\n")
+ # cat("lb_starr", lb_starr, "\n")
# print("**********")
# Find the starr at the mean return midpoint
new_ret <- (lb_mean + ub_mean) / 2
@@ -920,13 +931,19 @@
ub_sr <- ub_mean / ub_sd
# Calculate the sr at the miminum var portfolio
- lb_sr <- gmv_opt(R=R, constraints=constraints, moments=moments, lambda=1e6, target=NA, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
+ tmpmoments <- moments
+ tmpmoments$mean <- rep(0, length(moments$mean))
+ lb_sr <- gmv_opt(R=R, constraints=constraints, moments=tmpmoments, lambda=1, target=NA, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
lb_weights <- matrix(lb_sr$weights)
lb_mean <- as.numeric(t(lb_weights) %*% fmean)
lb_sd <- as.numeric(sqrt(t(lb_weights) %*% moments$var %*% lb_weights))
# sr at the lower bound
lb_sr <- lb_mean / lb_sd
+ # cat("lb_mean:", lb_mean, "\n")
+ # cat("ub_mean:", ub_mean, "\n")
+ # print("**********")
+
# want to find the return that maximizes mean / sd
i <- 1
while((abs(ub_sr - lb_sr) > tol) & (i < maxit)){
@@ -934,7 +951,7 @@
# Find the starr at the mean return midpoint
new_ret <- (lb_mean + ub_mean) / 2
- mid <- gmv_opt(R=R, constraints=constraints, moments=moments, lambda=1, target=new_ret, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
+ mid <- gmv_opt(R=R, constraints=constraints, moments=tmpmoments, lambda=1, target=new_ret, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
mid_weights <- matrix(mid$weights, ncol=1)
mid_mean <- as.numeric(t(mid_weights) %*% fmean)
mid_sd <- as.numeric(sqrt(t(mid_weights) %*% moments$var %*% mid_weights))
@@ -942,7 +959,8 @@
# tmp_sr <- mid_sr
# print(i)
- # print(mid_sr)
+ # cat("new_ret:", new_ret, "\n")
+ # cat("mid_sr:", mid_sr, "\n")
# print("**********")
if(mid_sr > ub_sr){
@@ -950,7 +968,7 @@
ub_mean <- mid_mean
ub_sr <- mid_sr
new_ret <- (lb_mean + ub_mean) / 2
- mid <- gmv_opt(R=R, constraints=constraints, moments=moments, lambda=1, target=new_ret, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
+ mid <- gmv_opt(R=R, constraints=constraints, moments=tmpmoments, lambda=1, target=new_ret, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
mid_weights <- matrix(mid$weights, ncol=1)
mid_mean <- as.numeric(t(mid_weights) %*% fmean)
mid_sd <- as.numeric(sqrt(t(mid_weights) %*% moments$var %*% mid_weights))
@@ -960,7 +978,7 @@
lb_mean <- mid_mean
lb_sr <- mid_sr
new_ret <- (lb_mean + ub_mean) / 2
- mid <- gmv_opt(R=R, constraints=constraints, moments=moments, lambda=1, target=new_ret, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
+ mid <- gmv_opt(R=R, constraints=constraints, moments=tmpmoments, lambda=1, target=new_ret, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
mid_weights <- matrix(mid$weights, ncol=1)
mid_mean <- as.numeric(t(mid_weights) %*% fmean)
mid_sd <- as.numeric(sqrt(t(mid_weights) %*% moments$var %*% mid_weights))
Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R
===================================================================
--- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-10-23 17:54:52 UTC (rev 3239)
+++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-10-25 17:05:02 UTC (rev 3240)
@@ -805,6 +805,7 @@
if(hasArg(maxSR)) maxSR=match.call(expand.dots=TRUE)$maxSR else maxSR=FALSE
if(maxSR){
target <- max_sr_opt(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, lambda_hhi=lambda_hhi, conc_groups=conc_groups)
+ moments$mean <- rep(0, length(moments$mean))
}
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
More information about the Returnanalytics-commits
mailing list