R/benchmarks.R

In SBOAtools: Secretary Bird Optimization for Continuous Optimization and Neural Network Training

# Internal helper: penalty function used in F12 and F13
.u_penalty <- function(x, a, k, m) {
  ifelse(
    x > a, k * (x - a)^m,
    ifelse(x < -a, k * (-x - a)^m, 0)
  )
}

# ---------------------------------
# Built-in benchmark functions F1-F23
# ---------------------------------

.f1 <- function(x) {
  x <- as.numeric(x)
  sum(x^2)
}

.f2 <- function(x) {
  x <- as.numeric(x)
  sum(abs(x)) + prod(abs(x))
}

.f3 <- function(x) {
  x <- as.numeric(x)
  sum(cumsum(x)^2)
}

.f4 <- function(x) {
  x <- as.numeric(x)
  max(abs(x))
}

.f5 <- function(x) {
  x <- as.numeric(x)
  sum(100 * (x[-1] - x[-length(x)]^2)^2 + (x[-length(x)] - 1)^2)
}

.f6 <- function(x) {
  x <- as.numeric(x)
  sum((floor(x + 0.5))^2)
}

.f7 <- function(x) {
  x <- as.numeric(x)
  i <- seq_along(x)
  sum(i * x^4) + runif(1)
}

.f8 <- function(x) {
  x <- as.numeric(x)
  sum(-x * sin(sqrt(abs(x))))
}

.f9 <- function(x) {
  x <- as.numeric(x)
  n <- length(x)
  10 * n + sum(x^2 - 10 * cos(2 * pi * x))
}

.f10 <- function(x) {
  x <- as.numeric(x)
  n <- length(x)
  -20 * exp(-0.2 * sqrt(sum(x^2) / n)) -
    exp(sum(cos(2 * pi * x)) / n) + 20 + exp(1)
}

.f11 <- function(x) {
  x <- as.numeric(x)
  i <- seq_along(x)
  sum(x^2) / 4000 - prod(cos(x / sqrt(i))) + 1
}

.f12 <- function(x) {
  x <- as.numeric(x)
  n <- length(x)
  y <- 1 + (x + 1) / 4

  term1 <- 10 * sin(pi * y[1])^2
  term2 <- sum((y[1:(n - 1)] - 1)^2 * (1 + 10 * sin(pi * y[2:n])^2))
  term3 <- (y[n] - 1)^2

  (pi / n) * (term1 + term2 + term3) + sum(.u_penalty(x, 10, 100, 4))
}

.f13 <- function(x) {
  x <- as.numeric(x)
  n <- length(x)

  term1 <- sin(3 * pi * x[1])^2
  term2 <- sum((x[1:(n - 1)] - 1)^2 * (1 + sin(3 * pi * x[2:n])^2))
  term3 <- (x[n] - 1)^2 * (1 + sin(2 * pi * x[n])^2)

  0.1 * (term1 + term2 + term3) + sum(.u_penalty(x, 5, 100, 4))
}

.f14 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 2) {
    stop("F14 requires a 2-dimensional input.")
  }

  a1 <- c(-32, -16, 0, 16, 32)
  aS <- rbind(rep(a1, 5), rep(a1, each = 5))

  s <- numeric(25)
  for (j in 1:25) {
    s[j] <- sum((x - aS[, j])^6)
  }

  1 / (1 / 500 + sum(1 / ((1:25) + s)))
}

.f15 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 4) {
    stop("F15 requires a 4-dimensional input.")
  }

  aK <- c(
    0.1957, 0.1947, 0.1735, 0.16,
    0.0844, 0.0627, 0.0456, 0.0342,
    0.0323, 0.0235, 0.0246
  )
  bK <- 1 / c(
    0.25, 0.5, 1, 2,
    4, 6, 8, 10,
    12, 14, 16
  )

  sum((aK - (x[1] * (bK^2 + x[2] * bK)) /
         (bK^2 + x[3] * bK + x[4]))^2)
}

