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

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

Author: rossbennett34
Date: 2013-07-19 03:58:31 +0200 (Fri, 19 Jul 2013)
New Revision: 2597

Modified:
   pkg/PortfolioAnalytics/R/constraint_fn_map.R
Log:
modified rp_transform to better handle max_pos_long and max_pos_short cardinality constraints

Modified: pkg/PortfolioAnalytics/R/constraint_fn_map.R
===================================================================
--- pkg/PortfolioAnalytics/R/constraint_fn_map.R	2013-07-18 22:07:06 UTC (rev 2596)
+++ pkg/PortfolioAnalytics/R/constraint_fn_map.R	2013-07-19 01:58:31 UTC (rev 2597)
@@ -337,14 +337,20 @@
   # in randomize_portfolio if min_sum and max_sum were satisfied, but the
   # min/max constraints were violated.
   
+  # Set the tolerance to determine non-zero weights
   tolerance=.Machine$double.eps^0.5
+  
+  # Set value for max_pos if it is not specified
   if(is.null(max_pos)) max_pos <- length(w)
   
+  # Determine maximum number of non-zero weights
   if(!is.null(group_pos)) {
     max_group_pos <- sum(group_pos)
   } else {
     max_group_pos <- length(w)
   }
+  
+  # Set maximum number of assets based on max_pos and group_pos
   max_assets <- min(max_pos, max_group_pos)
   
   # Create a temporary min vector that will be modified, because a feasible
@@ -405,6 +411,45 @@
     # violation of any(tmp_w < tmp_min)
     tmp_min[not_index] <- 0
     
+    # Transform weights to satisfy max_pos_long and max_pos_short before being
+    # passed into the main loops
+    # Both max_pos_long and max_pos_short should be specified
+    if(!is.null(max_pos_long) & !is.null(max_pos_short)){
+      pos_idx <- which(tmp_w > 0)
+      neg_idx <- which(tmp_w < 0)
+      
+      # Check if number of positive weights exceeds max_pos_long
+      if(length(pos_idx) > max_pos_long){
+        # Randomly sample positive weights that cause violation of max_pos_long
+        # and replace with randomly sampled negative weights from weight_seq
+        make_neg_idx <- sample(pos_idx, length(pos_idx) - max_pos_long)
+        for(i in make_neg_idx){
+          tmp_idx <- weight_seq[weight_seq < 0 & weight_seq >= min[i]]
+          if(length(tmp_idx) > 0){
+            tmp_w[i] <- sample(tmp_idx, 1)
+          } else {
+            # This should never happen if the correct weight_seq and min is specified
+            tmp_w[i] <- -tmp_w[i]
+          }
+        }
+      }
+      # Check if number of negative weights exceeds max_pos_short
+      if(length(neg_idx) > max_pos_short){
+        # Randomly sample negative weights that cause violation of max_pos_short
+        # and replace with randomly sampled positive weights from weight_seq
+        make_pos_idx <- sample(neg_idx, length(neg_idx) - max_pos_short)
+        for(i in make_pos_idx){
+          tmp_seq <- weight_seq[weight_seq > 0 & weight_seq <= max[i]]
+          if(length(tmp_seq) > 0){
+            tmp_w[i] <- sample(tmp_seq, 1)
+          } else {
+            # This should never happen if the correct weight_seq and max is specified
+            tmp_w[i] <- -tmp_w[i]
+          }
+        }
+      }
+    }
+    
     i = 1
     # while sum of weights is less than min_sum or tmp_min/max box or group constraint is violated
     while ((sum(tmp_w) < min_sum | any(tmp_w < tmp_min) | any(tmp_w > max) | any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | (pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short))) & i <= length(tmp_w)) {