Skip to content

Commit

Permalink
Merge pull request #166 from aadler/Hotfix-global-wrapper
Browse files Browse the repository at this point in the history 
Patch: Fix for test-wrapper-global
  • Loading branch information
@astamm
astamm authored Jun 27, 2024
2 parents 779a143 + 26519d3 commit 8c975a3
Show file tree
Hide file tree
Showing 2 changed files with 61 additions and 50 deletions.
5 changes: 4 additions & 1 deletion NEWS.md
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,7 @@
# nloptr (development version)
# nloptr 2.1.1.9000
This is a patch (pre) release. It includes

* Correcting some of the unit tests in `test-global-wrapper`.

# nloptr 2.1.1

Expand Down
106 changes: 57 additions & 49 deletions inst/tinytest/test-wrapper-global.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,10 +9,15 @@
# algorithms have issues, this test suite may not be completed.
#
# Changelog:
# 2023-08-23: Change _output to _stdout
# 2023-08-23: Change _output to _stdout. (Avraham Adler)
# 2023-06-24: Reduce tolerance of ISRES tests to pass CRAN. (Aymeric Stamm)
# 2023-06-25: Use analytic gradients and Jacobians for hin/heq. Correct some
# of the ISRES tests which were pulling on Stogo results.
# (Avraham Adler)
#

library(nloptr)
tol <- 1e-3 # Stochastic algorithms require a weaker tolerance

depMess <- paste("The old behavior for hin >= 0 has been deprecated. Please",
"restate the inequality to be <=0. The ability to use the old",
Expand All @@ -23,38 +28,14 @@ rbf <- function(x) {(1 - x[1]) ^ 2 + 100 * (x[2] - x[1] ^ 2) ^ 2}
## Analytic gradient
gr <- function(x) {c(-2 * (1 - x[1]) - 400 * x[1] * (x[2] - x[1] ^ 2),
200 * (x[2] - x[1] ^ 2))}
gr.diff <- function(x) nl.grad(x, rbf)

hin <- function(x) 0.25 * x[1L] ^ 2 + x[2L] ^ 2 - 1 # hin <= 0
heq <- function(x) x[1L] - 2 * x[2L] + 1 # heq = 0
hinjac <- function(x) nl.jacobian(x, hin)
heqjac <- function(x) nl.jacobian(x, heq)
heq <- function(x) x[1L] + x[2L] - 1 # heq = 0
hinjac <- function(x) c(0.5 * x[1L], 2 * x[2L])
heqjac <- function(x) c(1, 1)
hin2 <- function(x) -hin(x) # Needed to test old behavior
hinjac2 <- function(x) nl.jacobian(x, hin2) # Needed to test old behavior

# Take these outside the function since they are unchanging; just pass them!
a <- c(1.0, 1.2, 3.0, 3.2)
A <- matrix(c(10, 0.05, 3, 17,
3, 10, 3.5, 8,
17, 17, 1.7, 0.05,
3.5, 0.1, 10, 10,
1.7, 8, 17, 0.1,
8, 14, 8, 14), nrow = 4)

B <- matrix(c(.1312, .2329, .2348, .4047,
.1696, .4135, .1451, .8828,
.5569, .8307, .3522, .8732,
.0124, .3736, .2883, .5743,
.8283, .1004, .3047, .1091,
.5886, .9991, .6650, .0381), nrow = 4)

hartmann6 <- function(x, a, A, B) {
fun <- 0
for (i in 1:4) {
fun <- fun - a[i] * exp(-sum(A[i, ] * (x - B[i, ]) ^ 2))
}

fun
}
hinjac2 <- function(x) -hinjac(x)

x0 <- c(-1.2, 1)
lb <- c(-3, -3)
Expand All @@ -73,7 +54,7 @@ stogoTest <- stogo(x0, rbf, lower = lb, upper = ub)

stogoControl <- nloptr(x0 = x0,
eval_f = rbf,
eval_grad_f = function(x) nl.grad(x, rbf),
eval_grad_f = gr.diff,
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GD_STOGO",
Expand Down Expand Up @@ -140,27 +121,29 @@ isresControl <- nloptr(x0 = x0,
maxeval = 2e4L, xtol_rel = 1e-6,
population = 60))

expect_equal(isresTest$par, isresControl$solution, tolerance = 1e-4)
expect_equal(isresTest$value, isresControl$objective, tolerance = 1e-4)
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
expect_equal(isresTest$par, isresControl$solution, tolerance = tol)
expect_equal(isresTest$value, isresControl$objective, tolerance = tol)
expect_identical(isresTest$convergence, isresControl$status)
expect_identical(isresTest$message, isresControl$message)

# Passing heq
# Need a ridiculously loose tolerance on ISRES now.
# (AA: 2023-02-06)
isresTest <- isres(x0, rbf, lb, ub, heq = heq, maxeval = 2e4L)
# Cannot check for value equivalence since the stochastic nature of the problem
# creates different solutions to this "improper" test even using the same seed
# and calls! So dropping maxeval to 1e4 for speed.
# (AA: 2024-06-25)
isresTest <- isres(x0, rbf, lb, ub, heq = heq, maxeval = 1e4L)

isresControl <- nloptr(x0 = x0,
eval_f = rbf,
eval_g_eq = heq,
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GN_ISRES",
maxeval = 2e4L, xtol_rel = 1e-6,
maxeval = 1e4L, xtol_rel = 1e-6,
population = 60))

expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
expect_identical(isresTest$convergence, isresControl$status)
expect_identical(isresTest$message, isresControl$message)

# Passing hin
isresControl <- nloptr(x0 = x0,
Expand All @@ -178,10 +161,10 @@ expect_silent(isres(x0, rbf, lb, ub, hin = hin, maxeval = 2e4L,
isresTest <- isres(x0, rbf, lb, ub, hin = hin, maxeval = 2e4L,
deprecatedBehavior = FALSE)

expect_equal(isresTest$par, isresControl$solution, tolerance = 1e-4)
expect_equal(isresTest$value, isresControl$objective, tolerance = 1e-4)
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
expect_equal(isresTest$par, isresControl$solution, tolerance = tol)
expect_equal(isresTest$value, isresControl$objective, tolerance = tol)
expect_identical(isresTest$convergence, isresControl$status)
expect_identical(isresTest$message, isresControl$message)

# Test deprecated message
expect_warning(isres(x0, rbf, lower = lb, upper = ub, hin = hin2,
Expand All @@ -191,12 +174,37 @@ expect_warning(isres(x0, rbf, lower = lb, upper = ub, hin = hin2,
isresTest <- suppressWarnings(isres(x0, rbf, lb, ub, hin = hin2,
maxeval = 2e4L))

expect_equal(isresTest$par, isresControl$solution, tolerance = 1e-4)
expect_equal(isresTest$value, isresControl$objective, tolerance = 1e-3)
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
expect_equal(isresTest$par, isresControl$solution, tolerance = tol)
expect_equal(isresTest$value, isresControl$objective, tolerance = tol)
expect_identical(isresTest$convergence, isresControl$status)
expect_identical(isresTest$message, isresControl$message)

## CRS2LM
# Take these outside the function since they are unchanging; just pass them!
a <- c(1.0, 1.2, 3.0, 3.2)
A <- matrix(c(10, 0.05, 3, 17,
3, 10, 3.5, 8,
17, 17, 1.7, 0.05,
3.5, 0.1, 10, 10,
1.7, 8, 17, 0.1,
8, 14, 8, 14), nrow = 4)

B <- matrix(c(0.1312, 0.2329, 0.2348, 0.4047,
0.1696, 0.4135, 0.1451, 0.8828,
0.5569, 0.8307, 0.3522, 0.8732,
0.0124, 0.3736, 0.2883, 0.5743,
0.8283, 0.1004, 0.3047, 0.1091,
0.5886, 0.9991, 0.6650, 0.0381), nrow = 4)

hartmann6 <- function(x, a, A, B) {
fun <- 0
for (i in 1:4) {
fun <- fun - a[i] * exp(-sum(A[i, ] * (x - B[i, ]) ^ 2))
}

fun
}

# Test printout if nl.info passed. The word "Call:" should be in output if
# passed and not if not passed.
x0 <- lb <- rep(0, 6L)
Expand Down

0 comments on commit 8c975a3

Please sign in to comment.