.f16 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 2) {
    stop("F16 requires a 2-dimensional input.")
  }

  4 * x[1]^2 - 2.1 * x[1]^4 + x[1]^6 / 3 +
    x[1] * x[2] - 4 * x[2]^2 + 4 * x[2]^4
}

.f17 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 2) {
    stop("F17 requires a 2-dimensional input.")
  }

  a <- 1
  b <- 5.1 / (4 * pi^2)
  c <- 5 / pi
  r <- 6
  s <- 10
  t <- 1 / (8 * pi)

  a * (x[2] - b * x[1]^2 + c * x[1] - r)^2 + s * (1 - t) * cos(x[1]) + s
}

.f18 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 2) {
    stop("F18 requires a 2-dimensional input.")
  }

  term1 <- 1 + (x[1] + x[2] + 1)^2 *
    (19 - 14 * x[1] + 3 * x[1]^2 - 14 * x[2] + 6 * x[1] * x[2] + 3 * x[2]^2)

  term2 <- 30 + (2 * x[1] - 3 * x[2])^2 *
    (18 - 32 * x[1] + 12 * x[1]^2 + 48 * x[2] - 36 * x[1] * x[2] + 27 * x[2]^2)

  term1 * term2
}

.f19 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 3) {
    stop("F19 requires a 3-dimensional input.")
  }

  alpha <- c(1.0, 1.2, 3.0, 3.2)

  A <- rbind(
    c(3.0, 10, 30),
    c(0.1, 10, 35),
    c(3.0, 10, 30),
    c(0.1, 10, 35)
  )

  P <- 1e-4 * rbind(
    c(3689, 1170, 2673),
    c(4699, 4387, 7470),
    c(1091, 8732, 5547),
    c(381, 5743, 8828)
  )

  outer_sum <- numeric(4)
  for (i in 1:4) {
    outer_sum[i] <- sum(A[i, ] * (x - P[i, ])^2)
  }

  -sum(alpha * exp(-outer_sum))
}

.f20 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 6) {
    stop("F20 requires a 6-dimensional input.")
  }

  alpha <- c(1.0, 1.2, 3.0, 3.2)

  A <- rbind(
    c(10, 3, 17, 3.5, 1.7, 8),
    c(0.05, 10, 17, 0.1, 8, 14),
    c(3, 3.5, 1.7, 10, 17, 8),
    c(17, 8, 0.05, 10, 0.1, 14)
  )

  P <- 1e-4 * rbind(
    c(1312, 1696, 5569, 124, 8283, 5886),
    c(2329, 4135, 8307, 3736, 1004, 9991),
    c(2348, 1451, 3522, 2883, 3047, 6650),
    c(4047, 8828, 8732, 5743, 1091, 381)
  )

  outer_sum <- numeric(4)
  for (i in 1:4) {
    outer_sum[i] <- sum(A[i, ] * (x - P[i, ])^2)
  }

  -sum(alpha * exp(-outer_sum))
}

.f21 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 4) {
    stop("F21 requires a 4-dimensional input.")
  }

  aSH <- rbind(
    c(4, 4, 4, 4),
    c(1, 1, 1, 1),
    c(8, 8, 8, 8),
    c(6, 6, 6, 6),
    c(3, 7, 3, 7),
    c(2, 9, 2, 9),
    c(5, 5, 3, 3),
    c(8, 1, 8, 1),
    c(6, 2, 6, 2),
    c(7, 3.6, 7, 3.6)
  )

  cSH <- c(0.1, 0.2, 0.2, 0.4, 0.4, 0.6, 0.3, 0.7, 0.5, 0.5)

  m <- 5
  -sum(1 / (rowSums((aSH[1:m, , drop = FALSE] - matrix(x, nrow = m, ncol = 4, byrow = TRUE))^2) + cSH[1:m]))
}

