# NOT RUN {
## Thin plate spline interpolation with x and y only
# some example data
r <-rast(system.file("exdata/test.tif", package="terra"))
ra <- aggregate(r, 10)
xy <- data.frame(xyFromCell(ra, 1:ncell(ra)))
v <- values(ra)
#### Thin plate spline model
library(fields)
tps <- Tps(xy, v)
x <- rast(r)
# use model to predict values at all locations
p <- interpolate(x, tps)
p <- mask(p, r)
plot(p)
## change the fun from predict to fields::predictSE to get the TPS standard error
se <- interpolate(x, tps, fun=predictSE)
se <- mask(se, r)
plot(se)
## another variable; let"s call it elevation
elevation <- (init(r, "x") * init(r, "y")) / 100000000
names(elevation) <- "elev"
elevation <- mask(elevation, r)
z <- extract(elevation, vect(xy), fun=function(x)x[1])
# add as another independent variable
vv <- na.omit(cbind(xy, z, v))
tps2 <- Tps(vv[,1:3], vv[,4])
p2 <- interpolate(elevation, tps2)
# as a linear coveriate
tps3 <- Tps(vv[,1:2], vv[,4], Z=vv[,3])
# Z is a separate argument in Krig.predict, so we need a new function
# Internally (in interpolate) a matrix is formed of x, y, and elev (Z)
pfun <- function(model, x, ...) {
predict(model, x[,1:2], Z=x[,3], ...)
}
p3 <- interpolate(elevation, tps3, fun=pfun)
#### gstat examples
library(sp)
library(gstat)
data(meuse)
## inverse distance weighted (IDW)
r <-rast(system.file("exdata/test.tif", package="terra"))
mg <- gstat(id = "zinc", formula = zinc~1, locations = ~x+y, data=meuse,
nmax=7, set=list(idp = .5))
f <- function(model, data, ...) predict(model, data, ...)[,3,drop=FALSE]
z <- interpolate(r, mg, fun=f, debug.level=0)
## kriging
coordinates(meuse) <- ~x+y
crs(meuse) <- crs(r)
## ordinary kriging
v <- variogram(log(zinc)~1, meuse)
m <- fit.variogram(v, vgm(1, "Sph", 300, 1))
gOK <- gstat(NULL, "log.zinc", log(zinc)~1, meuse, model=m)
fg <- function(model, d, crs, ...) {
sp <- SpatialPointsDataFrame(d[,1:2,drop=FALSE], data.frame(d), proj4string=CRS(crs))
data.frame(predict(model, sp, ...))[,3:4]
}
OK1 <- interpolate(r, gOK, fun=fg, debug.level=0, crs=crs(r), na.rm=TRUE)
OK2 <- interpolate(r, gOK, fun=fg, debug.level=0, crs=crs(r), na.rm=FALSE)
OK3 <- interpolate(x, gOK, fun=fg, debug.level=0, crs=crs(x))
plot(c(OK1[[1]], OK2[[1]], OK3[[1]]))
# examples below provided by Maurizio Marchi
## universial kriging
vu <- variogram(log(zinc)~elev, meuse)
mu <- fit.variogram(vu, vgm(1, "Sph", 300, 1))
gUK <- gstat(NULL, "log.zinc", log(zinc)~elev, meuse, model=mu)
names(r) <- "elev"
UK <- interpolate(r, gUK, fun=fg, debug.level=0, crs=crs(r))
## co-kriging
gCoK <- gstat(NULL, "log.zinc", log(zinc)~1, meuse)
gCoK <- gstat(gCoK, "elev", elev~1, meuse)
gCoK <- gstat(gCoK, "cadmium", cadmium~1, meuse)
gCoK <- gstat(gCoK, "copper", copper~1, meuse)
coV <- variogram(gCoK)
plot(coV, type="b", main="Co-variogram")
coV.fit <- fit.lmc(coV, gCoK, vgm(model="Sph", range=1000))
coV.fit
plot(coV, coV.fit, main="Fitted Co-variogram")
coK <- interpolate(r, coV.fit, fun=fg, debug.level=0, crs=crs(r))
plot(coK)
# }
Run the code above in your browser using DataLab