nloptr: R Interface to NLopt

# Copyright (C) 2023 Avraham Adler. All Rights Reserved.
# SPDX-License-Identifier: LGPL-3.0-or-later
#
# File:   test-is.nloptr
# Author: Avraham Adler
# Date:   6 February 2023
#
# Test code in "is.nloptr" function that is not tested elsewhere.
#
# Changelog:
#

library(nloptr)

ctlNM <- list(algorithm = "NLOPT_LN_NELDERMEAD", xtol_rel = 1e-8)
ctlLB <- list(algorithm = "NLOPT_LD_LBFGS", xtol_rel = 1e-8)

# Check whether the object exists and is a list
expect_false(is.nloptr(NULL))
expect_false(is.nloptr(3))

# Check whether the needed wrapper functions are supplied
# This seems to ALWAYS be preempted by .checkfunargs in nloptr itself (AA)

fphv <- function(x) {
  100 * (x[3L] - 10 * atan2(x[2L], x[1L]) / (2 * pi)) ^ 2 +
    (sqrt(x[1L] ^ 2 + x[2L] ^ 2) - 1) ^ 2 + x[3L] ^ 2
}

# Check whether bounds are defined for all controls
expect_error(nloptr(x0 = c(-1.2, 1.5, NA), eval_f = fphv, opts = ctlNM),
             "x0 contains NA", fixed = TRUE)

expect_error(nloptr(x0 = c(-1.2, 1.5, 3), eval_f = fphv, lb = c(-2, -2),
                    opts = ctlNM),
             "length(lb) != length(x0)", fixed = TRUE)

expect_error(nloptr(x0 = c(-1.2, 1.5, 3), eval_f = fphv, ub = c(-2, -2),
                    opts = ctlNM),
             "length(ub) != length(x0)", fixed = TRUE)

# Check whether the initial value is within the bounds
expect_error(nloptr(x0 = c(-1.2, 1.5, 3), eval_f = fphv, lb = c(-1, -1, -1),
                    opts = ctlNM),
             "at least one element in x0 < lb", fixed = TRUE)

expect_error(nloptr(x0 = c(-1.2, 1.5, 3), eval_f = fphv, ub = c(2, 2, 2),
                    opts = ctlNM),
             "at least one element in x0 > ub", fixed = TRUE)

# check if an existing algorithm was supplied
expect_error(nloptr(x0 = c(-1.2, 1.5, 3), eval_f = fphv,
                    opts = list(algorithm = "NLOPT_LN_NEDERMEAD",
                                xtol_rel = 1e-8)),
             "Incorrect algorithm supplied. Use one of the", fixed = TRUE)

# Check that we don't have NA's if we evaluate the objective function in x0.
f0 <- function(x) 3 * x ^ 1.5 - 2 * x ^ 0.5

expect_error(suppressWarnings(nloptr(x0 = -1, eval_f = f0, opts = ctlNM)),
             "objective in x0 returns NA", fixed = TRUE)

f0 <- function(x) 3 * x ^ 4 - 12 * x ^ 3
g0 <- function(x) 4 * sqrt(x) # Yes it's not the gradient. This is a unit test!!
expect_error(suppressWarnings(nloptr(x0 = -1, f0, g0, opts = ctlLB)),
             "objective in x0 returns NA", fixed = TRUE)

g0 <- function(x) c(4, 2) # Yes it's not the gradient. This is a unit test!!
expect_error(suppressWarnings(nloptr(x0 = -1, f0, g0, opts = ctlLB)),
             "wrong number of elements in gradient of objective",
             fixed = TRUE)

# check whether algorithm needs a derivative
g0 <- function(x) 12 * x ^ 3 - 36 * x ^ 2 # Actual gradient
## Just checking...
expect_silent(nloptr(x0 = -1, f0, g0, opts = ctlLB))
expect_warning(nloptr(x0 = -1, f0, g0, opts = ctlNM),
               "a gradient was supplied for the objective function",
               fixed = TRUE)
expect_error(nloptr(x0 = -1, f0, opts = ctlLB),
             "A gradient for the objective function is needed", fixed = TRUE)

# Malformed objects solely intended to trigger tests:
## eval_f test
expect_error(is.nloptr(list(eval_f = "Hello")), "eval_f is not a function")

## eval_g_ineq test
expect_error(is.nloptr(list(eval_f = fphv, eval_g_ineq = "GoodBye")),
             "eval_g_ineq is not a function")

## eval_g_eq test
expect_error(is.nloptr(list(eval_f = fphv, eval_g_eq = 27)),
             "eval_g_eq is not a function")

## MULTIVARIATE FUNCTION WITH CONSTRAINTS
x0 <- c(2, 2)
ub <- c(5, 5)
lb <- c(-1, -1)
fn <- function(x) (x[1L] - 1) ^ 2 + (x[2L] - 1) ^ 2 + 1
gr <- function(x) c(2 * (x[1L] - 1), 2 * (x[2L] - 1))
fnl <- function(x) list("objective" = fn(x), "gradient" = gr(x))
fnlNA <- function(x) list("objective" = NA_real_, "gradient" = gr(x))
hin <- function(x) c(1.44 - x[1L] ^ 2, 2.197 - x[2L] ^ 3)
hinjac <- function(x) matrix(c(-2 * x[1L], 0, 0, -3 * x[2L] ^ 2), 2L, 2L)
hinl <- function(x) list("constraints" = hin(x), "jacobian" = hinjac(x))
hinlNA <- function(x) {
  list("constraints" = hin(NA_real_), "jacobian" = hinjac(x))
}
heq <- function(x) c(x[1L] * x[2L] - 2.55, x[1L] - x[2L] - 0.2)
heqjac <- function(x) matrix(c(x[2L], 1, x[1L], -1), 2L)
heql <- function(x) list("constraints" = heq(x), "jacobian" = heqjac(x))
heqlNA <- function(x) {
  list("constraints" = heq(NA_real_), "jacobian" = heqjac(x))
}

