R/TestFunctions.R

In GPareto: Gaussian Processes for Pareto Front Estimation and Optimization

#' @name ZDT1
#' @aliases ZDT2
#' @aliases ZDT3
#' @aliases ZDT4
#' @aliases ZDT6
#' @aliases P1
#' @aliases P2
#' @aliases MOP2
#' @aliases MOP3
#' @aliases DTLZ1
#' @aliases DTLZ2
#' @aliases DTLZ3
#' @aliases DTLZ7
#' @aliases OKA1
#' 
#' @description Multi-objective test functions.
#' @title Test functions of x
#'
#' @param x matrix specifying the location where the function is to be evaluated, one point per row,
#' @param nobj optional argument to select the number of objective for the DTLZ test functions.
#'
## ' @note \code{funs} is a generic name for the functions documented.
#' 
#' @details These functions are coming from different benchmarks:
#' the \code{ZDT} test problems from an article of E. Zitzler et al., \code{P1} from the thesis of J. Parr and \code{P2}
#' from an article of Poloni et al. . \code{MOP2} and \code{MOP3} are from Van Veldhuizen and \code{DTLZ} functions are from Deb et al. . \cr \cr
#' 
#' Domains (sometimes rescaled to \code{[0,1]}):
#' \itemize{
#' \item \code{ZDT1-6}: \code{[0,1]^d} 
#' \item \code{P1}, \code{P2}: \code{[0,1]^2} 
#' \item \code{MOP2}: \code{[0,1]^d}
#' \item \code{MOP3}: \code{[-3,3]}, tri-objective, 2 variables
#' \item \code{DTLZ1-3,7}: \code{[0,1]^d}, m-objective problems, with at least \code{d>m} variables.
#' \item \code{OKA1}: [0,1]^2, initially \code{[6 sin(pi/12), 6 sin(pi/12) + 2pi cos(pi/12)] x [-2pi sin(pi/12), 6 cos(pi/12)], bi-objective}
#' }

#' 
#' @return Matrix of values corresponding to the objective functions, the number of colums is the number of objectives.
#' 
#' @references
#' 
#' J. M. Parr (2012), \emph{Improvement Criteria for Constraint Handling and Multiobjective Optimization}, University of Southampton, PhD thesis. 
#' 
#' C. Poloni, A. Giurgevich, L. Onesti, V. Pediroda (2000), Hybridization of a multi-objective genetic algorithm, a neural network and a classical optimizer for a complex design problem in fluid dynamics, \emph{Computer Methods in Applied Mechanics and Engineering}, 186(2), 403-420.
#' 
#' E. Zitzler, K. Deb, and L. Thiele (2000), Comparison of multiobjective evolutionary
#' algorithms: Empirical results, \emph{Evol. Comput.}, 8(2), 173-195.
#' 
#' K. Deb, L. Thiele, M. Laumanns and E. Zitzler (2002), Scalable Test Problems for Evolutionary Multiobjective Optimization, 
#' \emph{IEEE Transactions on Evolutionary Computation}, 6(2), 182-197.
#' 
#' D. A. Van Veldhuizen, G. B. Lamont (1999), Multiobjective evolutionary algorithm test suites, \emph{In Proceedings of the 1999 ACM symposium on Applied computing}, 351-357.
#' 
#' T. Okabe, J. Yaochu, M. Olhofer, B. Sendhoff (2004), On test functions for evolutionary multi-objective optimization, 
#' \emph{International Conference on Parallel Problem Solving from Nature}, Springer, Berlin, Heidelberg.
#' 
#' @rdname TestFunctions
#' @export
#' @examples 
#' # ----------------------------------
#' # 2-objectives test problems
#' # ---------------------------------- 
#' 
#' plotParetoGrid("ZDT1", n.grid = 21)
#' 
#' plotParetoGrid("ZDT2", n.grid = 21)
#' 
#' plotParetoGrid("ZDT3", n.grid = 21)
#' 
#' plotParetoGrid("ZDT4", n.grid = 21)
#' 
#' plotParetoGrid("ZDT6", n.grid = 21)
#' 
#' plotParetoGrid("P1", n.grid = 21)
#' 
#' plotParetoGrid("P2", n.grid = 21)
#' 
#' plotParetoGrid("MOP2", n.grid = 21)
#' 
#' @export
ZDT1 <-
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, nrow = 1) 
    }
    n <- ncol(x)
    g <- 1+rowSums(x[,2:n, drop = FALSE])*9/(n-1)
    return(cbind(x[,1],g*(1-sqrt(x[,1]/g))))
  }

#' @rdname TestFunctions
#' @export
ZDT2 <- 
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, nrow = 1) 
    }
    n <- ncol(x)
    g <- 1+rowSums(x[,2:n, drop = FALSE])*9/(n-1)
    return(cbind(x[,1],g*(1-(x[,1]/g)^2)))
  }

