ROI optimisation in R using multi-argument F_objective function - r

Trying to run a simple ROI optimisation in R, but after hours of fidgeting I'm at a loss. I keep getting the error:
Error in .check_function_for_sanity(F, n) :
cannot evaluate function 'F' using 'n' = 5 parameters.
Here is the sample code:
library(ROI)
library(nloptr)
library(ROI.plugin.nloptr)
#Generate some random data for this example
set.seed(3142)
myRet = matrix(runif(100 * 5, -0.1, 0.1), ncol = 5)
myCovMatrix = cov(myRet)
myRet <- myRet
myCovMatrix <- myCovMatrix
# Sample weights
w <- rep(1/ncol(myRet), ncol(myRet))
#Define functions for the optimisation
diversificationRatio = function(w, covMatrix)
{
weightedAvgVol = sum(w * sqrt(diag(covMatrix)))
portfolioVariance = (w %*% covMatrix %*% w)[1,1]
- 1 * weightedAvgVol / sqrt(portfolioVariance)
}
# Check that the F_objective function works:
diversificationRatio(w, myCovMatrix)
# Now construct the F_objective
foo <- F_objective(F = diversificationRatio, n = (ncol(myRet)))
Any ideas on how many parameters to pass to n?

F_objective expects a function with only one argument so you have to write a wrapper function.
#Define functions for the optimisation
diversificationRatio <- function(w, covMatrix) {
weightedAvgVol <- sum(w * sqrt(diag(covMatrix)))
portfolioVariance <- (w %*% covMatrix %*% w)[1,1]
- 1 * weightedAvgVol / sqrt(portfolioVariance)
}
# Check that the F_objective function works:
wrapper <- function(x) diversificationRatio(x, myCovMatrix)
# Now construct the F_objective
o <- OP(F_objective(F = wrapper, n = (ncol(myRet))))
ROI_applicable_solvers(o)
start <- runif(ncol(myRet))
s <- ROI_solve(o, solver = "nloptr", start = start, method = "NLOPT_LD_SLSQP")
s
solution(s)

Related

R Error: function returns NA at 3.07653253930756e+181 distance from x

I am using the R programming language.
Based on the code following website https://www.stat.cmu.edu/~ryantibs/statcomp-F15/lectures/optimization.pdf (note: for some reason, this website does not open in Google Chrome - please try Microsoft Edge Explorer), I am trying to use the "Gradient Descent Optimization Algorithm" to optimize (i.e. find the minimum value) of the function : f(x) = x^3 - 2x - 5
I first defined the function that I want to optimize:
#define function to be optimized
func2 <- function(x) {
return( x[1]^3 - 2* x[1] - 5)
}
Next, I defined the function for the Gradient Descent Optimization Algorithm:
#load library
library(numDeriv)
#define gradient descent function
grad.descent = function(f, x0, max.iter=200, step.size=0.05,
stopping.deriv=0.01, ...) {
n = length(x0)
xmat = matrix(0,nrow=n,ncol=max.iter)
xmat[,1] = x0
for (k in 2:max.iter) {
# Calculate the gradient
grad.cur = grad(f,xmat[,k-1],...)
# Should we stop?
if (all(abs(grad.cur) < stopping.deriv)) {
k = k-1; break
}
# Move in the opposite direction of the grad
xmat[,k] = xmat[,k-1] - step.size * grad.cur
}
xmat = xmat[,1:k] # Trim
return(list(x=xmat[,k], xmat=xmat, k=k))
}
Finally, I tried to optimize the function :
# I think this serves as an initialization value
x0 = c(-1.9)
#run gradient descent algorithm
gd = grad.descent(func2,x0,step.size=1/3)
Problem : But this returns the following error:
Error in grad.default(f, xmat[, k - 1], ...) :
function returns NA at 3.07653253930756e+181 distance from x.
Can someone please show me what I am doing wrong?
Thanks!
If you want to impose boundaries, you can do it like this:
#load library
library(numDeriv)
#define gradient descent function
grad.descent = function(f, x0, max.iter=200, step.size=0.05,
stopping.deriv=0.01, boundaries = NULL, verbose = TRUE, ...) {
n = length(x0)
xmat = matrix(0,nrow=n,ncol=max.iter)
xmat[,1] = x0
for (k in 2:max.iter) {
if (verbose) message(paste(xmat[, k-1], collapse = ", "))
# Calculate the gradient
grad.cur = grad(f,xmat[,k-1],...)
# Should we stop?
if (all(abs(grad.cur) < stopping.deriv)) {
k = k-1; break
}
# Move in the opposite direction of the grad
xmat[,k] = xmat[,k-1] - step.size * grad.cur
if (!is.null(boundaries)) {
xmat[,k] <- ifelse(xmat[,k] < boundaries[1], boundaries[1], xmat[,k])
xmat[,k] <- ifelse(xmat[,k] > boundaries[2], boundaries[2], xmat[,k])
if (all(xmat[, k] == xmat[, k-1] | abs(grad.cur) < stopping.deriv))) break #stop if boundaries
}
}
xmat = xmat[,1:k, drop = FALSE] # Trim
return(list(x=xmat[,k], xmat=xmat, k=k))
}
# starting values
x0 = c(-1.9, 1.9)
#use functions that are actually vectorized
#if you want to use multiple starting values
f1 <- \(x) x^3 - 2* x - 5
grad.descent(f1,x0,step.size=1/3, boundaries = c(-5, 5))
f2 <- \(x) x^2
grad.descent(f2,x0,step.size=1/3, boundaries = c(-5, 5))

