tests/testthat/test-broydt.R

broydt.f <- function(x) {
    n <- length(x)
    res <- rep(NA, n)
    res[1] <- ((3 - 0.5 * x[1]) * x[1]) - 2 * x[2] + 1
    tnm1 <- 2:(n - 1)
    res[tnm1] <- ((3 - 0.5 * x[tnm1]) * x[tnm1]) - x[tnm1 - 1] -
        2 * x[tnm1 + 1] + 1
    res[n] <- ((3 - 0.5 * x[n]) * x[n]) - x[n - 1] + 1
    sum(res * res)
}

broydt.g <- function(x) {
    n <- length(x)
    gg <- rep(NA, n)  # gradient set to NA to start with
    gg[1] <- -2 + 2 * x[1] + 4 * x[3] + (6 - 2 * x[1]) * (1 -
        2 * x[2] + x[1] * (3 - 0.5 * x[1])) - 2 * x[2] * (3 -
        0.5 * x[2])
    gg[2] <- -6 + 4 * x[4] + 10 * x[2] + (6 - 2 * x[2]) * (1 -
        x[1] - 2 * x[3] + x[2] * (3 - 0.5 * x[2])) - 4 * x[1] *
        (3 - 0.5 * x[1]) - 2 * x[3] * (3 - 0.5 * x[3])
    tnm2 <- 3:(n - 2)
    gg[tnm2] <- -6 + 4 * x[tnm2 - 2] + 4 * x[tnm2 + 2] + 10 *
        x[tnm2] + (6 - 2 * x[tnm2]) * (1 - x[tnm2 - 1] - 2 *
        x[tnm2 + 1] + x[tnm2] * (3 - 0.5 * x[tnm2])) - 4 * x[tnm2 -
        1] * (3 - 0.5 * x[tnm2 - 1]) - 2 * x[tnm2 + 1] * (3 -
        0.5 * x[tnm2 + 1])
    gg[n - 1] <- -6 + 4 * x[n - 3] + 10 * x[n - 1] + (6 - 2 *
        x[n - 1]) * (1 - x[n - 2] - 2 * x[n] + x[n - 1] * (3 -
        0.5 * x[n - 1])) - 4 * x[n - 2] * (3 - 0.5 * x[n - 2]) -
        2 * x[n] * (3 - 0.5 * x[n])

    gg[n] <- -4 + 4 * x[n - 2] + 8 * x[n] + (6 - 2 * x[n]) *
        (1 - x[n - 1] + x[n] * (3 - 0.5 * x[n])) - 4 * x[n -
        1] * (3 - 0.5 * x[n - 1])
    return(gg)
}

ni <- c(10, 100, 400)

p10 <- c(4.556, 2.134, 0.301, -0.101, 0.261, 1.052, 1.892, 2.09, 1.349, 0.45);
p10c <- c(1.836, 2.415, 1.751, 1.147, 1, 1.157, 1.546, 1.948, 1.855, 1);
p100 <- c(2.062, 2.53, 1.664, 1.039, 0.956, 1.187, 1.45, 1.556, 1.504,
          1.412, 1.368, 1.378, 1.408, 1.428, 1.428, 1.418, 1.411, 1.409,
          1.412, 1.415, 1.416, 1.415, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.415, 1.414, 1.414, 1.413,
          1.413, 1.416, 1.418, 1.418, 1.412, 1.403, 1.401, 1.416, 1.442,
          1.456, 1.423, 1.346, 1.287, 1.342, 1.551, 1.776, 1.659, 1.039,
          0.342);
p100c <- c(1.363, 2.08, 1.857, 1.383, 1.168, 1.219, 1.373, 1.479, 1.485,
           1.437, 1.397, 1.389, 1.403, 1.418, 1.423, 1.419, 1.414, 1.411,
           1.412, 1.414, 1.415, 1.415, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.415, 1.415, 1.415, 1.413,
           1.412, 1.413, 1.416, 1.419, 1.42, 1.413, 1.4, 1.395, 1.411, 1.448,
           1.473, 1.438, 1.335, 1.239, 1.282, 1.544, 1.891, 1.821, 1);
