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
148
149
150
151
152
153
154
155
156
157
158
|
### =========================================================================
### SerialParam objects
### -------------------------------------------------------------------------
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###
.SerialParam_prototype <- c(
list(
workers = 1L,
backend = NULL
),
.BiocParallelParam_prototype
)
.SerialParam <- setRefClass(
"SerialParam",
fields=list(backend = "ANY"),
contains="BiocParallelParam",
)
SerialParam <-
function(stop.on.error = TRUE,
progressbar=FALSE,
RNGseed = NULL,
timeout = WORKER_TIMEOUT,
log=FALSE, threshold="INFO", logdir=NA_character_,
resultdir = NA_character_,
jobname = "BPJOB",
force.GC = FALSE)
{
if (!is.null(RNGseed))
RNGseed <- as.integer(RNGseed)
if (progressbar) {
tasks <- TASKS_MAXIMUM
} else {
tasks <- 0L
}
prototype <- .prototype_update(
.SerialParam_prototype,
tasks = tasks,
stop.on.error=stop.on.error,
progressbar=progressbar,
RNGseed = RNGseed,
timeout = as.integer(timeout),
log=log,
threshold=threshold,
logdir=logdir,
resultdir = resultdir,
jobname = jobname,
force.GC = force.GC,
fallback = FALSE,
exportglobals = FALSE,
exportvariables = FALSE
)
x <- do.call(.SerialParam, prototype)
validObject(x)
x
}
setAs("BiocParallelParam", "SerialParam", function(from) {
SerialParam(
stop.on.error = bpstopOnError(from),
progressbar = bpprogressbar(from),
RNGseed = bpRNGseed(from),
timeout = bptimeout(from),
log = bplog(from),
threshold = bpthreshold(from),
logdir = bplogdir(from),
resultdir = bpresultdir(from),
jobname = bpjobname(from),
force.GC = bpforceGC(from)
)
})
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Methods - control
###
setMethod(
"bpbackend", "SerialParam",
function(x)
{
x$backend
})
setMethod(
"bpstart", "SerialParam",
function(x, ...)
{
x$backend <- .SerialBackend()
x$backend$BPPARAM <- x
.bpstart_impl(x)
})
setMethod(
"bpstop", "SerialParam",
function(x)
{
x$backend <- NULL
.bpstop_impl(x)
})
setMethod(
"bpisup", "SerialParam",
function(x)
{
is.environment(bpbackend(x))
})
setReplaceMethod("bplog", c("SerialParam", "logical"),
function(x, value)
{
x$log <- value
validObject(x)
x
})
setReplaceMethod(
"bpthreshold", c("SerialParam", "character"),
function(x, value)
{
x$threshold <- value
x
})
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Backend method
###
.SerialBackend <- setClass("SerialBackend", contains = "environment")
setMethod(".send_to", "SerialBackend",
function(backend, node, value){
backend$value <- value
TRUE
})
setMethod(
".recv_any", "SerialBackend",
function(backend)
{
on.exit(backend$value <- NULL)
msg <- backend$value
if (inherits(msg, "error"))
stop(msg)
if (msg$type == "EXEC") {
value <- .bpworker_EXEC(msg, bplog(backend$BPPARAM))
list(node = 1L, value = value)
}
})
setMethod("length", "SerialBackend",
function(x){
1L
})
|
