Allow processes to be named. (#198)

Because of how R assigns names to stack frames, all processes in a
typical individual simulation would end up being called `p`. This makes
it difficult to interpret profiling results.

R uses the name of the variable the called function is bound to. By
dynamically creating a variable with a chosen name and using `eval` to
execute that variable, we can get the stack frame to show up with any
desired name.

This uses this trick to allow the list of processes to be given names,
and these names are used in the calls.

R/simulation.R

@@ -57,9 +57,13 @@ simulation_loop <- function(
   flat_events <- unlist(events)
   flat_variables <- unlist(variables)
 
+  processes <- lapply(seq_along(processes), function(i) {
+    prepare_process(processes[[i]], names(processes)[[i]])
+  })
+
   for (t in seq(start, timesteps)) {
-    for (process in processes) {
-      execute_any_process(process, t)
+    for (p in processes) {
+      p(t)
     }
     for (event in flat_events) {
       event$.process()
@@ -194,14 +198,24 @@ restore_object_state <- function(timesteps, objects, state) {
   }
 }
 
-#' @title Execute a C++ or R process in the simulation
-#' @param p the process to execute
-#' @param t the timestep to pass to the process
+#' @title Prepare a process function for execution
+#' @description Wraps an R or C++ process into an R function, allowing either to
+#' be called uniformly. Additionally, if a name is provided, it will be used
+#' in creating the stack frame when calling the function.
+#' @param p an R or C++ process
+#' @param name the name to use for the process. This will appear in stack
+#' traces and profiles.
+#' @return an R function
 #' @noRd
-execute_any_process <- function(p, t) {
+prepare_process <- function(p, name = NULL) {
   if (inherits(p, "externalptr")) {
-    execute_process(p, t)
-  } else {
-    p(t)
+    ptr <- p
+    p <- function(t) execute_process(ptr, t)
+  }
+  if (!is.null(name)) {
+    env <- new.env()
+    assign(name, p, envir=env)
+    p <- function(t) eval(call(name, t), env)
   }
+  p
 }

tests/testthat/test-prefab.R

@@ -80,7 +80,7 @@ test_that("Multinomial process samples probabilities correctly", {
     rate = l_p,
     destination_probabilities = d_p
   )
-  individual:::execute_any_process(mult_process,1)
+  individual:::prepare_process(mult_process)(1)
   state$.update()
   state_new <- sapply(X = LETTERS[1:5],FUN = function(l){state$get_size_of(l)})
 
@@ -117,7 +117,7 @@ test_that("Overdispersed multinomial process samples probabilities correctly", {
     rate_variable = rate,
     destination_probabilities = d_p
   )
-  individual:::execute_any_process(mult_process,1)
+  individual:::prepare_process(mult_process)(1)
   state$.update()
 
   state_a <- state$get_index_of(values = "A")$to_vector()
@@ -145,7 +145,7 @@ test_that("Overdispersed multinomial process doesn't move people it shouldn't",
     rate_variable = rate,
     destination_probabilities = d_p
   )
-  individual:::execute_any_process(mult_process,1)
+  individual:::prepare_process(mult_process)(1)
   state$.update()
 
   state_a <- state$get_index_of(values = "A")$to_vector()
@@ -172,7 +172,7 @@ test_that("Overdispersed bernoulli process works correctly", {
     rate_variable = rate 
   )
 
-  individual:::execute_any_process(multi_bp,1)
+  individual:::prepare_process(multi_bp)(1)
   state$.update()
 
   state_s <- state$get_index_of(values = "S")$to_vector()
@@ -252,4 +252,4 @@ test_that("age-structured infection process gives same results as R version", {
     health_R$get_index_of("I")$to_vector(),
     health_cpp$get_index_of("I")$to_vector()
   )
-})
+})

tests/testthat/test-simulation-e2e.R

@@ -138,3 +138,37 @@ test_that("deterministic state & variable model works", {
 
   expect_mapequal(true_render, render$to_dataframe())
 })
+
+test_that("Can give names to processes", {
+  names <- NULL
+
+  simulation_loop(
+    processes = list(
+      foo = function(t) {
+        names <<- c(names, deparse(sys.call()[[1]]))
+      },
+      bar = function(t) {
+        names <<- c(names, deparse(sys.call()[[1]]))
+      }
+    ),
+    timesteps = 1)
+
+  expect_equal(names, c("foo", "bar"))
+})
+
+test_that("Can give two processes the same name", {
+  names <- NULL
+
+  simulation_loop(
+    processes = list(
+      foo = function(t) {
+        names <<- c(names, deparse(sys.call()[[1]]))
+      },
+      foo = function(t) {
+        names <<- c(names, deparse(sys.call()[[1]]))
+      }
+    ),
+    timesteps = 1)
+
+  expect_equal(names, c("foo", "foo"))
+})