how can I set up this equation for constrained maximization?

How i can write this equation inside R as a function?
subject to: 20* x1 + 170*x2 = 20000
#ATTEMPT
library(Rsolnp)
fn <- function(h, s){
z=200 * x[1]^(2/3) * x[2]^(1/3)
return(-z)}
# constraint z1: 20*x+170*y=20000
eqn <- function(x) {
z1=20*x[1] + 170*x[2]
return(c(z1))
}
constraints = c(20000)
x0 <- c(1, 1) # setup init values
sol1 <- solnp(x0, fun = fn, eqfun = eqn, eqB = constraints)
sol1$pars
In R, we would use the keyword function, and we would pass the necessary parameters:
for example in this case.
R <- function(h, s)200 * h^(2/3) * s^(1/3)
We now have a function called R, that takes in arguments h and s and gives us an output.
For example, we could do:
R(27, 8)

Sequential Quadratic Programming in R to find optimal weights of an Equally-Weighted Risk Contribution Portfolio

Introduction to the problem
I am trying to write down a code in R so to obtain the weights of an Equally-Weighted Contribution (ERC) Portfolio. As some of you may know, the portfolio construction was presented by Maillard, Roncalli and Teiletche.
Skipping technicalities, in order to find the optimal weights of an ERC portfolio one needs to solve the following Sequential Quadratic Programming problem:
with:
Suppose we are analysing N assets. In the above formulas, we have that x is a (N x 1) vector of portfolio weights and Σ is the (N x N) variance-covariance matrix of asset returns.
What I have done so far
Using the function slsqp of the package nloptr which solves SQP problems, I would like to solve the above minimisation problem. Here is my code. Firstly, the objective function to be minimised:
ObjFuncERC <- function (x, Sigma) {
sum <- 0
R <- Sigma %*% x
for (i in 1:N) {
for (j in 1:N) {
sum <- sum + (x[i]*R[i] - x[j]*R[j])^2
}
}
}
Secondly, the starting point (we start by an equally-weighted portfolio):
x0 <- matrix(1/N, nrow = N, ncol = 1)
Then, the equality constraint (weights must sum to one, that is: sum of the weights minus one equal zero):
heqERC <- function (x) {
h <- numeric(1)
h[1] <- (t(matrix(1, nrow = N, ncol = 1)) %*% x) - 1
return(h)
}
Finally, the lower and upper bounds constraints (weights cannot exceed one and cannot be lower than zero):
lowerERC <- matrix(0, nrow = N, ncol = 1)
upperERC <- matrix(1, nrow = N, ncol = 1)
So that the function which should output optimal weights is:
slsqp(x0 = x0, fn = ObjFuncERC, Sigma = Sigma, lower = lowerERC, upper = upperERC, heq = heqERC)
Unfortunately, I do not know how to share with you my variance-covariance matrix (which takes name Sigma and is a (29 x 29) matrix, so that N = 29) so to reproduce my result, still you can simulate one.
The output error
Running the above code yields the following error:
Error in nl.grad(x, fn) :
Function 'f' must be a univariate function of 2 variables.
I have no idea what to do guys. Probably, I have misunderstood how things must be written down in order for the function slsqp to understand what to do. Can someone help me understand how to fix the problem and get the result I want?
UPDATE ONE: as pointed out by #jogo in the comments, I have updated the code, but it still produces an error. The code and the error above are now updated.
UPDATE 2: as requested by #jaySf, here is the full code that allows you to reproduce my error.
## ERC Portfolio Test
# Preliminary Operations
rm(list=ls())
require(quantmod)
require(nloptr)
# Load Stock Data in R through Yahoo! Finance
stockData <- new.env()
start <- as.Date('2014-12-31')
end <- as.Date('2017-12-31')
tickers <-c('AAPL','AXP','BA','CAT','CSCO','CVX','DIS','GE','GS','HD','IBM','INTC','JNJ','JPM','KO','MCD','MMM','MRK','MSFT','NKE','PFE','PG','TRV','UNH','UTX','V','VZ','WMT','XOM')
getSymbols.yahoo(tickers, env = stockData, from = start, to = end, periodicity = 'monthly')
# Create a matrix containing the price of all assets
prices <- do.call(cbind,eapply(stockData, Op))
prices <- prices[-1, order(colnames(prices))]
colnames(prices) <- tickers
# Compute Returns
returns <- diff(prices)/lag(prices)[-1,]
# Compute variance-covariance matrix
Sigma <- var(returns)
N <- 29
# Set up the minimization problem
ObjFuncERC <- function (x, Sigma) {
sum <- 0
R <- Sigma %*% x
for (i in 1:N) {
for (j in 1:N) {
sum <- sum + (x[i]*R[i] - x[j]*R[j])^2
}
}
}
x0 <- matrix(1/N, nrow = N, ncol = 1)
heqERC <- function (x) {
h <- numeric(1)
h[1] <- t(matrix(1, nrow = N, ncol = 1)) %*% x - 1
}
lowerERC <- matrix(0, nrow = N, ncol = 1)
upperERC <- matrix(1, nrow = N, ncol = 1)
slsqp(x0 = x0, fn = ObjFuncERC, Sigma = Sigma, lower = lowerERC, upper = upperERC, heq = heqERC)
I spotted several mistakes in your code. For instance, ObjFuncERC is not returning any value. You should use the following instead:
# Set up the minimization problem
ObjFuncERC <- function (x, Sigma) {
sum <- 0
R <- Sigma %*% x
for (i in 1:N) {
for (j in 1:N) {
sum <- sum + (x[i]*R[i] - x[j]*R[j])^2
}
}
sum
}
heqERC doesn't return anything too, I also changed your function a bit
heqERC <- function (x) {
sum(x) - 1
}
I made those changes and tried slsqp without lower and upper and it worked. Still, another thing to consider is that you set lowerERC and upperERC as matrices. Use the following instead:
lowerERC <- rep(0,N)
upperERC <- rep(1,N)
Hope this helps.

