feat/refactor/fix(distributionregistry): amend model, trajectories, generator and json so that the model actually successfully runs (also improved a docstring in registry) (#11)

Author: amyheather

R/add_patient_generator.R

@@ -29,7 +29,7 @@ add_patient_generator <- function(env, trajectory, unit, patient_type, param) {
     name_prefix = paste0(unit, "_", patient_type),
     trajectory = trajectory,
     distribution = function() {
-      param[["dist"]][["arrivals"]][[unit]][[patient_type]]()
+      param[["dist"]][["arrival"]][[unit]][[patient_type]]()
     }
   )
 }

R/create_asu_trajectory.R

@@ -36,25 +36,27 @@ create_asu_trajectory <- function(env, patient_type, param) {
     }) |>
 
     log_(function() {
-      dest <- get_attribute(env, "post_asu_destination")
-      paste0("\U0001F3AF Planned ASU -> ", dest)
+      dest_num <- get_attribute(env, "post_asu_destination")
+      dest <- param[["map_num2val"]][as.character(dest_num)]
+      paste0("\U0001F3AF Planned ASU -> ", dest_num, " (", dest, ")")
     }, level = 1L) |>
 
     # Sample ASU LOS. For stroke patients, LOS distribution is based on
     # the planned destination after the ASU.
     set_attribute("asu_los", function() {
-      dest <- get_attribute(env, "post_asu_destination")
+      dest_num <- get_attribute(env, "post_asu_destination")
+      dest <- param[["map_num2val"]][as.character(dest_num)]
       if (patient_type == "stroke") {
         switch(
           dest,
-          esd = param[["dest"]][["los"]][["asu"]][["stroke_esd"]],
-          rehab = param[["dest"]][["los"]][["asu"]][["stroke_no_esd"]],
-          other = param[["dest"]][["los"]][["asu"]][["stroke_mortality"]],
+          esd = param[["dist"]][["los"]][["asu"]][["stroke_esd"]](),
+          rehab = param[["dist"]][["los"]][["asu"]][["stroke_noesd"]](),
+          other = param[["dist"]][["los"]][["asu"]][["stroke_mortality"]](),
           stop("Stroke post-asu destination '", dest, "' invalid",
                call. = FALSE)
         )
       } else {
-        param[["dest"]][["los"]][["asu"]][[patient_type]]()
+        param[["dist"]][["los"]][["asu"]][[patient_type]]()
       }
     }) |>
 
