Incomplete Trajectories in R Simmer when using Branches within Do_Parallel

Question

I am building a simulation in R using the simmer package.

The simulation models a restaurant where customers wait for their food after an order is placed.

Each order resource takes a different amount of time to use. Branch assigns a trajectory with a related timeout value depending on which resource was selected and records whether the resource used was digital or live for later reference. Note that this trajectory is incomplete on its own (explained later).

An order may have up to three types of products, each type having a different probability and taking a different amount of time to assemble. The limiting resource here is space to assemble orders. An assembly does not start until there is space for its tray. The trajectory is returned by the following function.

# Packages and model variables used
library(simmer)
library(simmer.plot)
library(simmer.bricks)
library(tidyr)

# (p) probability
p_rts <- 0.125 # ready to serve menu item
p_hot <- 0.25 # hot food item
p_bev <- 0.7 # Beverage

# (t) time in seconds - average from 
t_rts <- 10
t_hot <- 175
t_bev <- 25

# arrival distribution
r_arrive <- function(){
    runif(20, min = 0, max = 600) %>% # all arrivals occur within first 600 seconds
    sort
}

# The trajectory where the issue likely exists
f_order_prepare <- function(e, p_rts, p_hot, p_bev, t_rts, t_hot, t_bev){
  trajectory() %>%
    set_attribute("start_assembly", function() now(e)) %>%
    do_parallel(
      traj = list(
        trajectory() %>% branch(
          function() ifelse(runif(1) <= p_rts, 1, 2),
          continue = c(TRUE, TRUE), 
          trajectory() %>% set_attribute("has_rts", 1) %>% timeout(t_rts), 
          trajectory() %>% set_attribute("has_rts", 0)),
        trajectory() %>% branch(
          function() ifelse(runif(1) <= p_hot, 1, 2),
          continue = c(TRUE, TRUE), 
          trajectory() %>% set_attribute("has_hot", 1) %>% timeout(t_hot),
          trajectory() %>% set_attribute("has_hot", 0)),
        trajectory() %>% branch(
          function() ifelse(runif(1) <= p_bev, 1, 2),
          continue = c(TRUE, TRUE), 
          trajectory() %>% set_attribute("has_bev", 1) %>% timeout(t_bev), 
          trajectory() %>% set_attribute("has_bev", 0))
      ),
      .env = e, 
      wait = TRUE
    ) %>%
    log_("order ready") %>%
    set_attribute("order_ready", function() now(e))
}

We record when the assembly starts and then run three branches in parallel. If a product is chosen, it sets its timeout and records that it was chosen; otherwise, it records that the product was not selected. do_parallel waits for the longest of the three trajectories to complete, then continues.

trj_QSR <- trajectory() %>%
  seize("pickup_capacity", 1) %>%
  log_("seized the pick_up capacity") %>%
  simmer::join(
    f_order_prepare(env, p_rts, p_hot, p_bev, 
                  t_rts, t_hot, t_bev)
    )%>%
  timeout(20) %>% #delay for customer to collect tray
  release("pickup_capacity", 1) %>%
  set_attribute("transaction_done", function() now(env))

## Initiate
reset(env)
set.seed(12345)
env <- simmer() 
env <- env %>%
  add_resource("pickup_capacity", 12) %>%
  add_generator("transaction", trj_QSR, 
                distribution = at(r_arrive()), mon = 2)

env %>% run(until=50000000) #~578 days to ensure issues are not related to run time

The script executes without error; however, only the first 13 arrivals make it far enough to record which products were selected in do_parallel and only two finish their trajectory. The other 11 record the selections but then stop. The following code summarizes the attributes I tracked for troubleshooting.

get_mon_attributes(env) %>%
  dplyr::select(-c("time", "replication")) %>%
  pivot_wider(
    names_from = key,
    values_from = value
  ) %>%
  View(title = "atts")

Summary: For some reason, most arrivals do not complete the do_parallel trajectories and, therefore, never release the "pickup_capacity" resource, leaving remaining arrivals in the queue.

I am looking for help isolating why this is occurring. Thanks.

Answer 1

The original issue has to do with the simultaneity of events, which cannot be properly resolved by the simulator unless you give it a hint.

Basically, in your parallel trajectories, you have a branch with a timeout and a branch without it. When the latter is picked, then you are in trouble, because you send a signal that a trajectory finished up to 3 times before any of those signals are processed, so most of your arrivals get stuck at some wait activity (plot the trajectory to see and understand the structure that do_parallel assembles).

The solution is simple: add a timeout(0) as follows.

f_order_prepare <- function(e, p_rts, p_hot, p_bev, t_rts, t_hot, t_bev){
  trajectory() %>%
    set_attribute("start_assembly", function() now(e)) %>%
    do_parallel(
      traj = list(
        trajectory() %>% branch(
          function() ifelse(runif(1) <= p_rts, 1, 2),
          continue = c(TRUE, TRUE), 
          trajectory() %>% set_attribute("has_rts", 1) %>% timeout(t_rts), 
          trajectory() %>% set_attribute("has_rts", 0) %>% timeout(0)),
        trajectory() %>% branch(
          function() ifelse(runif(1) <= p_hot, 1, 2),
          continue = c(TRUE, TRUE), 
          trajectory() %>% set_attribute("has_hot", 1) %>% timeout(t_hot),
          trajectory() %>% set_attribute("has_hot", 0) %>% timeout(0)),
        trajectory() %>% branch(
          function() ifelse(runif(1) <= p_bev, 1, 2),
          continue = c(TRUE, TRUE), 
          trajectory() %>% set_attribute("has_bev", 1) %>% timeout(t_bev), 
          trajectory() %>% set_attribute("has_bev", 0) %>% timeout(0))
      ),
      .env = e, 
      wait = TRUE
    ) %>%
    log_("order ready") %>%
    set_attribute("order_ready", function() now(e))
}