[Returnanalytics-commits] r3216 - pkg/PortfolioAnalytics/R

[noreply at r-forge.r-project.org]

Author: rossbennett34
Date: 2013-10-11 03:25:05 +0200 (Fri, 11 Oct 2013)
New Revision: 3216

Modified:
   pkg/PortfolioAnalytics/R/optFUN.R
   pkg/PortfolioAnalytics/R/optimize.portfolio.R
Log:
Modifying optimize.portfolio and optFUN for optimize_method=ROI to use the arguments list for clean, p, and other arguments.

Modified: pkg/PortfolioAnalytics/R/optFUN.R
===================================================================
--- pkg/PortfolioAnalytics/R/optFUN.R	2013-10-08 16:44:15 UTC (rev 3215)
+++ pkg/PortfolioAnalytics/R/optFUN.R	2013-10-11 01:25:05 UTC (rev 3216)
@@ -287,6 +287,9 @@
 #' @author Ross Bennett
 etl_opt <- function(R, constraints, moments, target, alpha){
   
+  # Check for cleaned returns in moments
+  if(!is.null(moments$cleanR)) R <- moments$cleanR
+  
   N <- ncol(R)
   T <- nrow(R)
   # Applying box constraints
@@ -348,6 +351,9 @@
 #' @author Ross Bennett
 etl_milp_opt <- function(R, constraints, moments, target, alpha){
   
+  # Check for cleaned returns in moments
+  if(!is.null(moments$cleanR)) R <- moments$cleanR
+  
   # Number of rows
   n <- nrow(R)
   
@@ -474,6 +480,9 @@
 gmv_opt_toc <- function(R, constraints, moments, lambda, target, init_weights){
   # function for minimum variance or max quadratic utility problems
   
+  # Check for cleaned returns in moments
+  if(!is.null(moments$cleanR)) R <- moments$cleanR
+  
   # Modify the returns matrix. This is done because there are 3 sets of
   # variables 1) w.initial, 2) w.buy, and 3) w.sell
   R0 <- matrix(0, ncol=ncol(R), nrow=nrow(R))
@@ -599,6 +608,9 @@
   # function for minimum variance or max quadratic utility problems
   # modifying ProportionalCostOpt function from MPO package
   
+  # Check for cleaned returns in moments
+  if(!is.null(moments$cleanR)) R <- moments$cleanR
+  
   # Modify the returns matrix. This is done because there are 3 sets of
   # variables 1) w.initial, 2) w.buy, and 3) w.sell
   returns <- cbind(R, R, R)

Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R
===================================================================
--- pkg/PortfolioAnalytics/R/optimize.portfolio.R	2013-10-08 16:44:15 UTC (rev 3215)
+++ pkg/PortfolioAnalytics/R/optimize.portfolio.R	2013-10-11 01:25:05 UTC (rev 3216)
@@ -733,19 +733,48 @@
     #  lambda_hhi <- 0
     #}
     lambda <- 1
+    
+    # list of valid objective names for ROI solvers
+    valid_objnames <- c("HHI", "mean", "var", "sd", "StdDev", "CVaR", "ES", "ETL")
+    
     for(objective in portfolio$objectives){
       if(objective$enabled){
-        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.")
+        if(!(objective$name %in% valid_objnames)){
+          stop("ROI only solves mean, var/StdDev, HHI, or sample ETL/ES/CVaR type business objectives, choose a different optimize_method.")
+        }
+        
+        # Grab the arguments list per objective
+        # Currently we are only getting arguments for "p" and "clean", not sure if we need others for the ROI QP/LP solvers
+        # if(length(objective$arguments) >= 1) arguments <- objective$arguments else arguments <- list()
+        arguments <- objective$arguments
+        if(!is.null(arguments$clean)) clean <- arguments$clean else clean <- "none"
+        # Note: arguments$p grabs arguments$portfolio_method if no p is specified
+        # so we need to be explicit with arguments[["p"]]
+        if(!is.null(arguments[["p"]])) alpha <- arguments$p else alpha <- alpha
+        if(alpha > 0.5) alpha <- (1 - alpha)
+        
+        # Some of the sub-functions for optimizations use the returns object as
+        # part of the constraints matrix (e.g. etl_opt and etl_milp_opt) so we
+        # will store the cleaned returns in the moments object. This may not
+        # be the most efficient way to pass around a cleaned returns object, 
+        # but it will keep it separate from the R object passed in by the user
+        # and avoid "re-cleaning" already cleaned returns if specified in 
+        # 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
         if(objective$name == "mean"){
-          moments[[objective$name]] <- try(as.vector(apply(R, 2, "mean", na.rm=TRUE)), silent=TRUE)
+          moments[[objective$name]] <- 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)
         } else {
-          moments[[objective$name]] <- try(eval(as.symbol(objective$name))(R), silent=TRUE)
+          moments[[objective$name]] <- try(eval(as.symbol(objective$name))(Return.clean(R=R, method=clean)), silent=TRUE)
         }
         target <- ifelse(!is.null(objective$target), objective$target, target)
-        alpha <- ifelse(!is.null(objective$alpha), objective$alpha, alpha)
+        # alpha <- ifelse(!is.null(objective$alpha), objective$alpha, alpha)
+        # only accept confidence level for ES/ETL/CVaR to come from the 
+        # arguments list to be consistent with how this is done in other solvers.
         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
@@ -807,7 +836,7 @@
       idx <- which(tmpnames %in% names(moments))
       # Minimize sample ETL/ES/CVaR if CVaR, ETL, or ES is specified as an objective
       if(length(moments) == 2 & all(moments$mean != 0) & ef==FALSE & maxSTARR){
-        # This is called by meanetl.efficient.frontier and we do not want that, need to have ef==FALSE
+        # This is called by meanetl.efficient.frontier and we do not want that for efficient frontiers, need to have ef==FALSE
         target <- mean_etl_opt(R=R, constraints=constraints, moments=moments, target=target, alpha=alpha)
         meanetl <- TRUE
       }