-
Notifications
You must be signed in to change notification settings - Fork 29
/
bpvec-methods.R
81 lines (67 loc) · 2.4 KB
/
bpvec-methods.R
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
### =========================================================================
### bpvec methods
### -------------------------------------------------------------------------
## bpvec() dispatches to bplapply() where errors and logging are
## handled.
setMethod("bpvec", c("ANY", "BiocParallelParam"),
function(X, FUN, ..., AGGREGATE=c, BPREDO=list(),
BPPARAM=bpparam(), BPOPTIONS = bpoptions())
{
if (!length(X))
return(.rename(list(), X))
FUN <- match.fun(FUN)
AGGREGATE <- match.fun(AGGREGATE)
BPREDO <- bpresult(BPREDO)
if (!bpschedule(BPPARAM)) {
param <- as(BPPARAM, "SerialParam")
return(
bpvec(
X, FUN, ..., AGGREGATE=AGGREGATE, BPREDO=BPREDO,
BPPARAM = param, BPOPTIONS = BPOPTIONS
)
)
}
si <- .splitX(seq_along(X), bpnworkers(BPPARAM), bptasks(BPPARAM))
otasks <- bptasks(BPPARAM)
bptasks(BPPARAM) <- 0L
on.exit(bptasks(BPPARAM) <- otasks)
FUN1 <- function(i, ...) FUN(X[i], ...)
res <- bptry(bplapply(
si, FUN1, ..., BPREDO=BPREDO, BPPARAM=BPPARAM, BPOPTIONS = BPOPTIONS
))
if (is(res, "error") || !all(bpok(res)))
stop(.error_bplist(res))
if (any(lengths(res) != lengths(si)))
stop(.error("length(FUN(X)) not equal to length(X)", "bpvec_error"))
do.call(AGGREGATE, res)
})
setMethod("bpvec", c("ANY", "missing"),
function(X, FUN, ..., AGGREGATE=c, BPREDO=list(),
BPPARAM=bpparam(), BPOPTIONS = bpoptions())
{
FUN <- match.fun(FUN)
AGGREGATE <- match.fun(AGGREGATE)
bpvec(X, FUN, ..., AGGREGATE=AGGREGATE, BPREDO=BPREDO,
BPPARAM=BPPARAM, BPOPTIONS = BPOPTIONS)
})
setMethod("bpvec", c("ANY", "list"),
function(X, FUN, ..., BPREDO=list(),
BPPARAM=bpparam(), BPOPTIONS = bpoptions())
{
FUN <- match.fun(FUN)
if (!all(vapply(BPPARAM, inherits, logical(1), "BiocParallelParam")))
stop("All elements in 'BPPARAM' must be BiocParallelParam objects")
if (length(BPPARAM) == 0L)
stop("'length(BPPARAM)' must be > 0")
myFUN <- if (length(BPPARAM) > 1L) {
param <- BPPARAM[-1]
if (length(param) == 1L)
function(...) FUN(..., BPPARAM=param[[1]])
else
function(...) FUN(..., BPPARAM=param)
} else FUN
bpvec(
X, myFUN, ..., BPREDO=BPREDO,
BPPARAM=BPPARAM[[1]], BPOPTIONS = BPOPTIONS
)
})