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
|
### =========================================================================
### DelayedSubset objects
### -------------------------------------------------------------------------
###
### Representation of a delayed multi-dimensional single bracket subsetting
### operation.
###
setClass("DelayedSubset",
contains="DelayedUnaryOp",
representation(
index="list" # List of subscripts as positive integer vectors,
# one per dimension in the input. **Missing** list
# elements are allowed and represented by NULLs.
),
prototype(
index=list(NULL)
)
)
.validate_DelayedSubset <- function(x)
{
## 'index' slot.
if (length(x@index) != length(dim(x@seed)))
return("'x@index' must have one list element per dimension in 'x@seed'")
if (!is.null(names(x@index)))
return("'x@index' should not have names")
ok <- lapply(x@index,
function(i) {is.null(i) || is.integer(i) && is.null(names(i))})
if (!all(unlist(ok)))
return(paste0("each list element in 'x@index' must be NULL ",
"or an integer vector with no names on it"))
TRUE
}
setValidity2("DelayedSubset", .validate_DelayedSubset)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###
### 'Nindex' must be a "multidimensional subsetting Nindex" (see
### Nindex-utils.R) or NULL.
new_DelayedSubset <- function(seed=new("array"), Nindex=NULL)
{
index <- normalizeNindex(Nindex, seed)
new2("DelayedSubset", seed=seed, index=index)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### is_noop() method
###
setMethod("is_noop", "DelayedSubset",
function(x) all(S4Vectors:::sapply_isNULL(x@index))
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Display
###
### S3/S4 combo for summary.DelayedSubset
.DelayedSubset_summary <- function(object) "Subset"
summary.DelayedSubset <-
function(object, ...) .DelayedSubset_summary(object, ...)
setMethod("summary", "DelayedSubset", summary.DelayedSubset)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Seed contract
###
setMethod("dim", "DelayedSubset",
function(x) get_Nindex_lengths(x@index, dim(x@seed))
)
setMethod("dimnames", "DelayedSubset",
function(x) subset_dimnames_by_Nindex(dimnames(x@seed), x@index)
)
subset_DelayedSubset <- function(x, index)
{
stopifnot(is(x, "DelayedSubset"))
x_ndim <- length(x@index)
stopifnot(is.list(index), length(index) == x_ndim)
seed_dim <- dim(x@seed)
## Would mapply() be faster here?
x@index <- lapply(seq_len(x_ndim),
function(along) {
i0 <- x@index[[along]]
i <- index[[along]]
if (is.null(i))
return(i0)
if (is.null(i0))
return(i)
ans <- i0[i]
if (isSequence(ans, of.length=seed_dim[[along]]))
return(NULL)
ans
})
x
}
setMethod("extract_array", "DelayedSubset",
function(x, index)
{
x2 <- subset_DelayedSubset(x, index)
extract_array(x2@seed, x2@index)
}
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Propagation of sparsity
###
setMethod("is_sparse", "DelayedSubset",
function(x)
{
if (!is_sparse(x@seed))
return(FALSE)
## Duplicates in x@index break structural sparsity.
!any(vapply(x@index, anyDuplicated,
integer(1), USE.NAMES=FALSE))
}
)
### '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", "DelayedSubset",
function(x, index)
{
x2 <- subset_DelayedSubset(x, index)
## Assuming that the caller respected "extract_sparse_array() Terms
## of Use" (see SparseArraySeed-class.R), 'is_sparse(x)' should be
## TRUE and the subscripts in 'index' should not contain duplicates.
## This in turn means that the subscripts in 'x2@index' should not
## contain duplicates either so the call below should also respect
## "extract_sparse_array() Terms of Use".
extract_sparse_array(x2@seed, x2@index)
}
)
|
