R shiny 非线性编程 - nloptr 中的错误：REAL() 只能应用于 'numeric'，而不是 'list'

Question

我尝试使用库 nloptr 制作简单的非线性规划应用程序，仅根据用户输入计算非线性优化。

如果我尝试添加 objective 函数的梯度和来自输入的约束，我会得到一个错误：nloptr 中的错误：REAL() 只能应用于 'numeric'，而不是 'list'。感谢您的帮助。

library(shiny)
library(shinythemes)
library(nloptr)

ui <- fluidPage(theme = shinytheme("united"),
                navbarPage(" Optimization",
                           tabPanel("Nonlinear programming",
                                    sidebarLayout(
                                      sidebarPanel(
                                        h3('Please enter nonlinear problem for solving'),
                                        textInput('obj', 'Objective  function ', "x[1]*x[4]*(x[1] +x[2] + x[3]) + x[3]"),
                                        textInput('gobj', 'Gradient of objective  function ', " x[1] * x[4] + x[4] * (x[1] + x[2] + x[3]), x[1] * x[4], x[1] * x[4] + 1.0, x[1] * (x[1] + x[2] + x[3])"),
                                        textInput('eq', 'Equality constraints ', "x[1]^2 + x[2]^2 + x[3]^2 + x[4]^2 - 40"),
                                        textInput('geq', 'Gradient of equality constraints ', "2.0*x[1], 2.0*x[2], 2.0*x[3], 2.0*x[4]"),
                                        textInput('ineq', 'Inequality constraints', "25 - x[1]*x[2]*x[3]*x[4]"),
                                        textInput('gineq', 'Gradient of inequality constraints', "-x[2]*x[3]*x[4], -x[1]*x[3]*x[4], -x[1]*x[2]*x[4], -x[1]*x[2]*x[3]"),
                                        textInput('lb', 'Lower bounds (comma separated)', "1,1,1,1"),
                                        textInput('ub', 'Upper bounds (comma separated)', "5,5,5,5"),
                                        textInput('x0', 'Initial values (comma separated)', "1,5,5,1"),
                                        actionButton('submit',"Submit")
                                      ),
                                      
                                      mainPanel(
                                        h4('The result is:'),
                                        verbatimTextOutput("res")
                                      )
                                    ))))

server <- function(input, output, session) {
  
  eval_f <- function( x ) {
    req(input$obj)
    return( list( "objective" = rlang::eval_tidy(rlang::parse_expr(as.character(input$obj))), 
                  "gradient" =  rlang::eval_tidy(rlang::parse_exprs(as.character(unlist(strsplit(input$gobj, ",")))))
    ) )
  }
  
  # constraint functions
  # inequalities
  eval_g_ineq <- function( x ) {
    constr <- rlang::eval_tidy(rlang::parse_expr(as.character(input$ineq))) # c( 25 - x[1] * x[2] * x[3] * x[4] )
    grad <- rlang::eval_tidy(rlang::parse_exprs(as.character(unlist(strsplit(input$gineq, ",")))))
    return( list( "constraints"=constr, "jacobian"=grad ) )
  }
  
  # equalities
  eval_g_eq <- function( x ) {
    constr <- rlang::eval_tidy(rlang::parse_expr(as.character(input$eq)))  # c( x[1]^2 + x[2]^2 + x[3]^2 + x[4]^2 - 40 )
    grad <- rlang::eval_tidy(rlang::parse_exprs(as.character(unlist(strsplit(input$geq, ",")))))
    return( list( "constraints"=constr, "jacobian"=grad ) )
  }
  
  res <- eventReactive(input$submit, {
    req(input$obj,input$ineq,input$eq,input$lb,input$ub,input$x0,input$gobj,input$gineq,input$geq)
    lb <<- as.numeric(unlist(strsplit(input$lb,",")))
    ub <<- as.numeric(unlist(strsplit(input$ub,",")))
    x0 <<- as.numeric(unlist(strsplit(input$x0,",")))
    
    local_opts <- list( "algorithm" = "NLOPT_LD_MMA", "xtol_rel" = 1.0e-15 )
    opts <- list( "algorithm"= "NLOPT_LD_AUGLAG",
                  "xtol_rel"= 1.0e-15,
                  "maxeval"= 16000,
                  "local_opts" = local_opts,
                  "print_level" = 0 )
    
    res <- nloptr ( x0 = x0,
                    eval_f = eval_f,
                    lb = lb,
                    ub = ub,
                    eval_g_ineq = eval_g_ineq,
                    eval_g_eq = eval_g_eq,
                    opts = opts)
    res  
  })
  output$res<-renderPrint({
    
    cat("Result:\n")
    print(res())
  })
}

shinyApp(ui = ui, server = server)

Answer 1

您需要为 gradient 执行与为 objective 相同的操作。但是，由于输入是元素向量，您可以使用 lapply。现在，lapply 给出了一个列表，因此我们将其转换回向量。

试试这个

server <- function(input, output, session) {

  eval_f <- function( x ) {
    req(input$obj)
    return( list( "objective" = rlang::eval_tidy(rlang::parse_expr(as.character(input$obj))),
                  "gradient" =  as.numeric(as.character(lapply(unlist(strsplit(input$gobj, ",")), function(par) { 
                    val <<- rlang::eval_tidy(rlang::parse_expr(as.character(par)))
                    return(val)})))
    ) )
  }

  # constraint functions
  # inequalities
  eval_g_ineq <- function( x ) {
    constr <- rlang::eval_tidy(rlang::parse_expr(as.character(input$ineq)))
    grad <- as.numeric(as.character(lapply(unlist(strsplit(input$gineq, ",")), function(par) { 
      val <<- rlang::eval_tidy(rlang::parse_expr(as.character(par)))
      return(val)})))
    return( list( "constraints"=constr, "jacobian"=grad ) )
  }

  # equalities
  eval_g_eq <- function( x ) {
    constr <- rlang::eval_tidy(rlang::parse_expr(as.character(input$eq)))
    grad <- as.numeric(as.character(lapply(unlist(strsplit(input$geq, ",")), function(par) { 
      val <<- rlang::eval_tidy(rlang::parse_expr(as.character(par)))
      return(val)})))
    return( list( "constraints"=constr, "jacobian"=grad ) )
  }

  res <- eventReactive(input$submit, {
    req(input$obj,input$ineq,input$eq,input$lb,input$ub,input$x0,input$gobj,input$gineq,input$geq)
    lb <<- as.numeric(unlist(strsplit(input$lb,",")))
    ub <<- as.numeric(unlist(strsplit(input$ub,",")))
    x0 <<- as.numeric(unlist(strsplit(input$x0,",")))

    local_opts <- list( "algorithm" = "NLOPT_LD_MMA", "xtol_rel" = 1.0e-15 )
    opts <- list( "algorithm"= "NLOPT_LD_AUGLAG",
                  "xtol_rel"= 1.0e-15,
                  "maxeval"= 16000,
                  "local_opts" = local_opts,
                  "print_level" = 0 )

    res <- nloptr ( x0 = x0,
                    eval_f = eval_f,
                    lb = lb,
                    ub = ub,
                    eval_g_ineq = eval_g_ineq,
                    eval_g_eq = eval_g_eq,
                    opts = opts)
    res
  })
  
  output$res<-renderPrint({
    cat("Result:\n")
    print(res())
  })
}