1grid2nb <- function(grid, d = grid@cells.dim,
2                    queen = TRUE, nb = TRUE, self = FALSE) {
3### supply either a grid (GridTopology)
4###    or d (number of cells in each dimention)
5### choose queen and nb (see the poly2nb() function)
6    n <- as.integer(prod(d))
7    if (n==1) {
8        if (nb) {
9            nn <- list(self*1L)
10            class(nn) <- 'nb'
11            return(nn)
12        } else return(matrix(0L, 1, 1))
13    }
14    nd <- as.integer(length(d))
15    if (nd==1) {
16        nn <- cbind(c(0L, 1L:(n-1)),
17                    c(2L:n, 0L))
18    } else {
19        if (queen) {
20            exd <- expand.grid(
21                lapply(1L:nd, function(j)
22                    c(1,d)[j]^(j-1)*(-1L:1L)))
23            ll <- as.integer(rowSums(exd))
24            gc(reset=TRUE)
25            nn <- matrix(1L:n, n, length(ll))
26            for (j in 1:ncol(nn))
27                nn[, j] <- nn[, j] + ll[j]
28            for (j in 1:nd) {
29                ii <- rep(rep(1:d[j],
30                              each=prod(c(1,d)[1:j])
31                              ), prod(d[-(1:j)]))
32                id <- which(ii==1)
33                for (jj in which(exd[,j]<0))
34                    nn[id, jj] <- 0L
35                id <- which(ii==d[j])
36                for (jj in which(exd[,j]>0))
37                    nn[id, jj] <- 0L
38            }
39            if (!self)
40                nn[, which(ll==0)] <- 0L
41        } else {
42            nn <- matrix(0L, n, self + 2*nd)
43            id <- 1L:n
44            if (self) nn[, 1] <- id
45            for (j in 1:nd) {
46                ii <- rep(rep(1L:d[j],
47                              each=prod(c(1,d)[1:j])
48                              ), prod(d[-(1:j)]))
49                nn[, self + 2*(j-1)+1] <- as.integer((
50                    id-c(1,d)[j]^(j-1))*(ii!=1))
51                nn[, self + 2*(j-1)+2] <- as.integer((
52                    id+c(1,d)[j]^(j-1))*(ii!=d[j]))
53            }
54        }
55    }
56    if (nb) {
57        nn <- lapply(1L:n, function(i)
58            nn[i, nn[i,]>0L])
59        class(nn) <- 'nb'
60        return(nn)
61    } else {
62        if (self) return(nn)
63        else return(nn[, -which(ll==0)])
64    }
65}
66