Análisis espacial con R (asignatura de Master - UPM)

Asignatura: Análisis espacial
Curso 2014/2015
Practicas con R
Prof. Vladimir Gutiérrez, PhD
(www.vlado.es)
fv.gutierrez@upm.es
Madrid, España
1
Máster en Ingeniería Geodésica y Cartografía

Índice
1. Descarga / Instalación
2. Inicio de R
3. Entorno de desarrollo R-Studio
4. Carga de datos
5. Pre-procesos de datos
6. Datos espaciales en R
7. Interpolación determinística /exportar resultado
8. Análisis de variograma: empírico
9. Modelo de variograma
10. Interpolación geoestadística
11. Validaciones cruzadas
2

R
3
- Entorno estadístico y/o lenguaje de programación / OpenSource / Win - Linux - Mac
- Con más de 6000 packages (bibliotecas) agrupados en vistas o temas.
- “Analysis of Spatial Data” con 131 packages (“R-SIG-Geo” lista oficial de correos)

4
4) Download R for Windows
5) base -> install R for the first
6) Download R 3.1.2 for Windows
1) http://www.r-project.org
2) download R
3) Seleccionar un Mirror (Spain)

5
2. Inicio de
01> a <- 1 + 2 04 > class(d) 06 > ls() 08> getwd()
02> b <- c(1, 2, 3) 05 > str(d) 07 > rm( “objeto” ) 09 > gc()
03 > d <- matrix(c(11.11, 12.12, 13.13, 14.14, 15.15, 16.16, 17.17, 18.18, 19.19), ncol=3)

6
2. Inicio de R
01> x <- rnorm(n=100, mean=10, sd=2) 04> max(x) 07 > hist(x)
02> summary(x) 05> min(x) 08 > boxplot(x)
03> mean(x) 06 > sd(x) 09 > par(mfrow=c(2,1), mar=c(4,4,4,4))
- El núcleo incluye packages con funciones básicas (estadísticas, manejo de datos, graficas)

7
2. Inicio de R
01 > x <- 0:25 04 > cor(x, y) 07 > Fn <- lm(y~x, losDatos)
02 > y <- (x + rnorm(x)) + 10 05 > losDatos <- cbind(x, y) 08 > abline(Fn, col = "red", lty=1, lwd = 2)
03 > plot(x, y) 06 > losDatos <- as.data.frame(losDatos ) 09 > summary(Fn)

8
-Instalación de paquetes
- “rgdal”
2. Inicio de R

10
http://www.rstudio.com

11

12
3. Entorno de desarrollo R-Studio (*)
2
1
3
- En (1) observar “rgdal”, y la forma de instalar nuevos “packages”
- En (2) la opción de guardar y cargar Workspace.
- En (3) [ R ] en las opciones globales.
4
5

13
4. Carga de datos
Múltiples fuentes:
- Bases de datos relacionales y NoSql:
RODBC, RMySQL, RpgSQL, RPostgreSQL, RSQLite
- Archivos:
read.table in {utils}: csv, excel …
- Datos espaciales (vectoriales y rasters):
rgdal, maptools , shapefiles, maps
- Servicios webs, paginas webs, google earth, OSM y etc.
- sqldf “ para el manejo de dataframes como tablas de BD”

