1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
# Return the current time, in milliseconds from epoch, with
# unspecified time zone.
now <- function() {
as.numeric(Sys.time()) * 1000
}
TimerCallbacks <- R6Class(
'TimerCallbacks',
portable = FALSE,
class = FALSE,
public = list(
.nextId = 0L,
.funcs = 'Map',
.times = data.frame(),
initialize = function() {
.funcs <<- Map$new()
},
clear = function() {
.nextId <<- 0L
.funcs$clear()
.times <<- data.frame()
},
schedule = function(millis, func) {
# If args could fail to evaluate, let's make them do that before
# we change any state
force(millis)
force(func)
id <- .nextId
.nextId <<- .nextId + 1L
t <- now()
# TODO: Horribly inefficient, use a heap instead
.times <<- rbind(.times, data.frame(time=t+millis,
scheduled=t,
id=id))
.times <<- .times[order(.times$time),]
.funcs$set(as.character(id), func)
return(id)
},
timeToNextEvent = function() {
if (dim(.times)[1] == 0)
return(Inf)
return(.times[1, 'time'] - now())
},
takeElapsed = function() {
t <- now()
elapsed <- .times$time < now()
result <- .times[elapsed,]
.times <<- .times[!elapsed,]
# TODO: Examine scheduled column to check if any funny business
# has occurred with the system clock (e.g. if scheduled
# is later than now())
return(result)
},
executeElapsed = function() {
elapsed <- takeElapsed()
if (nrow(elapsed) == 0)
return(FALSE)
for (id in elapsed$id) {
thisFunc <- .funcs$remove(as.character(id))
# TODO: Catch exception, and...?
# TODO: Detect NULL, and...?
thisFunc()
}
return(TRUE)
}
)
)
timerCallbacks <- TimerCallbacks$new()
scheduleTask <- function(millis, callback) {
cancelled <- FALSE
timerCallbacks$schedule(millis, function() {
if (!cancelled)
callback()
})
function() {
cancelled <<- TRUE
callback <<- NULL # to allow for callback to be gc'ed
}
}
|
