tests/testthat/test-conditions.R

In hmsr: Multipopulation Evolutionary Strategy HMS

test_that("Global stopping condition (metaepochs count) works:", {
  max_metaepochs_count <- 2
  global_stopping_condition <- gsc_metaepochs_count(max_metaepochs_count)
  metaepoch_snapshot <- methods::new(
    "MetaepochSnapshot",
    demes = list(),
    best_fitness = 0,
    best_solution = 0,
    time_in_seconds = 0,
    fitness_evaluations = 0,
    blocked_sprouts = list(),
    is_evolutionary = TRUE
  )
  metaepoch_snapshots <- list(metaepoch_snapshot)
  expect_false(global_stopping_condition(metaepoch_snapshots))
  new_metaepoch_snapshots <- c(metaepoch_snapshots, list(metaepoch_snapshot))
  expect_true(global_stopping_condition(new_metaepoch_snapshots))
})

test_that("Global stopping condition (fitness evaluations count) works:", {
  max_evaluations_count <- 2
  global_stopping_condition <- gsc_max_fitness_evaluations(max_evaluations_count)
  metaepoch_snapshot_with_evaluations_count_lower_than_max <- methods::new(
    "MetaepochSnapshot",
    demes = list(),
    best_fitness = 0,
    best_solution = 0,
    time_in_seconds = 0,
    fitness_evaluations = 1,
    blocked_sprouts = list(),
    is_evolutionary = TRUE
  )
  metaepoch_snapshots <- list(metaepoch_snapshot_with_evaluations_count_lower_than_max)
  expect_false(global_stopping_condition(metaepoch_snapshots))
  metaepoch_snapshot_with_evaluations_count_greater_than_max <- methods::new(
    "MetaepochSnapshot",
    demes = list(),
    best_fitness = 0,
    best_solution = 0,
    time_in_seconds = 0,
    fitness_evaluations = 3,
    blocked_sprouts = list(),
    is_evolutionary = TRUE
  )
  new_metaepoch_snapshots <- c(metaepoch_snapshots, list(metaepoch_snapshot_with_evaluations_count_greater_than_max))
  expect_true(global_stopping_condition(new_metaepoch_snapshots))
})

test_that("Global stopping condition (trivial) works:", {
  global_stopping_condition <- gsc_trivial()
  expect_false(global_stopping_condition(list()))
  expect_false(global_stopping_condition(NULL))
})

test_that("Local stopping condition (max metaepochs without improvement) works:", {
  local_stopping_condition <- lsc_metaepochs_without_improvement(5)
  deme <- methods::new(
    "Deme",
    id = "id1",
    population = matrix(),
    level = 2,
    best_fitness = 5,
    best_solution = 5,
    best_solutions_per_metaepoch = list(5, 4, 3, 2, 1),
    best_fitnesses_per_metaepoch = list(5, 4, 3, 2, 1),
    sprout = NULL,
    parent_id = NULL,
    evaluations_count = 0,
    is_active = TRUE
  )
  expect_false(local_stopping_condition(deme, list()))
  deme@best_fitnesses_per_metaepoch <- list(5, 4, 3, 2, 1, 0)
  deme@best_solutions_per_metaepoch <- list(5, 4, 3, 2, 1, 0)
  expect_true(local_stopping_condition(deme, list()))
})

test_that("Local stopping condition (max evaluations) works:", {
  local_stopping_condition <- lsc_max_fitness_evaluations(5)
  deme <- methods::new(
    "Deme",
    id = "id1",
    population = matrix(),
    level = 2,
    best_fitness = 0,
    best_solution = 0,
    best_solutions_per_metaepoch = list(),
    best_fitnesses_per_metaepoch = list(),
    sprout = NULL,
    parent_id = NULL,
    evaluations_count = 0,
    is_active = TRUE
  )
  expect_false(local_stopping_condition(deme, list()))
  deme@evaluations_count <- 6
  expect_true(local_stopping_condition(deme, list()))
})

test_that("Local stopping condition (mmetaepochs without active child) works:", {
  deme <- methods::new(
    "Deme",
    id = "id1",
    population = matrix(),
    level = 2,
    best_fitness = 0,
    best_solution = 0,
    best_solutions_per_metaepoch = list(),
    best_fitnesses_per_metaepoch = list(),
    sprout = NULL,
    parent_id = NULL,
    evaluations_count = 0,
    is_active = TRUE
  )
  active_child_deme <- methods::new(
    "Deme",
    id = "id2",
    population = matrix(),
    level = 2,
    best_fitness = 0,
    best_solution = 0,
    best_solutions_per_metaepoch = list(),
    best_fitnesses_per_metaepoch = list(),
    sprout = NULL,
    parent_id = "id1",
    evaluations_count = 0,
    is_active = TRUE
  )
  inactive_child_deme <- methods::new(
    "Deme",
    id = "id3",
    population = matrix(),
    level = 2,
    best_fitness = 0,
    best_solution = 0,
    best_solutions_per_metaepoch = list(),
    best_fitnesses_per_metaepoch = list(),
    sprout = NULL,
    parent_id = "id1",
    evaluations_count = 0,
    is_active = FALSE
  )
  snapshot <- function(demes) {
    methods::new(
      "MetaepochSnapshot",
      demes = demes,
      best_fitness = 0,
      best_solution = 0,
      time_in_seconds = 0,
      fitness_evaluations = 3,
      blocked_sprouts = list(),
      is_evolutionary = FALSE
    )
  }
  expect_false(lsc_metaepochs_without_active_child(1)(deme, list(snapshot(
    list(deme, active_child_deme)
  ))))
  expect_true(lsc_metaepochs_without_active_child(1)(deme, list(snapshot(
    list(deme, active_child_deme)
  ), snapshot(
    list(deme, inactive_child_deme)
  ))))
  expect_false(lsc_metaepochs_without_active_child(2)(deme, list(snapshot(
    list(deme, active_child_deme)
  ), snapshot(
    list(deme, inactive_child_deme)
  ))))
  expect_true(lsc_metaepochs_without_active_child(2)(deme, list(snapshot(
    list(deme, inactive_child_deme)
  ), snapshot(
    list(deme, inactive_child_deme)
  ))))
  expect_true(lsc_metaepochs_without_active_child(2)(deme, list(
    snapshot(list(deme, active_child_deme)), snapshot(list(deme, inactive_child_deme)), snapshot(list(deme, inactive_child_deme))
  )))
})

test_that("Local stopping condition (trivial) works:", {
  local_stopping_condition <- lsc_trivial()
  deme <- methods::new(
    "Deme",
    id = "id1",
    population = matrix(),
    level = 2,
    best_fitness = 0,
    best_solution = 0,
    best_solutions_per_metaepoch = list(),
    best_fitnesses_per_metaepoch = list(),
    sprout = NULL,
    parent_id = NULL,
    evaluations_count = 0,
    is_active = TRUE
  )
  expect_false(local_stopping_condition(deme, list()))
  expect_false(local_stopping_condition(NULL, list()))
})