[Returnanalytics-commits] r3261 - pkg/PortfolioAnalytics/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 15 07:12:22 CET 2013
Author: rossbennett34
Date: 2013-11-15 07:12:21 +0100 (Fri, 15 Nov 2013)
New Revision: 3261
Modified:
pkg/PortfolioAnalytics/R/constrained_objective.R
pkg/PortfolioAnalytics/R/optimize.portfolio.R
Log:
Modifying optimize.portfolio to add an argument for testing how moments are passed to constrained_objective. Adding moments as a formal argument to constrained_objective
Modified: pkg/PortfolioAnalytics/R/constrained_objective.R
===================================================================
--- pkg/PortfolioAnalytics/R/constrained_objective.R 2013-11-14 19:36:15 UTC (rev 3260)
+++ pkg/PortfolioAnalytics/R/constrained_objective.R 2013-11-15 06:12:21 UTC (rev 3261)
@@ -345,7 +345,7 @@
#' @aliases constrained_objective constrained_objective_v1
#' @rdname constrained_objective
#' @export
-constrained_objective_v2 <- function(w, R, portfolio, ..., trace=FALSE, normalize=TRUE, storage=FALSE)
+constrained_objective_v2 <- function(w, R, portfolio, ..., trace=FALSE, normalize=TRUE, storage=FALSE, moments=NULL)
{
if (ncol(R) > length(w)) {
R <- R[ ,1:length(w)]
@@ -516,31 +516,36 @@
} # End leverage exposure penalty
# The "..." are passed in from optimize.portfolio and contain the output of
- # the momentFUN. The default is momentFUN=set.portfolio.moments and returns
+ # momentFUN. The default is momentFUN=set.portfolio.moments and returns
# moments$mu, moments$sigma, moments$m3, moments$m4, etc. depending on the
# the functions corresponding to portfolio$objective$name. Would it be better
- # to make this a formal argument for constrained_objective?
+ # to make this a formal argument for constrained_objective? This means that
+ # we completely avoid evaluating the set.portfolio.moments function. Can we
+ # trust that all the moments are correctly set in optimize.portfolio through
+ # momentFUN?
- # nargs are used as the arguments for functions corresponding to
- # objective$name called in the objective loop later
+ if(!is.null(moments)){
+ nargs <- moments
+ } else {
+ # print("calculating moments")
+ # calculating the moments
+ # nargs are used as the arguments for functions corresponding to
+ # objective$name called in the objective loop later
+ momentargs <- eval(substitute(alist(...)))
+ .formals <- formals(set.portfolio.moments)
+ .formals <- modify.args(formals=.formals, arglist=alist(momentargs=momentargs), dots=TRUE)
+ .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE)
+ .formals <- modify.args(formals=.formals, arglist=NULL, portfolio=portfolio, dots=TRUE)
+ .formals$... <- NULL
+ # print(.formals)
+ nargs <- do.call(set.portfolio.moments, .formals)
+ }
- momentargs <- eval(substitute(alist(...)))
- .formals <- formals(set.portfolio.moments)
- .formals <- modify.args(formals=.formals, arglist=alist(momentargs=momentargs), dots=TRUE)
- .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE)
- .formals <- modify.args(formals=.formals, arglist=NULL, portfolio=portfolio, dots=TRUE)
- .formals$... <- NULL
- # print(.formals)
- nargs <- do.call(set.portfolio.moments, .formals)
+ # We should avoid modifying nargs in the loop below.
+ # If we modify nargs with something like nargs$x, nargs is copied and this
+ # should be avoided because nargs could be large because it contains the moments.
+ tmp_args <- list()
- #nargs <- list(...)
- #if(length(nargs)==0) nargs <- NULL
- #if (length('...')==0 | is.null('...')) {
- # # rm('...')
- # nargs <- NULL
- #}
- #nargs <- set.portfolio.moments(R, portfolio, momentargs=nargs)
-
if(is.null(portfolio$objectives)) {
warning("no objectives specified in portfolio")
} else{
@@ -556,7 +561,7 @@
median = {
fun = match.fun(objective$name)
# would it be better to do crossprod(w, moments$mu)?
- nargs$x <- ( R %*% w ) #do the multivariate mean/median with Kroneker product
+ tmp_args$x <- ( R %*% w ) #do the multivariate mean/median with Kroneker product
},
sd =,
var =,
@@ -566,7 +571,7 @@
mVaR =,
VaR = {
fun = match.fun(VaR)
- if(!inherits(objective,"risk_budget_objective") & is.null(objective$arguments$portfolio_method) & is.null(nargs$portfolio_method)) nargs$portfolio_method='single'
+ if(!inherits(objective,"risk_budget_objective") & is.null(objective$arguments$portfolio_method) & is.null(nargs$portfolio_method)) tmp_args$portfolio_method='single'
if(is.null(objective$arguments$invert)) objective$arguments$invert = FALSE
},
es =,
@@ -577,7 +582,7 @@
mETL=,
ES = {
fun = match.fun(ES)
- if(!inherits(objective,"risk_budget_objective") & is.null(objective$arguments$portfolio_method)& is.null(nargs$portfolio_method)) nargs$portfolio_method='single'
+ if(!inherits(objective,"risk_budget_objective") & is.null(objective$arguments$portfolio_method) & is.null(nargs$portfolio_method)) tmp_args$portfolio_method='single'
if(is.null(objective$arguments$invert)) objective$arguments$invert = FALSE
},
turnover = {
@@ -587,38 +592,22 @@
fun <- try(match.fun(objective$name))
}
)
+
if(is.function(fun)){
- .formals <- formals(fun)
- onames <- names(.formals)
- if(is.list(objective$arguments)){
- #TODO FIXME only do this if R and weights are in the argument list of the fn
- if(is.null(nargs$R) | !length(nargs$R)==length(R)) nargs$R <- R
-
- if(is.null(nargs$weights)) nargs$weights <- w
-
- pm <- pmatch(names(objective$arguments), onames, nomatch = 0L)
- if (any(pm == 0L))
- warning(paste("some arguments stored for", objective$name, "do not match"))
- # this line overwrites the names of things stored in $arguments with names from formals.
- # I'm not sure it's a good idea, so commenting for now, until we prove we need it
- #names(objective$arguments[pm > 0L]) <- onames[pm]
- .formals[pm] <- objective$arguments[pm > 0L]
- #now add dots
- if (length(nargs)) {
- dargs <- nargs
- pm <- pmatch(names(dargs), onames, nomatch = 0L)
- names(dargs[pm > 0L]) <- onames[pm]
- .formals[pm] <- dargs[pm > 0L]
- }
- .formals$... <- NULL
- }
- } # TODO do some funky return magic here on try-error
+ .formals <- formals(fun)
+ # Add the moments from the nargs object
+ .formals <- modify.args(formals=.formals, arglist=nargs, dots=TRUE)
+ # Add anything from tmp_args
+ .formals <- modify.args(formals=.formals, arglist=tmp_args, dots=TRUE)
+ # Now add the objective$arguments
+ .formals <- modify.args(formals=.formals, arglist=objective$arguments, dots=TRUE)
+ # Add R and weights if necessary
+ if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE)
+ if("weights" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, weights=w, dots=TRUE)
+ .formals$... <- NULL
+ }
- #.formals <- formals(fun)
- #.formals <- modify.args(formals=.formals, arglist=objective$arguments, ...=nargs, dots=TRUE)
- #print(.formals)
- #print(nargs)
-
+ # print(.formals)
tmp_measure <- try((do.call(fun,.formals)), silent=TRUE)
if(isTRUE(trace) | isTRUE(storage)) {
Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R
===================================================================
--- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-11-14 19:36:15 UTC (rev 3260)
+++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2013-11-15 06:12:21 UTC (rev 3261)
@@ -443,7 +443,8 @@
trace=FALSE, ...,
rp=NULL,
momentFUN='set.portfolio.moments',
- message=FALSE
+ message=FALSE,
+ reuse_moments=TRUE
)
{
optimize_method <- optimize_method[1]
@@ -681,7 +682,11 @@
if ("package:foreach" %in% search() & !hasArg(parallel)){
rp_objective_results <- foreach(ii=1:nrow(rp), .errorhandling='pass') %dopar% constrained_objective(w=rp[ii,], R, portfolio, trace=trace,...=dotargs, normalize=FALSE)
} else {
- rp_objective_results <- apply(rp, 1, constrained_objective, R=R, portfolio=portfolio, trace=trace, ...=dotargs, normalize=FALSE)
+ if(reuse_moments){
+ rp_objective_results <- apply(rp, 1, constrained_objective, R=R, portfolio=portfolio, trace=trace, normalize=FALSE, moments=dotargs)
+ } else {
+ rp_objective_results <- apply(rp, 1, constrained_objective, R=R, portfolio=portfolio, trace=trace, ...=dotargs, normalize=FALSE, moments=NULL)
+ }
}
#' if trace=TRUE , store results of foreach in out$random_results
if(isTRUE(trace)) out$random_portfolio_objective_results <- rp_objective_results
@@ -705,7 +710,11 @@
}
#' re-call constrained_objective on the best portfolio, as above in DEoptim, with trace=TRUE to get results for out list
out$weights <- min_objective_weights
- obj_vals <- try(constrained_objective(w=min_objective_weights, R=R, portfolio=portfolio, trace=TRUE, normalize=FALSE)$objective_measures)
+ if(reuse_moments){
+ obj_vals <- try(constrained_objective(w=min_objective_weights, R=R, portfolio=portfolio, trace=TRUE, normalize=FALSE, moments=dotargs)$objective_measures)
+ } else {
+ obj_vals <- try(constrained_objective(w=min_objective_weights, R=R, portfolio=portfolio, trace=TRUE, normalize=FALSE)$objective_measures)
+ }
out$objective_measures <- obj_vals
out$opt_values <- obj_vals
out$call <- call
@@ -736,7 +745,7 @@
# list of valid objective names for ROI solvers
valid_objnames <- c("HHI", "mean", "var", "sd", "StdDev", "CVaR", "ES", "ETL")
-
+ #objnames <- unlist(lapply(portfolio$objectives, function(x) x$name))
for(objective in portfolio$objectives){
if(objective$enabled){
if(!(objective$name %in% valid_objnames)){
@@ -762,19 +771,17 @@
# multiple objectives.
if(clean != "none") moments$cleanR <- Return.clean(R=R, method=clean)
- # 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
+ # Use $mu and $sigma estimates from momentFUN if available, fall back to
+ # calculating sample mean and variance
if(objective$name == "mean"){
- if(!is.null(objective$estimate)){
- print("User has specified an estimated mean returns vector")
- moments[["mean"]] <- as.vector(objective$estimate)
+ if(!is.null(mout$mu)){
+ moments[["mean"]] <- as.vector(mout$mu)
} 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")){
- if(!is.null(objective$estimate)){
- print("User has specified an estimated covariance matrix")
- moments[["var"]] <- objective$estimate
+ if(!is.null(mout$sigma)){
+ moments[["var"]] <- mout$sigma
} else {
moments[["var"]] <- try(var(x=Return.clean(R=R, method=clean), na.rm=TRUE), silent=TRUE)
}
@@ -790,6 +797,7 @@
if(!is.null(objective$conc_groups)) conc_groups <- objective$conc_groups else conc_groups <- NULL
}
}
+
if("var" %in% names(moments)){
# Minimize variance if the only objective specified is variance
# Maximize Quadratic Utility if var and mean are specified as objectives
More information about the Returnanalytics-commits
mailing list