I try to make easy app for nonlinear programming using library nloptr for calculate nonlinear optimization only from user input.
If I try to add gradients of objective function and constraints from input I get an error: Error in nloptr: REAL() can only be applied to a 'numeric', not a 'list'. I appreciate your help.
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)
You need to do for gradient the same as you did for objective. However, as input is a vector of elements, you can use lapply. Now, lapply gives a list, so we convert that back to a vector.
Try this
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())
})
}