R/sboa.R

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

#' Secretary Bird Optimization Algorithm
#'
#' General-purpose continuous optimization using the Secretary Bird
#' Optimization Algorithm (SBOA).
#'
#' @param fn Objective function to be minimized, or a character string
#'   naming a built-in benchmark function such as \code{"F1"}.
#' @param lower Lower bounds for decision variables.
#' @param upper Upper bounds for decision variables.
#' @param n_agents Number of search agents.
#' @param max_iter Maximum number of iterations.
#' @param ... Additional arguments passed to \code{fn}.
#' @param verbose Logical; if \code{TRUE}, progress is printed.
#' @param seed Optional random seed.
#'
#' @return An object of class \code{"sboa"}.
#' @references
#' Fu, W., Wang, K., Liu, J., et al. (2024). Secretary Bird Optimization Algorithm.
#' Artificial Intelligence Review. DOI: 10.1007/s10462-024-10729-y
#' @importFrom stats runif rnorm
#' @examples
#' sphere <- function(x) sum(x^2)
#'
#' res <- sboa(
#'   fn = sphere,
#'   lower = rep(-10, 5),
#'   upper = rep(10, 5),
#'   n_agents = 10,
#'   max_iter = 20,
#'   seed = 123,
#'   verbose = FALSE
#' )
#'
#' res2 <- sboa(
#'   fn = "F1",
#'   lower = rep(-100, 5),
#'   upper = rep(100, 5),
#'   n_agents = 10,
#'   max_iter = 20,
#'   seed = 123,
#'   verbose = FALSE
#' )
#'
#' print(res)
#' print(res2)
#' list_benchmarks()
#' get_benchmark("F9")
#' @export
sboa <- function(fn,
                 lower,
                 upper,
                 n_agents = 30,
                 max_iter = 500,
                 ...,
                 verbose = TRUE,
                 seed = NULL) {

  if (!is.null(seed)) {
    set.seed(seed)
  }

  benchmark_name <- NULL

  if (is.character(fn) && length(fn) == 1) {
    benchmark_name <- fn
    bench <- get_benchmark(fn)
    fn <- bench$fn
  } else if (!is.function(fn)) {
    stop("'fn' must be either a function or a built-in benchmark name.")
  }

  lower <- as.numeric(lower)
  upper <- as.numeric(upper)

  if (length(lower) != length(upper)) {
    stop("lower and upper must have the same length.")
  }

  if (any(lower >= upper)) {
    stop("Each element of lower must be strictly less than upper.")
  }

  if (!is.null(benchmark_name)) {
    bench <- get_benchmark(benchmark_name)

    if (!is.na(bench$fixed_dim)) {
      if (length(lower) != bench$fixed_dim || length(upper) != bench$fixed_dim) {
        stop(
          benchmark_name, " requires dimension ", bench$fixed_dim,
          ". Please provide lower and upper of that length."
        )
      }
    }
  }

  dimension <- length(lower)

  X <- matrix(NA_real_, nrow = n_agents, ncol = dimension)
  for (j in seq_len(dimension)) {
    X[, j] <- runif(n_agents, min = lower[j], max = upper[j])
  }

  fit <- vapply(seq_len(n_agents), function(i) fn(X[i, ], ...), numeric(1))

  best_idx <- which.min(fit)
  best_pos <- X[best_idx, ]
  best_score <- fit[best_idx]
  convergence <- numeric(max_iter)

  for (t in seq_len(max_iter)) {
    CF <- (1 - t / max_iter)^(2 * t / max_iter)

    current_best_idx <- which.min(fit)
    current_best <- fit[current_best_idx]

    if (current_best < best_score) {
      best_score <- current_best
      best_pos <- X[current_best_idx, ]
    }

    # Predation strategy
    for (i in seq_len(n_agents)) {
      if (t < max_iter / 3) {
        ids <- sample(seq_len(n_agents), 2, replace = FALSE)
        r1 <- runif(1)
        x_new <- X[i, ] + (X[ids[1], ] - X[ids[2], ]) * r1

      } else if (t < 2 * max_iter / 3) {
        rb <- rnorm(dimension)
        x_new <- best_pos + exp((t / max_iter)^4) * (rb - 0.5) * (best_pos - X[i, ])

      } else {
        rl <- 0.5 * levy_flight(dimension)
        x_new <- best_pos + CF * X[i, ] * rl
      }

      x_new <- clip_bounds(x_new, lower, upper)
      f_new <- fn(x_new, ...)

      if (f_new <= fit[i]) {
        X[i, ] <- x_new
        fit[i] <- f_new
      }
    }

    # Escape strategy
    r <- runif(1)
    k <- sample(seq_len(n_agents), 1)
    x_random <- X[k, ]

    for (i in seq_len(n_agents)) {
      if (r < 0.5) {
        rb <- runif(dimension, -1, 1)
        x_new <- best_pos + (1 - t / max_iter)^2 * (2 * rb - 1) * X[i, ]
      } else {
        K <- round(1 + runif(1))
        r2 <- runif(dimension)
        x_new <- X[i, ] + r2 * (x_random - K * X[i, ])
      }

      x_new <- clip_bounds(x_new, lower, upper)
      f_new <- fn(x_new, ...)

      if (f_new <= fit[i]) {
        X[i, ] <- x_new
        fit[i] <- f_new
      }
    }

    best_idx <- which.min(fit)
    if (fit[best_idx] < best_score) {
      best_score <- fit[best_idx]
      best_pos <- X[best_idx, ]
    }

    convergence[t] <- best_score

    if (verbose) {
      message("Iteration ", t, " | Best Cost = ", signif(best_score, 6))
    }
  }

  out <- list(
    par = best_pos,
    value = best_score,
    convergence = convergence,
    population = X,
    fitness = fit,
    call = match.call()
  )

  class(out) <- "sboa"
  out
}