fzero function from MATLAB to R

I want to use R's fzero function to find roots of a function. The problem gets complicated, as the function in question calls some other functions which in turn call another ones. I do have MATLAB code that does it and I am trying to translate it to R, but cannot make in work. My experience with MATLAB is limited, so it's probable I just missed some feature of the MATLAB code while translating. My ultimate goal is to obtain R's working equivalent of the MATLAB code. Any hints will by highly appreciated!
The error I got is in function psi():
Error in (-t(I) * pi^2) %*% time : non-conformable arguments
Although the sizes of matrices do match and this part of code works with some naive input when ran in isolation.
NB: I have tried using mrdivide (R's equivalent of MATLAB's right matrix division) in some places, but with no effect.
NB2: I obtain the same error trying function uniroot instead of fzero.
# Global parameters:
N = 140
A2 = (256 times 256) matrix with data
I = vector of size 256: (0, 1, 2^2, 3^2, 4^2, ..., 255^2)
# ----------------------------------------------------------------
MATLAB working code:
fzero( #(t)(t-evolve(t)),[0,0.1])
function [out,time]=evolve(t)
global N
Sum_func = func([0,2],t) + func([2,0],t) + 2*func([1,1],t);
time=(2*pi*N*Sum_func)^(-1/3);
out=(t-time)/time;
end
function out=func(s,t)
global N
if sum(s)<=4
Sum_func=func([s(1)+1,s(2)],t)+func([s(1),s(2)+1],t); const=
(1+1/2^(sum(s)+1))/3;
time=(-2*const*K(s(1))*K(s(2))/N/Sum_func)^(1/(2+sum(s)));
out=psi(s,time);
else
out=psi(s,t);
end
end
function out=psi(s,Time)
global I A2
% s is a vector
w=exp(-I*pi^2*Time).*[1,.5*ones(1,length(I)-1)];
wx=w.*(I.^s(1));
wy=w.*(I.^s(2));
out=(-1)^sum(s)*(wy*A2*wx')*pi^(2*sum(s));
end
function out=K(s)
out=(-1)^s*prod((1:2:2*s-1))/sqrt(2*pi);
end
# ----------------------------------------------------------------
My attempt at R translation (not working):
fzero(subtract_evolve, c(0, 0.1))
K <- function(s) {
out <- (-1)^s * prod(seq(from = 1,to = 2*s-1, by = 2))/sqrt(2*pi)
return(out)
}
psi <- function(s, time) {
w <- (exp((-t(I) * pi^2) %*% time)) *
t(c(cbind(1, 0.5*ones(1,length(I)-1))))
wx <- t(w * (I^s[1]))
wy <- t(w * (I^s[2]))
out <- (-1)^sum(s) * (wy %*% A2 %*% t(wx)) * pi^(2*sum(s))
return(out)
}
func <- function(s, t) {
if (sum(s) <= 4) {
sum_func <- func(c(s[1]+1,s[2]), t) + func(c(s[1],s[2]+1), t)
const <- (1+1/2^(sum(s)+1))/3
time <- (-2 * const * K(s[1]) * K(s[2]) / N / sum_func)^(1/(2+sum(s)))
out <- psi(s, time)
} else {
out <- psi(s, t)
}
return(out)
}
evolve <- function(t) {
sum_func = func(c(0,2), t) + func(c(2,0), t) + 2*func(c(1,1),t)
time <- (2*pi*N*Sum_func)^(-1/3)
out <- (t-time)/time
return(c(out, time))
}
subtract_evolve <- function(t) {
return(t - evolve(t))
}

Markowitz model / portfolio optimization using local search in R

I am taking baby steps to use metaheuristics for solving constrained optimization problems. I am trying to solve basic Markowitz Mean-Variance optimization model (given below) using NMOFpackage in R.
Min
lambda * [sum{i=1 to N}sum{j = 1 to N}w_i*w_i*Sigma_ij] - (1-lambda) * [sum{i=1 to N}(w_i*mu_i)]
subject to
sum{i=1 to N}{w_i} = 1
0 <= w_i <= 1; i = 1,...,N
where, lambda takes values between 0 and 1, N is number of assets.
Following is my code (Based on Book: Numerical Methods and Optimization in Finance):
library(NMOF)
na <- dim(fundData)[2L]
ns <- dim(fundData)[1L]
Sigma <- cov(fundData)
winf <- 0.0
wsup <- 1.0
m <- colMeans(fundData)
resample <- function(x,...) x[sample.int(length(x),...)]
data <- list(R = t(fundData),
m = m,
na = dim(fundData)[2L],
ns = dim(fundData)[1L],
Sigma = Sigma,
eps = 0.5/100,
winf = winf,
wsup = wsup,
nFP = 100)
w0 <- runif(data$na); w0 <- w0/sum(w0)
OF <- function(w,data){
wmu <- crossprod(w,m)
res <- crossprod(w, data$Sigma)
res <- tcrossprod(w,res)
result <- res - wmu
}
neighbour <- function(w, data){
toSell <- w > data$winf
toBuy <- w < data$wsup
i <- resample(which(toSell), size = 1L)
j <- resample(which(toBuy), size = 1L)
eps <- runif(1) * data$eps
eps <- min(w[i] - data$winf, data$wsup - w[j], eps)
w[i] <- w[i] - eps
w[j] <- w[j] + eps
w
}
algo <- list(x0 = w0, neighbour = neighbour, nS = 5000L)
system.time(sol1 <- LSopt(OF, algo, data))
I am not sure how to include lambda in the objective function (OF). The above code does not include lambda in OF. I tried using for loop but it resulted in following error:
OF <- function(w,data){
lambdaSeq <- seq(.001,0.999, length = data$nFP)
for(lambda in lambdaSeq){
wmu <- crossprod(w,m)
res <- crossprod(w, data$Sigma)
res <- tcrossprod(w,res)
result <- lambda*res - (1-lambda)*wmu
}
}
Error:
Local Search.
Initial solution:
| | 0%
Error in if (xnF <= xcF) { : argument is of length zero
Timing stopped at: 0.01 0 0.03
It would be nice if someone could help me in this regard.
P.S: I am also aware that this can be solved using quadratic programming. This is just an initiation to include other constraints.
If I understand correctly, you want to replicate the mean--variance efficient frontier by Local Search? Then you need to run a Local Search for every value of lambda that you want to include in the frontier.
The following example should help you get going. I start by attaching the package and setting up the list data.
require("NMOF")
data <- list(m = colMeans(fundData), ## expected returns
Sigma = cov(fundData), ## expected var of returns
na = dim(fundData)[2L], ## number of assets
eps = 0.2/100, ## stepsize for LS
winf = 0, ## minimum weight
wsup = 1, ## maximum weight
lambda = 1)
Next I compute a benchmark for the minimum-variance case (i.e. lambda equals one).
## benchmark: the QP solution
## ==> this will only work with a recent version of NMOF,
## which you can get by saying:
## install.packages('NMOF', type = 'source',
## repos = c('http://enricoschumann.net/R',
## getOption('repos')))
##
require("quadprog")
sol <- NMOF:::minvar(data$Sigma, 0, 1)
Objective function and neighbourhood function. I have slightly simplified both functions (for clarity; using crossprod in the objective function would probably be more efficient).
OF <- function(w, data){
data$lambda * (w %*% data$Sigma %*% w) -
(1 - data$lambda) * sum(w * data$m)
}
neighbour <- function(w, data){
toSell <- which(w > data$winf)
toBuy <- which(w < data$wsup)
i <- toSell[sample.int(length(toSell), size = 1L)]
j <- toBuy[sample.int(length(toBuy), size = 1L)]
eps <- runif(1) * data$eps
eps <- min(w[i] - data$winf, data$wsup - w[j], eps)
w[i] <- w[i] - eps
w[j] <- w[j] + eps
w
}
Now we can run Local Search. Since it is a fairly large dataset (200 assets),
you will need a relatively large number of steps to reproduce the QP solution.
w0 <- runif(data$na) ## a random initial solution
w0 <- w0/sum(w0)
algo <- list(x0 = w0, neighbour = neighbour, nS = 50000L)
sol1 <- LSopt(OF, algo, data)
You can compare the weights you get from Local Search with the QP solution.
par(mfrow = c(3,1), mar = c(2,4,1,1), las = 1)
barplot(sol, main = "QP solution")
barplot(sol1$xbest, main = "LS solution")
barplot(sol - sol1$xbest,
ylim = c(-0.001,0.001)) ## +/-0.1%
Finally, if you want to compute the whole frontier, you need to rerun this code for different levels of data$lambda.

Resources