14
4. Carga de datos
Desde base de datos (p. ej: Oracle):
01 > library(RODBC)
02 > myCn <- odbcConnect("RsMercator", uid = "USUARIO", pwd = "CLAVE", believeNRows=FALSE)
03 > ElSql <- paste('SELECT AEMETDATA.ID as estacion, ROUND(avg(TA), 2) as T_MEDIA,
ROUND(min(TA), 2) as T_MIN, ROUND(max(TA), 2) as T_MAX, EXTRACT(year FROM FECHA) as
annio, EXTRACT(month FROM FECHA) as mes, EXTRACT(day FROM FECHA) as dia,
ROUND(a.geometry.sdo_point.x, 12) as CX, ROUND(a.geometry.sdo_point.y, 12) as CY, Z,
Count(*) as totalregistros ', sep = '')
04 > ElSql <- paste(ElSql, 'FROM AEMETDATA, AEMET a ', sep = '')
05 > ElSql <- paste(ElSql, 'WHERE AEMETDATA.ID = a.ID and TA IS NOT NULL ', sep = '')
06 > ElSql <- paste(ElSql, AND EXTRACT(year FROM FECHA) = 2011 and EXTRACT(month FROM
FECHA) = 7 and EXTRACT(day FROM FECHA) BETWEEN 1 AND 7 ', sep = '')
07 > ElSql <- paste(ElSql, 'group by AEMETDATA.ID, EXTRACT(year FROM FECHA), EXTRACT(month
FROM FECHA), EXTRACT(day FROM FECHA), a.geometry.sdo_point.x, a.geometry.sdo_point.y, z',
sep = '')
08 > ElSql <- paste(ElSql, 'order by EXTRACT(year FROM FECHA), EXTRACT(month FROM FECHA),
EXTRACT(day FROM FECHA), AEMETDATA.ID ', sep = '')
NOTA: La sintaxis SQL depende del motor de base de datos… (p. ej: alternativas “DBF“, “Sql-Server”)
09 > datosT_Raw <- sqlQuery(myCn, ElSql)
10> write.csv2(datosT_Raw, file=paste(getwd(), '/Data/DatosT_Mercator.csv', sep = ''))

15
4. Carga de datos
Desde archivo CSV:
01 > datos_Raw <- read.csv2(paste(getwd(), '/Data/DatosT_Mercator.csv', sep = ''))
Explorando los datos:
02 > class(datos_Raw)
03 > names (datos_Raw)
04 > str(datos_Raw)
05 > nrow(datos_Raw)
06 > ncol(datos_Raw)
Visual:
07 > plot(datos_Raw$CX, datos_Raw$T_MEDIA)
08 > plot(datos_Raw$CY, datos_Raw$T_MIN)
09 > plot(datos_Raw$CY, datos_Raw$T_MAX)
10 > plot(datos_Raw$CY, datos_Raw$T_MEDIA)
11 > abline(lm(T_MEDIA~CY, datos_Raw), col = "red", lty=1, lwd = 2)
12 > plot(datos_Raw$Z, datos_Raw$T_MEDIA)
13 > abline(lm(T_MEDIA~Z, datos_Raw), col = "red", lty=1, lwd = 2)

16
01 > datos2 <- subset(datos_Raw, CY > 33)
02 > nrow(datos2)
03 > plot(datos2$CY, datos2$T_MEDIA)
04 > abline(lm(T_MEDIA~CY, datos2), col = "red", lty=1, lwd = 2)
05 > plot(datos2$Z, datos2$T_MEDIA)
06 > abline(lm(T_MEDIA~Z, datos2), col = "red", lty=1, lwd = 2)

17
Datos espaciales (estructura en sp package):
Spatial
SpatialPoints … DataFrame
SpatialLines
SpatialPolygons
SpatialPixels
SpatialGrid
01 > library(rgdal)
02 > library(sp)
03 > datosGeo2 <- datos2
04 > coordinates (datosGeo2) <- c('CX', 'CY')
05 > class(datosGeo2)
06 > proj4string(datosGeo2) <- CRS("+init=epsg:4326")
07 > str(datosGeo2)
08 > datosUtm2 <- spTransform(datosGeo2, CRS("+init=epsg:23030"))

18
01 > class(datosGeo2@data)
02 > summary(datosGeo2@data$T_MEDIA)
03 > datosGeo2@bbox

19
01 > bubble(datosGeo2, "T_MEDIA", scales=list(draw=T), col="blue", pch=1, maxsize=1.5)

20
01 > library(maptools) 02 > gpclibPermit()
03 > SpainMask <- readShapeSpatial("C:R_EspacialDataMaskEspW.shp",
proj4string=CRS("+init=epsg:4326")) # WGS-84 (*)
04 > bubble(datosGeo2, "T_MEDIA", scales=list(draw=T), col="blue", pch=1, maxsize=3,
sp.layout=list("sp.polygons", SpainMask, col="red"))

21
# Un “grid” data frame:
01 > rango.x <- as.integer(range(datosUtm2@bbox[1,]))
02 > rango.y <- as.integer(range(datosUtm2@bbox[2,]))
03 > ElGrid_puntos <- expand.grid(x=seq(from=rango.x[1]-8000, to=rango.x[2]+8000,
by=4000), y=seq(from=rango.y[1]-8000, to=rango.y[2]+8000, by=4000))
04 > class(ElGrid_puntos) 05 > names(ElGrid_puntos)

22
# El data frame -> SpatialPoint:
01 > coordinates(ElGrid_puntos) <- ~ x+y
02 > class(ElGrid_puntos) # SpatialPoints
03 > proj4string(ElGrid_puntos) <- CRS("+init=epsg:23030")
04 > nrow(as.data.frame(ElGrid_puntos))
# overlay (Nota: debe haber otra forma … ):
05 > TodoElGrid_PuntosDataFrame <- SpatialPointsDataFrame(as.data.frame(ElGrid_puntos),
data=as.data.frame(rep(1,nrow(as.data.frame(ElGrid_puntos))))) # una columna
06 > SpainMaskUtm <- spTransform(SpainMask,CRS("+init=epsg:23030"))
07 > PointsInSpain <- overlay(TodoElGrid_PuntosDataFrame, SpainMaskUtm) # 1 (in)| NA (out)
08 > TodoElGrid_PuntosDataFrame$PointsInSpain=PointsInSpain # vector: correspondencia 1-1
09 > ElGrid <-na.exclude(as.data.frame(TodoElGrid_PuntosDataFrame))
10 > nrow(ElGrid)
11 > coordinates(ElGrid) <- ~ x+y
# El grid de tipo raster:
12 > gridded(ElGrid) <- TRUE 13 > class(ElGrid) # SpatialPixelsDataFrame
14 > proj4string(ElGrid) <- CRS("+init=epsg:23030")
15 > writeAsciiGrid(ElGrid,"C:/R_Espacial/Data/GridEsp4km.asc")
16 > writeSpatialShape(datosUtm2, "C:/R_Espacial/Data/Estaciones.shp")

01 > library(gstat)
02 > InterP.idw1 <- idw(T_MEDIA ~ 1, datosUtm2, ElGrid, idp = 1)
03 > InterP.idw2 <- idw(T_MEDIA ~ 1, datosUtm2, ElGrid, idp = 2)
04> library(latticeExtra)
05 > InterP <- ElGrid # Una copia del grid original para agregarle “bandas”
23
7. Interpolación determinística

01 > InterP[["IDW1"]] <- InterP.idw1$var1.pred
02 > InterP[["IDW2"]] <- InterP.idw2$var1.pred
03 > spplot(InterP, c("IDW1","IDW2"), names.attr = c("IDW_1", "IDW_2"), as.table =
TRUE, main = "IDW_1 / IDW_2", col.regions = grey(rev(seq(0,0.75,0.05))), par.settings
= list(panel.background=list(col="blue"))) +
04 > layer(sp.polygons(SpainMaskUtm, col='blue')) +
95 > layer(sp.points(datosUtm2, col='blue', pch = 20))
24
ver con “F1”

Índice
2. Inicio de R
4. Carga de datos
7. Interpolación determinística /exportar resultado
25

26
/exportar resultado
01 > library(sp)
02 > library(rgdal)
03 > library(gstat)
04 > library(latticeExtra)
05 > library(maptools)
06 > gpclibPermit()
07 > class(InterP)
08 > names(InterP)

/exportar resultado
01 > writeAsciiGrid(InterP.idw1,"C:/R_Espacial/Data/IDW1.asc")
02 > writeAsciiGrid(InterP.idw2,"C:/R_Espacial/Data/IDW2.asc")
27

… (ej. raster externo)
01 > library(raster)
02> library(rasterVis)
03 > ras_MED <- raster(paste(getwd(), '/Data/ctx12_mdt.tif' , sep = ''))
04 > pPlot <- levelplot(ras_MED, zscaleLog=1, par.settings=BTCTheme, xlim=c(-250000,
1000000), ylim=c(4000000, 5000000))
05> pPlot
28

01 > datos3 <- subset(datos_Raw, DIA == 1 & CY > 33) # la condición “AND”
02 > col_x <- 9 03 > col_y <- 10 04 > col_var <- 3 05 > datosGeo3 <- datos3
06 > coordinates(datosGeo3) <- c('CX', 'CY')
08 > datosUtm3 <- spTransform(datosGeo3,CRS("+init=epsg:23030"))
09 > par(mfrow=c(2,1), mar=c(4,4,4,4))
29

01 > library(geoR)
02 > vario.cloud1 <- variog(coords = as.data.frame(datosUtm3)[, col_x:col_y],
data = as.data.frame(datosUtm3)[col_var], max.dist=150000, op="cloud")
03 > plot(vario.cloud1, main="variograma (nube)", xlim = c(0, 2000))
04 > vario.smoothed10 <- variog(coords = as.data.frame(datosUtm3)[,
col_x:col_y], data = as.data.frame(datosUtm3)[col_var], max.dist=150000,
op="sm", band=10)
05> plot(vario.smoothed10, main="variograma (suavizado)", xlim = c(0, 2000), ylim =
c(0, 100))
06 > vario.binned1 <- variog(coords = as.data.frame(datosUtm3)[, col_x:col_y],
data = as.data.frame(datosUtm3)[col_var], max.dist=150000,
bin.cloud=TRUE)
07 > plot(vario.binned1, main="variograma (agrupadado)", xlim = c(0, 2000), ylim = c(0, 100))
08 > lines(vario.binned1, col = "red", lty=3)
08 > plot(vario.binned1, bin.cloud = T, ylim = c(0, 100))
30

31

32

8. Análisis de variograma:
empírico direccional
01 > library(sqldf)
02 > strSQL <- paste("select ESTACION, avg(T_MEDIA) as TMEDIA, min(T_MIN) as
TMIN, max(T_MAX) as TMAX, ANNIO, MES, CX, CY, Z from datos_Raw where
CY > 33 group by ESTACION, CX, CY, Z, ANNIO, MES", sep="")
03 > datos4 <- sqldf(strSQL)
04 > col_x <- 7 05 > col_y <- 8 06 > col_var <- 2 07 > datosGeo4 <- datos4
08 > coordinates(datosGeo4) <- c('CX', 'CY')
10 > datosUtm4 <- spTransform(datosGeo4,CRS("+init=epsg:23030"))
11 > vario <- variog(coords = as.data.frame(datosUtm4)[, col_x:col_y], data =
as.data.frame(datosUtm4)[col_var], max.dist=50000, bin.cloud=TRUE)
12 > par(mfrow=c(1,1), mar=c(4,4,4,4))
33

8. Análisis de variograma:
empírico direccional
01 > vario.0 <- variog(coords = as.data.frame(datosUtm4)[, col_x:col_y], data =
as.data.frame(datosUtm4)[col_var], max.dist=50000, dir=0, tol=pi/4)
as.data.frame(datosUtm4)[col_var], max.dist=50000, dir=45*pi/180, tol=pi/4)
as.data.frame(datosUtm4)[col_var], max.dist=50000, dir=90*pi/180, tol=pi/4)
as.data.frame(datosUtm4)[col_var], max.dist=50000, dir=135*pi/180,
tol=pi/4)
34

