From 3d199bc37f1f54d5cc25035dd43d3202719f0c23 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Paul=20Li=C3=A9tar?= <pl2113@ic.ac.uk>
Date: Fri, 12 Jul 2024 11:08:42 +0100
Subject: [PATCH] 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                       | 32 ++++++++++++++++++--------
 tests/testthat/test-prefab.R         | 10 ++++----
 tests/testthat/test-simulation-e2e.R | 34 ++++++++++++++++++++++++++++
 3 files changed, 62 insertions(+), 14 deletions(-)

diff --git a/R/simulation.R b/R/simulation.R
index 50c58e74..5e051130 100644
--- a/R/simulation.R
+++ b/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
 }
diff --git a/tests/testthat/test-prefab.R b/tests/testthat/test-prefab.R
index d7c74075..538396f2 100644
--- a/tests/testthat/test-prefab.R
+++ b/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()
   )
-})
\ No newline at end of file
+})
diff --git a/tests/testthat/test-simulation-e2e.R b/tests/testthat/test-simulation-e2e.R
index 64f6af36..fbd1bbd8 100644
--- a/tests/testthat/test-simulation-e2e.R
+++ b/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"))
+})