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
|
whichIndex <- function(I, dim, dimnames = NULL) {
ndim <- length(dim)
stop_if_not((is.matrix(I) || is.data.frame(I)), ncol(I) == ndim)
if (!is.null(dimnames)) stop_if_not(length(dimnames) == ndim)
if (ndim == 0L) return(integer(0L))
if (is.data.frame(I)) {
## Convert each column to indices
I2 <- array(NA_integer_, dim = dim(I))
for (kk in 1:ndim) {
idxs <- I[[kk]]
if (is.numeric(idxs)) {
if (any(idxs < 1 | idxs > dim[kk])) {
stop("Index out of range.")
}
} else {
idxs <- as.character(idxs)
idxs <- match(idxs, dimnames[[kk]])
if (anyNA(idxs)) {
unknown <- I[is.na(idxs), kk]
stop("Unknown indices: ", hpaste(sQuote(unknown)))
}
}
I2[, kk] <- idxs
}
I <- I2
I2 <- NULL
} else if (is.numeric(I)) {
for (kk in 1:ndim) {
idxs <- I[, kk]
if (any(idxs < 1 | idxs > dim[kk])) {
stop("Index out of range.")
}
}
} else {
## Convert dimnames to dimindices
I2 <- array(NA_integer_, dim = dim(I))
for (kk in 1:ndim) {
## Could be, say, factor
idxs <- I[, kk]
idxs <- as.character(idxs)
idxs <- match(idxs, dimnames[[kk]])
if (anyNA(idxs)) {
unknown <- I[is.na(idxs), kk]
stop("Unknown indices: ", hpaste(sQuote(unknown)))
}
I2[, kk] <- idxs
}
I <- I2
I2 <- NULL
}
## Nothing more to do?
if (ndim == 1) return(I[, 1L])
base <- cumprod(dim[-ndim])
for (kk in 2:ndim) {
I[, kk] <- (I[, kk] - 1) * base[kk - 1L]
}
rowSums(I)
}
|
