Having tested the main components of the simulation, we now proceed to test the actual simulation. We do this by checking the logic of the results since the individual components have already been tested. Before doing this however, we must first bring in the required simulation modules. We will need everything developed for the simulation except for the functions which generate arrival times, as we will be providing standardized arrival times to ease in fact checking.

Load Required Code Modules

Event codes:

event_arrive_park = 1
event_enter_park = 2
event_leave_park = 30
event_leave_dining = 31
event_leave_ride = 32
event_process_attraction = 40
event_choose_experience = 50
event_choose_attraction = 51
event_choose_dining = 52

choose_turnstile() utility function:

choose_turnstile <- function(turnstiles, rule){
  if (rule == "shortest"){
    shortest <- 1 #index into turnstiles, not necessarily turnstile id
    line_length <- turnstiles[[shortest]]$agents_waiting

    #find the first shortest line
    for (i in 1:length(turnstiles)){
      if (turnstiles[[i]]$agents_waiting < line_length){
        shortest <- i
        line_length <- turnstiles[[i]]$agents_waiting
      }
    }

    return(shortest)
  }
}

layover() utility function:

layover <- function(turnstile, time){
  return(turnstile$calculate_wait_time(time) + turnstile$service_time)
}

turnstile class:

Turnstile <- R6::R6Class(
  "Turnstile",
  inherit = SimpleQueue
)

SimpleQueue class:

SimpleQueue <- R6::R6Class(
  "SimpleQueue",

  public = list(
    initialize = function(id, service_time){

      #initialize with unique turnstile id and zero agents waiting
      private$.id <- id
      private$.service_time <- service_time
      private$.agents_waiting <- 0
    },

    add_agent = function(current_time){
      if(!missing(current_time)){
        private$.agents_waiting <- private$.agents_waiting + 1

        if(is.na(private$.service_complete_at)){
          private$.service_complete_at <- current_time + private$.service_time
        }
      } else {
        stop("Cannot add agent without knowing the current time\n")
      }
      invisible(self)
    },

    remove_agent = function(){

      private$.agents_waiting = private$.agents_waiting - 1
      private$.service_complete_at <- private$.service_complete_at + private$.service_time

      if (private$.agents_waiting <= 0){
        private$.agents_waiting = 0
        private$.service_complete_at <- NA
      }

      invisible(self)
    },

    calculate_wait_time = function(current_time){
      if(missing(current_time)){
        stop("Cannot calculate current wait time without current time\n")
      } else {
        current_wait_time <- (private$.service_time * (private$.agents_waiting - 1)) +
          (private$.service_complete_at - current_time)

        #if we return a negative wait time, that means no one is in line, so
        #replace with zero
        if (is.na(current_wait_time) || current_wait_time < 0){
          current_wait_time <- 0
        }

        return(current_wait_time)
      }
    }
  ),

  active = list(
    id = function(value){
      if(missing(value)){
        private$.id
      } else{
        stop("Cannot set `$turnstile_id` after instantiation\n")
      }
    },

    service_time = function(value){
      if(missing(value)){
        private$.service_time
      } else{
        stop("Cannot change `$service_time` after instantiation\n")
      }
    },

    agents_waiting = function(value){
      if(missing(value)){
        private$.agents_waiting
      } else {
        stop("Cannot set `$agents_waiting`\n")
      }
    },

    service_complete_at = function(value){
      if(missing(value)){
        private$.service_complete_at
      } else{
        stop("cannot set `$service_complete_at`, use `$add_agent\n`")
      }
    }
  ),

  private = list(
    .id = -1,
    .service_time = -1,
    .agents_waiting = -1,
    .service_complete_at = NA
  )
)

Event record class:

Event <- R6::R6Class(
  "Event",

  public = list(
    initialize = function(agent_id = NA, trigger_time, arrive_park = NA, event_type,
                          remaining_attractions=NA, turnstile_chosen = NA,
                          remaining_dining = NA, attractions_visited = NA,
                          dining_visited = NA, attraction_index = NA){
      private$.agent_id <- agent_id
      private$.event_type <- event_type
      private$.trigger_time <- trigger_time
      private$.arrive_park <- arrive_park
      private$.remaining_attractions <- remaining_attractions
      private$.turnstile_chosen <- turnstile_chosen
      private$.remaining_dining <- remaining_dining
      private$.attractions_visited <- attractions_visited
      private$.dining_visited <- dining_visited
      private$.attraction_index <- attraction_index
      private$.data <- list()
    }
  ),

  active = list(
    agent_id = function(value){
      if(missing(value)){
        private$.agent_id
      } else{
        stop("Cannot set `$agent_id`\n")
      }
    },

    event_type = function(value){
      if(missing(value)){
        private$.event_type
      } else {
        private$.event_type <- value
      }
    },

    trigger_time = function(value){
      if(missing(value)){
        private$.trigger_time
      } else {
        private$.trigger_time <- value
      }
    },

    arrive_park = function(value){
      if(missing(value)){
        private$.arrive_park
      } else{
        stop("Cannot change `$arrive_park` after instantiation\n")
      }
    },

    retired = function(value){
      if(missing(value)){
        private$.retired
      } else{
        private$.retired <- value
      }
    },

    remaining_attractions = function(value){
      if(missing(value)){
        private$.remaining_attractions
      } else {
        private$.remaining_attractions <- value
      }
    },

    turnstile_chosen = function(value){
      if(missing(value)){
        private$.turnstile_chosen
      } else {
        private$.turnstile_chosen <- value
      }
    },

    remaining_dining = function(value){
      if(missing(value)){
        private$.remaining_dining
      } else{
        private$.remaining_dining <- value
      }
    },

    attractions_visited = function(value){
      if(missing(value)){
        Filter(Negate(is.na),private$.attractions_visited)
      } else{
        private$.attractions_visited <- c(private$.attractions_visited, value)
      }
    },

    dining_visited = function(value){
      if(missing(value)){
        Filter(Negate(is.na),private$.dining_visited)
      } else{
        private$.dining_visited <- c(private$.dining_visited, value)
      }
    },

    attraction_index = function(value){
      if(missing(value)){
        private$.attraction_index
      } else{
        private$.attraction_index <- value
      }
    },

    data = function(value){
      if(missing(value)){
        private$.data
      } else{
        private$.data <- append(private$.data, value)
      }
    }
  ),

  private = list(
    .agent_id = -1,
    .event_type = -1,
    .trigger_time = NA,
    .arrive_park = NA,
    .remaining_attractions = -1,
    .retired = FALSE,
    .turnstile_chosen = NA,
    .remaining_dining = NA,
    .attractions_visited = NA,
    .dining_visited = NA,
    .attraction_index = NA,
    .data = NULL
  )
)