8. …empírico direccional
01 > plot(vario, type="l", col = "black", lty=2, xlim = c(0, 50000), ylim = c(0, 80))
02 > lines(vario.0, col = "darkgray", lty=1, xlim = c(0, 50000), ylim = c(0, 80))
03 > lines(vario.45, col = "blue", lty=3, xlim = c(0, 50000), ylim = c(0, 80))
04 > lines(vario.90, col = "red", lty=4, xlim = c(0, 50000), ylim = c(0, 80))
05 > lines(vario.135, col = "green", lty=5, xlim = c(0, 50000), ylim = c(0, 80))
35

01 > plot(vario, type="l", col = "black", lty=2, xlim = c(0, 10000), ylim = c(0, 80))
02 > lines(vario.0, col = "darkgray", lty=1, xlim = c(0, 10000), ylim = c(0, 80))
03 > lines(vario.45, col = "blue", lty=3, xlim = c(0, 10000), ylim = c(0, 80))
04 > lines(vario.90, col = "red", lty=4, xlim = c(0, 10000), ylim = c(0, 80))
05 > lines(vario.135, col = "green", lty=5, xlim = c(0, 10000), ylim = c(0, 80))
36
8. …empírico direccional

01 > a <- remove.duplicates(datosUtm4, zero = 50, remove.second = TRUE)
02 > datosUtm5 <- a
03 > vgmEmp <- variogram(TMEDIA ~ 1, datosUtm5, cutoff = 50000, alpha=0) #
dig bbox/3 # ,cutoff = 50000, alpha=c(0) = # 90º norte…
04 > plot(vgmEmp)
05 > vgmEmp <- variogram(TMEDIA ~ 1, datosUtm5) # diag.bbox/3 # omnidireccional
06 > plot(vgmEmp)
37
9. Modelo de variograma# library(gstat)

