tests/testthat/test_ntrm.R

In drda: Dose-Response Data Analysis

test_that("ntrm_solve_tr_subproblem: random vector", {
  set.seed(4705968)

  G <- c(-6.26752849, -1.40272211, -0.02658175, -1.85259931)
  H <- matrix(
    c(
      15, 21.188528, -0.5116276, 3.120284,
      21.1885279, 48.405099, -1.4542101, 3.925457,
      -0.5116276, -1.454210, -0.3024076, -1.191577,
      3.1202843, 3.925457, -1.1915771, 3.543116
    ),
    nrow = 4,
    ncol = 4
  )

  m <- function(x) {
    sum(G * x) + sum(x * (H %*% x)) / 2
  }

  result <- ntrm_solve_tr_subproblem(G, H, 1)

  expect_equal(result$m, m(result$p))

  for (j in seq_len(10)) {
    # generate a random vector and set it on the boundary
    bad_p <- runif(4)
    bad_p <- bad_p / sqrt(sum(bad_p^2))

    expect_lte(result$m, m(bad_p) + 1.0e-8)
  }
})

test_that("ntrm_solve_tr_subproblem: random Hessian", {
  set.seed(4306006)

  for (i in seq_len(1000)) {
    G <- rnorm(4)
    H <- matrix(rnorm(16), nrow = 4, ncol = 4)
    H <- H + t(H)

    result <- ntrm_solve_tr_subproblem(G, H, 1)

    m <- function(x) {
      sum(G * x) + sum(x * (H %*% x)) / 2
    }

    expect_equal(result$m, m(result$p))
    expect_lte(result$m, m(rep(0, 4)) + 1.0e-8)

    for (j in seq_len(10)) {
      # generate a random vector and set it on the boundary
      bad_p <- runif(4)
      bad_p <- bad_p / sqrt(sum(bad_p^2))

      expect_lte(result$m, m(bad_p) + 1.0e-8)

      bad_p <- bad_p * runif(1)

      expect_lte(result$m, m(bad_p) + 1.0e-8)
    }
  }
})

test_that("ntrm_solve_tr_subproblem: various situations", {
  set.seed(7160982)

  H <- matrix(runif(16), nrow = 4, ncol = 4)
  H <- t(H) * H + 4 * diag(4)

  H_eig <- eigen(H, symmetric = TRUE)
  U <- H_eig$vectors

  G <- rep(0, 4)
  G[1] <- 1

  true_p <- -solve(H, G)
  true_p_sn <- sum(true_p^2)

  true_m <- sum(G * true_p) + sum(true_p * (H %*% true_p)) / 2

  # An interior solution
  delta <- sqrt(true_p_sn) + 1
  result <- ntrm_solve_tr_subproblem(G, H, delta)

  expect_lte(sum(result$p^2), delta^2)
  expect_equal(result$m, true_m)
  expect_equal(result$p, true_p)

  # A boundary solution
  delta <- sqrt(true_p_sn) / 2
  result <- ntrm_solve_tr_subproblem(G, H, delta)

  expect_gt(result$m, true_m)
  expect_equal(sqrt(sum(result$p^2)), delta)

  # hard case problem
  L <- rep(0.1, 4)
  L[1] <- -1

  H <- U %*% diag(L) %*% t(U)
  H <- (t(H) + H) / 2
  G <- U[, 2]

  expect_true(isSymmetric(H))
  expect_lt(abs(sum(G * U[, 1])), 1.0e-12)

  true_p <- -solve(H, G)
  true_p_sn <- sum(true_p^2)
  true_m <- sum(G * true_p) + sum(true_p * (H %*% true_p)) / 2

  delta <- sqrt(true_p_sn) / 2
  result <- ntrm_solve_tr_subproblem(G, H, delta)

  expect_equal(sqrt(sum(result$p^2)), delta)
})

test_that("ntrm: Rosenbrock function", {
  set.seed(2823441)

  fn <- function(x) {
    (1 - x[1])^2 + 100 * (x[2] - x[1]^2)^2
  }

  gradient <- function(x) {
    c(2 * (200 * x[1]^3 - 200 * x[1] * x[2] + x[1] - 1), 200 * (x[2] - x[1]^2))
  }

  hessian <- function(x) {
    matrix(
      c(1200 * x[1]^2 - 400 * x[2] + 2, -400 * x[1], -400 * x[1], 200),
      nrow = 2, ncol = 2
    )
  }

  gh <- function(x) {
    list(G = gradient(x), H = hessian(x))
  }

  # try different random starting points
  for (i in 1:10) {
    result <- ntrm(fn, gh, rnorm(2, sd = 3), 1000)
    expect_equal(result$optimum, c(1, 1))
  }
})