add event dispatcher

NAMESPACE

@@ -32,6 +32,7 @@ export(doNondominatedSorting)
 export(doTheEvolution)
 export(dominated)
 export(dominates)
+export(getAvailableEventNames)
 export(getEvaluations)
 export(getGenerations)
 export(getOperatorName)

R/eventDispatcher.R

@@ -0,0 +1,64 @@
+# @title
+# Generate event dispatcher.
+#
+# @description
+# The event dispatcher is a simple container for a hashmap of (event, actionForEvent)
+# lists. The dispatcher has two important function properties, namely registerAction and
+# fireEvent. The first one serves to fill the hashmap, i.e., to link actions to
+# events. The latter triggers an event and calls all actions associated with this
+# event.
+#
+# @return [\code{ecr_event_dispatcher}]
+# List with the following components:
+# \describe{
+#   \item{registerAction}{Function to register a function 'fun' to an 'event.name'.}
+#   \item{fireEvent}{Call all actions registered for 'event.name' and pass 'opt.state'
+#   \item{getActionList}{Returns the hashmap.}
+#   and '...' to them.}
+#
+# }
+setupEventDispatcher = function(name) {
+  action.list = list()
+
+  # register action for event
+  registerAction = function(event.name, fun) {
+    assertChoice(event.name, choices = getAvailableEventNames())
+    assertFunction(fun, args = c("opt.state", "..."), ordered = TRUE)
+    if (is.null(action.list[[event.name]])) {
+      action.list[[event.name]] = list()
+    }
+    action.list[[event.name]] <<- c(action.list[[event.name]], fun)
+    invisible()
+  }
+
+  # call all actions for event
+  fireEvent = function(event.name, opt.state, ...) {
+    if (!is.null(action.list[[event.name]])) {
+      for (action in action.list[[event.name]]) {
+        action(opt.state, ...)
+      }
+    }
+    invisible()
+  }
+
+  getActionList = function() {
+    return(action.list)
+  }
+
+  makeS3Obj(
+    register = registerAction,
+    fireEvent = fireEvent,
+    getActionList = getActionList,
+    classes = "ecr_event_dispatcher"
+  )
+}
+
+#' Receive a character vector of all valid event names.
+#' @export
+getAvailableEventNames = function() {
+  return(c(
+    "onGeneratedOffspring",
+    "onFinishedOptimization",
+    "onInitializedOptimization")
+  )
+}

tests/testthat/test_eventDispatcher.R

@@ -0,0 +1,22 @@
+context("event dispatching")
+
+test_that("event dispatcher works well", {
+  eventDispatcher = setupEventDispatcher()
+
+  x = NA
+
+  # now register some events
+  expect_error(eventDispatcher$registerAction("onNotExistentEvent", function(opt.state, ...) "foo"))
+  eventDispatcher$register("onInitializedOptimization", function(opt.state, ...) {
+    catf("init")
+  })
+  eventDispatcher$register("onInitializedOptimization", 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(x, 10L)
+})