.f22 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 4) {
    stop("F22 requires a 4-dimensional input.")
  }

  aSH <- rbind(
    c(4, 4, 4, 4),
    c(1, 1, 1, 1),
    c(8, 8, 8, 8),
    c(6, 6, 6, 6),
    c(3, 7, 3, 7),
    c(2, 9, 2, 9),
    c(5, 5, 3, 3),
    c(8, 1, 8, 1),
    c(6, 2, 6, 2),
    c(7, 3.6, 7, 3.6)
  )

  cSH <- c(0.1, 0.2, 0.2, 0.4, 0.4, 0.6, 0.3, 0.7, 0.5, 0.5)

  m <- 7
  -sum(1 / (rowSums((aSH[1:m, , drop = FALSE] - matrix(x, nrow = m, ncol = 4, byrow = TRUE))^2) + cSH[1:m]))
}

.f23 <- function(x) {
  x <- as.numeric(x)
  if (length(x) != 4) {
    stop("F23 requires a 4-dimensional input.")
  }

  aSH <- rbind(
    c(4, 4, 4, 4),
    c(1, 1, 1, 1),
    c(8, 8, 8, 8),
    c(6, 6, 6, 6),
    c(3, 7, 3, 7),
    c(2, 9, 2, 9),
    c(5, 5, 3, 3),
    c(8, 1, 8, 1),
    c(6, 2, 6, 2),
    c(7, 3.6, 7, 3.6)
  )

  cSH <- c(0.1, 0.2, 0.2, 0.4, 0.4, 0.6, 0.3, 0.7, 0.5, 0.5)

  m <- 10
  -sum(1 / (rowSums((aSH[1:m, , drop = FALSE] - matrix(x, nrow = m, ncol = 4, byrow = TRUE))^2) + cSH[1:m]))
}

# ---------------------------------
# Benchmark registry
# ---------------------------------