p400 <- c(2.066, 2.532, 1.662, 1.037, 0.955, 1.186, 1.45, 1.556, 1.504,
          1.412, 1.368, 1.378, 1.408, 1.428, 1.428, 1.418, 1.411, 1.409,
          1.412, 1.415, 1.416, 1.415, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
          1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.415,
          1.414, 1.414, 1.413, 1.413, 1.416, 1.418, 1.418, 1.412, 1.403,
          1.401, 1.416, 1.442, 1.456, 1.423, 1.346, 1.287, 1.342, 1.551,
          1.776, 1.659, 1.039, 0.342);
p400c <- c(1.321, 2.045, 1.862, 1.404, 1.182, 1.222, 1.369, 1.474, 1.483,
           1.438, 1.398, 1.39, 1.403, 1.417, 1.422, 1.419, 1.414, 1.412,
           1.412, 1.414, 1.415, 1.415, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414,
           1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.414, 1.415,
           1.415, 1.415, 1.413, 1.412, 1.413, 1.416, 1.419, 1.42, 1.413,
           1.4, 1.395, 1.411, 1.448, 1.473, 1.438, 1.335, 1.239, 1.282,
           1.544, 1.891, 1.821, 1);
for (ii in ni) {
    n <- ii
    str <- paste0("Broydt unconstrained n=",n," with gradient")
    context(str)
    test_that(str, {
        x0 <- rep(pi, n)
        ans <- lbfgsb3c(x0, broydt.f, broydt.g, control = list(trace = -1L))
        if (n == 10){
            expect_equal(p10,
                     round(ans$par, 3))
            expect_equal(2.775,
                     round(ans$value, 3))
        } else if (n == 100){
            expect_equal(p100,
                         round(ans$par, 3))
            expect_equal(3.258,
                         round(ans$value, 3))
        } else {
            expect_equal(p400,
                         round(ans$par, 3))
            expect_equal(round(ans$value, 3),
                         3.258)
        }

    })
    str <- paste0("Broydt unconstrained n=",n," with no analytic gradient")
    context(str)
    test_that(str, {
        if (n > 100) skip_on_cran()
        x0 <- rep(pi, n)
        ans <- lbfgsb3c(x0, broydt.f)
        if (n == 10){
            expect_equal(p10,
                     round(ans$par, 3))
            expect_equal(2.775,
                     round(ans$value, 3))
        } else if (n == 100){
            expect_equal(p100,
                         round(ans$par, 3))
            expect_equal(3.258,
                         round(ans$value, 3))
        } else {
            expect_equal(p400,
                         round(ans$par, 3))
            expect_equal(round(ans$value, 3),
                         3.258)
        }
    })
    lower <- rep(1, n)
    upper <- rep(Inf, n)
    str <- paste0("constrained n= ",n," analytic gradient")
    context(str)
    test_that(str, {
        x0 <- rep(pi, n)
        ans <- lbfgsb3c(x0, broydt.f, broydt.g, lower=lower, upper=upper)
        if (n == 10){
            expect_equal(p10c,
                         round(ans$par, 3))
            expect_equal(4.065,
                         round(ans$value, 3))
        } else if (n == 100){
            expect_equal(p100c,
                         round(ans$par, 3))
            expect_equal(4.294,
                         round(ans$value, 3))
        } else {
            expect_equal(p400c,
                         round(ans$par, 3))
            expect_equal(round(ans$value, 3),
                         4.294)
        }
    })
    str <- paste0("constrained n= ",n," no analytic gradient")
    context(str)
    test_that(str, {
        if (n > 100) skip_on_cran()
        x0 <- rep(pi, n)
        ans <- lbfgsb3c(x0, broydt.f, lower=lower, upper=upper)
        if (n == 10){
            expect_equal(p10c,
                         round(ans$par, 3))
            expect_equal(4.065,
                         round(ans$value, 3))
        } else if (n == 100){
            expect_equal(p100c,
                         round(ans$par, 3))
            expect_equal(4.294,
                         round(ans$value, 3))
        } else {
            expect_equal(p400c,
                         round(ans$par, 3))
            expect_equal(round(ans$value, 3),
                         4.294)
        }
    })
}

Try the lbfgsb3c package in your browser

Any scripts or data that you put into this service are public.

lbfgsb3c documentation built on May 2, 2019, 4:59 p.m.