#' @rdname TestFunctions
#' @export
ZDT3 <-
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, nrow = 1) 
    }
    n <- ncol(x)
    g <- 1+rowSums(x[,2:n, drop = FALSE])*9/(n-1)
    
    return(cbind(x[,1], g*(1 - sqrt(x[,1]/g) - x[,1]/g*sin(10*pi*x[,1]))))
  }

#' @rdname TestFunctions
#' @export
ZDT4 <-
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, nrow = 1) 
    }
    n <- ncol(x)
    
    g <- 1+10*(n-1) + rowSums((x[,2:n, drop = FALSE]*10-5)^2-10*cos(4*pi*(x[,2:n, drop = FALSE]*10-5)))
    return(cbind(x[,1], g*(1 - sqrt(x[,1]/g))))
  }

#' @rdname TestFunctions
#' @export
ZDT6 <-
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, nrow = 1) 
    }
    n <- ncol(x)
    f1 <- 1-exp(-4*x[,1])*(sin(6*pi*x[,1]))^6
    g <- 1+9*(1/(n-1)*rowSums(x[,2:n, drop = FALSE]))^(0.25)
    return(cbind(f1,g*(1-(f1/g)^2)))
  }

#' @rdname TestFunctions
#' @export
P1 <-
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, nrow = 1) 
    }
    b1<-15*x[,1]-5
    b2<-15*x[,2]
    return(cbind((b2-5.1*(b1/(2*pi))^2+5/pi*b1-6)^2 +10*((1-1/(8*pi))*cos(b1)+1),
                 -sqrt((10.5-b1)*(b1+5.5)*(b2+0.5)) - 1/30*(b2 -5.1*(b1/(2*pi))^2-6)^2 - 1/3*((1-1/(8*pi))*cos(b1)+1)
    ) 
    )
  }

#' @rdname TestFunctions
#' @export
P2 <-
  function(x){
    if(is.null(dim(x))){
      x <- matrix(x, 1) 
    }
    xmod <- x*2*pi - pi
    ap <- matrix(c(0.5,1.5,1,2),2)
    bp <- matrix(c(-2,-1,-1.5,-0.5),2)
    A1 <- ap[1,1]*sin(1)+bp[1,1]*cos(1)+ap[1,2]*sin(2)+bp[1,2]*cos(2)
    A2 <- ap[2,1]*sin(1)+bp[2,1]*cos(1)+ap[2,2]*sin(2)+bp[2,2]*cos(2)
    
    B1 <- ap[1,1]*sin(xmod[,1])+bp[1,1]*cos(xmod[,1])+ap[1,2]*sin(xmod[,2])+bp[1,2]*cos(xmod[,2])
    B2 <- ap[2,1]*sin(xmod[,1])+bp[2,1]*cos(xmod[,1])+ap[2,2]*sin(xmod[,2])+bp[2,2]*cos(xmod[,2])
    F1 <- 1+(A1-B1)^2+(A2-B2)^2
    F2 <- (xmod[,1]+3)^2+(xmod[,2]+1)^2
    return(cbind(-F1,-F2))
  }

## ' @rdname TestFunctions
## ' @export
GSP <- function(x, gamma=1)
{
  N <- nrow(x)
  n <- ncol(x)
  
  if (is.null(N))
  { N <- 1
  n <- length(x)
  x <- matrix(x, nrow=1,ncol=n)
  }
  
  obj <- matrix(rep(0, 2*N), nrow=N, ncol=2)
  alpha <- 1/(2*gamma)
  
  obj[,1] <- (1/(n^alpha)) * (rowSums(x^2)^alpha)
  obj[,2] <- (1/(n^alpha)) * (rowSums((1-x)^2)^alpha)
  
  return(obj)
}

#' @rdname TestFunctions
#' @export
MOP2 <- function(x)
{
  xmod <- x*4 - 2
  if (is.null(nrow(x)))
  { 
    n <- length(xmod)
    y1 <- 1 - exp(-sum((xmod - 1/sqrt(n))^2) )
    y2 <- 1 - exp(-sum((xmod + 1/sqrt(n))^2) )
    Y <- matrix(c(y1,y2),1,2)
  } else
  {
    n <- ncol(xmod)
    y1 <- 1 - exp(-rowSums((xmod - 1/sqrt(n))^2) )
    y2 <- 1 - exp(-rowSums((xmod + 1/sqrt(n))^2) )
    Y <- cbind(y1,y2)
  }
  
  return(Y)
}

