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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
CCmaps <- function(obj, zcol=NULL, cvar=NULL, cvar.names=NULL,
..., names.attr, scales = list(draw = FALSE),
xlab = NULL, ylab = NULL, aspect = mapasp(obj, xlim, ylim),
sp.layout = NULL, xlim = bbox(obj)[1,], ylim = bbox(obj)[2,]) {
stopifnot(is(obj, "SpatialPolygonsDataFrame"))
stopifnot(!is.null(zcol), !is.null(cvar))
n <- length(slot(obj, "polygons"))
stopifnot(length(zcol) == 1L)
ncc <- length(cvar)
stopifnot(ncc <= 2, ncc > 0)
if (is.null(cvar.names)) cvar.names <- names(cvar)
nlcc <- integer(ncc)
lcc <- vector(mode="list", length=ncc)
# fcc <- logical(nlcc)
fcc <- logical(ncc)
for (i in 1:ncc) {
ccc <- class(cvar[[i]])
stopifnot(ccc %in% c("factor", "shingle"))
fcc[i] <- ccc == "factor"
stopifnot(length(cvar[[i]]) == n)
nlcc[i] <- nlevels(cvar[[i]])
lcc[[i]] <- levels(cvar[[i]])
}
obj <- obj[zcol]
zcol <- names(obj)
Outside <- function(x, y, z) (x < y | x > z)
if (ncc == 1) {
if (fcc[1]) {
for (j in 1:nlcc[1]) {
vn <- paste(cvar.names[1], lcc[[1]][j], sep="_")
io <- as.character(cvar[[1]]) != lcc[[1]][j]
obj[[vn]] <- obj[[zcol]]
is.na(obj[[vn]]) <- io
}
} else {
ilcc <- do.call("rbind", lcc[[1]])
for (j in 1:nlcc[1]) {
vn <- paste(cvar.names[1], j, sep="_")
io <- Outside(cvar[[1]], ilcc[j,1], ilcc[j,2])
obj[[vn]] <- obj[[zcol]]
is.na(obj[[vn]]) <- io
}
}
nms <- names(obj)
nms <- nms[-(match(zcol, nms))]
if (fcc[1]) {
print(spplot(obj, zcol=nms, ..., scales = scales,
xlab = xlab, ylab = ylab, aspect = aspect,
sp.layout = sp.layout, xlim = xlim, ylim = ylim,
strip=strip.custom(which.given=1,
factor.levels=lcc[[1]], par.strip.text=list(cex=0.8),
bg="grey95")))
} else {
print(spplot(obj, zcol=nms, ..., scales = scales,
xlab = xlab, ylab = ylab, aspect = aspect,
sp.layout = sp.layout, xlim = xlim, ylim = ylim,
strip=strip.custom(which.given=1,
shingle.intervals=as.matrix(lcc[[1]]),
var.name=cvar.names[1], par.strip.text=list(cex=0.8),
bg="grey95", fg="grey75")))
}
} else {
if (all(fcc)) {
for (i in 1:nlcc[1]) {
for (j in 1:nlcc[2]) {
vn <- paste(cvar.names[1], lcc[[1]][i], cvar.names[2],
lcc[[2]][j], sep="_")
obj[[vn]] <- obj[[zcol]]
ioi <- as.character(cvar[[1]]) != lcc[[1]][i]
ioj <- as.character(cvar[[2]]) != lcc[[2]][j]
io <- ioi | ioj
is.na(obj[[vn]]) <- io
}
}
nms <- names(obj)
nms <- nms[-(match(zcol, nms))]
lcc1 <- lcc[[1]]
xlcc <- NULL
for (i in 1:nlcc[1]) {
xlcc <- c(xlcc, rep(lcc1[i], nlcc[2]))
}
lcc2 <- lcc[[2]]
xlcc2 <- rep(lcc2, nlcc[1])
print(spplot(obj, zcol=nms, ..., scales = scales,
xlab = xlab, ylab = ylab, aspect = aspect,
sp.layout = sp.layout, xlim = xlim, ylim = ylim,
strip=strip.custom(which.given=1,
factor.levels=xlcc,
par.strip.text=list(cex=0.8), bg="grey95"),
strip.left=strip.custom(which.given=1,
factor.levels=xlcc2,
par.strip.text=list(cex=0.8), bg="grey95")))
} else if (any(fcc)) {
if (fcc[1]) {
jlcc <- do.call("rbind", lcc[[2]])
for (i in 1:nlcc[1]) {
for (j in 1:nlcc[2]) {
vn <- paste(cvar.names[1], lcc[[1]][i], cvar.names[2],
j, sep="_")
obj[[vn]] <- obj[[zcol]]
ioi <- as.character(cvar[[1]]) != lcc[[1]][i]
ioj <- Outside(cvar[[2]], jlcc[j,1], jlcc[j,2])
io <- ioi | ioj
is.na(obj[[vn]]) <- io
}
}
nms <- names(obj)
nms <- nms[-(match(zcol, nms))]
lcc1 <- lcc[[1]]
xlcc <- NULL
for (i in 1:nlcc[1]) {
xlcc <- c(xlcc, rep(lcc1[i], nlcc[2]))
}
lcc2 <- matrix(unlist(lcc[[2]]), ncol=2, byrow=TRUE)
xlcc2 <- matrix(rep(t(lcc2), nlcc[1]), byrow=TRUE, ncol=2)
print(spplot(obj, zcol=nms, ..., scales = scales,
xlab = xlab, ylab = ylab, aspect = aspect,
sp.layout = sp.layout, xlim = xlim, ylim = ylim,
strip=strip.custom(which.given=1,
factor.levels=xlcc,
par.strip.text=list(cex=0.8), bg="grey95"),
strip.left=strip.custom(which.given=1,
shingle.intervals=xlcc2, var.name=cvar.names[2],
par.strip.text=list(cex=0.8), bg="grey95", fg="grey75")))
} else {
ilcc <- do.call("rbind", lcc[[1]])
for (i in 1:nlcc[1]) {
for (j in 1:nlcc[2]) {
vn <- paste(cvar.names[1], i, cvar.names[2],
lcc[[2]][j], sep="_")
obj[[vn]] <- obj[[zcol]]
ioi <- Outside(cvar[[1]], ilcc[i,1], ilcc[i,2])
ioj <- as.character(cvar[[2]]) != lcc[[2]][j]
io <- ioi | ioj
is.na(obj[[vn]]) <- io
}
}
nms <- names(obj)
nms <- nms[-(match(zcol, nms))]
lcc1 <- matrix(unlist(lcc[[1]]), ncol=2, byrow=TRUE)
xlcc <- matrix(ncol=2)
for (i in 1:nlcc[1]) {
xlcc <- rbind(xlcc, matrix(rep(lcc1[i,], nlcc[2]),
ncol=2, byrow=TRUE))
}
xlcc <- xlcc[-1,]
lcc2 <- lcc[[2]]
xlcc2 <- rep(lcc2, nlcc[1])
print(spplot(obj, zcol=nms, ..., scales = scales,
xlab = xlab, ylab = ylab, aspect = aspect,
sp.layout = sp.layout, xlim = xlim, ylim = ylim,
strip=strip.custom(which.given=1,
shingle.intervals=xlcc, var.name=cvar.names[1],
par.strip.text=list(cex=0.8), bg="grey95", fg="grey75"),
strip.left=strip.custom(which.given=1,
factor.levels=xlcc2,
par.strip.text=list(cex=0.8), bg="grey95")))
}
} else {
ilcc <- do.call("rbind", lcc[[1]])
jlcc <- do.call("rbind", lcc[[2]])
for (i in 1:nlcc[1]) {
for (j in 1:nlcc[2]) {
vn <- paste(cvar.names[1], i, cvar.names[2], j, sep="_")
obj[[vn]] <- obj[[zcol]]
ioi <- Outside(cvar[[1]], ilcc[i,1], ilcc[i,2])
ioj <- Outside(cvar[[2]], jlcc[j,1], jlcc[j,2])
io <- ioi | ioj
is.na(obj[[vn]]) <- io
}
}
nms <- names(obj)
nms <- nms[-(match(zcol, nms))]
lcc1 <- matrix(unlist(lcc[[1]]), ncol=2, byrow=TRUE)
xlcc <- matrix(ncol=2)
for (i in 1:nlcc[1]) {
xlcc <- rbind(xlcc, matrix(rep(lcc1[i,], nlcc[2]),
ncol=2, byrow=TRUE))
}
xlcc <- xlcc[-1,]
lcc2 <- matrix(unlist(lcc[[2]]), ncol=2, byrow=TRUE)
xlcc2 <- matrix(rep(t(lcc2), nlcc[1]), byrow=TRUE, ncol=2)
print(spplot(obj, zcol=nms, ..., scales = scales,
xlab = xlab, ylab = ylab, aspect = aspect,
sp.layout = sp.layout, xlim = xlim, ylim = ylim,
strip=strip.custom(which.given=1,
shingle.intervals=xlcc, var.name=cvar.names[1],
par.strip.text=list(cex=0.8), bg="grey95", fg="grey75"),
strip.left=strip.custom(which.given=1,
shingle.intervals=xlcc2, var.name=cvar.names[2],
par.strip.text=list(cex=0.8), bg="grey95", fg="grey75")))
}
}
invisible(obj)
}
|
