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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
### =========================================================================
### Dim tuning utilities
### -------------------------------------------------------------------------
###
### "Dim tuning" is the act of adding and/or dropping "ineffective
### dimensions" to/from an array-like object, typically via the drop()
### and/or dim() setter. The exact transformation to operate on the vector
### of dimensions of the object can be precisely described by supplying
### a 'dim_tuner' vector.
### See src/dim_tuning_utils.c for additional information.
### NOT exported but used in the DelayedArray package!
normalize_dim_replacement_value <- function(value, x_dim)
{
if (is.null(value))
stop(wmsg("you can't do that, sorry"))
if (!is.numeric(value))
stop(wmsg("the supplied dim vector must be numeric"))
if (length(value) == 0L)
stop(wmsg("the supplied dim vector cannot be empty"))
if (!is.integer(value))
value <- as.integer(value)
if (S4Vectors:::anyMissingOrOutside(value, 0L))
stop(wmsg("the supplied dim vector cannot contain negative ",
"or NA values"))
prod1 <- prod(value)
prod2 <- prod(x_dim)
if (prod1 != prod2)
stop(wmsg("the supplied dims [product ", prod1, "] do not match ",
"the length of object [", prod2, "]"))
value
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### The tune_Array_dims() low-level generic
###
### Array derivatives (e.g. SparseArray or DelayedArray objects) only need
### to implement a tune_Array_dims() method to have drop() and the dim()
### setter work out-of-the-box.
###
### Note that a "dim tuning" operation does NOT change the length of the
### object (which is prod(dim(x))) or alter its content, and should always
### be reversible (except when it drops ineffective dimensions with dimnames
### on them). To revert a "dim tuning" operation, simply tune again
### with '-dim_tuner' (i.e. with minus 'dim_tuner'). More precisely, for
### tune_Array_dims(), 'x2' should always be identical to 'x' here:
###
### y <- tune_Array_dims(x, dim_tuner)
### x2 <- tune_Array_dims(y, -dim_tuner)
### identical(x2, x) # should be TRUE
###
### This should be the case for any array-like object 'x' (with no dimnames
### on its ineffective dimensions) and any 'dim_tuner' vector compatible
### with 'dim(x)'.
setGeneric("tune_Array_dims", signature="x",
function(x, dim_tuner) standardGeneric("tune_Array_dims")
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### tune_dims() and tune_dimnames()
###
### NOT exported but used by the tune_Array_dims() method for SVT_SparseArray
### objects defined in the SparseArray package.
tune_dims <- function(dim, dim_tuner)
{
stopifnot(is.integer(dim),
is.integer(dim_tuner))
.Call2("C_tune_dims", dim, dim_tuner, PACKAGE="S4Arrays")
}
tune_dimnames <- function(dimnames, dim_tuner)
{
stopifnot(is.null(dimnames) || is.list(dimnames),
is.integer(dim_tuner))
.Call2("C_tune_dimnames", dimnames, dim_tuner, PACKAGE="S4Arrays")
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### drop() method
###
### base::drop() is kind of messed up in the 1D case. This is a replacement
### that does the right thing.
### NOT exported but used in the SparseArray package!
drop_even_if_1D <- function(a)
{
stopifnot(is.array(a) || is.vector(a))
if (length(dim(a)) != 1L)
return(base::drop(a))
setNames(as.vector(a), names(a))
}
### Expected to be semantically equivalent to 'drop_even_if_1D(as.array(x))'.
### Will work out-of-the-box on any Array derivative that supports
### tune_Array_dims() and as.array(). Note that the latter is used
### only if 'x' has at most one effective dimension.
.drop_Array <- function(x)
{
if (!isS4(x)) {
## Avoid S4 dispatch on Array objects that are not S4 objects (e.g.
## Array objects from the arrow package).
return(base::drop(x))
}
is_effective <- dim(x) != 1L
if (sum(is_effective) <= 1L)
return(drop_even_if_1D(as.array(x))) # ordinary vector
dim_tuner <- -as.integer(!is_effective)
tune_Array_dims(x, dim_tuner)
}
setMethod("drop", "Array", .drop_Array)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### dim() setter
###
.diff_dims <- function(old_dim, new_dim, x_class)
{
stopifnot(is.integer(old_dim), is.integer(new_dim))
cannot_map_msg <- c(
"Cannot map the supplied dim vector to the current dimensions of ",
"the object. On a ", x_class, " object, the dim() setter can only ",
"be used to drop and/or add \"ineffective dimensions\" (i.e. ",
"dimensions equal to 1) to the object."
)
can_map_effective_dimensions <- function(effdim_idx1, effdim_idx2) {
if (length(effdim_idx1) != length(effdim_idx2))
return(FALSE)
if (length(effdim_idx1) == 0L)
return(TRUE)
all(old_dim[effdim_idx1] == new_dim[effdim_idx2])
}
## Get index of old and new effective dimensions.
effdim_idx1 <- which(old_dim != 1L)
effdim_idx2 <- which(new_dim != 1L)
if (!can_map_effective_dimensions(effdim_idx1, effdim_idx2))
stop(wmsg(cannot_map_msg))
compute_dim_tuner <- function(effdim_idx1, effdim_idx2) {
idx1 <- c(effdim_idx1, length(old_dim) + 1L)
idx2 <- c(effdim_idx2, length(new_dim) + 1L)
diffs1 <- S4Vectors:::diffWithInitialZero(idx1)
diffs2 <- S4Vectors:::diffWithInitialZero(idx2)
deltas <- pmax(diffs1, diffs2)
nonzero_runlengths <- deltas - 1L
ans_len <- sum(nonzero_runlengths) + length(effdim_idx1)
ans <- integer(ans_len)
offsets <- c(0L, head(cumsum(deltas), n=-1L))
for (k in seq_along(idx1)) {
d <- diffs2[[k]] - diffs1[[k]]
op <- ifelse(d > 0L, 1L, -1L)
ans[offsets[[k]] + seq_len(abs(d))] <- rep.int(op, abs(d))
}
ans
}
compute_dim_tuner(effdim_idx1, effdim_idx2)
}
.set_Array_dim <- function(x, value)
{
x_dim <- dim(x)
value <- normalize_dim_replacement_value(value, x_dim)
dim_tuner <- .diff_dims(x_dim, value, class(x))
ans <- tune_Array_dims(x, dim_tuner)
stopifnot(identical(dim(ans), value)) # sanity check
ans
}
setReplaceMethod("dim", "Array", .set_Array_dim)
|
