feat(model): add creation of ASU and rehab trajectories (create_asu/rehab_trajectory), with ASU sampling the routing destination (sample_routing)

Author: amyheather

NAMESPACE

@@ -4,14 +4,19 @@ export(add_patient_generator)
 export(create_asu_arrivals)
 export(create_asu_los)
 export(create_asu_routing)
+export(create_asu_trajectory)
 export(create_parameters)
 export(create_rehab_arrivals)
 export(create_rehab_los)
 export(create_rehab_routing)
+export(create_rehab_trajectory)
 export(model)
+export(sample_routing)
 importFrom(simmer,add_generator)
+importFrom(simmer,get_attribute)
 importFrom(simmer,get_mon_arrivals)
 importFrom(simmer,get_mon_resources)
+importFrom(simmer,set_attribute)
 importFrom(simmer,simmer)
 importFrom(simmer,timeout)
 importFrom(simmer,trajectory)

R/create_asu_trajectory.R

@@ -0,0 +1,22 @@
+#' Create ASU patient trajectory
+#'
+#' @param patient_type Character string specifying patient category. Must be
+#' one of: "stroke", "tia", "neuro", or "other". Determines which arrival rate
+#' parameter is used.
+#' @param param Nested list containing simulation parameters. Must have
+#' structure `param$asu_routing$<patient_type>` containing the probability of
+#' routing to each destination (e.g.`param$asu_routing_stroke$rehab = 0.24`).
+#'
+#' @importFrom simmer trajectory
+#'
+#' @return Simmer trajectory object. Defines patient journey logic through the
+#' healthcare system.
+#' @export
+
+create_asu_trajectory <- function(patient_type, param) {
+  trajectory(paste0("ASU_", patient_type, "_path")) |>
+    set_attribute("post_asu_destination", function(env) {
+      sample_routing(prob_list = param[["asu_routing"]][[patient_type]])
+    }) |>
+    timeout(1L)
+}

R/create_rehab_trajectory.R

@@ -0,0 +1,19 @@
+#' Create rehab patient trajectory
+#'
+#' @param patient_type Character string specifying patient category. Must be
+#' one of: "stroke", "tia", "neuro", or "other". Determines which arrival rate
+#' parameter is used.
+#' @param param Nested list containing simulation parameters. Must have
+#' structure `param$asu_routing$<patient_type>` containing the probability of
+#' routing to each destination (e.g.`param$asu_routing_stroke$rehab = 0.24`).
+#'
+#' @importFrom simmer trajectory
+#'
+#' @return Simmer trajectory object. Defines patient journey logic through the
+#' healthcare system.
+#' @export
+
+create_rehab_trajectory <- function(patient_type, param) {
+  trajectory(paste0("rehab_", patient_type, "_path")) |>
+    timeout(1L)
+}

R/model.R

@@ -6,8 +6,8 @@
 #' may not wish to do if being set elsewhere - such as done in runner()).
 #' Default is TRUE.
 #'
-#' @importFrom simmer get_mon_arrivals get_mon_resources simmer timeout
-#' @importFrom simmer trajectory wrap
+#' @importFrom simmer get_attribute get_mon_arrivals get_mon_resources
+#' @importFrom simmer set_attribute simmer timeout wrap
 #'
 #' @return TBC
 #' @export
