More flexible objective definitions with the nloptr package - r

Question

I'm using the nloptr package and everything works well. But I need a way to define the objective function and the constraints in a faster way. I can't write all the settings by hand each time.
For example, I want to solve this problem:
library(nloptr)
eval_f <- function(x){
return(x[4]^2+x[7]^2+x[9]^2)
}
x0 = c(1,1,1,1,0.5,0,0.5,1,0)
hin <- function(x){
h <- numeric(6)
h[1] = x[1]+x[4]-x[2]-x[5]-0.01
h[2] = x[1]+x[4]-x[3]-x[6]-0.01
h[3] = x[2]+x[5]-x[3]-x[6]-0.01
h[4] = x[2]+x[8]-x[1]-x[7]-0.01
h[5] = x[2]+x[8]-x[3]-x[9]-0.01
h[6] = x[1]+x[7]-x[3]-x[9]-0.01
return(h)
}
heq <- function(x){
h <- numeric(1)
h[1] <- x[1]+x[2]+x[3]-3
return(h)
}
res <- slsqp(x0=x0,fn=eval_f,hin = hin,heq = heq)
Everything works.
But I want to define the objective function in a faster way. Can I pass another argument (the indices) to the function in an automatic way? For example:
eval_f <- function(x,indices){
return(x[indices]^2)
}
I tried but I have an error.

Answer 1

The ... argument to slsqp allows you to pass arbitrary arguments through to the objective function. So define a new objective function that takes indices as an argument:
eval_f2 <- function(x,indices){
return(sum(x[indices]^2))
}
... and include indices=c(4,7,9) (to match your previous objective function's definition):
res2 <- slsqp(x0=x0,fn=eval_f2, hin = hin,heq = heq, indices=c(4,7,9))
Check the solution:
all.equal(res$par,res2$par) ## TRUE
factories
More generally, you can define a factory - a function that returns a function. This works because functions have associated environments in which variables (such as the indices) can be stored. This will work even in cases where the top-level function doesn't allow arbitrary arguments to be passed through (and may e.g. be important if you want to use different sets of indices for your objective and constraint functions ...)
eval_factory <- function(indices) {
fun <- function(x) {
return(sum(x[indices]^2))
}
return(fun)
}
res3 <- slsqp(x0=x0, fn=eval_factory(indices=c(4,7,9)),
hin = hin,heq = heq)
all.equal(res$par,res3$par) ## TRUE
factory for hin
hin_factory <- function(A,b) {
fun <- function(x) {
return((A %*% x) + b)
}
return(fun)
}
A0 <- matrix(c(1, -1, 0, 1,-1, 0, 0, 0, 0,
1, 0, -1, 1, 0, -1, 0, 0, 0,
0, 1, -1, 0, 1, -1, 0, 0, 0,
-1, 1, 0, 0, 0, 0,-1, 1, 0,
0, 1, -1, 0, 0, 0, 0, 1, -1,
1, 0, -1, 0, 0, 0, 1, 0, -1),
byrow=TRUE,ncol=9)
all.equal(c(hin_factory(A0,-0.01)(x0)),hin(x0))
res4 <- slsqp(x0=x0, fn=eval_factory(indices=c(4,7,9)),
hin = hin_factory(A0,b=-0.01), heq = heq)
all.equal(res$par, res4$par)