Nothing
# Copyright (C) 2023 Avraham Adler. All Rights Reserved.
# SPDX-License-Identifier: LGPL-3.0-or-later
#
# File: test-wrapper-ccsaq
# Author: Avraham Adler
# Date: 6 February 2023
#
# Test wrapper calls to ccsaq algorithm
#
# 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.")
# Taken from example
x0.hs100 <- c(1, 2, 0, 4, 0, 1, 1)
fn.hs100 <- function(x) {(x[1] - 10) ^ 2 + 5 * (x[2] - 12) ^ 2 + x[3] ^ 4 +
3 * (x[4] - 11) ^ 2 + 10 * x[5] ^ 6 + 7 * x[6] ^ 2 +
x[7] ^ 4 - 4 * x[6] * x[7] - 10 * x[6] - 8 * x[7]}
hin.hs100 <- function(x) {c(
2 * x[1] ^ 2 + 3 * x[2] ^ 4 + x[3] + 4 * x[4] ^ 2 + 5 * x[5] - 127,
7 * x[1] + 3 * x[2] + 10 * x[3] ^ 2 + x[4] - x[5] - 282,
23 * x[1] + x[2] ^ 2 + 6 * x[6] ^ 2 - 8 * x[7] - 196,
4 * x[1] ^ 2 + x[2] ^ 2 - 3 * x[1] * x[2] + 2 * x[3] ^ 2 + 5 * x[6] -
11 * x[7])
}
gr.hs100 <- function(x) {
c( 2 * x[1] - 20,
10 * x[2] - 120,
4 * x[3] ^ 3,
6 * x[4] - 66,
60 * x[5] ^ 5,
14 * x[6] - 4 * x[7] - 10,
4 * x[7] ^ 3 - 4 * x[6] - 8)
}
hinjac.hs100 <- function(x) {
matrix(c(4 * x[1], 12 * x[2] ^ 3, 1, 8 * x[4], 5, 0, 0,
7, 3, 20 * x[3], 1, -1, 0, 0,
23, 2 * x[2], 0, 0, 0, 12 * x[6], -8,
8 * x[1] - 3 * x[2], 2 * x[2] - 3 * x[1], 4 * x[3], 0, 0, 5, -11),
nrow = 4, byrow = TRUE)
}
# In older version, the HS100 was not properly copied, so the gradients caused
# an issue. This has since been corrected, but leaving the calls in to test the
# gradient/Jacobian creation routines.
gr.hs100.computed <- function(x) nl.grad(x, fn.hs100)
hin2.hs100 <- function(x) -hin.hs100(x) # Needed to test old behavior
hinjac2.hs100 <- function(x) -hinjac.hs100(x) # Needed to test old behavior
hinjac.hs100.computed <- function(x) nl.jacobian(x, hin.hs100) # See example
hinjac2.hs100.computed <- function(x) nl.jacobian(x, hin2.hs100) # See example
ctl <- list(xtol_rel = 1e-8, maxeval = 1000L)
# Test normal silent running
expect_silent(ccsaq(x0.hs100, fn.hs100)) # Provides incorrect answer
expect_silent(ccsaq(x0.hs100, fn.hs100, hin = hin.hs100, hinjac = hinjac.hs100,
deprecatedBehavior = FALSE))
# Test printout if nl.info passed. The word "Call:" should be in output if
# passed and not if not passed.
expect_stdout(ccsaq(x0.hs100, fn.hs100, nl.info = TRUE,
deprecatedBehavior = FALSE), "Call:", fixed = TRUE)
# Control for CCSAQ HS100
## Exact
ccsaqControlE <- nloptr(
x0 = x0.hs100,
eval_f = fn.hs100,
eval_grad_f = gr.hs100,
eval_g_ineq = hin.hs100,
eval_jac_g_ineq = hinjac.hs100,
opts = list(algorithm = "NLOPT_LD_CCSAQ", xtol_rel = 1e-8, maxeval = 1000L)
)
## Computed
ccsaqControlC <- nloptr(
x0 = x0.hs100,
eval_f = fn.hs100,
eval_grad_f = gr.hs100.computed,
eval_g_ineq = hin.hs100,
eval_jac_g_ineq = hinjac.hs100.computed,
opts = list(algorithm = "NLOPT_LD_CCSAQ", xtol_rel = 1e-8, maxeval = 1000L)
)
# Test no passed gradient or Jacobian (so algorithm computes).
ccsaqTest <- ccsaq(x0.hs100, fn.hs100, hin = hin.hs100, control = ctl,
deprecatedBehavior = FALSE)
expect_identical(ccsaqTest$par, ccsaqControlC$solution)
expect_identical(ccsaqTest$value, ccsaqControlC$objective)
expect_identical(ccsaqTest$iter, ccsaqControlC$iterations)
expect_identical(ccsaqTest$convergence, ccsaqControlC$status)
expect_identical(ccsaqTest$message, ccsaqControlC$message)
# Test passed gradient and Jacobian
## Exact
ccsaqTest <- ccsaq(x0.hs100, fn.hs100, gr = gr.hs100, hin = hin.hs100,
hinjac = hinjac.hs100, control = ctl,
deprecatedBehavior = FALSE)
expect_identical(ccsaqTest$par, ccsaqControlE$solution)
expect_identical(ccsaqTest$value, ccsaqControlE$objective)
expect_identical(ccsaqTest$iter, ccsaqControlE$iterations)
expect_identical(ccsaqTest$convergence, ccsaqControlE$status)
expect_identical(ccsaqTest$message, ccsaqControlE$message)
## Computed
ccsaqTest <- ccsaq(x0.hs100, fn.hs100, gr = gr.hs100.computed, hin = hin.hs100,
hinjac = hinjac.hs100.computed, control = ctl,
deprecatedBehavior = FALSE)
expect_identical(ccsaqTest$par, ccsaqControlC$solution)
expect_identical(ccsaqTest$value, ccsaqControlC$objective)
expect_identical(ccsaqTest$iter, ccsaqControlC$iterations)
expect_identical(ccsaqTest$convergence, ccsaqControlC$status)
expect_identical(ccsaqTest$message, ccsaqControlC$message)
# Test deprecated behavior message
expect_warning(ccsaq(x0.hs100, fn.hs100, hin = hin2.hs100), depMess)
# Test deprecated behavior
ccsaqTest <- suppressWarnings(ccsaq(x0.hs100, fn.hs100, gr = gr.hs100,
hin = hin2.hs100, hinjac = hinjac2.hs100,
control = ctl))
expect_identical(ccsaqTest$par, ccsaqControlE$solution)
expect_identical(ccsaqTest$value, ccsaqControlE$objective)
expect_identical(ccsaqTest$iter, ccsaqControlE$iterations)
expect_identical(ccsaqTest$convergence, ccsaqControlE$status)
expect_identical(ccsaqTest$message, ccsaqControlE$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.