Nothing
# Copyright (C) 2023 Avraham Adler. All Rights Reserved.
# SPDX-License-Identifier: LGPL-3.0-or-later
#
# File: test-wrapper-global
# Author: Avraham Adler
# Date: 6 February 2023
#
# Test wrapper calls to StoGo, ISRES, and CRS algorithms. As many of these
# algorithms have issues, this test suite may not be completed.
#
# Changelog:
# 2023-08-23: Change _output to _stdout
#
library(nloptr)
depMess <- paste("The old behavior for hin >= 0 has been deprecated. Please",
"restate the inequality to be <=0. The ability to use the old",
"behavior will be removed in a future release.")
## Functions for the algorithms
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))}
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)
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
}
x0 <- c(-1.2, 1)
lb <- c(-3, -3)
ub <- c(3, 3)
## StoGo
# Test printout if nl.info passed. The word "Call:" should be in output if
# passed and not if not passed.
expect_stdout(stogo(x0, rbf, lower = lb, upper = ub, nl.info = TRUE),
"Call:", fixed = TRUE)
expect_silent(stogo(x0, rbf, lower = lb, upper = ub))
# No passed gradient; Randomized: FALSE
stogoTest <- stogo(x0, rbf, lower = lb, upper = ub)
stogoControl <- nloptr(x0 = x0,
eval_f = rbf,
eval_grad_f = function(x) nl.grad(x, rbf),
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GD_STOGO",
xtol_rel = 1e-6, maxeval = 10000L))
expect_identical(stogoTest$par, stogoControl$solution)
expect_identical(stogoTest$value, stogoControl$objective)
expect_identical(stogoTest$iter, stogoControl$iterations)
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
# Passed gradient; Randomized: FALSE
stogoTest <- stogo(x0, rbf, gr, lb, ub)
stogoControl <- nloptr(x0 = x0,
eval_f = rbf,
eval_grad_f = gr,
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GD_STOGO",
xtol_rel = 1e-6, maxeval = 10000L))
expect_identical(stogoTest$par, stogoControl$solution)
expect_identical(stogoTest$value, stogoControl$objective)
expect_identical(stogoTest$iter, stogoControl$iterations)
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
# Passed gradient; Randomized: TRUE
stogoTest <- stogo(x0, rbf, gr, lb, ub, randomized = TRUE)
stogoControl <- nloptr(x0 = x0,
eval_f = rbf,
eval_grad_f = gr,
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GD_STOGO_RAND",
xtol_rel = 1e-6, maxeval = 10000L))
expect_identical(stogoTest$par, stogoControl$solution)
expect_identical(stogoTest$value, stogoControl$objective)
expect_identical(stogoTest$iter, stogoControl$iterations)
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
## ISRES
# Test printout if nl.info passed. The word "Call:" should be in output if
# passed and not if not passed.
expect_stdout(isres(x0, rbf, lb, ub, nl.info = TRUE), "Call:", fixed = TRUE)
expect_silent(isres(x0, rbf, lb, ub))
# As ISRES is stochastic, more iterations and a much looser tolerance is needed.
# Also, iteration count will almost surely not be equal.
# No passed hin or heq
isresTest <- isres(x0, rbf, lb, ub, maxeval = 2e4L)
isresControl <- nloptr(x0 = x0,
eval_f = rbf,
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GN_ISRES",
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)
# Passing heq
# Need a ridiculously loose tolerance on ISRES now.
# (AA: 2023-02-06)
isresTest <- isres(x0, rbf, lb, ub, heq = heq, maxeval = 2e4L)
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,
population = 60))
expect_identical(stogoTest$convergence, stogoControl$status)
expect_identical(stogoTest$message, stogoControl$message)
# Passing hin
isresControl <- nloptr(x0 = x0,
eval_f = rbf,
eval_g_ineq = hin,
lb = lb,
ub = ub,
opts = list(algorithm = "NLOPT_GN_ISRES",
maxeval = 2e4L, xtol_rel = 1e-6,
population = 60))
expect_silent(isres(x0, rbf, lb, ub, hin = hin, maxeval = 2e4L,
deprecatedBehavior = FALSE))
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)
# Test deprecated message
expect_warning(isres(x0, rbf, lower = lb, upper = ub, hin = hin2,
maxeval = 2e4L), depMess)
# Test deprecated behavior
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)
## CRS2LM
# 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)
ub <- rep(1, 6L)
expect_stdout(crs2lm(x0 = x0, hartmann6, lower = lb, upper = ub,
nl.info = TRUE, a = a, A = A, B = B),
"Call:", fixed = TRUE)
expect_silent(crs2lm(x0 = x0, hartmann6, lower = lb, upper = ub,
a = a, A = A, B = B))
crs2lmTest <- crs2lm(x0 = x0, hartmann6, lower = lb, upper = ub, ranseed = 43L,
xtol_rel = 1e-8, maxeval = 100L, a = a, A = A, B = B)
crs2lmControl <- nloptr(x0 = x0,
eval_f = hartmann6,
lb = lb,
ub = ub,
a = a,
A = A,
B = B,
opts = list(algorithm = "NLOPT_GN_CRS2_LM",
xtol_rel = 1e-8,
maxeval = 100L,
ranseed = 43L,
population = 70))
expect_identical(crs2lmTest$par, crs2lmControl$solution)
expect_identical(crs2lmTest$value, crs2lmControl$objective)
expect_identical(crs2lmTest$iter, crs2lmControl$iterations)
expect_identical(crs2lmTest$convergence, crs2lmControl$status)
expect_identical(crs2lmTest$message, crs2lmControl$message)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.