[Returnanalytics-commits] r3247 - pkg/PortfolioAnalytics/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 8 07:38:10 CET 2013
Author: rossbennett34
Date: 2013-11-08 07:38:10 +0100 (Fri, 08 Nov 2013)
New Revision: 3247
Modified:
pkg/PortfolioAnalytics/R/optFUN.R
pkg/PortfolioAnalytics/R/optimize.portfolio.R
Log:
Adding option for specifying estimated covariance matrix or estimated mean returns for ROI solvers. Modifying optFUN functions to calculate objective measures instead of calling constrained_objective so that the estimates can be used.
Modified: pkg/PortfolioAnalytics/R/optFUN.R
===================================================================
--- pkg/PortfolioAnalytics/R/optFUN.R 2013-11-08 03:06:29 UTC (rev 3246)
+++ pkg/PortfolioAnalytics/R/optFUN.R 2013-11-08 06:38:10 UTC (rev 3247)
@@ -129,6 +129,23 @@
out <- list()
out$weights <- weights
out$out <- result$value
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # and moments$var that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+ if(!all(moments$mean == 0)){
+ port.mean <- as.numeric(sum(weights * moments$mean))
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ port.sd <- as.numeric(sqrt(t(weights) %*% moments$var %*% weights))
+ names(port.sd) <- "StdDev"
+ obj_vals[["StdDev"]] <- port.sd
+ } else {
+ port.sd <- as.numeric(sqrt(t(weights) %*% moments$var %*% weights))
+ names(port.sd) <- "StdDev"
+ obj_vals[["StdDev"]] <- port.sd
+ }
+ out$obj_vals <- obj_vals
# out$out <- result$objval # ROI
# out$call <- call # need to get the call outside of the function
return(out)
@@ -222,6 +239,14 @@
out <- list()
out$weights <- weights
out$out <- roi.result$objval
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+ port.mean <- -roi.result$objval
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ out$obj_vals <- obj_vals
# out$call <- call # need to get the call outside of the function
return(out)
}
@@ -334,7 +359,16 @@
out <- list()
out$weights <- weights
- out$out <- result$objval
+ out$out <- result$optimum
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+
+ port.mean <- -result$optimum
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ out$obj_vals <- obj_vals
return(out)
}
@@ -410,6 +444,25 @@
out <- list()
out$weights <- weights
out$out <- roi.result$objval
+ es_names <- c("ES", "ETL", "CVaR")
+ es_idx <- which(es_names %in% names(moments))
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # and moments$var that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+ if(!all(moments$mean == 0)){
+ port.mean <- as.numeric(sum(weights * moments$mean))
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ port.es <- roi.result$objval
+ names(port.es) <- es_names[es_idx]
+ obj_vals[[es_names[es_idx]]] <- port.es
+ } else {
+ port.es <- roi.result$objval
+ names(port.es) <- es_names[es_idx]
+ obj_vals[[es_names[es_idx]]] <- port.es
+ }
+ out$obj_vals <- obj_vals
#out$call <- call # add this outside of here, this function doesn't have the call
return(out)
}
@@ -540,6 +593,25 @@
out <- list()
out$weights <- weights
out$out <- result$optimum
+ es_names <- c("ES", "ETL", "CVaR")
+ es_idx <- which(es_names %in% names(moments))
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # and moments$var that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+ if(!all(moments$mean == 0)){
+ port.mean <- as.numeric(sum(weights * moments$mean))
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ port.es <- result$optimum
+ names(port.es) <- es_names[es_idx]
+ obj_vals[[es_names[es_idx]]] <- port.es
+ } else {
+ port.es <- result$optimum
+ names(port.es) <- es_names[es_idx]
+ obj_vals[[es_names[es_idx]]] <- port.es
+ }
+ out$obj_vals <- obj_vals
#out$call <- call # add this outside of here, this function doesn't have the call
return(out)
}
@@ -680,7 +752,24 @@
names(weights) <- colnames(R)
out <- list()
out$weights <- weights
- out$out <- qp.result$val
+ out$out <- qp.result$value
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # and moments$var that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+ if(!all(moments$mean == 0)){
+ port.mean <- as.numeric(sum(weights * moments$mean))
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ port.sd <- as.numeric(sqrt(t(weights) %*% moments$var %*% weights))
+ names(port.sd) <- "StdDev"
+ obj_vals[["StdDev"]] <- port.sd
+ } else {
+ port.sd <- as.numeric(sqrt(t(weights) %*% moments$var %*% weights))
+ names(port.sd) <- "StdDev"
+ obj_vals[["StdDev"]] <- port.sd
+ }
+ out$obj_vals <- obj_vals
return(out)
# TODO
@@ -803,7 +892,24 @@
names(weights) <- colnames(R)
out <- list()
out$weights <- weights
- out$out <- qp.result$val
+ out$out <- qp.result$value
+ obj_vals <- list()
+ # Calculate the objective values here so that we can use the moments$mean
+ # and moments$var that might be passed in by the user. This will avoid
+ # the extra call to constrained_objective
+ if(!all(moments$mean == 0)){
+ port.mean <- as.numeric(sum(weights * moments$mean))
+ names(port.mean) <- "mean"
+ obj_vals[["mean"]] <- port.mean
+ port.sd <- as.numeric(sqrt(t(weights) %*% moments$var %*% weights))
+ names(port.sd) <- "StdDev"
+ obj_vals[["StdDev"]] <- port.sd
+ } else {
+ port.sd <- as.numeric(sqrt(t(weights) %*% moments$var %*% weights))
+ names(port.sd) <- "StdDev"
+ obj_vals[["StdDev"]] <- port.sd
+ }
+ out$obj_vals <- obj_vals
return(out)
# TODO
Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R
===================================================================
--- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-11-08 03:06:29 UTC (rev 3246)
+++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-11-08 06:38:10 UTC (rev 3247)
@@ -765,9 +765,19 @@
# 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
if(objective$name == "mean"){
- moments[[objective$name]] <- try(as.vector(apply(Return.clean(R=R, method=clean), 2, "mean", na.rm=TRUE)), silent=TRUE)
+ if(!is.null(objective$estimate)){
+ print("User has specified an estimated mean returns vector")
+ moments[["mean"]] <- as.vector(objective$estimate)
+ } else {
+ moments[["mean"]] <- try(as.vector(apply(Return.clean(R=R, method=clean), 2, "mean", na.rm=TRUE)), silent=TRUE)
+ }
} else if(objective$name %in% c("StdDev", "sd", "var")){
- moments[["var"]] <- try(var(x=Return.clean(R=R, method=clean), na.rm=TRUE), silent=TRUE)
+ if(!is.null(objective$estimate)){
+ print("User has specified an estimated covariance matrix")
+ moments[["var"]] <- objective$estimate
+ } else {
+ moments[["var"]] <- try(var(x=Return.clean(R=R, method=clean), na.rm=TRUE), silent=TRUE)
+ }
} else {
moments[[objective$name]] <- try(eval(as.symbol(objective$name))(Return.clean(R=R, method=clean)), silent=TRUE)
}
@@ -791,13 +801,15 @@
if(!is.null(constraints$turnover_target) & is.null(constraints$ptc)){
qp_result <- gmv_opt_toc(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, init_weights=portfolio$assets)
weights <- qp_result$weights
- obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ # obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ obj_vals <- qp_result$obj_vals
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=qp_result$out, call=call)
}
if(!is.null(constraints$ptc) & is.null(constraints$turnover_target)){
qp_result <- gmv_opt_ptc(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, init_weights=portfolio$assets)
weights <- qp_result$weights
- obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ # obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ obj_vals <- qp_result$obj_vals
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=qp_result$out, call=call)
}
} else {
@@ -805,11 +817,20 @@
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)
+ # need to set moments$mean=0 here because quadratic utility and target return is sensitive to returning no solution
+ tmp_moments_mean <- moments$mean
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
- obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ # obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ obj_vals <- roi_result$obj_vals
+ if(maxSR){
+ # need to recalculate mean here if we are maximizing sharpe ratio
+ port.mean <- as.numeric(sum(weights * tmp_moments_mean))
+ names(port.mean) <- "mean"
+ obj_vals$mean <- port.mean
+ }
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=roi_result$out, call=call)
}
}
@@ -819,13 +840,15 @@
# This is an MILP problem if max_pos is specified as a constraint
roi_result <- maxret_milp_opt(R=R, constraints=constraints, moments=moments, target=target)
weights <- roi_result$weights
- obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ # obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ obj_vals <- roi_result$obj_vals
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=roi_result$out, call=call)
} else {
# Maximize return LP problem
roi_result <- maxret_opt(R=R, constraints=constraints, moments=moments, target=target)
weights <- roi_result$weights
- obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ # obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ obj_vals <- roi_result$obj_vals
out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=roi_result$out, call=call)
}
}
@@ -846,6 +869,7 @@
roi_result <- etl_milp_opt(R=R, constraints=constraints, moments=moments, target=target, alpha=alpha)
weights <- roi_result$weights
# obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
+ # obj_vals <- roi_result$obj_vals
# calculate obj_vals based on solver output
obj_vals <- list()
if(meanetl) obj_vals$mean <- as.numeric(t(weights) %*% moments$mean)
@@ -856,7 +880,7 @@
roi_result <- etl_opt(R=R, constraints=constraints, moments=moments, target=target, alpha=alpha)
weights <- roi_result$weights
# obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures
- # calculate obj_vals based on solver output
+ # obj_vals <- roi_result$obj_vals
obj_vals <- list()
if(meanetl) obj_vals$mean <- as.numeric(t(weights) %*% moments$mean)
obj_vals[[tmpnames[idx]]] <- roi_result$out
More information about the Returnanalytics-commits
mailing list