.benchmark_registry <- function() {
  list(
    F1 = list(
      name = "F1",
      label = "Sphere",
      category = "unimodal",
      fn = .f1,
      lower = -100,
      upper = 100,
      fixed_dim = NA_integer_
    ),
    F2 = list(
      name = "F2",
      label = "Schwefel 2.22",
      category = "unimodal",
      fn = .f2,
      lower = -10,
      upper = 10,
      fixed_dim = NA_integer_
    ),
    F3 = list(
      name = "F3",
      label = "Schwefel 1.2",
      category = "unimodal",
      fn = .f3,
      lower = -100,
      upper = 100,
      fixed_dim = NA_integer_
    ),
    F4 = list(
      name = "F4",
      label = "Schwefel 2.21",
      category = "unimodal",
      fn = .f4,
      lower = -100,
      upper = 100,
      fixed_dim = NA_integer_
    ),
    F5 = list(
      name = "F5",
      label = "Rosenbrock",
      category = "unimodal",
      fn = .f5,
      lower = -30,
      upper = 30,
      fixed_dim = NA_integer_
    ),
    F6 = list(
      name = "F6",
      label = "Step",
      category = "unimodal",
      fn = .f6,
      lower = -100,
      upper = 100,
      fixed_dim = NA_integer_
    ),
    F7 = list(
      name = "F7",
      label = "Quartic Noise",
      category = "unimodal",
      fn = .f7,
      lower = -1.28,
      upper = 1.28,
      fixed_dim = NA_integer_
    ),
    F8 = list(
      name = "F8",
      label = "Schwefel",
      category = "multimodal",
      fn = .f8,
      lower = -500,
      upper = 500,
      fixed_dim = NA_integer_
    ),
    F9 = list(
      name = "F9",
      label = "Rastrigin",
      category = "multimodal",
      fn = .f9,
      lower = -5.12,
      upper = 5.12,
      fixed_dim = NA_integer_
    ),
    F10 = list(
      name = "F10",
      label = "Ackley",
      category = "multimodal",
      fn = .f10,
      lower = -32,
      upper = 32,
      fixed_dim = NA_integer_
    ),
    F11 = list(
      name = "F11",
      label = "Griewank",
      category = "multimodal",
      fn = .f11,
      lower = -600,
      upper = 600,
      fixed_dim = NA_integer_
    ),
    F12 = list(
      name = "F12",
      label = "Penalized 1",
      category = "multimodal",
      fn = .f12,
      lower = -50,
      upper = 50,
      fixed_dim = NA_integer_
    ),
    F13 = list(
      name = "F13",
      label = "Penalized 2",
      category = "multimodal",
      fn = .f13,
      lower = -50,
      upper = 50,
      fixed_dim = NA_integer_
    ),
    F14 = list(
      name = "F14",
      label = "Shekel's Foxholes",
      category = "fixed_dimension",
      fn = .f14,
      lower = -65.536,
      upper = 65.536,
      fixed_dim = 2L
    ),
    F15 = list(
      name = "F15",
      label = "Kowalik",
      category = "fixed_dimension",
      fn = .f15,
      lower = -5,
      upper = 5,
      fixed_dim = 4L
    ),
    F16 = list(
      name = "F16",
      label = "Six-Hump Camel Back",
      category = "fixed_dimension",
      fn = .f16,
      lower = -5,
      upper = 5,
      fixed_dim = 2L
    ),
    F17 = list(
      name = "F17",
      label = "Branin",
      category = "fixed_dimension",
      fn = .f17,
      lower = c(-5, 0),
      upper = c(10, 15),
      fixed_dim = 2L
    ),
    F18 = list(
      name = "F18",
      label = "Goldstein-Price",
      category = "fixed_dimension",
      fn = .f18,
      lower = -2,
      upper = 2,
      fixed_dim = 2L
    ),
    F19 = list(
      name = "F19",
      label = "Hartman 3",
      category = "fixed_dimension",
      fn = .f19,
      lower = 0,
      upper = 1,
      fixed_dim = 3L
    ),
    F20 = list(
      name = "F20",
      label = "Hartman 6",
      category = "fixed_dimension",
      fn = .f20,
      lower = 0,
      upper = 1,
      fixed_dim = 6L
    ),
    F21 = list(
      name = "F21",
      label = "Shekel 5",
      category = "fixed_dimension",
      fn = .f21,
      lower = 0,
      upper = 10,
      fixed_dim = 4L
    ),
    F22 = list(
      name = "F22",
      label = "Shekel 7",
      category = "fixed_dimension",
      fn = .f22,
      lower = 0,
      upper = 10,
      fixed_dim = 4L
    ),
    F23 = list(
      name = "F23",
      label = "Shekel 10",
      category = "fixed_dimension",
      fn = .f23,
      lower = 0,
      upper = 10,
      fixed_dim = 4L
    )
  )
}

#' List built-in benchmark functions
#'
#' Returns a summary table of the built-in F1-F23 benchmark functions.
#'
#' @return A data frame.
#' @examples
#' list_benchmarks()
#' @export
list_benchmarks <- function() {
  reg <- .benchmark_registry()

  data.frame(
    name = names(reg),
    label = vapply(reg, function(z) z$label, character(1)),
    category = vapply(reg, function(z) z$category, character(1)),
    fixed_dim = vapply(
      reg,
      function(z) if (is.na(z$fixed_dim)) "scalable" else as.character(z$fixed_dim),
      character(1)
    ),
    row.names = NULL,
    stringsAsFactors = FALSE
  )
}

#' Get a built-in benchmark definition
#'
#' Returns a built-in benchmark definition by name.
#'
#' @param name Benchmark name such as \code{"F1"} or \code{"F14"}.
#'
#' @return A list containing the benchmark function and its metadata.
#' @examples
#' b <- get_benchmark("F1")
#' b$fn(rep(0, 5))
#' @export
get_benchmark <- function(name) {
  reg <- .benchmark_registry()

  if (!is.character(name) || length(name) != 1 || !name %in% names(reg)) {
    stop("Unknown benchmark name. Use list_benchmarks() to see available benchmarks.")
  }

  reg[[name]]
}