| pqueue {microsimulation} | R Documentation |
S3 priority queue implementation using C++
Description
This provides a priority queue that is sorted by the priority and entry order. The priority is assumed to be numeric. The events can be of any type. As an extension, events can be cancelled if they satisfy a certain predicate. Note that the inactive events are not removed, rather they are marked as cancelled and will not be available to be popped.
Based on C++ code. See also the S3 implementation pqueue.
This event queue is simple and useful for pedagogic purposes.
Inherit from this class to represent a discrete event simulation. The
API is similar to that for Omnet++, where an init method sets up
the initial events using the scheduleAt(time,event) method, the
messages are handled using the handleMessage(event) method, the
simulation is run using the run method, and the final
method is called at the end of the simulation.
Usage
pqueue(lower = TRUE)
Arguments
lower |
boolean to determine whether to give priority to lower values (default=TRUE) or higher values |
Details
The algorithm for pushing values into the queue is computationally
very simple: simply rank the times using order() and re-order
times and events. This approach is probably of acceptable performance
for smaller queue. A more computationally efficient approach for
pushing into larger queues would be to use a binary search (e.g. using
findInterval()).
For faster alternatives, see pqueue and PQueueRef.
Value
a list with
- push
function with arguments priority (numeric) and event (SEXP). Pushes an event with a given priority
- pop
function to return a list with a priority (numeric) and an event (SEXP). This pops the first active event.
- cancel
function that takes a predicate (or R function) for a given event and returns a logical that indicates whether to cancel that event or not. This may cancel some events that will no longer be popped.
- empty
function that returns whether the priority queue is empty (or has no active events).
- clear
function to clear the priority queue.
- ptr
XPtr value
Fields
ptrExternal pointer to the C++ class
timesvector of times
eventslist of events
timesvector of times
eventslist of events
Methods
cancel(predicate)Method to cancel events that satisfy some predicate
clear()Method to clear the event queue
empty()Method to check whether there are no events in the queue
initialize(lower = TRUE)Method to initialize the object. lower argument indicates whether lowest priority or highest priority
pop()Method to remove the head of the event queue and return its value
push(priority, event)Method to push an event with a given priority
cancel(predicate, ...)Method to remove events that satisfy some predicate
clear()Method to clear the event queue
empty()Method to check whether there are no events in the queue
pop()Method to remove the head of the event queue and return its value
push(time, event)Method to insert the event at the given time
final()Method for finalising the simulation
handleMessage(event)Virtual method to handle the messages as they arrive
init()Virtual method to initialise the event queue and attributes
reset(startTime = 0)Method to reset the event queue
run(startTime = 0)Method to run the simulation
scheduleAt(time, event)Method that adds attributes for the event time and the sendingTime, and then insert the event into the event queue
Examples
pq = pqueue()
pq$push(3,"Clear drains")
pq$push(4, "Feed cat")
pq$push(5, "Make tea")
pq$push(1, "Solve RC tasks")
pq$push(2, "Tax return")
while(!pq$empty())
print(pq$pop())
pq = new("PQueueRef")
pq$push(3,"Clear drains")
pq$push(4, "Feed cat")
pq$push(5, "Make tea")
pq$push(1, "Solve RC tasks")
pq$push(2, "Tax return")
while(!pq$empty())
print(pq$pop())
pq = new("EventQueue")
pq$push(3,"Clear drains")
pq$push(4, "Feed cat")
pq$push(5, "Make tea")
pq$push(1, "Solve RC tasks")
pq$push(2, "Tax return")
while(!pq$empty())
print(pq$pop())
DES = setRefClass("DES",
contains = "BaseDiscreteEventSimulation",
methods=list(
init=function() {
scheduleAt(3,"Clear drains")
scheduleAt(4, "Feed cat")
scheduleAt(5, "Make tea")
scheduleAt(1, "Solve RC tasks")
scheduleAt(2, "Tax return")
},
handleMessage=function(event) print(event)))
des = new("DES")
des$run()
## Not run:
testRsimulation1 <- function() {
## A simple example
Simulation <-
setRefClass("Simulation",
contains = "BaseDiscreteEventSimulation")
Simulation$methods(
init = function() {
scheduleAt(rweibull(1,8,85), "Death due to other causes")
scheduleAt(rweibull(1,3,90), "Cancer diagnosis")
},
handleMessage = function(event) {
if (event %in% c("Death due to other causes", "Cancer death")) {
clear()
print(event)
}
else if (event == "Cancer diagnosis") {
if (runif(1) < 0.5)
scheduleAt(now() + rweibull(1,2,10), "Cancer death")
print(event)
}
})
Simulation$new()$run()
}
## An extension with individual life histories
testRsimulation2 <- function(n=100) {
Simulation <-
setRefClass("Simulation",
contains = "BaseDiscreteEventSimulation",
fields = list(state = "character", report = "data.frame"))
Simulation$methods(
init = function() {
report <<- data.frame()
state <<- "Healthy"
scheduleAt(rweibull(1,8,85), "Death due to other causes")
scheduleAt(rweibull(1,3,90), "Cancer diagnosis")
},
handleMessage = function(event) {
report <<- rbind(report, data.frame(state = state,
begin = attr(event,"sendingTime"),
end = currentTime,
event = event,
stringsAsFactors = FALSE))
if (event %in% c("Death due to other causes", "Cancer death")) {
clear()
}
else if (event == "Cancer diagnosis") {
state <<- "Cancer"
if (runif(1) < 0.5)
scheduleAt(now() + rweibull(1,2,10), "Cancer death")
}
},
final = function() report)
sim <- Simulation$new()
do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run())))
}
## reversible illness-death model
testRsimulation3 <- function(n=100) {
Simulation <-
setRefClass("Simulation",
contains = "BaseDiscreteEventSimulation",
fields = list(state = "character", everCancer = "logical",
report = "data.frame"))
Simulation$methods(
init = function() {
report <<- data.frame()
state <<- "Healthy"
everCancer <<- FALSE
scheduleAt(rweibull(1,8,85), "Death due to other causes")
scheduleAt(rweibull(1,3,90), "Cancer diagnosis")
},
handleMessage = function(event) {
report <<- rbind(report, data.frame(state = state,
everCancer = everCancer,
begin = attr(event,"sendingTime"),
end = currentTime,
event = event,
stringsAsFactors = FALSE))
if (event %in% c("Death due to other causes", "Cancer death")) {
clear()
}
else if (event == "Cancer diagnosis") {
state <<- "Cancer"
everCancer <<- TRUE
if (runif(1) < 0.5)
scheduleAt(now() + rweibull(1,2,10), "Cancer death")
scheduleAt(now() + 10, "Recovery")
}
else if (event == "Recovery") {
state <<- "Healthy"
scheduleAt(now() + rexp(1,10), "Cancer diagnosis")
}
},
final = function() report)
sim <- Simulation$new()
do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run())))
}
## cancer screening
testRsimulation4 <- function(n=1) {
Simulation <-
setRefClass("Simulation",
contains = "BaseDiscreteEventSimulation",
fields = list(state = "character", report = "data.frame"))
Simulation$methods(
init = function() {
report <<- data.frame()
state <<- "Healthy"
scheduleAt(rweibull(1,8,85), "Death due to other causes")
scheduleAt(rweibull(1,3,90), "Cancer onset")
scheduleAt(50,"Screening")
},
handleMessage = function(event) {
report <<- rbind(report, data.frame(state = state,
begin = attr(event,"sendingTime"),
end = currentTime,
event = event,
stringsAsFactors = FALSE))
if (event %in% c("Death due to other causes", "Cancer death")) {
clear()
}
else if (event == "Cancer onset") {
state <<- event
dx <- now() + rweibull(1,2,10)
scheduleAt(dx, "Clinical cancer diagnosis")
scheduleAt(dx + rweibull(1,1,10), "Cancer death")
scheduleAt(now() + rweibull(1,1,10), "Metastatic cancer")
}
else if (event == "Metastatic cancer") {
state <<- event
cancel(function(event) event %in%
c("Clinical cancer diagnosis","Cancer death")) # competing events
scheduleAt(now() + rweibull(1,2,5), "Cancer death")
}
else if (event == "Clinical cancer diagnosis") {
state <<- event
cancel(function(event) event == "Metastatic cancer")
}
else if (event == "Screening") {
switch(state,
"Cancer onset" = {
state <<- "Screen-detected cancer diagnosis"
cancel(function(event) event %in%
c("Clinical cancer diagnosis","Metastatic cancer"))
},
"Metastatic cancer" = {}, # ignore
"Clincal cancer diagnosis" = {}, # ignore
"Healthy" = {
if (now()<=68) scheduleAt(now()+2, "Screening")
})
}
else stop(event)
},
final = function() report)
sim <- Simulation$new()
do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run())))
}
## ticking bomb - toy example
testRsimulation5 <- function(n=1) {
Simulation <-
setRefClass("Simulation",
contains = "BaseDiscreteEventSimulation",
fields = list(report = "data.frame"))
Simulation$methods(
init = function() {
report <<- data.frame()
scheduleAt(rexp(1,1), "tick")
if (runif(1)<0.1)
scheduleAt(rexp(1,1), "explosion")
},
handleMessage = function(event) {
report <<- rbind(report, data.frame(begin = attr(event,"sendingTime"),
end = currentTime,
event = event,
stringsAsFactors = FALSE))
if (event == "explosion")
clear()
else {
clear() # queue
if (event == "tick") scheduleAt(currentTime+rexp(1,1), "tock")
else scheduleAt(currentTime+rexp(1,1), "tick")
if (runif(1)<0.1)
scheduleAt(currentTime+rexp(1,1), "explosion")
}
},
final = function() report)
sim <- Simulation$new()
do.call("rbind", lapply(1:n, function(id) data.frame(id=id,sim$run())))
}
## End(Not run)