rp_transform2 <- function(weights,
min_sum,
max_sum,
min_box,
max_box,
groups=NULL,
cLO=NULL,
cUP=NULL,
max_pos=NULL,
group_pos=NULL,
max_pos_long=NULL,
max_pos_short=NULL,
leverage=NULL,
weight_seq=NULL,
max_permutations=200){
tmp_w <- weights
# Set some reasonable default values
# Maybe I should leave these as NULL values and incorporate that into the
# checks
#if(is.null(min_sum)) min_sum <- 0.99
#if(is.null(max_sum)) max_sum <- 1.01
#if(is.null(min_box)) min_box <- rep(-Inf, length(tmp_w))
#if(is.null(max_box)) max_box <- rep(Inf, length(tmp_w))
if(is.null(max_pos)) max_pos <- length(tmp_w)
#if(is.null(max_poslong)) max_pos_long <- length(tmp_w)
#if(is.null(max_pos_short)) max_pos_short <- length(tmp_w)
#if(is.null(leverage)) leverage <- Inf
# Generate a weight sequence, we should check for portfolio$weight_seq
if(is.null(weight_seq))
weight_seq <- generatesequence(min=min(min_box), max=max(max_box), by=0.002)
# make sure there is a 0 in weight_seq if we have a position limit constraint
if((!is.null(max_pos) | !is.null(group_pos) | !is.null(max_pos_long) | !is.null(max_pos_short)) & !is.element(0, weight_seq)) weight_seq <- c(0, weight_seq)
# Tolerance for "non-zero" definition for position limit constraints
tolerance <- .Machine$double.eps^0.5
# initialize the outer while loop
permutations <- 1
# while we have not reached max_permutations and the following constraints
# are violated:
# - min_sum
# - max_sum
# - leverage
# - max_pos, max_pos_long, max_pos_short
# - group
# Do we want to check all constraints in here?
# Box constraints should be satisfied by construction so we should not need
# to check those here
while (( min_sum_fail(tmp_w, min_sum) |
max_sum_fail(tmp_w, max_sum) |
leverage_fail(tmp_w, leverage) |
pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) |
any(group_fail(tmp_w, groups, cLO, cUP)) ) &
(permutations < max_permutations)) {
# cat("permutation #:", permutations, "\n")
permutations <- permutations+1
# Reset tmp_w to original weights vector
# I'm not sure we want to do this here because it puts us back to where we
# started, but it seems to help with the position limit constraint
# tmp_w <- weights
# Reset the random index based on the maximum position constraint
# This basically allows us to generate a portfolio of max_pos assets
# with the given constraints and then add assets with zero weight
random_index <- sample(1:length(tmp_w), max_pos)
# Get the index values that are not in random_index and set them equal to 0
full_index <- 1:length(tmp_w)
not_index <- setdiff(full_index, random_index)
tmp_w[not_index] <- 0
# min_sum violation
if(min_sum_fail(tmp_w, min_sum)){
tmp_w <- rp_increase(weights=tmp_w,
min_sum=min_sum,
max_box=max_box,
weight_seq=weight_seq)
}
# max_sum violation
if(max_sum_fail(tmp_w, max_sum)){
tmp_w <- rp_decrease(weights=tmp_w,
max_sum=max_sum,
min_box=min_box,
weight_seq=weight_seq)
}
# leverage violation
if(leverage_fail(tmp_w, leverage)){
tmp_w <- rp_decrease_leverage(weights=tmp_w,
max_box=max_box,
min_box=min_box,
leverage=leverage,
weight_seq=weight_seq)
}
# position limit violation
if(pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short)){
tmp_w <- rp_position_limit(weights=tmp_w,
min_box=min_box,
max_box=max_box,
max_pos=max_pos,
max_pos_long=max_pos_long,
max_pos_short=max_pos_short,
weight_seq=weight_seq)
}
# group violation
if(any(group_fail(tmp_w, groups, cLO, cUP, group_pos))){
n_groups <- length(groups)
for(j in 1:n_groups){
# index of the weights vector belonging to the jth group
j_idx <- groups[[j]]
# weights of the jth group
tmp_group_w <- tmp_w[j_idx]
# May be easier to just make a recursive call and treat each group
# as a portfolio of weight vectors
tmp_w[j_idx] <- rp_transform2(weights=tmp_group_w,
min_sum=cLO[j],
max_sum=cUP[j],
min_box=min_box[j_idx],
max_box=max_box[j_idx],
group_pos=group_pos[j])
# treat this as if min_sum were violated
# if(sum(tmp_group_w) < cLO[j]){
# tmp_w[j_idx] <- rp_increase(weights=tmp_group_w,
# min_sum=cLO[j],
# max_box=max_box[j_idx],
# weight_seq=weight_seq)
# }
# treat this as if max_sum were violated
# if(sum(tmp_group_w) > cUP[j]){
# tmp_w[j_idx] <- rp_decrease(weights=tmp_group_w,
# max_sum=cUP[j],
# min_box=min_box[j_idx],
# weight_seq=weight_seq)
# }
}
} # end group violation loop
} # end final walk towards the edges
portfolio <- tmp_w
colnames(portfolio) <- colnames(weights)
# checks for infeasible portfolio
# Stop execution and return an error if an infeasible portfolio is created
# This will be useful in fn_map so that we can catch the error and take
# action (try again with more permutations, relax constraints, different
# method to normalize, etc.)
if (sum(portfolio) < min_sum | sum(portfolio) > max_sum){
portfolio <- weights
stop("Infeasible portfolio created, perhaps increase max_permutations and/or adjust your parameters.")
}
return(portfolio)
}
rp_increase <- function(weights, min_sum, max_box, weight_seq){
# randomly permute and increase a random portfolio element if the sum of
# the weights is less than min_sum while respecting box constraints
if(sum(weights) >= min_sum) return(weights)
tmp_w <- weights
n_weights <- length(weights)
# random_index <- sample(1:length(weights), max_pos)
random_index <- sample(1:n_weights, n_weights)
i <- 1
while (sum(tmp_w) < min_sum & i <= n_weights) {
# print("min_sum violation loop")
cur_index <- random_index[i]
cur_val <- tmp_w[cur_index]
tmp_seq <- weight_seq[(weight_seq > cur_val) & (weight_seq <= max_box[cur_index])]
n_tmp_seq <- length(tmp_seq)
if(n_tmp_seq > 1){
# randomly sample one of the larger weights
tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)]
} else if(n_tmp_seq == 1){
tmp_w[cur_index] <- tmp_seq
}
i <- i + 1 # increment our counter
} # end increase loop
return(tmp_w)
}
rp_decrease <- function(weights, max_sum, min_box, weight_seq){
# randomly permute and decrease a random portfolio element if the sum of
# the weights is greater than max_sum while respecting box constraints
if(sum(weights) <= max_sum) return(weights)
tmp_w <- weights
n_weights <- length(weights)
# random_index <- sample(1:length(weights), max_pos)
random_index <- sample(1:n_weights, n_weights)
i <- 1
while (sum(tmp_w) > max_sum & i <= n_weights) {
# print("max_sum violation loop")
cur_index <- random_index[i]
cur_val <- tmp_w[cur_index]
tmp_seq <- weight_seq[(weight_seq < cur_val) & (weight_seq >= min_box[cur_index])]
n_tmp_seq <- length(tmp_seq)
if(n_tmp_seq > 1){
tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)]
} else if(n_tmp_seq == 1){
tmp_w[cur_index] <- tmp_seq
}
i <- i + 1 # increment our counter
} # end decrease loop
return(tmp_w)
}
rp_decrease_leverage <- function(weights, max_box, min_box, leverage, weight_seq){
# randomly permute and increae decrease a random portfolio element
# according to leverage exposure while respecting box constraints
tmp_w <- weights
n_weights <- length(weights)
# random_index <- sample(1:length(weights), max_pos)
random_index <- sample(1:n_weights, n_weights)
# set counter to 1 for leverage violation loop
i <- 1
while (sum(abs(tmp_w)) > leverage & i <= length(tmp_w)) {
#print("leverage violation loop")
cur_index <- random_index[i]
cur_val <- tmp_w[cur_index]
tmp_seq <- NULL
# check the sign of the current value
if(cur_val < 0){
# if the current value is negative, we want to increase to lower
# sum(abs(weights)) while respecting uppper bound box constraint
tmp_seq <- weight_seq[(weight_seq > cur_val) & (weight_seq <= max_box[cur_index])]
} else if(cur_val > 0){
# if the current value is positive, we want to decrease to lower
# sum(abs(weights)) while respecting lower bound box constraint
tmp_seq <- weight_seq[(weight_seq < cur_val) & (weight_seq >= min_box[cur_index])]
}
# tmp_seq can be NULL if cur_val is zero
if(!is.null(tmp_seq)){
n_tmp_seq <- length(tmp_seq)
if(n_tmp_seq > 1) {
# randomly sample one of the weights
tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)]
} else if(n_tmp_seq == 1){
tmp_w[cur_index] <- tmp_seq
}
}
i <- i + 1 # increment our counter
} # end leverage violation loop
return(tmp_w)
}
rp_position_limit <- function(weights, max_pos=NULL, max_pos_long=NULL, max_pos_short=NULL, min_box, max_box, weight_seq){
tmp_w <- weights
n_weights <- length(weights)
# random_index <- sample(1:length(weights), max_pos)
random_index <- sample(1:n_weights, n_weights)
tolerance <- .Machine$double.eps^0.5
# set counter to 1 for position limit violation loop
i <- 1
while ( pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) & i <= length(tmp_w)) {
#print("position limit violation loop")
cur_index <- random_index[i]
cur_val <- tmp_w[cur_index]
if(!is.null(max_pos_long)){
# Check if max_pos_long is violated
# If max_pos_long is violated, we we grab a positive weight and set it
# to be between min_box and 0
if(sum(tmp_w > tolerance) > max_pos_long){
if(cur_val > tolerance){
# subset such that min_box_i <= weight_i <= 0
tmp_seq <- weight_seq[(weight_seq <= 0) & (weight_seq >= min_box[cur_index])]
n_tmp_seq <- length(tmp_seq)
if(n_tmp_seq > 1){
tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)]
} else if(n_tmp_seq == 1){
tmp_w[cur_index] <- tmp_seq
}
}
} # end max_pos_long violation loop
}
if(!is.null(max_pos_short)){
# Check if max_pos_short is violated
# If max_pos_short is violated, we grab a negative weight and set it
# to be between 0 and max_box
if(sum(tmp_w < tolerance) > max_pos_short){
if(cur_val < tolerance){
# subset such that 0 <= weight_i <= max_box_i
tmp_seq <- weight_seq[(weight_seq >= 0) & (weight_seq <= max_box[cur_index])]
n_tmp_seq <- length(tmp_seq)
if(n_tmp_seq > 1){
tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)]
} else if(n_tmp_seq == 1){
tmp_w[cur_index] <- tmp_seq
}
}
} # end max_pos_short violation loop
}
i <- i + 1 # increment our counter
} # end position limit violation loop
return(tmp_w)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.