tests/testthat/test-hypervolume.R

In olafmersmann/emoa: Evolutionary Multiobjective Optimization Algorithms

##
## test-hypervolume.r - Hypervolume tests
##

context("hypervolume")

## Predeclare some simple test fronts:
simpleFront <- matrix(c(0.0, 1.0, 0.5,
                        1.0, 0.0, 0.5),
                      ncol=3, byrow=TRUE)

infFront <- simpleFront
infFront[,2] <- Inf

naFront <- simpleFront
naFront[,2] <- NA

nanFront <- simpleFront
nanFront[,2] <- NaN

test_that("dominated_hypervolume", {
  expect_equal(dominated_hypervolume(simpleFront), 0.5^2)
  expect_equal(dominated_hypervolume(simpleFront, c(1.0, 1.0)), 0.5^2)
  ## OME: FIXME should ignore outer points?
  ## expect_equal(dominated_hypervolume(simpleFront, c(0.8, 0.8)), 0.3^2)
  expect_equal(dominated_hypervolume(simpleFront, c(2.0, 2.0)), 3.25)
  expect_equal(dominated_hypervolume(simpleFront, c(0.0, 0.0)), 0)
  expect_equal(dominated_hypervolume(simpleFront, c(0.5, 0.5)), 0)

  suppressWarnings(expect_equal(dominated_hypervolume(simpleFront, c(NaN, NaN)),
                                NaN))
  expect_warning(dominated_hypervolume(simpleFront, c(NaN, NaN)))
})

test_that("bad_front", {
  ## OME: Should probably also return NaN instead of NA
  suppressWarnings(expect_equal(is.na(dominated_hypervolume(naFront)), TRUE))
  suppressWarnings(expect_equal(dominated_hypervolume(nanFront), NaN))

  expect_warning(is.na(dominated_hypervolume(naFront)))
  expect_warning(dominated_hypervolume(nanFront))
})

test_that("inf_front", {
  ## OME: These should probably be reworked to return 'saner' values.
  suppressWarnings(expect_equal(dominated_hypervolume(infFront), NaN))
  expect_warning(dominated_hypervolume(infFront))

  suppressWarnings(expect_equal(dominated_hypervolume(infFront, ref=c(1, 1)), NaN))
  expect_warning(dominated_hypervolume(infFront, ref=c(1, 1)))

  suppressWarnings(expect_equal(dominated_hypervolume(simpleFront, ref=c(Inf, Inf)), NaN))
  expect_warning(dominated_hypervolume(simpleFront, ref=c(Inf, Inf)))
})

test.badInput <- function() {
  expect_error(dominated_hypervolume(1:10))
  expect_error(dominated_hypervolume("abc"))
  expect_error(dominated_hypervolume(simpleFront, 1:3))
  expect_error(dominated_hypervolume(simpleFront, 1))
}

test.dhv3d <- function() {
  ## Built with Lego. Hurra!
  m3 <- structure(c(5, 2, 0, 4, 3, 0, 4, 2, 1, 4, 1, 2, 3, 2, 2, 2, 3,
                    2, 4, 0, 3, 3, 1, 3, 2, 2, 3, 3, 0, 4, 2, 1, 4, 1,
                    2, 4, 0, 3, 4, 0, 2, 5), .Dim = c(3L, 14L))
  m3_dhv <- c(1, 1,
              1,
              2, 1, 1,
              2, 1, 1,
              2, 2, 1, 1,
              1)
  expect_equal(hypervolume_contribution(m3, c(6, 4, 6)), m3_dhv)
}

## Regression test for the permutation bug (missing duplicate()).
test.regress_perm <- function() {
  ## Built with Lego. Hurra!
  m3 <- structure(c(5, 2, 0, 4, 3, 0, 4, 2, 1, 4, 1, 2, 3, 2, 2, 2, 3,
                    2, 4, 0, 3, 3, 1, 3, 2, 2, 3, 3, 0, 4, 2, 1, 4, 1,
                    2, 4, 0, 3, 4, 0, 2, 5), .Dim = c(3L, 14L))
  o3 <- structure(c(5, 2, 0, 4, 3, 0, 4, 2, 1, 4, 1, 2, 3, 2, 2, 2, 3,
                    2, 4, 0, 3, 3, 1, 3, 2, 2, 3, 3, 0, 4, 2, 1, 4, 1,
                      2, 4, 0, 3, 4, 0, 2, 5), .Dim = c(3L, 14L))
  hypervolume_contribution(m3)
  expect_equal(m3, o3)
}