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
|
### =========================================================================
### Array objects
### -------------------------------------------------------------------------
### A virtual class with no slots to be extended by concrete subclasses with
### an array-like semantic.
setClass("Array", representation("VIRTUAL"))
### Note that some objects with dimensions (i.e. with a non-NULL dim()) can
### have a length() that is not 'prod(dim(x))' e.g. data-frame-like objects
### (for which 'length(x)' is 'ncol(x)') and SummarizedExperiment derivatives
### (for which 'length(x)' is 'nrow(x)').
### Terminology: Should we still consider that these objects are "array-like"
### or "matrix-like"? Or should these terms be used only for objects that
### have dimensions **and** have a length() defined as 'prod(dim(x))'?
### Even though prod() always returns a double, it seems that the length()
### primitive function takes care of turning this double into an integer if
### it's <= .Machine$integer.max
setMethod("length", "Array", function(x) prod(dim(x)))
setMethod("isEmpty", "Array", function(x) any(dim(x) == 0L))
### 'subscripts' is assumed to be an integer vector parallel to 'dim(x)' and
### with no out-of-bounds subscripts (i.e. 'all(subscripts >= 1)' and
### 'all(subscripts <= dim(x))').
### NOT exported for now but should probably be at some point (like
### S4Vectors::getListElement() is).
setGeneric("getArrayElement", signature="x",
function(x, subscripts) standardGeneric("getArrayElement")
)
### Support multidimensional and linear subsetting.
### TODO: Multidimensional subsetting should support things like
### x[[5, 15, 2]] and x[["E", 15, "b"]].
### TODO: Linear subsetting should support a single *numeric* subscript.
setMethod("[[", "Array",
function(x, i, j, ...)
{
if (missing(x))
stop("'x' is missing")
Nindex <- extract_Nindex_from_syscall(sys.call(), parent.frame())
nsubscript <- length(Nindex)
x_dim <- dim(x)
x_ndim <- length(x_dim)
if (!(nsubscript == x_ndim || nsubscript == 1L))
stop("incorrect number of subscripts")
ok <- vapply(Nindex, isSingleInteger, logical(1), USE.NAMES=FALSE)
if (!all(ok))
stop(wmsg("each subscript must be a single integer ",
"when subsetting an ", class(x), " object with [["))
if (nsubscript == x_ndim) {
## Multidimensional subsetting.
subscripts <- unlist(Nindex, use.names=FALSE)
if (!(all(subscripts >= 1L) && all(subscripts <= x_dim)))
stop("some subscripts are out of bounds")
} else {
## Linear subsetting.
## We turn this into a multidimensional subsetting by
## transforming the user-supplied linear index into an array
## (i.e. multidimensional) index.
i <- Nindex[[1L]]
if (i < 1L || i > prod(x_dim))
stop("subscript is out of bounds")
subscripts <- as.integer(arrayInd(i, x_dim))
}
getArrayElement(x, subscripts)
}
)
.SLICING_TIP <- c(
"Consider reducing its number of effective dimensions by slicing it ",
"first (e.g. x[8, 30, , 2, ]). Make sure that all the indices used for ",
"the slicing have length 1 except at most 2 of them which can be of ",
"arbitrary length or missing."
)
.from_Array_to_matrix <- function(x)
{
if (!isS4(x)) {
## The arrow package does not define any as.matrix method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array in the extract_array.R
## file for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" S3 as.matrix method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.matrix(x))
}
}
x_dim <- dim(x)
if (sum(x_dim != 1L) > 2L)
stop(wmsg(class(x), " object has more than 2 effective dimensions ",
"--> cannot coerce it to a matrix. ", .SLICING_TIP))
ans <- drop(as.array(x)) # this could drop all the dimensions!
if (length(x_dim) == 2L) {
ans <- set_dim(ans, x_dim)
ans <- set_dimnames(ans, dimnames(x))
} else {
as.matrix(ans)
}
ans
}
### S3/S4 combo for as.matrix.Array
as.matrix.Array <- function(x, ...) .from_Array_to_matrix(x, ...)
setMethod("as.matrix", "Array", .from_Array_to_matrix)
### S3/S4 combo for t.Array
### t() will work out-of-the-box on any Array derivative that supports aperm().
t.Array <- function(x)
{
if (!isS4(x)) {
## The arrow package does not define any t method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array in the extract_array.R
## file for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" S3 t method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::t(x))
}
}
if (length(dim(x)) != 2L)
stop(wmsg("the ", class(x), " object to transpose ",
"must have exactly 2 dimensions"))
aperm(x)
}
setMethod("t", "Array", t.Array)
|
