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

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

Author: rossbennett34
Date: 2013-09-11 07:34:29 +0200 (Wed, 11 Sep 2013)
New Revision: 3054

Modified:
   pkg/PortfolioAnalytics/R/extractstats.R
Log:
Making extractObjectiveMeasures and S3 generic function and adding function to extract objective measures for opt.list object.

Modified: pkg/PortfolioAnalytics/R/extractstats.R
===================================================================
--- pkg/PortfolioAnalytics/R/extractstats.R	2013-09-11 02:39:36 UTC (rev 3053)
+++ pkg/PortfolioAnalytics/R/extractstats.R	2013-09-11 05:34:29 UTC (rev 3054)
@@ -307,6 +307,12 @@
 #' @author Ross Bennett
 #' @export
 extractObjectiveMeasures <- function(object){
+  UseMethod("extractObjectiveMeasures")
+}
+
+#' @method extractObjectiveMeasures optimize.portfolio
+#' @S3method extractObjectiveMeasures optimize.portfolio
+extractObjectiveMeasures.optimize.portfolio <- function(object){
   if(!inherits(object, "optimize.portfolio")) stop("object must be of class 'optimize.portfolio'")
   # objective measures returned as $objective_measures for all other solvers
   out <- object$objective_measures
@@ -395,3 +401,32 @@
   }
   return(weights_mat)
 }
+
+#' @method extractObjectiveMeasures opt.list
+#' @S3method extractObjectiveMeasures opt.list
+extractObjectiveMeasures.opt.list <- function(object){
+  if(!inherits(object, "opt.list")) stop("object must be of class 'opt.list'")
+  # get/set the names in the object
+  opt_names <- names(object)
+  if(is.null(opt_names)) opt_names <- paste("opt", 1:length(object))
+  
+  obj_list <- list()
+  for(i in 1:length(object)){
+    tmp <- unlist(object[[i]]$objective_measures)
+    names(tmp) <- PortfolioAnalytics:::name.replace(names(tmp))
+    obj_list[[opt_names[i]]] <- tmp
+  }
+  obj_list
+  
+  obj_names <- unique(unlist(lapply(obj_list, names)))
+  
+  obj_mat <- matrix(NA, nrow=length(obj_list), ncol=length(obj_names), 
+                    dimnames=list(opt_names, obj_names))
+  
+  for(i in 1:length(obj_list)){
+    pm <- pmatch(x=names(obj_list[[i]]), table=obj_names)
+    obj_mat[i, pm] <- obj_list[[i]]
+  }
+  return(obj_mat)
+}
+