189 lines
6.1 KiB
R
189 lines
6.1 KiB
R
|
#-*- R -*-
|
||
|
|
|
||
|
|
## Script from Fourth Edition of `Modern Applied Statistics with S'
|
||
|
|
|
||
|
|
# Chapter 15 Spatial Statistics
|
||
|
|
|
||
|
|
library(MASS)
|
||
|
|
pdf(file="ch15.pdf", width=8, height=8, pointsize=9)
|
||
|
|
options(width=65, digits=5)
|
||
|
|
|
||
|
|
library(spatial)
|
||
|
|
|
||
|
|
# 15.1 Spatial interpolation and smoothing
|
||
|
|
|
||
|
|
par(mfrow=c(2,2), pty = "s")
|
||
|
|
topo.ls <- surf.ls(2, topo)
|
||
|
|
trsurf <- trmat(topo.ls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(trsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(trsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("Degree=2")
|
||
|
|
topo.ls <- surf.ls(3, topo)
|
||
|
|
trsurf <- trmat(topo.ls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(trsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(trsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("Degree=3")
|
||
|
|
topo.ls <- surf.ls(4, topo)
|
||
|
|
trsurf <- trmat(topo.ls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(trsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(trsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("Degree=4")
|
||
|
|
topo.ls <- surf.ls(6, topo)
|
||
|
|
trsurf <- trmat(topo.ls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(trsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(trsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("Degree=6")
|
||
|
|
|
||
|
|
library(lattice)
|
||
|
|
topo.ls <- surf.ls(4, topo)
|
||
|
|
trsurf <- trmat(topo.ls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
trsurf[c("x", "y")] <- expand.grid(x=trsurf$x, y=trsurf$y)
|
||
|
|
plt1 <- levelplot(z ~ x * y, trsurf, aspect=1,
|
||
|
|
at = seq(650, 1000, 10), xlab = "", ylab = "")
|
||
|
|
plt2 <- wireframe(z ~ x * y, trsurf, aspect=c(1, 0.5),
|
||
|
|
screen = list(z = -30, x = -60))
|
||
|
|
print(plt1, position = c(0, 0, 0.5, 1), more=TRUE)
|
||
|
|
print(plt2, position = c(0.45, 0, 1, 1))
|
||
|
|
|
||
|
|
par(mfcol = c(2, 2), pty = "s")
|
||
|
|
topo.loess <- loess(z ~ x * y, topo, degree = 2, span = 0.25,
|
||
|
|
normalize = FALSE)
|
||
|
|
topo.mar <- list(x = seq(0, 6.5, 0.1), y = seq(0, 6.5, 0.1))
|
||
|
|
topo.lo <- predict(topo.loess, expand.grid(topo.mar), se = TRUE)
|
||
|
|
eqscplot(topo.mar, xlab = "fit", ylab = "", type = "n")
|
||
|
|
contour(topo.mar$x, topo.mar$y, topo.lo$fit,
|
||
|
|
levels = seq(700, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
eqscplot(topo.mar, xlab = "standard error", ylab = "", type = "n")
|
||
|
|
contour(topo.mar$x,topo.mar$y,topo.lo$se.fit,
|
||
|
|
levels = seq(5, 25, 5), add = TRUE)
|
||
|
|
title("Loess degree = 2")
|
||
|
|
points(topo)
|
||
|
|
|
||
|
|
topo.loess <- loess(z ~ x * y, topo, degree = 1, span = 0.25, normalize = FALSE)
|
||
|
|
topo.lo <- predict(topo.loess, expand.grid(topo.mar), se=TRUE)
|
||
|
|
eqscplot(topo.mar, xlab = "fit", ylab = "", type = "n")
|
||
|
|
contour(topo.mar$x,topo.mar$y,topo.lo$fit, levels = seq(700, 1000, 25),
|
||
|
|
add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
eqscplot(topo.mar, xlab = "standard error", ylab = "", type = "n")
|
||
|
|
contour(topo.mar$x,topo.mar$y,topo.lo$se.fit, levels = seq(5, 25, 5),
|
||
|
|
add = TRUE)
|
||
|
|
title("Loess degree = 1")
|
||
|
|
points(topo)
|
||
|
|
|
||
|
|
library(interp) # was akima, interp.old()
|
||
|
|
par(mfrow = c(1, 2), pty= "s")
|
||
|
|
topo.int <- interp(topo$x, topo$y, topo$z)
|
||
|
|
eqscplot(topo.int, xlab = "interp default", ylab = "", type = "n")
|
||
|
|
contour(topo.int, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
topo.mar <- list(x = seq(0, 6.5, 0.1), y = seq(0, 6.5, 0.1))
|
||
|
|
topo.int2 <- interp(topo$x, topo$y, topo$z, topo.mar$x, topo.mar$y,
|
||
|
|
extrap = TRUE) # was ncp = 4.
|
||
|
|
eqscplot(topo.int2, xlab = "interp", ylab = "", type = "n")
|
||
|
|
contour(topo.int2, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
# 15.2 Kriging
|
||
|
|
|
||
|
|
par(mfrow = c(2, 2), pty = "s")
|
||
|
|
topo.ls <- surf.ls(2, topo)
|
||
|
|
trsurf <- trmat(topo.ls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(trsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(trsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("LS trend surface")
|
||
|
|
|
||
|
|
topo.gls <- surf.gls(2, expcov, topo, d = 0.7)
|
||
|
|
trsurf <- trmat(topo.gls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(trsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(trsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("GLS trend surface")
|
||
|
|
|
||
|
|
prsurf <- prmat(topo.gls, 0, 6.5, 0, 6.5, 50)
|
||
|
|
eqscplot(prsurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(prsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("Kriging prediction")
|
||
|
|
sesurf <- semat(topo.gls, 0, 6.5, 0, 6.5, 30)
|
||
|
|
eqscplot(sesurf, , xlab = "", ylab = "", type = "n")
|
||
|
|
contour(sesurf, levels = c(20, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
title("Kriging s.e.")
|
||
|
|
|
||
|
|
par(mfrow = c(2, 2), pty = "m")
|
||
|
|
topo.kr <- surf.ls(2, topo)
|
||
|
|
correlogram(topo.kr, 25)
|
||
|
|
d <- seq(0, 7, 0.1)
|
||
|
|
lines(d, expcov(d, 0.7))
|
||
|
|
variogram(topo.kr, 25)
|
||
|
|
|
||
|
|
## left panel of Figure 15.7
|
||
|
|
topo.kr <- surf.gls(2, expcov, topo, d=0.7)
|
||
|
|
correlogram(topo.kr, 25)
|
||
|
|
lines(d, expcov(d, 0.7))
|
||
|
|
lines(d, gaucov(d, 1.0, 0.3), lty = 3) # try nugget effect
|
||
|
|
|
||
|
|
## right panel
|
||
|
|
topo.kr <- surf.ls(0, topo)
|
||
|
|
correlogram(topo.kr, 25)
|
||
|
|
lines(d, gaucov(d, 2, 0.05))
|
||
|
|
|
||
|
|
par(mfrow = c(2, 2), pty = "s")
|
||
|
|
## top row of Figure 15.8
|
||
|
|
topo.kr <- surf.gls(2, gaucov, topo, d = 1, alph = 0.3)
|
||
|
|
prsurf <- prmat(topo.kr, 0, 6.5, 0, 6.5, 50)
|
||
|
|
eqscplot(prsurf, , xlab = "fit", ylab = "", type = "n")
|
||
|
|
contour(prsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
sesurf <- semat(topo.kr, 0, 6.5, 0, 6.5, 25)
|
||
|
|
eqscplot(sesurf, , xlab = "standard error", ylab = "", type = "n")
|
||
|
|
contour(sesurf, levels = c(15, 20, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
|
||
|
|
## bottom row of Figure 15.8
|
||
|
|
topo.kr <- surf.gls(0, gaucov, topo, d = 2, alph = 0.05,
|
||
|
|
nx = 10000)
|
||
|
|
prsurf <- prmat(topo.kr, 0, 6.5, 0, 6.5, 50)
|
||
|
|
eqscplot(prsurf, , xlab = "fit", ylab = "", type = "n")
|
||
|
|
contour(prsurf, levels = seq(600, 1000, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
sesurf <- semat(topo.kr, 0, 6.5, 0, 6.5, 25)
|
||
|
|
eqscplot(sesurf, , xlab = "standard error", ylab = "", type = "n")
|
||
|
|
contour(sesurf, levels = c(15, 20, 25), add = TRUE)
|
||
|
|
points(topo)
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
# 15.3 Point process analysis
|
||
|
|
|
||
|
|
library(spatial)
|
||
|
|
pines <- ppinit("pines.dat")
|
||
|
|
par(mfrow = c(2, 2), pty = "s")
|
||
|
|
plot(pines, xlim = c(0, 10), ylim = c(0, 10),
|
||
|
|
xlab = "", ylab = "", xaxs = "i", yaxs = "i")
|
||
|
|
plot(Kfn(pines,5), type = "s", xlab = "distance", ylab = "L(t)")
|
||
|
|
lims <- Kenvl(5, 100, Psim(72))
|
||
|
|
lines(lims$x, lims$l, lty = 2)
|
||
|
|
lines(lims$x, lims$u, lty = 2)
|
||
|
|
|
||
|
|
ppregion(pines)
|
||
|
|
plot(Kfn(pines, 1.5), type = "s",
|
||
|
|
xlab = "distance", ylab = "L(t)")
|
||
|
|
lims <- Kenvl(1.5, 100, Strauss(72, 0.2, 0.7))
|
||
|
|
lines(lims$x, lims$a, lty = 2)
|
||
|
|
lines(lims$x, lims$l, lty = 2)
|
||
|
|
lines(lims$x, lims$u, lty = 2)
|
||
|
|
pplik(pines, 0.7)
|
||
|
|
lines(Kaver(1.5, 100, Strauss(72, 0.15, 0.7)), lty = 3)
|
||
|
|
|
||
|
|
# End of ch15
|