introduce event stuff in doTheEvolution

NAMESPACE

@@ -78,6 +78,7 @@ export(makeUniformGenerator)
 export(makeUniformMutator)
 export(nsga2)
 export(onePlusOneGA)
+export(registerAction)
 export(rescalePoints)
 export(setupECRControl)
 export(setupEvolutionaryOperators)

R/doTheEvolution.R

@@ -44,14 +44,19 @@ doTheEvolution = function(task, control, initial.population = NULL) {
   population = buildInitialPopulation(control$n.population, task, control, initial.population)
   population$fitness = evaluateFitness(population, task$fitness.fun, task, control)
   opt.state = setupOptState(task, population, control)
+  fireEvent("onEAInitialized", control, opt.state)
 
   monitor$before()
   repeat {
     matingPool = selectForMating(opt.state, control)
+    fireEvent("onMatingPoolGenerated", control, opt.state)
+
     offspring = generateOffspring(opt.state, matingPool, control)
-    population = getNextGeneration(opt.state, offspring, control)
+    fireEvent("onOffspringGenerated", control, opt.state)
 
+    population = getNextGeneration(opt.state, offspring, control)
     updateOptState(opt.state, population, control)
+    fireEvent("onPopulationUpdated", control, opt.state)
 
     monitor$step()
 
@@ -60,9 +65,9 @@ doTheEvolution = function(task, control, initial.population = NULL) {
       break
     }
   }
+  fireEvent("onEAFinished", control, opt.state)
   monitor$after()
-  setupResult(opt.state, stop.object, control)
-  # end of new doTheEvolution
+  return(setupResult(opt.state, stop.object, control))
 }
 
 # @title

R/eventDispatcher.R

@@ -57,8 +57,36 @@ setupEventDispatcher = function(name) {
 #' @export
 getAvailableEventNames = function() {
   return(c(
-    "onGeneratedOffspring",
-    "onFinishedOptimization",
-    "onInitializedOptimization")
-  )
+    "onEAInitialized",
+    "onMatingPoolGenerated",
+    "onOffspringGenerated",
+    "onPopulationUpdated",
+    "onEAFinished"
+  ))
+}
+
+fireEvent = function(event.name, control, opt.state, ...) {
+  control$event.dispatcher$fireEvent(event.name, opt.state, ...)
+}
+
+#' @title
+#' Register an action.
+#'
+#' @description
+#' Register an action for a specific event in the EA circle.
+#' See \code{\link{getAvailableEventNames}} for a list of available event names.
+#'
+#' @param control [\code{ecr_control}]\cr
+#'   Control object.
+#' @param event.name [\code{character(1)}]\cr
+#'   Name of the event.
+#' @param fun [\code{function()}]\cr
+#'   Function with arguments \code{opt.state} and \code{...}.
+#' @return [\code{ecr_control}] Updated control object.
+#' @seealso \code{\link{getAvailableEventNames}}
+#' @export
+registerAction = function(control, event.name, fun) {
+  assertClass(control, "ecr_control")
+  control$event.dispatcher$registerAction(event.name, fun)
+  return(control)
 }

R/setupECRControl.R

@@ -124,6 +124,7 @@ setupECRControl = function(
     extras.fun = extras.fun,
     custom.constants = custom.constants,
     vectorized.evaluation = vectorized.evaluation,
+    event.dispatcher = setupEventDispatcher(),
     classes = "ecr_control"
   )
 

tests/testthat/test_eventDispatcher.R

@@ -7,16 +7,16 @@ test_that("event dispatcher works well", {
 
   # now register some events
   expect_error(eventDispatcher$registerAction("onNotExistentEvent", function(opt.state, ...) "foo"))
-  eventDispatcher$register("onInitializedOptimization", function(opt.state, ...) {
+  eventDispatcher$register("onEAInitialized", function(opt.state, ...) {
     catf("init")
   })
-  eventDispatcher$register("onInitializedOptimization", function(opt.state, ...) {
+  eventDispatcher$register("onEAInitialized", function(opt.state, ...) {
     x <<- 10L # modify test var
   })
 
   action.list = eventDispatcher$getActionList()
-  expect_equal(length(action.list[["onInitializedOptimization"]]), 2L) # added two actions
-  expect_true(all(sapply(action.list[["onInitializedOptimization"]], is.function)))
-  expect_output(eventDispatcher$fireEvent("onInitializedOptimization", opt.state = NULL), regexp = "init")
+  expect_equal(length(action.list[["onEAInitialized"]]), 2L) # added two actions
+  expect_true(all(sapply(action.list[["onEAInitialized"]], is.function)))
+  expect_output(eventDispatcher$fireEvent("onEAInitialized", opt.state = NULL), regexp = "init")
   expect_equal(x, 10L)
 })