@@ -72,7 +74,9 @@ create_asu_trajectory <- function(env, patient_type, param) {
     # If that patient's destination is rehab, then start on that trajectory
     branch(
       option = function() {
-        if (get_attribute(env, "post_asu_destination") == "rehab") 1L else 0L
+        dest_num <- get_attribute(env, "post_asu_destination")
+        dest <- param[["map_num2val"]][as.character(dest_num)]
+        if (dest == "rehab") 1L else 0L
       },
       continue = FALSE,  # Do not continue main trajectory after branch
       create_rehab_trajectory(env, patient_type, param)

R/create_rehab_trajectory.R

@@ -36,24 +36,26 @@ create_rehab_trajectory <- function(env, patient_type, param) {
     }) |>
 
     log_(function() {
-      dest <- get_attribute(env, "post_rehab_destination")
-      paste0("\U0001F3AF Planned rehab -> ", dest_index, " (", dest, ")")
+      dest_num <- get_attribute(env, "post_rehab_destination")
+      dest <- param[["map_num2val"]][as.character(dest_num)]
+      paste0("\U0001F3AF Planned rehab -> ", dest_num, " (", dest, ")")
     }, level = 1L) |>
 
     # Sample rehab LOS. For stroke patients, LOS distribution is based on
     # the planned destination after the rehab
     set_attribute("rehab_los", function() {
-      dest <- get_attribute(env, "post_rehab_destination")
+      dest_num <- get_attribute(env, "post_rehab_destination")
+      dest <- param[["map_num2val"]][as.character(dest_num)]
       if (patient_type == "stroke") {
         switch(
           dest,
-          esd = param[["los"]][["rehab"]][["stroke_esd"]](),
-          other = param[["los"]][["rehab"]][["stroke_no_esd"]](),
+          esd = param[["dist"]][["los"]][["rehab"]][["stroke_esd"]](),
+          other = param[["dist"]][["los"]][["rehab"]][["stroke_noesd"]](),
           stop("Stroke post-rehab destination '", dest, "' invalid",
                call. = FALSE)
         )
       } else {
-        param[["los"]][["rehab"]][[patient_type]]()
+        param[["dist"]][["los"]][["rehab"]][[patient_type]]()
       }
     }) |>
 

R/distribution_registry.R

@@ -78,9 +78,15 @@ DistributionRegistry <- R6Class("DistributionRegistry", list( # nolint: object_n
   #' @description
   #' Register a distribution generator under a name.
   #'
-  #' Typically, the generator should be a function that takes
-  #' distribution-specific parameters and returns a function of `size` (the
-  #' sample size).
+  #' Typically, the generator should be a function that:
+  #' 1. Accepts parameters for a distribution.
+  #' 2. Returns another function - the *sampler* - which takes a `size`
+  #' argument and produces that many random values from the specified
+  #' distribution.
+  #'
+  #' By storing generators rather than fixed samplers, you can create as many
+  #' different samplers as you want later, each with different parameters,
+  #' while reusing the same generator code.
   #'
   #' @param name Distribution name (string)
   #' @param generator Function to create a sampler given its parameters.
@@ -146,6 +152,8 @@ DistributionRegistry <- R6Class("DistributionRegistry", list( # nolint: object_n
              "for a lognormal distribution.")
       }
     }
+    # Calls the `get()` method above which finds the distribution generator
+    # function, then do.call() populates it with dots (a list of arguments).
     generator <- self$get(name)
     do.call(generator, dots)
   },
@@ -162,6 +170,7 @@ DistributionRegistry <- R6Class("DistributionRegistry", list( # nolint: object_n
   #' @return List of parameterised samplers (named if config is named).
   create_batch = function(config) {
     if (is.list(config)) {
+      # Calls `create()` for each distribution specified in config
       lapply(config, function(cfg) {
         do.call(self$create, c(cfg$class_name, cfg$params))
       })

R/model.R

@@ -32,9 +32,29 @@ model <- function(run_number, param, set_seed = TRUE) {
   param[["verbose"]] <- any(c(param[["log_to_console"]],
                               param[["log_to_file"]]))
 
+  # Convert discrete categories from character to numeric (as will store using
+  # set.attribute(), which doesn't accept strings)
+  # Identify discrete configs
+  discrete_cfg <- Filter(\(x) x$class_name == "discrete", param$dist_config)
+  # Get all the unique "values" (categories)
+  all_vals <- unique(unlist(lapply(discrete_cfg, \(x) unlist(x$params$values))))
+  # Build mapping
+  param[["map_val2num"]] <- setNames(seq_along(all_vals), all_vals)
+  param[["map_num2val"]] <- setNames(all_vals, seq_along(all_vals))
+  # Replace discrete values with numeric codes in a copy
+  param$dist_config_num <- lapply(param$dist_config, \(cfg) {
+    if (cfg$class_name == "discrete") {
+      # Flatten, map to numbers, drop names
+      cfg$params$values <- unname(
+        param[["map_val2num"]][unlist(cfg$params$values)]
+      )
+    }
+    cfg
+  })
+
   # Set up sampling distributions
   registry <- simulation::DistributionRegistry$new()
-  param[["dist"]] <- registry$create_batch(as.list(param[["dist_config"]]))
+  param[["dist"]] <- registry$create_batch(as.list(param[["dist_config_num"]]))
 
   # Restructure as dist[type][unit][patient]
   dist <- list()
@@ -61,7 +81,7 @@ model <- function(run_number, param, set_seed = TRUE) {
       .env = env, name = paste0(unit, "_bed"), capacity = Inf
     )
 
-    for (patient_type in names(param[[paste0(unit, "_arrivals")]])) {
+    for (patient_type in names(param[["dist"]][["arrival"]][[unit]])) {
 
       # Create patient trajectory
       traj <- if (unit == "asu") {

inst/extdata/parameters.json

@@ -114,8 +114,8 @@
       "rehab_routing_tia": {
         "class_name": "discrete",
         "params": {
-          "values": ["other"],
-          "prob": [1.0]
+          "values": ["esd", "other"],
+          "prob": [0.0, 1.0]
         }
       },
       "rehab_routing_neuro": {