Support checkpoint and restore of Event and TargetedEvent. (#179)

R/RcppExports.R

@@ -173,8 +173,16 @@ create_targeted_event <- function(size) {
     .Call(`_individual_create_targeted_event`, size)
 }
 
-event_tick <- function(event) {
-    invisible(.Call(`_individual_event_tick`, event))
+event_base_tick <- function(event) {
+    invisible(.Call(`_individual_event_base_tick`, event))
+}
+
+event_base_get_timestep <- function(event) {
+    .Call(`_individual_event_base_get_timestep`, event)
+}
+
+event_base_should_trigger <- function(event) {
+    .Call(`_individual_event_base_should_trigger`, event)
 }
 
 event_schedule <- function(event, delays) {
@@ -185,6 +193,14 @@ event_clear_schedule <- function(event) {
     invisible(.Call(`_individual_event_clear_schedule`, event))
 }
 
+event_checkpoint <- function(event) {
+    .Call(`_individual_event_checkpoint`, event)
+}
+
+event_restore <- function(event, time, schedule) {
+    invisible(.Call(`_individual_event_restore`, event, time, schedule))
+}
+
 targeted_event_clear_schedule_vector <- function(event, target) {
     invisible(.Call(`_individual_targeted_event_clear_schedule_vector`, event, target))
 }
@@ -229,14 +245,6 @@ targeted_event_schedule_multi_delay_vector <- function(event, target, delay) {
     invisible(.Call(`_individual_targeted_event_schedule_multi_delay_vector`, event, target, delay))
 }
 
-event_get_timestep <- function(event) {
-    .Call(`_individual_event_get_timestep`, event)
-}
-
-event_should_trigger <- function(event) {
-    .Call(`_individual_event_should_trigger`, event)
-}
-
 targeted_event_get_target <- function(event) {
     .Call(`_individual_targeted_event_get_target`, event)
 }
@@ -245,6 +253,14 @@ targeted_event_resize <- function(event) {
     invisible(.Call(`_individual_targeted_event_resize`, event))
 }
 
+targeted_event_checkpoint <- function(event) {
+    .Call(`_individual_targeted_event_checkpoint`, event)
+}
+
+targeted_event_restore <- function(event, time, state) {
+    invisible(.Call(`_individual_targeted_event_restore`, event, time, state))
+}
+
 process_listener <- function(event, listener) {
     invisible(.Call(`_individual_process_listener`, event, listener))
 }

R/event.R

@@ -1,61 +1,78 @@
-#' @title Event Class
-#' @description Describes a general event in the simulation.
+#' @title EventBase Class
+#' @description Common functionality shared between simple and targeted events.
 #' @importFrom R6 R6Class
-#' @export
-Event <- R6Class(
-  'Event',
+EventBase <- R6Class(
+  'EventBase',
   public = list(
-
     .event = NULL,
     .listeners = list(),
 
-    #' @description Initialise an Event.
-    initialize = function() {
-      self$.event <- create_event()
-    },
-
     #' @description Add an event listener.
     #' @param listener the function to be executed on the event, which takes a single
     #' argument giving the time step when this event is triggered.
     add_listener = function(listener) {
       self$.listeners <- c(self$.listeners, listener)
     },
 
-    #' @description Schedule this event to occur in the future.
-    #' @param delay the number of time steps to wait before triggering the event,
-    #' can be a scalar or a vector of values for events that should be triggered
-    #' multiple times.
-    schedule = function(delay) event_schedule(self$.event, delay),
+    .timestep = function() event_base_get_timestep(self$.event),
 
-    #' @description Stop a future event from triggering.
-    clear_schedule = function() event_clear_schedule(self$.event),
-
-    .tick = function() event_tick(self$.event),
+    .tick = function() event_base_tick(self$.event),
 
     .process = function() {
       for (listener in self$.listeners) {
-        if (event_should_trigger(self$.event)) {
+        if (event_base_should_trigger(self$.event)) {
           if (inherits(listener, "externalptr")) {
             self$.process_listener_cpp(listener)
           } else {
             self$.process_listener(listener)
           }
         }
       }
+    }
+  )
+)
+
+#' @title Event Class
+#' @description Describes a general event in the simulation.
+#' @importFrom R6 R6Class
+#' @export
+Event <- R6Class(
+  'Event',
+  inherit=EventBase,
+  public = list(
+    #' @description Initialise an Event.
+    initialize = function() {
+      self$.event <- create_event()
     },
 
+    #' @description Schedule this event to occur in the future.
+    #' @param delay the number of time steps to wait before triggering the event,
+    #' can be a scalar or a vector of values for events that should be triggered
+    #' multiple times.
+    schedule = function(delay) event_schedule(self$.event, delay),
+
+    #' @description Stop a future event from triggering.
+    clear_schedule = function() event_clear_schedule(self$.event),
+
     .process_listener = function(listener) {
-      listener(event_get_timestep(self$.event))
+      listener(self$.timestep())
     },
 
-    .process_listener_cpp = function(listener){
+    .process_listener_cpp = function(listener) {
       process_listener(
         event = self$.event,
         listener = listener
       )
     },
 
     # NOTE: intentionally empty
-    .resize = function() {}
+    .resize = function() {},
+
+    .checkpoint = function() {
+      event_checkpoint(self$.event)
+    },
+    .restore = function(time, schedule) {
+      event_restore(self$.event, time, schedule)
+    }
   )
 )

R/simulation.R

@@ -85,6 +85,7 @@ checkpoint_state <- function(timesteps, variables, events) {
   random_state <- .GlobalEnv$.Random.seed
   list(
     variables=lapply(variables, function(v) v$.checkpoint()),
+    events=lapply(events, function(e) e$.checkpoint()),
     timesteps=timesteps,
     random_state=random_state
   )
@@ -99,19 +100,25 @@ checkpoint_state <- function(timesteps, variables, events) {
 #' @param variables the list of Variables
 #' @param events the list of Events
 restore_state <- function(state, variables, events) {
+  timesteps <- state$timesteps + 1
+
   if (length(variables) != length(state$variables)) {
     stop("Checkpoint's variables do not match simulation's")
   }
   for (i in seq_along(variables)) {
     variables[[i]]$.restore(state$variables[[i]])
   }
-  if (length(events) > 0) {
-    stop("Events cannot be restored yet")
+
+  if (length(events) != length(state$events)) {
+    stop("Checkpoint's events do not match simulation's")
+  }
+  for (i in seq_along(events)) {
+    events[[i]]$.restore(timesteps, state$events[[i]])
   }
 
   .GlobalEnv$.Random.seed <- state$random_state
 
-  state$timesteps + 1
+  timesteps
 }
 
 #' @title Execute a C++ or R process in the simulation

R/targeted_event.R

@@ -5,7 +5,7 @@
 #' @export
 TargetedEvent <- R6Class(
   'TargetedEvent',
-  inherit = Event,
+  inherit = EventBase,
   public = list(
 
     #' @description Initialise a TargetedEvent.
@@ -103,7 +103,7 @@ TargetedEvent <- R6Class(
 
     .process_listener = function(listener) {
       listener(
-        event_get_timestep(self$.event),
+        self$.timestep(),
         Bitset$new(from=targeted_event_get_target(self$.event))
       )
     },
@@ -116,6 +116,13 @@ TargetedEvent <- R6Class(
       )
     },
 
-    .resize = function() targeted_event_resize(self$.event)
+    .resize = function() targeted_event_resize(self$.event),
+
+    .checkpoint = function() {
+      targeted_event_checkpoint(self$.event)
+    },
+    .restore = function(time, schedule) {
+      targeted_event_restore(self$.event, time, schedule)
+    }
   )
 )

inst/include/Event.h

@@ -12,6 +12,7 @@
 #include <Rcpp.h>
 #include <set>
 #include <map>
+#include <vector>
 #include <functional>
 #include <unordered_set>
 #include <queue>
@@ -40,6 +41,7 @@ inline std::vector<size_t> round_delay(const std::vector<double>& delay) {
 
 //' @title abstract base class for events
 class EventBase {
+protected:
     size_t t = 1;
 public:
     virtual void tick();
@@ -78,7 +80,9 @@ class Event : public EventBase {
 
     virtual void schedule(std::vector<double> delays);
     virtual void clear_schedule();
-
+
+    virtual std::vector<size_t> checkpoint();
+    virtual void restore(size_t time, std::vector<size_t> schedule);
 };
 
 //' @title process an event by calling a listener
@@ -109,6 +113,17 @@ inline void Event::clear_schedule() {
     simple_schedule.clear();
 }
 
+//' @title save this event's state
+inline std::vector<size_t> Event::checkpoint() {
+    return {simple_schedule.begin(), simple_schedule.end()};
+}
+
+//' @title restore this event's state from a previous checkpoint
+inline void Event::restore(size_t time, std::vector<size_t> schedule) {
+    t = time;
+    simple_schedule.clear();
+    simple_schedule.insert(schedule.begin(), schedule.end());
+}
 
 //' @title a targeted event in the simulation
 //' @description This class provides functionality for targeted events which are 
@@ -155,6 +170,8 @@ class TargetedEvent : public EventBase {
     virtual void clear_schedule(const individual_index_t&);
     virtual individual_index_t get_scheduled() const;
 
+    virtual std::vector<std::pair<size_t, individual_index_t>> checkpoint() const;
+    virtual void restore(size_t time, std::vector<std::pair<size_t, individual_index_t>> schedule);
 };
 
 inline TargetedEvent::TargetedEvent(size_t size)
@@ -364,4 +381,20 @@ inline void TargetedEvent::resize() {
     }
 }
 
+//' @title save this event's state
+inline std::vector<std::pair<size_t, individual_index_t>>
+TargetedEvent::checkpoint() const {
+    return {targeted_schedule.begin(), targeted_schedule.end()};
+}
+
+//' @title restore this event's state from a previous checkpoint
+inline void TargetedEvent::restore(
+        size_t time,
+        std::vector<std::pair<size_t, individual_index_t>> schedule
+) {
+    t = time;
+    targeted_schedule.clear();
+    targeted_schedule.insert(schedule.begin(), schedule.end());
+}
+
 #endif /* INST_INCLUDE_EVENT_H_ */