Це один з найбільш повчальних і цікавих видів моделювання: ви створюєте незалежні агенти в комп'ютері, дозволяєте їм взаємодіяти, слідкувати за тим, що вони роблять, і вивчати, що відбувається. Це чудовий спосіб дізнатися про складні системи, особливо (але не обмежуючись ними) тих, які неможливо зрозуміти чисто математичним аналізом.
Найкращий спосіб побудувати такі симуляції - це конструкція зверху вниз.
На самому високому рівні код повинен виглядати приблизно так
initialize(...)
while (process(get.next.event())) {}
(Цей та всі наступні приклади є виконуваним R кодом, а не лише псевдо-кодом.) Цикл - це симуляція, керована подіями : get.next.event()знаходить будь-яку «подію», що цікавить, і передає її опис process, який робить щось із цим (включаючи реєстрацію будь-якого відомості про нього). Він повертається TRUEдо тих пір, поки все працює добре; при виявленні помилки або в кінці моделювання вона повертається FALSE, закінчуючи цикл.
Якщо ми уявляємо фізичну реалізацію цієї черги, наприклад людей, які чекають шлюбного посвідчення в Нью-Йорку, або посвідчення водія або квитка на поїзд майже де завгодно, ми думаємо про два види агентів: клієнтів та "помічників" (або серверів) . Клієнти оголошують себе, показуючи; помічники оголошують про їх наявність, включаючи світло або підписуючи або відкриваючи вікно. Це два види подій, які слід обробити.
Ідеальне середовище для такого моделювання - це справжнє об'єктно-орієнтоване, в якому об'єкти є змінними : вони можуть змінювати стан, щоб самостійно реагувати на речі навколо. Rабсолютно жахливо для цього (навіть Фортран було б краще!). Однак ми все-таки можемо використовувати його, якщо докладати певних заходів. Трюк полягає в збереженні всієї інформації в загальному наборі структур даних, до яких можна отримати доступ (і змінити) багатьма окремими взаємодіючими процедурами. Я прийму умову використання імен змінних ВСІХ КАПС для таких даних.
Наступний рівень дизайну зверху вниз - це кодування process. Він відповідає одному дескриптору подій e:
process <- function(e) {
if (is.null(e)) return(FALSE)
if (e$type == "Customer") {
i <- find.assistant(e$time)
if (is.null(i)) put.on.hold(e$x, e$time) else serve(i, e$x, e$time)
} else {
release.hold(e$time)
}
return(TRUE)
}
Він повинен реагувати на нульову подію, коли get.next.eventне має повідомляти про події. В іншому випадку processреалізує "бізнес-правила" системи. Це практично пише з опису в питанні. Принцип роботи повинен вимагати невеликих коментарів, за винятком зазначення, що врешті-решт нам потрібно буде кодувати підпрограми put.on.holdта release.hold(реалізуючи чергу клієнта-холдингу) та serve(реалізуючи взаємодію замовника-помічника).
Що таке "подія"? Він повинен містити інформацію про те, хто діє, які дії вони вживають та коли це відбувається. Тому мій код використовує список, що містить ці три види інформації. Однак get.next.eventпотрібно лише оглянути час. Він несе відповідальність лише за підтримку черги подій, в яких відбувається
Будь-яка подія може бути поміщена в чергу після її отримання та
Найдавніша подія в черзі може бути легко вилучена і передана абоненту.
Кращою реалізацією цієї черги за пріоритетом було б купу, але це занадто метушливо R. Після пропозиції в програмі «Мистецтво R» Нормана Матлофа (який пропонує більш гнучкий, абстрактний, але обмежений симулятор черги), я використав кадр даних для проведення подій та просто пошуку його протягом мінімального часу серед його записів.
get.next.event <- function() {
if (length(EVENTS$time) <= 0) new.customer() # Wait for a customer$
if (length(EVENTS$time) <= 0) return(NULL) # Nothing's going on!$
if (min(EVENTS$time) > next.customer.time()) new.customer()# See text
i <- which.min(EVENTS$time)
e <- EVENTS[i, ]; EVENTS <<- EVENTS[-i, ]
return (e)
}
Є багато способів, як це можна було б закодувати. Кінцева версія, показана тут, відображає вибір, який я зробив у кодуванні того, як processреагує на подію "Помічник" і як new.customerпрацює: get.next.eventпросто виймає клієнта з черги утримування, потім сідає назад і чекає чергової події. Іноді потрібно буде шукати нового клієнта двома способами: по-перше, щоб побачити, чи чекає один у дверях (як би) і по-друге, чи зайшов він, коли ми не шукали.
Зрозуміло, new.customerі next.customer.timeце важливі процедури , тому давайте подбаємо про них далі.
new.customer <- function() {
if (CUSTOMER.COUNT < dim(CUSTOMERS)[2]) {
CUSTOMER.COUNT <<- CUSTOMER.COUNT + 1
insert.event(CUSTOMER.COUNT, "Customer",
CUSTOMERS["Arrived", CUSTOMER.COUNT])
}
return(CUSTOMER.COUNT)
}
next.customer.time <- function() {
if (CUSTOMER.COUNT < dim(CUSTOMERS)[2]) {
x <- CUSTOMERS["Arrived", CUSTOMER.COUNT]
} else {x <- Inf}
return(x) # Time when the next customer will arrive
}
CUSTOMERSявляє собою двовимірний масив із даними для кожного клієнта у стовпцях. Він має чотири рядки (виступають у ролі полів), які описують клієнтів та записують їх досвід під час моделювання : "Прибув", "Обслугований", "Тривалість" та "Помічник" (позитивний числовий ідентифікатор помічника, якщо такий є, який служив їх, інакше -1для сигналів зайнятості). У надзвичайно гнучкому моделюванні ці стовпці будуть динамічно створюватися, але завдяки тому, як Rподобається працювати, зручно генерувати всіх клієнтів на самому початку, в одній великій матриці, з часом генерування їх вже випадково. next.customer.timeможе зазирнути у наступний стовпчик цієї матриці, щоб побачити, хто наступний. Глобальна зміннаCUSTOMER.COUNTвказує останнього клієнта, який прибув. Клієнти управляються дуже просто за допомогою цього вказівника, просуваючи його до отримання нового клієнта і дивлячись за межі нього (не просуваючись) зазирнути до наступного клієнта.
serve реалізує бізнес-правила в моделюванні.
serve <- function(i, x, time.now) {
#
# Serve customer `x` with assistant `i`.
#
a <- ASSISTANTS[i, ]
r <- rexp(1, a$rate) # Simulate the duration of service
r <- round(r, 2) # (Make simple numbers)
ASSISTANTS[i, ]$available <<- time.now + r # Update availability
#
# Log this successful service event for later analysis.
#
CUSTOMERS["Assistant", x] <<- i
CUSTOMERS["Served", x] <<- time.now
CUSTOMERS["Duration", x] <<- r
#
# Queue the moment the assistant becomes free, so they can check for
# any customers on hold.
#
insert.event(i, "Assistant", time.now + r)
if (VERBOSE) cat(time.now, ": Assistant", i, "is now serving customer",
x, "until", time.now + r, "\n")
return (TRUE)
}
Це прямо. ASSISTANTSце фрейм даних з двома полями: capabilities(із зазначенням їх швидкості обслуговування) і available, які наступні позначки прапорці, коли помічник буде безкоштовним. Клієнт обслуговується шляхом генерування випадкової тривалості обслуговування відповідно до можливостей помічника, оновлення часу, коли наступний помічник стане доступним, та реєстрації інтервалу обслуговування в CUSTOMERSструктурі даних. VERBOSEПрапор зручний для тестування і налагодження: якщо вірно, випускає потік англійських фраз , що описують ключові моменти обробки.
Те, як помічники призначені клієнтам, важливо і цікаво. Можна уявити кілька процедур: присвоєння випадковим чином, за допомогою якогось фіксованого замовлення або відповідно до того, хто був безкоштовним найдовший (або найкоротший) час. Багато з них проілюстровано у коментованому коді:
find.assistant <- function(time.now) {
j <- which(ASSISTANTS$available <= time.now)
#if (length(j) > 0) {
# i <- j[ceiling(runif(1) * length(j))]
#} else i <- NULL # Random selection
#if (length(j) > 0) i <- j[1] else i <- NULL # Pick first assistant
#if (length(j) > 0) i <- j[length(j)] else i <- NULL # Pick last assistant
if (length(j) > 0) {
i <- j[which.min(ASSISTANTS[j, ]$available)]
} else i <- NULL # Pick most-rested assistant
return (i)
}
Решта моделювання насправді є лише звичайною вправою переконати Rреалізувати стандартні структури даних, головним чином, круговий буфер для черги на очікування. Оскільки ви не хочете запускати amok з глобальними, я все це об'єднав в одну процедуру sim. Його аргументи описують проблему: кількість клієнтів для імітації ( n.events), швидкість прибуття клієнта, можливості помічників та розмір черги затримки (яку можна встановити на нуль, щоб повністю усунути чергу).
r <- sim(n.events=250, arrival.rate=60/45, capabilities=1:5/10, hold.queue.size=10)
Він повертає список структур даних, що підтримуються під час моделювання; найбільший інтерес представляє CUSTOMERSмасив. Rдозволяє досить легко побудувати важливу інформацію в цьому масиві цікавим чином. Ось один вихід, який показує останніх клієнтів у більш тривалому моделюванні клієнтів.25050250
Кожен досвід клієнта побудований у вигляді горизонтальної лінії часу з круговим символом на момент прибуття, суцільною чорною лінією для будь-якого очікування на очікуванні та кольоровою лінією протягом тривалості їх взаємодії з помічником (колір та тип лінії диференціювати серед помічників). Під цим сюжетом для клієнтів - це досвід, який показує досвід помічників, відзначаючи часи, коли вони були і не були пов'язані із замовником. Кінцеві точки кожного інтервалу діяльності розмежовані вертикальними смугами.
У режимі запуску verbose=TRUEтекст тексту моделювання виглядає приблизно так:
...
160.71 : Customer 211 put on hold at position 1
161.88 : Customer 212 put on hold at position 2
161.91 : Assistant 3 is now serving customer 213 until 163.24
161.91 : Customer 211 put on hold at position 2
162.68 : Assistant 4 is now serving customer 212 until 164.79
162.71 : Assistant 5 is now serving customer 211 until 162.9
163.51 : Assistant 5 is now serving customer 214 until 164.05
...
(Число зліва - це час, коли кожне повідомлення надсилалося.) Ці описи можна зіставити з частинами ділянки Клієнтів, що лежать між та .165160165
Ми можемо вивчити досвід клієнтів у режимі очікування, будуючи графік тривалості очікування за ідентифікатором клієнта, використовуючи спеціальний (червоний) символ, щоб показати клієнтам, які отримують сигнал зайнятості.
(Чи не всі ці сюжети стануть чудовою панеллю керування в режимі реального часу для тих, хто керує цією службовою чергою!)
Захоплююче порівнювати графіки та статистику, яку ви отримуєте, змінюючи передавані параметри sim. Що станеться, коли клієнти надто швидко приходять, щоб їх обробити? Що станеться, коли чергу утримування зменшена чи усунена? Що змінюється, коли помічники вибираються різними способами? Як чисельність та можливості помічників впливають на досвід клієнта? Які найважливіші моменти, коли деякі клієнти починають відхилятися або починають довго затримуватися?
Зазвичай для очевидних питань самостійного вивчення, як це, ми зупинимось тут і залишимо решту деталей як вправу. Однак я не хочу розчаровувати читачів, які, можливо, досягли цього часу і зацікавлені спробувати це для себе (а можливо, модифікуючи його та будуючи на ньому для інших цілей), тому додається нижче повний робочий код.
( Обробка на цьому веб-сайті зіпсує відступ у будь-яких рядках, що містять символ , але читабене відступ слід відновити, коли код вставлений у текстовий файл.)$TEX$
sim <- function(n.events, verbose=FALSE, ...) {
#
# Simulate service for `n.events` customers.
#
# Variables global to this simulation (but local to the function):
#
VERBOSE <- verbose # When TRUE, issues informative message
ASSISTANTS <- list() # List of assistant data structures
CUSTOMERS <- numeric(0) # Array of customers that arrived
CUSTOMER.COUNT <- 0 # Number of customers processed
EVENTS <- list() # Dynamic event queue
HOLD <- list() # Customer on-hold queue
#............................................................................#
#
# Start.
#
initialize <- function(arrival.rate, capabilities, hold.queue.size) {
#
# Create common data structures.
#
ASSISTANTS <<- data.frame(rate=capabilities, # Service rate
available=0 # Next available time
)
CUSTOMERS <<- matrix(NA, nrow=4, ncol=n.events,
dimnames=list(c("Arrived", # Time arrived
"Served", # Time served
"Duration", # Duration of service
"Assistant" # Assistant id
)))
EVENTS <<- data.frame(x=integer(0), # Assistant or customer id
type=character(0), # Assistant or customer
time=numeric(0) # Start of event
)
HOLD <<- list(first=1, # Index of first in queue
last=1, # Next available slot
customers=rep(NA, hold.queue.size+1))
#
# Generate all customer arrival times in advance.
#
CUSTOMERS["Arrived", ] <<- cumsum(round(rexp(n.events, arrival.rate), 2))
CUSTOMER.COUNT <<- 0
if (VERBOSE) cat("Started.\n")
return(TRUE)
}
#............................................................................#
#
# Dispatching.
#
# Argument `e` represents an event, consisting of an assistant/customer
# identifier `x`, an event type `type`, and its time of occurrence `time`.
#
# Depending on the event, a customer is either served or an attempt is made
# to put them on hold.
#
# Returns TRUE until no more events occur.
#
process <- function(e) {
if (is.null(e)) return(FALSE)
if (e$type == "Customer") {
i <- find.assistant(e$time)
if (is.null(i)) put.on.hold(e$x, e$time) else serve(i, e$x, e$time)
} else {
release.hold(e$time)
}
return(TRUE)
}#$
#............................................................................#
#
# Event queuing.
#
get.next.event <- function() {
if (length(EVENTS$time) <= 0) new.customer()
if (length(EVENTS$time) <= 0) return(NULL)
if (min(EVENTS$time) > next.customer.time()) new.customer()
i <- which.min(EVENTS$time)
e <- EVENTS[i, ]; EVENTS <<- EVENTS[-i, ]
return (e)
}
insert.event <- function(x, type, time.occurs) {
EVENTS <<- rbind(EVENTS, data.frame(x=x, type=type, time=time.occurs))
return (NULL)
}
#
# Customer arrivals (called by `get.next.event`).
#
# Updates the customers pointer `CUSTOMER.COUNT` and returns the customer
# it newly points to.
#
new.customer <- function() {
if (CUSTOMER.COUNT < dim(CUSTOMERS)[2]) {
CUSTOMER.COUNT <<- CUSTOMER.COUNT + 1
insert.event(CUSTOMER.COUNT, "Customer",
CUSTOMERS["Arrived", CUSTOMER.COUNT])
}
return(CUSTOMER.COUNT)
}
next.customer.time <- function() {
if (CUSTOMER.COUNT < dim(CUSTOMERS)[2]) {
x <- CUSTOMERS["Arrived", CUSTOMER.COUNT]
} else {x <- Inf}
return(x) # Time when the next customer will arrive
}
#............................................................................#
#
# Service.
#
find.assistant <- function(time.now) {
#
# Select among available assistants.
#
j <- which(ASSISTANTS$available <= time.now)
#if (length(j) > 0) {
# i <- j[ceiling(runif(1) * length(j))]
#} else i <- NULL # Random selection
#if (length(j) > 0) i <- j[1] else i <- NULL # Pick first assistant
#if (length(j) > 0) i <- j[length(j)] else i <- NULL # Pick last assistant
if (length(j) > 0) {
i <- j[which.min(ASSISTANTS[j, ]$available)]
} else i <- NULL # Pick most-rested assistant
return (i)
}#$
serve <- function(i, x, time.now) {
#
# Serve customer `x` with assistant `i`.
#
a <- ASSISTANTS[i, ]
r <- rexp(1, a$rate) # Simulate the duration of service
r <- round(r, 2) # (Make simple numbers)
ASSISTANTS[i, ]$available <<- time.now + r # Update availability
#
# Log this successful service event for later analysis.
#
CUSTOMERS["Assistant", x] <<- i
CUSTOMERS["Served", x] <<- time.now
CUSTOMERS["Duration", x] <<- r
#
# Queue the moment the assistant becomes free, so they can check for
# any customers on hold.
#
insert.event(i, "Assistant", time.now + r)
if (VERBOSE) cat(time.now, ": Assistant", i, "is now serving customer",
x, "until", time.now + r, "\n")
return (TRUE)
}
#............................................................................#
#
# The on-hold queue.
#
# This is a cicular buffer implemented by an array and two pointers,
# one to its head and the other to the next available slot.
#
put.on.hold <- function(x, time.now) {
#
# Try to put customer `x` on hold.
#
if (length(HOLD$customers) < 1 ||
(HOLD$first - HOLD$last %% length(HOLD$customers) == 1)) {
# Hold queue is full, alas. Log this occurrence for later analysis.
CUSTOMERS["Assistant", x] <<- -1 # Busy signal
if (VERBOSE) cat(time.now, ": Customer", x, "got a busy signal.\n")
return(FALSE)
}
#
# Add the customer to the hold queue.
#
HOLD$customers[HOLD$last] <<- x
HOLD$last <<- HOLD$last %% length(HOLD$customers) + 1
if (VERBOSE) cat(time.now, ": Customer", x, "put on hold at position",
(HOLD$last - HOLD$first - 1) %% length(HOLD$customers) + 1, "\n")
return (TRUE)
}
release.hold <- function(time.now) {
#
# Pick up the next customer from the hold queue and place them into
# the event queue.
#
if (HOLD$first != HOLD$last) {
x <- HOLD$customers[HOLD$first] # Take the first customer
HOLD$customers[HOLD$first] <<- NA # Update the hold queue
HOLD$first <<- HOLD$first %% length(HOLD$customers) + 1
insert.event(x, "Customer", time.now)
}
}$
#............................................................................#
#
# Summaries.
#
# The CUSTOMERS array contains full information about the customer experiences:
# when they arrived, when they were served, how long the service took, and
# which assistant served them.
#
summarize <- function() return (list(c=CUSTOMERS, a=ASSISTANTS, e=EVENTS,
h=HOLD))
#............................................................................#
#
# The main event loop.
#
initialize(...)
while (process(get.next.event())) {}
#
# Return the results.
#
return (summarize())
}
#------------------------------------------------------------------------------#
#
# Specify and run a simulation.
#
set.seed(17)
n.skip <- 200 # Number of initial events to skip in subsequent summaries
system.time({
r <- sim(n.events=50+n.skip, verbose=TRUE,
arrival.rate=60/45, capabilities=1:5/10, hold.queue.size=10)
})
#------------------------------------------------------------------------------#
#
# Post processing.
#
# Skip the initial phase before equilibrium.
#
results <- r$c
ids <- (n.skip+1):(dim(results)[2])
arrived <- results["Arrived", ]
served <- results["Served", ]
duration <- results["Duration", ]
assistant <- results["Assistant", ]
assistant[is.na(assistant)] <- 0 # Was on hold forever
ended <- served + duration
#
# A detailed plot of customer experiences.
#
n.events <- length(ids)
n.assistants <- max(assistant, na.rm=TRUE)
colors <- rainbow(n.assistants + 2)
assistant.color <- colors[assistant + 2]
x.max <- max(results["Served", ids] + results["Duration", ids], na.rm=TRUE)
x.min <- max(min(results["Arrived", ids], na.rm=TRUE) - 2, 0)
#
# Lay out the graphics.
#
layout(matrix(c(1,1,2,2), 2, 2, byrow=TRUE), heights=c(2,1))
#
# Set up the customers plot.
#
plot(c(x.min, x.max), range(ids), type="n",
xlab="Time", ylab="Customer Id", main="Customers")
#
# Place points at customer arrival times.
#
points(arrived[ids], ids, pch=21, bg=assistant.color[ids], col="#00000070")
#
# Show wait times on hold.
#
invisible(sapply(ids, function(i) {
if (!is.na(served[i])) lines(x=c(arrived[i], served[i]), y=c(i,i))
}))
#
# More clearly show customers getting a busy signal.
#
ids.not.served <- ids[is.na(served[ids])]
ids.served <- ids[!is.na(served[ids])]
points(arrived[ids.not.served], ids.not.served, pch=4, cex=1.2)
#
# Show times of service, colored by assistant id.
#
invisible(sapply(ids.served, function(i) {
lines(x=c(served[i], ended[i]), y=c(i,i), col=assistant.color[i], lty=assistant[i])
}))
#
# Plot the histories of the assistants.
#
plot(c(x.min, x.max), c(1, n.assistants)+c(-1,1)/2, type="n", bty="n",
xlab="", ylab="Assistant Id", main="Assistants")
abline(h=1:n.assistants, col="#808080", lwd=1)
invisible(sapply(1:(dim(results)[2]), function(i) {
a <- assistant[i]
if (a > 0) {
lines(x=c(served[i], ended[i]), y=c(a, a), lwd=3, col=colors[a+2])
points(x=c(served[i], ended[i]), y=c(a, a), pch="|", col=colors[a+2])
}
}))
#
# Plot the customer waiting statistics.
#
par(mfrow=c(1,1))
i <- is.na(served)
plot(served - arrived, xlab="Customer Id", ylab="Minutes",
main="Service Wait Durations")
lines(served - arrived, col="Gray")
points(which(i), rep(0, sum(i)), pch=16, col="Red")
#
# Summary statistics.
#
mean(!is.na(served)) # Proportion of customers served
table(assistant)