Более гибкие определения целей с пакетом nloptr

Question

Я использую пакет nloptr и все работает хорошо. Но мне нужен способ определить целевую функцию и ограничения более быстрым способом. Я не могу написать все настройки вручную каждый раз.

Например, я хочу решить эту проблему:

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)

Все работает. Но я хочу определить целевую функцию быстрее. Могу ли я передать другой аргумент (индексы) функции автоматически? Например:

eval_f <- function(x,indices){
      return(x[indices]^2)
    }

Я пытался, но у меня ошибка.

Answer 1

Аргумент ... для slsqp позволяет передавать произвольные аргументы в целевую функцию. Итак, определите новую целевую функцию, которая принимает indices в качестве аргумента:

eval_f2 <- function(x,indices){
  return(sum(x[indices]^2))
}

... и включают indices=c(4,7,9) (чтобы соответствовать определению вашей предыдущей целевой функции):

res2 <- slsqp(x0=x0,fn=eval_f2, hin = hin,heq = heq, indices=c(4,7,9))

Проверьте решение:

all.equal(res$par,res2$par) ## TRUE

заводы

В более общем смысле вы можете определить factory - функцию, которая возвращает функцию. Это работает, потому что функции связаны с средами , в которых могут храниться переменные (например, индексы). Это будет работать даже в тех случаях, когда функция верхнего уровня не позволяет передавать произвольные аргументы (и, например, может быть важна, если вы хотите использовать различные наборы индексов для ваших целевых и ограничивающих функций. ..)

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

фабрика для хин

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)