Add a restore flag to the Event constructor. (mrc-ide#180)

By default, when restoring the simulation state all previous schedule on
events are cleared and restored from the saved state. This goes against
use cases that wish to resume a simulation with different intervention
schedules to compare effects. In those use cases, a different
initialization sequence is used when creating the simulation, and we do
not want that to be cleared and overwritten.

The new `restore` flag, when set to false, overrides this default
behaviour and the state of an Event is (mostly) unaffected by a restore.
Thanks to this, a new event schedule, that is unrelated to the schedule
of the original run, can be configured.

R/RcppExports.R

@@ -165,8 +165,8 @@ double_variable_queue_shrink_bitset <- function(variable, index) {
     invisible(.Call(`_individual_double_variable_queue_shrink_bitset`, variable, index))
 }
 
-create_event <- function() {
-    .Call(`_individual_create_event`)
+create_event <- function(restoreable) {
+    .Call(`_individual_create_event`, restoreable)
 }
 
 create_targeted_event <- function(size) {

R/event.R

@@ -38,18 +38,24 @@ EventBase <- R6Class(
 #' @export
 Event <- R6Class(
   'Event',
-  inherit=EventBase,
+  inherit = EventBase,
   public = list(
     #' @description Initialise an Event.
-    initialize = function() {
-      self$.event <- create_event()
+    #' @param restore if true, the schedule of this event is restored when restoring from a saved
+    #' simulation.
+    initialize = function(restore = TRUE) {
+      self$.event <- create_event(restore)
     },
 
     #' @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),
+    schedule = function(delay) {
+      if (!is.null(delay)) {
+        event_schedule(self$.event, delay)
+      }
+    },
 
     #' @description Stop a future event from triggering.
     clear_schedule = function() event_clear_schedule(self$.event),

inst/include/Event.h

@@ -70,8 +70,10 @@ inline size_t EventBase::get_time() const {
 class Event : public EventBase {
 
     std::set<size_t> simple_schedule;
+    bool restoreable;
 
 public:
+    Event(bool restoreable);
     virtual ~Event() = default;
 
     virtual void process(Rcpp::XPtr<listener_t> listener);
@@ -90,6 +92,9 @@ inline void Event::process(Rcpp::XPtr<listener_t> listener) {
     (*listener)(get_time());
 }
 
+inline Event::Event(bool restoreable) : restoreable(restoreable) {
+}
+
 //' @title should first event fire on this timestep?
 inline bool Event::should_trigger() {
     if (simple_schedule.empty()) {
@@ -124,8 +129,15 @@ inline std::vector<size_t> Event::checkpoint() {
 //' @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());
+    if (restoreable) {
+        simple_schedule.clear();
+        simple_schedule.insert(schedule.begin(), schedule.end());
+    } else {
+        // We don't restore the event, but it is possible that the resume time
+        // is beyond some already scheduled timesteps. These need to be removed.
+        auto it = simple_schedule.lower_bound(time);
+        simple_schedule.erase(simple_schedule.begin(), it);
+    }
 }
 
 //' @title a targeted event in the simulation

src/RcppExports.cpp

@@ -512,12 +512,13 @@ BEGIN_RCPP
 END_RCPP
 }
 // create_event
-Rcpp::XPtr<Event> create_event();
-RcppExport SEXP _individual_create_event() {
+Rcpp::XPtr<Event> create_event(bool restoreable);
+RcppExport SEXP _individual_create_event(SEXP restoreableSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
-    rcpp_result_gen = Rcpp::wrap(create_event());
+    Rcpp::traits::input_parameter< bool >::type restoreable(restoreableSEXP);
+    rcpp_result_gen = Rcpp::wrap(create_event(restoreable));
     return rcpp_result_gen;
 END_RCPP
 }
@@ -1487,7 +1488,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_individual_double_variable_queue_extend", (DL_FUNC) &_individual_double_variable_queue_extend, 2},
     {"_individual_double_variable_queue_shrink", (DL_FUNC) &_individual_double_variable_queue_shrink, 2},
     {"_individual_double_variable_queue_shrink_bitset", (DL_FUNC) &_individual_double_variable_queue_shrink_bitset, 2},
-    {"_individual_create_event", (DL_FUNC) &_individual_create_event, 0},
+    {"_individual_create_event", (DL_FUNC) &_individual_create_event, 1},
     {"_individual_create_targeted_event", (DL_FUNC) &_individual_create_targeted_event, 1},
     {"_individual_event_base_tick", (DL_FUNC) &_individual_event_base_tick, 1},
     {"_individual_event_base_get_timestep", (DL_FUNC) &_individual_event_base_get_timestep, 1},

src/event.cpp

@@ -9,8 +9,8 @@
 #include "utils.h"
 
 //[[Rcpp::export]]
-Rcpp::XPtr<Event> create_event() {
-    return Rcpp::XPtr<Event>(new Event(), true);
+Rcpp::XPtr<Event> create_event(bool restoreable) {
+    return Rcpp::XPtr<Event>(new Event(restoreable), true);
 }
 
 //[[Rcpp::export]]

tests/testthat/test-events.R

@@ -127,6 +127,8 @@ test_that("events can be saved and restored", {
     old_event$.timestep(),
     old_event$.checkpoint())
 
+  expect_equal(new_event$.timestep(), 3)
+
   #time = 3
   new_event$.process()
   mockery::expect_called(listener, 1)
@@ -164,7 +166,7 @@ test_that("events are cleared when restored", {
   mockery::expect_called(listener, 0)
   new_event$.tick()
 
-  #time=2
+  #time=3
   new_event$.process()
   mockery::expect_called(listener, 0)
   new_event$.tick()
@@ -176,6 +178,54 @@ test_that("events are cleared when restored", {
   new_event$.tick()
 })
 
+test_that("event is not cleared when restore is disabled", {
+  old_event <- Event$new()
+  old_event$schedule(3) # t=4
+
+  # time = 1
+  old_event$.process()
+  old_event$.tick()
+
+  # time = 2
+  old_event$.process()
+  old_event$.tick()
+
+  listener <- mockery::mock()
+  new_event <- Event$new(restore=FALSE)
+  new_event$add_listener(listener)
+  new_event$schedule(1) # t=2, this is before the restore timestep and will not fire.
+  new_event$schedule(5) # t=6, this will trigger
+
+  # This should restore the timestep, but not any of the old event's schedule.
+  new_event$.restore(
+    old_event$.timestep(),
+    old_event$.checkpoint())
+
+  expect_equal(new_event$.timestep(), 3)
+
+  # time = 3
+  new_event$.process()
+  mockery::expect_called(listener, 0)
+  new_event$.tick()
+
+  # time = 4
+  # The saved event from the `old_event` is not restored.
+  new_event$.process()
+  mockery::expect_called(listener, 0)
+  new_event$.tick()
+
+  # time = 5
+  new_event$.process()
+  mockery::expect_called(listener, 0)
+  new_event$.tick()
+
+  # time = 6
+  new_event$.process()
+  mockery::expect_called(listener, 1)
+  mockery::expect_args(listener, 1, t = 6)
+  new_event$.tick()
+})
+
 test_that("empty event never triggers", {
   event <- Event$new()
   listener <- mockery::mock()