Testing

We setup the simulation and arrivals to arrive at more standard times so that fact checking everything is easier.

master_event_queue <- datastructures::fibonacci_heap("integer")
agent_arrivals <- c(1,3,5,2,9,7) #seconds

#instantiate a progress bar
pb <- progress::progress_bar$new(total = length(agent_arrivals))

#load master event queue with arrivals
invisible(
  mapply(function(i){
  datastructures::insert(master_event_queue, as.integer(agent_arrivals[i]), 
                         Event$new(agent_id = i, trigger_time = agent_arrivals[i],
                                   arrive_park = agent_arrivals[i],
                                   event_type = event_arrive_park))
  pb$tick()
  }, 1:length(agent_arrivals))
)

turnstile_service_time = 60 #1 minute

#define the endtime of the simulation
simulation_end_time = 1*60*60 #1 hour in seconds

#define the number of turnstiles to keep open and the rule
num_of_turnstiles <- 5
turnstile_rule <- "shortest"

#log info
logging = TRUE
filepath = file.path("..","..","logs","sim_log.txt")

#static departure time 
#right now as soon as the agent gets into the park it waits for the time specified below
#until it leaves
static_departure_time = 1.5 * 60 #1.5 minutes

#instantiate turnstiles
turnstiles <- mapply(function(i){
    Turnstile$new(i, turnstile_service_time)
  }, 1:num_of_turnstiles)

We now run the simulation.

#instantiate current time by setting it equal to the very first item in the master event queue
cur_time = datastructures::peek(master_event_queue)[[1]]$trigger_time

#setup header
write(paste("cur_time", "agent_id", "trig_event_type", "next_trigger_time", "next_event_type","arrive_park",
            "turnstile_chosen","rem_attractions", "retired", sep = ","), file = filepath)

#perform the simulation until we go past the simulation end time or we run out of simulation events
while (!is.null(cur_time) && cur_time < simulation_end_time){

  #output the current time so you can know where in the simulation you are
  if (logging){
    cat(paste("\r\014Current Time:", cur_time))
  }

  #grab the next event record and save the triggering event for logging purposes
  event <- datastructures::pop(master_event_queue)[[1]]

  if (logging){
    triggering_event_type <- event$event_type
  }

  if (event$event_type == event_arrive_park){
    #agent has arrived at park so,

    #pick the shortest line and add it to the event record
    shortest_line <- choose_turnstile(turnstiles, turnstile_rule)
    event$turnstile_chosen <- shortest_line

    #schedule next event -> what time is it now + layover
    event$event_type <- event_enter_park
    event$trigger_time <- event$trigger_time + layover(turnstiles[[shortest_line]], cur_time)

    #place the agent into the line at the current time
    turnstiles[[shortest_line]]$add_agent(cur_time)

  } else if (event$event_type == event_enter_park){
    #agent has entered park so,

    #remove agent from turnstile line (we know the turnstile used based upon event record)
    turnstiles[[event$turnstile_chosen]]$remove_agent()

    #schedule next event
    #at the moment it uses a static departure time
    event$event_type <- event_leave_park
    event$trigger_time <- event$trigger_time + static_departure_time

  } else if (event$event_type == event_leave_park){
    #agent is leaving park so,

    #set the next event and trigger time to NA, retire the event record
    event$event_type <- -1
    event$trigger_time <- NA
    event$retired <- TRUE

  } else{
    stop("Unknown event type\n")
  }

  #outputs the contents of the event record if logging is enabled
  if (logging){
    write(paste(cur_time, event$agent_id, triggering_event_type, event$trigger_time,
                event$event_type, event$arrive_park, event$turnstile_chosen,
                event$remaining_attractions, event$retired,
                sep = ","),
          file=filepath, append = TRUE)
  }

  #add the event record back to the priority queue if the event has not been
  #retired (i.e. the agent has left)
  if(!event$retired){
    datastructures::insert(master_event_queue, as.integer(event$trigger_time), event)
  }

  #advance time to the next event epoch
  cur_time <- datastructures::peek(master_event_queue)[[1]]$trigger_time

}

The results of the simulation are as follows:

results <- read.csv("../../logs/sim_log.txt")
DT::datatable(results)

Upon analysis, we can see that each agent follows the appropriate path going from arrival to entrance to leaving. Testing has passed.