38
http://www.scielo.cl/scielo.php?script=sci_arttext&pid=S0717-92002003000200004&lng=en&nrm=iso&ignore=.html

01 > vgm()
02 > vgmModelo <- vgm(psill=10, model="Lin", range=400000, nugget = 5)
03 > vgmFitted <- fit.variogram(vgmEmp, model=vgmModelo)
04 > plot(vgmEmp, vgmFitted)
05 > str(vgmFitted)
39

01 > vgmModelo <- vgm(psill=10, model="Sph", range=50000, nugget = 5)
40

01 > vgmModelo <- vgm(psill=13, model="Gau", range=10267, nugget = 0)
41

01 > vgmModelo <- vgm(psill=73, model="Sph", range=3000000, nugget = 6.5)
42

01 > InterP.OK <- krige(TMEDIA ~ 1, datosUtm5, ElGrid, model = vgmFitted)
02 > names(InterP)
03 > InterP[["OK"]] <- InterP.OK$var1.pred
04 > names(InterP)
05 > spplot(InterP, c("OK"), names.attr = c("OK"), as.table = TRUE, main = “OK",
col.regions = grey(rev(seq(0,0.75,0.05))), par.settings =
list(panel.background=list(col="white"))) +
06 > layer(sp.polygons(SpainMaskUtm, col="orange", lwd = 3)) +
07 > layer(sp.points(datosUtm5, col="blue", pch = 20))
08 > writeAsciiGrid(InterP.OK,"C:/R_Espacial/Data/OK.asc")
43