@@ -22,16 +22,16 @@ model <- function(run_number, param, set_seed = TRUE) {
   # Create simmer environment
   env <- simmer("simulation", verbose = TRUE)
 
-  # Define the stroke patient trajectory
-  patient <- trajectory("patient_path") |>
-    timeout(1L)
-
   # Add ASU and rehab direct admission patient generators
   for (unit in c("asu", "rehab")) {
     for (patient_type in names(param[[paste0(unit, "_arrivals")]])) {
       env <- add_patient_generator(
         env = env,
-        trajectory = patient,
+        # Get trajectory given unit and patient type
+        trajectory = (
+          if (unit == "asu") create_asu_trajectory(patient_type, param)
+          else create_rehab_trajectory(patient_type, param)
+        ),
         unit = unit,
         patient_type = patient_type,
         param = param

R/parameters.R

@@ -68,7 +68,15 @@ create_asu_los <- function(
   neuro_mean = 4.0, neuro_sd = 5.0,
   other_mean = 3.8, other_sd = 5.2
 ) {
-  return(as.list(environment()))
+  list(
+    stroke_noesd = list(mean = stroke_noesd_mean, sd = stroke_noesd_sd),
+    stroke_esd = list(mean = stroke_esd_mean, sd = stroke_esd_sd),
+    stroke_mortality = list(mean = stroke_mortality_mean,
+                            sd = stroke_mortality_sd),
+    tia = list(mean = tia_mean, sd = tia_sd),
+    neuro = list(mean = neuro_mean, sd = neuro_sd),
+    other = list(mean = other_mean, sd = other_sd)
+  )
 }
 
 #' Rehabilitation unit length of stay (LOS) distributions (days).
@@ -96,7 +104,13 @@ create_rehab_los <- function(
   neuro_mean = 27.6, neuro_sd = 28.4,
   other_mean = 16.1, other_sd = 14.1
 ) {
-  return(as.list(environment()))
+  list(
+    stroke_noesd = list(mean = stroke_noesd_mean, sd = stroke_noesd_sd),
+    stroke_esd = list(mean = stroke_esd_mean, sd = stroke_esd_sd),
+    tia = list(mean = tia_mean, sd = tia_sd),
+    neuro = list(mean = neuro_mean, sd = neuro_sd),
+    other = list(mean = other_mean, sd = other_sd)
+  )
 }
 
 #' ASU routing probabilities.
@@ -131,7 +145,12 @@ create_asu_routing <- function(
   neuro_rehab = 0.11, neuro_esd = 0.05, neuro_other = 0.84,
   other_rehab = 0.05, other_esd = 0.10, other_other = 0.85
 ) {
-  return(as.list(environment()))
+  list(
+    stroke = list(rehab = stroke_rehab, esd = stroke_esd, other = stroke_other),
+    tia = list(rehab = tia_rehab, esd = tia_esd, other = tia_other),
+    neuro = list(rehab = neuro_rehab, esd = neuro_esd, other = neuro_other),
+    other = list(rehab = other_rehab, esd = other_esd, other = other_other)
+  )
 }
 
 #' Rehabilitation unit routing probabilities.
@@ -161,7 +180,12 @@ create_rehab_routing <- function(
   neuro_esd = 0.09, neuro_other = 0.91,
   other_esd = 0.13, other_other = 0.88
 ) {
-  return(as.list(environment()))
+  list(
+    stroke = list(esd = stroke_esd, other = stroke_other),
+    tia = list(esd = tia_esd, other = tia_other),
+    neuro = list(esd = neuro_esd, other = neuro_other),
+    other = list(esd = other_esd, other = other_other)
+  )
 }
 
 #' Generate complete parameter list for simulation.

R/sample_routing.R

@@ -0,0 +1,15 @@
+#' Sample a destination based on probabilities
+#'
+#' Randomly selects a destination from a list, where each destination has an
+#' associated probability.
+#'
+#' @param prob_list Named list. The names are destination labels (character),
+#' and the values are their corresponding probabilities (numeric, non-negative,
+#' sum to 1).
+#'
+#' @return A character string. The name of the selected destination.
+#' @export
+
+sample_routing <- function(prob_list) {
+  sample(seq_along(prob_list), size = 1L, prob = unlist(prob_list))
+}

man/create_asu_trajectory.Rd

@@ -16,6 +16,7 @@ devtools::load_all()
 library(simulation)
 ```
 
+
 ```{r}
 model(run_number = 1L, param = create_parameters(), set_seed = TRUE)
 ```