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
|
### =========================================================================
### NaArray subsetting
### -------------------------------------------------------------------------
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### tune_Array_dims() method NaArray objects
###
### This is the workhorse behind drop() and dim<-() on NaArray objects.
###
### Unlike with S4Arrays:::tune_dims() and S4Arrays:::tune_dimnames(),
### the 'dim_tuner' vector passed to .tune_NaArray_dims() must be
### normalized. See src/SparseArray_dim_tuning.c for more information.
.tune_NaArray_dims <- function(x, dim_tuner)
{
stopifnot(is(x, "NaArray"), is.integer(dim_tuner))
check_svt_version(x)
ans_NaSVT <- SparseArray.Call("C_tune_SVT_dims",
x@dim, x@type, x@NaSVT, dim_tuner)
ans_dim <- S4Arrays:::tune_dims(x@dim, dim_tuner)
ans_dimnames <- S4Arrays:::tune_dimnames(x@dimnames, dim_tuner)
new_NaArray(ans_dim, ans_dimnames, x@type, ans_NaSVT, check=FALSE)
}
setMethod("tune_Array_dims", "NaArray", .tune_NaArray_dims)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### .subset_NaSVT_by_Lindex()
### .subset_NaSVT_by_Mindex()
###
### Both return a vector (atomic or list) of the same type() as 'x'.
###
### 'Lindex' must be a numeric vector (integer or double), possibly a long one.
### NA indices are accepted.
.subset_NaSVT_by_Lindex <- function(x, Lindex)
{
stopifnot(is(x, "NaArray"))
check_svt_version(x)
stopifnot(is.vector(Lindex), is.numeric(Lindex))
on.exit(free_global_OPBufTree())
ans <- SparseArray.Call("C_subset_SVT_by_Lindex",
x@dim, x@type, x@NaSVT, TRUE, Lindex)
propagate_names_if_1D(ans, dimnames(x), Lindex)
}
setMethod("subset_Array_by_Lindex", "NaArray", .subset_NaSVT_by_Lindex)
### Alright, '.subset_NaSVT_by_Mindex(x, Mindex)' could just have done:
###
### .subset_NaSVT_by_Lindex(x, Mindex2Lindex(Mindex, dim(x)))
###
### However, the C code in C_subset_NaSVT_by_Mindex() avoids the Mindex2Lindex()
### step and so should be slightly more efficient, at least in theory. But is
### it? Some quick testing suggests that there's actually no significant
### difference!
### TODO: Investigate this more.
.subset_NaSVT_by_Mindex <- function(x, Mindex)
{
stopifnot(is(x, "NaArray"))
check_svt_version(x)
stopifnot(is.matrix(Mindex))
x_dimnames <- dimnames(x)
if (!is.numeric(Mindex)) {
if (!is.character(Mindex))
stop(wmsg("invalid matrix subscript type \"", type(Mindex), "\""))
if (is.null(x_dimnames))
stop(wmsg("NaArray object to subset has no dimnames"))
## Subsetting an ordinary array with dimnames on it by a character
## matrix is supported in base R but we don't support this yet for
## NaArray objects.
stop("subsetting an NaArray object by a character matrix ",
"is not supported at the moment")
}
on.exit(free_global_OPBufTree())
ans <- SparseArray.Call("C_subset_SVT_by_Mindex",
x@dim, x@type, x@NaSVT, TRUE, Mindex)
propagate_names_if_1D(ans, x_dimnames, Mindex)
}
setMethod("subset_Array_by_Mindex", "NaArray", .subset_NaSVT_by_Mindex)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### subset_NaSVT_by_Nindex()
###
### In addition to being one of the workhorses behind `[` on an
### NaArray object (see below), this is **the** workhorse behind the
### extract_na_array() and extract_array() methods for NaArray objects.
###
### 'Nindex' must be an N-index, that is, a list of numeric vectors (or NULLs),
### one along each dimension in the array to subset. Note that, strictly
### speaking, the vectors in an N-index are expected to be integer vectors,
### but subset_NaSVT_by_Nindex() can handle subscripts of type "double".
### This differs from the 'index' argument in 'extract_array()' where the
### subscripts **must** be integer vectors.
###
### Returns an NaArray object of the same type() as 'x' (endomorphism).
subset_NaSVT_by_Nindex <- function(x, Nindex, ignore.dimnames=FALSE)
{
stopifnot(is(x, "NaArray"),
is.list(Nindex),
length(Nindex) == length(x@dim),
isTRUEorFALSE(ignore.dimnames))
check_svt_version(x)
## Returns 'new_dim' and 'new_NaSVT' in a list of length 2.
C_ans <- SparseArray.Call("C_subset_SVT_by_Nindex",
x@dim, x@type, x@NaSVT, Nindex)
new_dim <- C_ans[[1L]]
new_NaSVT <- C_ans[[2L]]
## Compute 'new_dimnames'.
if (is.null(dimnames(x)) || ignore.dimnames) {
new_dimnames <- vector("list", length(x@dim))
} else {
new_dimnames <- S4Arrays:::subset_dimnames_by_Nindex(x@dimnames, Nindex)
}
BiocGenerics:::replaceSlots(x, dim=new_dim,
dimnames=new_dimnames,
NaSVT=new_NaSVT,
check=FALSE)
}
setMethod("subset_Array_by_Nindex", "NaArray",
function(x, Nindex) subset_NaSVT_by_Nindex(x, Nindex)
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### extract_na_array() and extract_array() methods for NaArray objects
###
setGeneric("extract_na_array", signature="x",
function(x, index) standardGeneric("extract_na_array")
)
### No need to propagate the dimnames.
setMethod("extract_na_array", "NaArray",
function(x, index) subset_NaSVT_by_Nindex(x, index, ignore.dimnames=TRUE)
)
### Note that the default extract_array() method would do the job but it
### relies on single-bracket subsetting so would needlessly go thru the
### complex .subset_NaArray() machinery above to finally call
### subset_NaSVT_by_Nindex(). It would also propagate the dimnames which
### extract_array() does not need to do. The method below completely bypasses
### all this complexity by calling subset_NaSVT_by_Nindex() directly.
setMethod("extract_array", "NaArray",
function(x, index)
as.array(subset_NaSVT_by_Nindex(x, index, ignore.dimnames=TRUE))
)
|