44

01 > spplot(InterP, c("IDW1","IDW2", "OK"), names.attr = c("IDW_1", "IDW_2",
"OK"), as.table = TRUE, main = "IDW_1 - IDW_2 - OK", col.regions =
grey(rev(seq(0,0.75,0.05))), par.settings =
list(panel.background=list(col="white"))) +
02 > layer(sp.polygons(SpainMaskUtm, col="orange", lwd = 3)) +
03 > layer(sp.points(datosUtm5, col=“green", pch = 20))
45

46

01 > cv.ok <- krige.cv(TMEDIA ~ 1, datosUtm5, model = vgmFitted)
# leave-one-out cross validation # , nfold = 10
02 > cv.idw <- krige.cv(TMEDIA ~ 1, datosUtm5)
03 > names(cv.ok)
04 > tail(cv.ok$var1.pred)
05 > tail(cv.ok$observed)
06 > tail(datosUtm5)
07 > plot(cv.ok$observed, cv.ok$var1.pred)
08 > fn1 <- lm(var1.pred~observed, cv.ok)
09 > ElR2 <- summary(fn1)$r.squared
10 > ElR2 <- round(ElR2, 2)
11 > ElR <- cor(cv.ok$observed, cv.ok$var1.pred)
12 > ElR <- round(ElR, 2)
13 > abline(fn1, col = "red", lty=1, lwd = 2)
14 > title(main = paste("R^2 = ", ElR2, " | R = ", ElR, sep = ""))
47

# RMSE
01 > i <- 0
02 > misuma <- 0
03 > while (i < nrow(cv.ok))
{
dif1 <- cv.ok$var1.pred[i+1] - datosUtm5$TMEDIA[i+1]
misuma <- misuma + (dif1*dif1)
print(datosUtm5$TMEDIA[i+1])
print(datosUtm5$ESTACION[i+1])
print("-----------------------------------")
i <- i + 1
}
04 > misuma <- sqrt(misuma/nrow(cv.ok))
05 > misuma
49

# RMSE // juntando Data-Frames (para rel. con otras variables)
01 > names(datosUtm5)
02 > datosUtm5$OK <- -99.999
03 > datosUtm5$diff <- -99.999
04 > i <- 0
05 > while (i < nrow(cv.ok))
{
datosUtm5$OK[i+1] <- cv.ok$var1.pred[i+1]
datosUtm5$diff[i+1] <- cv.ok$var1.pred[i+1] - datosUtm5$TMEDIA[i+1]
i <- i + 1
}
06 > tail(datosUtm5)
07 > sqrt(sum(datosUtm5$diff * datosUtm5$diff) / nrow(cv.ok))
50

# Rel. difs. y otras variables
01 > cor(datosUtm5$Z, abs(datosUtm5$diff))
02 > plot(datosUtm5$Z, abs(datosUtm5$diff))
03 > abline(lm(abs(diff)~Z, datosUtm5), col = "red", lty=1, lwd = 2)
51

# Rel. difs. y otras variables
01 > cor(as.data.frame(datosUtm5)$x, abs(datosUtm5$diff))
02 > plot(as.data.frame(datosUtm5)$x, abs(datosUtm5$diff))
03 > abline(lm(abs(diff)~x, as.data.frame(datosUtm5)), col = "red", lty=1, lwd = 2)
52

# Script
JuntarDF_Y_RMSE <- function(DF, CV)
{
DF$OK1 <- -99.999
DF$diff1 <- -99.999
i <- 0
while (i < nrow(CV))
{
DF$OK1[i+1] <- CV$var1.pred[i+1]
DF$diff1[i+1] <- CV$var1.pred[i+1] - DF$TMEDIA[i+1]
i <- i + 1
}
El <- sqrt(sum(DF$diff1 * DF$diff1) / nrow(CV))
list(ElDF = DF, ElRMSE = El)
}
53

# Ejecutar el Script
01 > ResultadosOK <- JuntarDF_Y_RMSE(datosUtm5, cv.ok)
02 > names(ResultadosOK)
03 > tail(ResultadosOK$ElDF)
04 > ResultadosOK$ElRMSE
55

56
UML: Relaciones de agregación simple (padre/hijo)

Análisis espacial con R (asignatura de Master - UPM)

Más contenido relacionado

La actualidad más candente (10)

Destacado (20)

Similar a Análisis espacial con R (asignatura de Master - UPM) (20)

Más de Vladimir Gutierrez, PhD (20)

Último (20)

Análisis espacial con R (asignatura de Master - UPM)