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
|
# Copyright 2001 by Roger Bivand
#
rookcell <- function(rowcol, nrow, ncol, torus=FALSE, rmin=1, cmin=1) {
if (is.null(dim(rowcol))) rowcol <- t(as.matrix(rowcol))
if(nrow(rowcol) != 1) stop("only single grid cell handled")
row <- rowcol[1]
col <- rowcol[2]
if (torus) {
y <- c(ifelse(col-1 < cmin, ncol, col-1), col, col,
ifelse(col+1 > (ncol+(cmin-1)), cmin, col+1))
x <- c(row, ifelse(row-1 < rmin, nrow, row-1),
ifelse(row+1 > (nrow+(rmin-1)), rmin, row+1), row)
} else {
y <- c(ifelse(col-1 < cmin, NA, col-1), col, col,
ifelse(col+1 > (ncol+(cmin-1)), NA, col+1))
x <- c(row, ifelse(row-1 < rmin, NA, row-1),
ifelse(row+1 > (nrow+(rmin-1)), NA, row+1), row)
}
res <- as.data.frame(list(row=x, col=y))
res <- na.omit(res)
res <- as.matrix(res)
rownames(res) <- NULL
attr(res, "coords") <- c(col, row)
res
}
queencell <- function(rowcol, nrow, ncol, torus=FALSE, rmin=1, cmin=1) {
if (is.null(dim(rowcol))) rowcol <- t(as.matrix(rowcol))
if(nrow(rowcol) != 1) stop("only single grid cell handled")
row <- rowcol[1]
col <- rowcol[2]
if (torus) {
y <- c(rep(ifelse(col-1 < cmin, ncol, col-1), 3), col, col,
rep(ifelse(col+1 > (ncol+(cmin-1)), cmin, col+1), 3))
x <- integer(8)
x[c(1,4,6)] <- rep(ifelse(row+1 > (nrow+(rmin-1)),
rmin, row+1), 3)
x[c(2,7)] <- rep(row, 2)
x[c(3,5,8)] <- rep(ifelse(row-1 < rmin, nrow, row-1), 3)
} else {
y <- c(rep(ifelse(col-1 < cmin, NA, col-1), 3), col, col,
rep(ifelse(col+1 > (ncol+(cmin-1)), NA, col+1), 3))
x <- integer(8)
x[c(1,4,6)] <- rep(ifelse(row+1 > (nrow+(rmin-1)),
NA, row+1), 3)
x[c(2,7)] <- rep(row, 2)
x[c(3,5,8)] <- rep(ifelse(row-1 < rmin, NA, row-1), 3)
}
res <- as.data.frame(list(row=x, col=y))
res <- na.omit(res)
res <- as.matrix(res)
rownames(res) <- NULL
attr(res, "coords") <- c(col, row)
res
}
mrc2vi <- function(rowcol, nrow, ncol) {
i <- ((rowcol[,2]-1) * nrow) + rowcol[,1]
if (i > nrow*ncol || i < 1) stop("row or column out of range")
as.integer(i)
}
vi2mrc <- function(i, nrow, ncol) {
col <- ceiling(i/nrow)
tmp <- i %% nrow
row <- ifelse(tmp == 0, nrow, tmp)
if (row < 1 || row > nrow) stop("i out of range")
if (col < 1 || col > ncol) stop("i out of range")
res <- cbind(row, col)
res
}
cell2nb <- function(nrow, ncol, type="rook", torus=FALSE, legacy=FALSE) {
nrow <- as.integer(nrow)
if (nrow < 1) stop("nrow nonpositive")
ncol <- as.integer(ncol)
if (ncol < 1) stop("ncol nonpositive")
xcell <- NULL
if (type == "rook") xcell <- rookcell
if (type == "queen") xcell <- queencell
if (is.null(xcell))
stop(paste(type, ": no such cell function", sep=""))
n <- nrow * ncol
if (n < 0) stop("non-positive number of cells")
res <- vector(mode="list", length=n)
rownames <- character(n)
if (legacy) {
for (i in 1:n) {
res[[i]] <- sort(mrc2vi(xcell(vi2mrc(i, nrow, ncol),
nrow, ncol, torus), nrow, ncol))
rownames[i] <- paste(vi2mrc(i, nrow, ncol), collapse=":")
}
} else {
for (i in 1:n) {
res[[i]] <- sort(mrc2vi(xcell(vi2mrc(i, ncol, nrow),
ncol, nrow, torus), ncol, nrow))
rownames[i] <- paste(vi2mrc(i, ncol, nrow), collapse=":")
}
}
class(res) <- "nb"
attr(res, "call") <- match.call()
attr(res, "region.id") <- rownames
attr(res, "cell") <- TRUE
attr(res, type) <- TRUE
if (torus) attr(res, "torus") <- TRUE
res <- sym.attr.nb(res)
res
}
|