#' @rdname TestFunctions
#' @export
MOP3 <- function(x){
  if(is.null(dim(x))){
    x <- matrix(x, 1) 
  }
  # One point per row
  f1 <- 0.5 * (x[,1]^2 + x[,2]^2) + sin(x[,1]^2 + x[,2]^2)
  f2 <- (3 * x[,1] - 2 * x[,2] + 4)^2/8 + (x[,1] - x[,2] + 1)^2/27  + 15
  f3 <- 1/(x[,1]^2 + x[,2]^2 + 1) - 1.1 * exp(-x[,1]^2 - x[,2]^2)
  f <- cbind(f1, f2, f3)
}

#' @rdname TestFunctions
#' @export 
DTLZ1 <- function(x, nobj = 3){
  
  if(is.null(dim(x))){
    x <- matrix(x, 1) 
  }
  n <- ncol(x)
  
  y <- matrix(x[,1:(nobj-1)], nrow(x))
  z <- matrix(x[,nobj:n], nrow(x))
  
  g <- 100 * (n - nobj + 1 + rowSums((z-0.5)^2 - cos(20 * pi *(z - 0.5))))
  
  tmp <- t(apply(y, 1, cumprod))
  tmp <- cbind(t(apply(tmp, 1, rev)) ,1)
  
  tmp2 <- cbind(1, t(apply(1-y, 1, rev)))
  
  f <- tmp * tmp2 * 0.5* (1 + g)
  return(f)
}

#' @rdname TestFunctions
#' @export 
DTLZ2 <- function(x, nobj = 3){
  if(is.null(dim(x))){
    x <- matrix(x, 1) 
  }
  n <- ncol(x)
  
  y <- matrix(x[,1:(nobj-1)], nrow(x))
  z <- matrix(x[,nobj:n], nrow(x))
  
  g <- rowSums((z-0.5)^2)
  
  #   tmp <- c(rev(cumprod(cos(y * pi/2))), 1)
  #   tmp2 <- c(1, rev(sin(y * pi/2)))
  tmp <- t(apply(cos(y * pi/2), 1, cumprod))
  tmp <- cbind(t(apply(tmp, 1, rev)), 1)
  
  tmp2 <- cbind(1, t(apply(sin(y * pi/2), 1, rev)))
  
  f <- tmp * tmp2 * (1 + g)
  
}


#' @rdname TestFunctions
#' @export 
DTLZ3 <- function(x, nobj = 3){
  if(is.null(dim(x))){
    x <- matrix(x, 1) 
  }
  n <- ncol(x)
  
  y <- matrix(x[,1:(nobj-1)], nrow(x))
  z <- matrix(x[,nobj:n], nrow(x))
  
  g <- 100 * (n - nobj + 1 + rowSums((z-0.5)^2 - cos(20 * pi *(z - 0.5))))
  
  tmp <- t(apply(cos(y * pi/2), 1, cumprod))
  tmp <- cbind(t(apply(tmp, 1, rev)), 1)
  
  tmp2 <- cbind(1, t(apply(sin(y * pi/2), 1, rev)))
  
  f <- tmp * tmp2 * (1 + g)
  
}

#' @rdname TestFunctions
#' @export 
DTLZ7 <- function(x, nobj = 3){
  if(is.null(dim(x))){
    x <- matrix(x, 1) 
  }
  n <- ncol(x)
  
  y <- matrix(x[,1:(nobj-1)], nrow(x))
  z <- matrix(x[,nobj:n], nrow(x))
  
  g <- 1 + 9 * rowSums(z/(1:(n - nobj + 1)))
  
  tmp <- cbind(y, 1)
  
  tmp2 <- cbind(matrix(1,nrow(x),nobj - 1), (1 + g) * (nobj -  rowSums(y/(1+g) * (1 + sin(3 * pi * y)))))
  
  #   tmp2 <- c(rep(1,(nobj - 1)), (1 + g) * (nobj -  sum(y/(1+g) * (1 + sin(3 * pi * y)))))
  
  f <- tmp * tmp2
  
}


#' @rdname TestFunctions
#' @export
OKA1 <- function(x){
  if(is.null(dim(x))){
    x <- matrix(x, 1) 
  }
  x[,1] <- x[,1] * 2 * pi * cos(pi/12) + 6 * sin(pi/12) 
  x[,2] <-  x[,2] * (6* cos(pi/12) + 2 *pi *sin(pi/12)) - 2 * pi * sin(pi/12)
  
  x1p <- cos(pi/12) * x[,1] - sin(pi/12) * x[,2]
  x2p <- sin(pi/12) * x[,1] + cos(pi/12) * x[,2]
  f1 <- x1p
  f2 <- sqrt(2*pi) - sqrt(abs(x1p)) + abs(x2p - 3*cos(x1p) - 3)^(1/3)
  return(cbind(f1, f2))
}