optSol <- c(1.7, 1.5)
optVal <- 1.74

# Test simple error messages first; roughly in their order in is.nloptr.R Many
# of these are testing the list versions of their functional parents. A list
# version is when a function and its gradient are returned in the same call.
expect_error(nloptr(x0, fnlNA,
                    opts = list(algorithm = "NLOPT_LN_COBYLA",
                                xtol_rel = 1e-8)),
             "objective in x0 returns NA", fixed = TRUE)

hinE <- function(x) c(4, NA_real_)
expect_error(nloptr(x0, fn, eval_g_ineq = hinE,
                    opts = list(algorithm = "NLOPT_LN_COBYLA",
                                xtol_rel = 1e-8)),
             "inequality constraints in x0 returns NA", fixed = TRUE)

expect_error(nloptr(x0, fnl, eval_g_ineq = hinlNA,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "inequality constraints in x0 returns NA", fixed = TRUE)

hinjacE <- function(x) c(-2 * x[1L], NA_real_)
expect_error(nloptr(x0, fn, gr, eval_g_ineq = hin, eval_jac_g_ineq = hinjacE,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "jacobian of inequality constraints in x0 returns NA",
             fixed = TRUE)

hinjacE <- function(x) c(-2 * x[1L], -3 * x[2L] ^ 2)
expect_error(nloptr(x0, fn, gr, eval_g_ineq = hin, eval_jac_g_ineq = hinjacE,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "wrong number of elements in jacobian of inequality", fixed = TRUE)

expect_warning(nloptr(x0, fn, eval_g_ineq = hin, eval_jac_g_ineq = hinjac,
                      opts = list(algorithm = "NLOPT_LN_COBYLA",
                                  xtol_rel = 1e-8)),
               "gradient was supplied for the inequality constraints",
               fixed = TRUE)

expect_error(nloptr(x0, fn, gr, eval_g_ineq = hin,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "gradient for the inequality constraints is needed", fixed = TRUE)

heqE <- function(x) c(x[1L] * x[2L] - 2.55, NA_real_)
expect_error(nloptr(x0, fn, eval_g_eq = heqE,
                    opts = list(algorithm = "NLOPT_LN_COBYLA",
                                xtol_rel = 1e-8)),
             "equality constraints in x0 returns NA", fixed = TRUE)

expect_error(nloptr(x0, fn, eval_g_eq = heqlNA,
                    opts = list(algorithm = "NLOPT_LN_COBYLA",
                                xtol_rel = 1e-8)),
             "equality constraints in x0 returns NA", fixed = TRUE)

heqjacE <- function(x) c(-2 * x[1L], NA_real_)
expect_error(nloptr(x0, fn, gr, eval_g_eq = heq, eval_jac_g_eq = heqjacE,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "jacobian of equality constraints in x0 returns NA",
             fixed = TRUE)

heqjacE <- function(x) c(-2 * x[1L], -3 * x[2L] ^ 2)
expect_error(nloptr(x0, fn, gr, eval_g_eq = heq, eval_jac_g_eq = heqjacE,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "wrong number of elements in jacobian of equality", fixed = TRUE)

expect_warning(nloptr(x0, fn, eval_g_eq = heq, eval_jac_g_eq = heqjac,
                      opts = list(algorithm = "NLOPT_GN_ISRES",
                                  xtol_rel = 1e-8)),
               "gradient was supplied for the equality constraints",
               fixed = TRUE)

expect_error(nloptr(x0, fn, gr, eval_g_eq = heq,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8)),
             "gradient for the equality constraints is needed", fixed = TRUE)


expect_error(nloptr(x0, fn, gr, eval_g_eq = heq, eval_jac_g_eq = heqjac,
                    opts = list(algorithm = "NLOPT_LD_LBFGS", xtol_rel = 1e-8)),
             "If you want to use equality constraints, then you should use one",
             fixed = TRUE)

expect_error(nloptr(x0, fn, gr, eval_g_eq = heq, eval_jac_g_eq = heqjac,
                    opts = list(algorithm = "NLOPT_LD_AUGLAG",
                                xtol_rel = 1e-8)),
             "needs a local optimizer; specify an algorithm and termination",
             fixed = TRUE)

expect_error(nloptr(x0, fn, gr, eval_g_ineq = hin, eval_jac_g_ineq = hinjac,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8,
                                tol_constraints_ineq = rep(0.1, 3L))),
             "The vector tol_constraints_ineq in the options list",
             fixed = TRUE)

expect_error(nloptr(x0, fn, gr, eval_g_eq = heq, eval_jac_g_eq = heqjac,
                    opts = list(algorithm = "NLOPT_LD_SLSQP", xtol_rel = 1e-8,
                                tol_constraints_eq = rep(0.1, 3L))),
             "The vector tol_constraints_eq in the options list", fixed = TRUE)