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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
# Return the current time, in milliseconds from epoch.
getTimeMs <- function() {
as.numeric(Sys.time()) * 1000
}
TimerCallbacks <- R6Class(
'TimerCallbacks',
portable = FALSE,
class = FALSE,
public = list(
.nextId = 0L,
.funcs = 'Map',
.times = data.frame(),
.now = 'Function',
initialize = function(nowFn = getTimeMs) {
.funcs <<- Map$new()
.now <<- nowFn
},
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)
},
unschedule = function(id) {
toRemoveIndices <- .times$id %in% id
toRemoveIds <- .times[toRemoveIndices, "id", drop = TRUE]
if (length(toRemoveIds) > 0) {
.times <<- .times[!toRemoveIndices,]
for (toRemoveId in as.character(toRemoveIds)) {
.funcs$remove(toRemoveId)
}
}
return(id %in% toRemoveIds)
},
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)
}
)
)
MockableTimerCallbacks <- R6Class(
'MockableTimerCallbacks',
inherit = TimerCallbacks,
portable = FALSE,
class = FALSE,
public = list(
# Empty constructor defaults to the getNow implementation
initialize = function() {
super$initialize(self$mockNow)
},
mockNow = function() {
return(private$time)
},
elapse = function(millis) {
private$time <- private$time + millis
},
getElapsed = function() {
private$time
}
), private = list(
time = 0L
)
)
timerCallbacks <- TimerCallbacks$new()
scheduleTask <- function(millis, callback) {
cancelled <- FALSE
id <- timerCallbacks$schedule(millis, callback)
function() {
invisible(timerCallbacks$unschedule(id))
}
}
#' Get a scheduler function for scheduling tasks. Give priority to the
#' session scheduler, but if it doesn't exist, use the global one.
#' @noRd
defineScheduler <- function(session){
if (!is.null(session) && !is.null(session$.scheduleTask)){
return(session$.scheduleTask)
}
scheduleTask
}
#' Get the current time using the current reactive domain. This will try to use
#' the session's .now() method, but if that's not available, it will just return
#' the real time (from getTimeMs()). The purpose of this function is to allow
#' MockableTimerCallbacks to work.
#' @noRd
getDomainTimeMs <- function(session){
if (!is.null(session) && !is.null(session$.now)){
return(session$.now())
} else {
getTimeMs()
}
}
|
