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
|
### =========================================================================
### DelayedNaryIsoOp objects
### -------------------------------------------------------------------------
###
### Representation of a delayed N-ary isometric operation.
### The input arrays must be "conformable" i.e. they all must have the same
### dimensions.
###
setClass("DelayedNaryIsoOp",
contains="DelayedNaryOp",
representation(
OP="function", # The function to use to combine the input objects.
# Should act as an isomorphism i.e. always return an
# array-like object **parallel** to the input objects
# (i.e. with the same dimensions).
Rargs="list" # Additional right arguments to OP.
),
prototype(
OP=identity
)
)
.arrays_are_conformable <- function(objects)
{
dims <- lapply(objects, dim)
ndims <- lengths(dims)
first_ndim <- ndims[[1L]]
if (!all(ndims == first_ndim))
return(FALSE)
tmp <- unlist(dims, use.names=FALSE)
if (is.null(tmp))
return(FALSE)
dims <- matrix(tmp, ncol=length(objects))
first_dim <- dims[ , 1L]
all(dims == first_dim)
}
.validate_DelayedNaryIsoOp <- function(x)
{
## 'seeds' slot.
if (!.arrays_are_conformable(x@seeds))
return("'x@seeds' must be a list of conformable array-like objects")
TRUE
}
setValidity2("DelayedNaryIsoOp", .validate_DelayedNaryIsoOp)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###
new_DelayedNaryIsoOp <- function(OP=identity, seed=new("array"), ...,
Rargs=list())
{
OP <- match.fun(OP)
seeds <- unname(list(seed, ...))
if (!.arrays_are_conformable(seeds))
stop(wmsg("non-conformable array-like objects"))
new2("DelayedNaryIsoOp", seeds=seeds, OP=OP, Rargs=Rargs, check=FALSE)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Display
###
### S3/S4 combo for summary.DelayedNaryIsoOp
.DelayedNaryIsoOp_summary <- function(object) "N-ary iso op"
summary.DelayedNaryIsoOp <-
function(object, ...) .DelayedNaryIsoOp_summary(object, ...)
setMethod("summary", "DelayedNaryIsoOp", summary.DelayedNaryIsoOp)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Seed contract
###
setMethod("dim", "DelayedNaryIsoOp", function(x) dim(x@seeds[[1L]]))
setMethod("dimnames", "DelayedNaryIsoOp",
function(x) get_first_non_NULL_dimnames(x@seeds)
)
setMethod("extract_array", "DelayedNaryIsoOp",
function(x, index)
{
arrays <- lapply(x@seeds, extract_array, index)
do.call(x@OP, c(arrays, x@Rargs))
}
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Propagation of sparsity
###
setMethod("is_sparse", "DelayedNaryIsoOp",
function(x)
{
ok <- vapply(x@seeds, is_sparse, logical(1), USE.NAMES=FALSE)
if (!all(ok))
return(FALSE)
if (length(x@Rargs) != 0L)
return(FALSE)
## Structural sparsity will be propagated if the operation in
## x@OP preserves the zeros. To find out whether zeros are preserved
## or not, we replace each current seed with an array of one "zero",
## that is, with an ordinary array of the same number of dimensions
## and type as the seed, but with a single "zero" element. Then we
## apply the n-ary operation in x@OP to them and see whether the
## zero were preserved or not.
seed_ndim <- length(dim(x@seeds[[1L]]))
x@seeds <- lapply(x@seeds,
function(seed) make_one_zero_array(type(seed), seed_ndim))
## Same as 'as.array(x)' but doesn't try to propagate the dimnames.
a0 <- extract_array(x, vector("list", length=seed_ndim))
is_filled_with_zeros(a0)
}
)
### 'is_sparse(x)' is assumed to be TRUE and 'index' is assumed to
### not contain duplicates. See "extract_sparse_array() Terms of Use"
### in SparseArraySeed-class.R
setMethod("extract_sparse_array", "DelayedNaryIsoOp",
function(x, index)
{
stop("NOT IMPLEMENTED YET!")
}
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Backward compatibility with DelayedArray < 0.5.24
###
### In DelayedArray 0.5.24 the ConformableSeedCombiner class got renamed
### DelayedNaryIsoOp. DelayedArray objects serialized with DelayedArray <
### 0.5.24 might contain ConformableSeedCombiner instances nested in their
### "seed" slot so we need to keep the class around for now.
###
setClass("ConformableSeedCombiner", contains="DelayedNaryIsoOp")
setMethod("updateObject", "ConformableSeedCombiner",
function(object, ..., verbose=FALSE)
{
object <- new2("DelayedNaryIsoOp", seeds=object@seeds,
OP=object@COMBINING_OP,
Rargs=object@Rargs)
callNextMethod()
}
)
|
