I am trying to create a spatial dataset from a txt file imported in R and structured as follows:
CitiesTXTSel=
COM City_NAME LONGI_DMS LATI_DMS
445 VILLEMOTIER 51916 462046
98 CHAZEY-BONS 54054 454811
57 BOZ 45434 462425
When I use the function below I get the following error message:
"Error in .checkNumericCoerce2double(obj) : non-finite coordinates"
Cities= SpatialPointsDataFrame(coords=CitiesTXTSel[,3:4], data=CitiesTXTSel[,1:2], proj4string=CRS("+proj=longlat +datum=wgs84"))
I guess the pre-formatting of the cooridnates is not correct but I cannot figure out how to fix this. Please can you help? The imported coordinates are in Lat/long DMS.
# Reproducing your data frame
CitiesTXTSel <- data.frame(
COM = c(445, 98, 7),
City_NAME = c("VILLEMOTIER", "CHAZEY-BONS", "BOZ"),
LONGI_DMS = c(51916, 54054, 45434),
LATI_DMS = c(462046, 454811, 462425),
stringsAsFactors = FALSE
)
# a function to convert your input to decimal degrees
convert_DMS_dec <- function(DMS) {
DMS_pad <- sprintf("%7s", DMS)
deg <- substr(DMS_pad, 1, 3)
deg <- gsub(" ", "", deg) # remove leading whitespace
min <- substr(DMS_pad, 4, 5)
sec <- substr(DMS_pad, 6, 7)
DMS_split <- paste(deg, min, sec)
dec_deg <- conv_unit(DMS_split, "deg_min_sec", "dec_deg")
round(as.numeric(dec_deg), 4) # precision to about one arc-second
}
CitiesTXTSel$long <- convert_DMS_dec(CitiesTXTSel$LONGI_DMS)
CitiesTXTSel$lat <- convert_DMS_dec(CitiesTXTSel$LATI_DMS)
# re-order the data frame so columns three and four match your code
CitiesTXTSel <- CitiesTXTSel[, c(1:2, 5:6, 3:4)]
# Your code, indented a little for clarity
Cities= SpatialPointsDataFrame(
coords=CitiesTXTSel[,3:4],
data=CitiesTXTSel[,1:2],
proj4string=CRS("+proj=longlat +datum=wgs84")
)
and here's the resulting output of Cities:
coordinates COM City_NAME
(5.3211, 46.3461) 445 VILLEMOTIER
(5.6817, 45.8031) 98 CHAZEY-BONS
(4.9094, 46.4069) 7 BOZ
Related
Imagine a regular 0.5° grid across the Earth's surface. A 3x3 subset of this grid is shown below. As a stylized example of what I'm working with, let's say I have three polygons—yellow, orange, and blue—that for the sake of simplicity all are 1 unit in area. These polygons have attributes Population and Value, which you can see in the legend:
I want to turn these polygons into a 0.5° raster (with global extent) whose values are based on the weighted-mean Value of the polygons. The tricky part is that I want to weight the polygons' values based on not their Population, but rather on their included population.
I know—theoretically—what I want to do, and below have done it for the center gridcell.
Multiply Population by Included (the area of the polygon that is included in the gridcell) to get Pop. included. (Assumes population is distributed evenly throughout polygon, which is acceptable.)
Divide each polygon's Included_pop by the sum of all polygons' Included_pop (32) to get Weight.
Multiply each polygon's Value by Weight to get Result.
Sum all polygons' Result to get the value for the center gridcell (0.31).
Population
Value
Frac. included
Pop. included
Weight
Result
Yellow
24
0.8
0.25
6
0.1875
0.15
Orange
16
0.4
0.5
8
0.25
0.10
Blue
18
0.1
1
18
0.5625
0.06
32
0.31
I have an idea of how to accomplish this in R, as described below. Where possible, I've filled in code that I think will do what I want. My questions: How do I do steps 2 and 3? Or is there a simpler way to do this? If you want to play around with this, I have uploaded old_polygons as a .rds file here.
library("sf")
library("raster")
Calculate the area of each polygon: old_polygons$area <- as.numeric(st_area(old_polygons))
Generate the global 0.5° grid as some kind of Spatial object.
Split the polygons by the grid, generating new_polygons.
Calculate area of the new polygons: new_polygons$new_area <- as.numeric(st_area(new_polygons))
Calculate fraction included for each new polygon: new_polygons$frac_included <- new_polygons$new_area / new_polygons$old_area
Calculate "included population" in the new polygons: new_polygons$pop_included <- new_polygons$pop * new_polygons$frac_included
Calculate a new attribute for each polygon that is just their Value times their included population. new_polygons$tmp <- new_polygons$Value * new_polygons$frac_included
Set up an empty raster for the next steps: empty_raster <- raster(nrows=360, ncols=720, xmn=-180, xmx=180, ymn=-90, ymx=90)
Rasterize the polygons by summing this new attribute together within each gridcell. tmp_raster <- rasterize(new_polygons, empty_raster, "tmp", fun = "sum")
Create another raster that is just the total population in each gridcell: pop_raster <- rasterize(new_polygons, empty_raster, "pop_included", fun = "sum")
Divide the first raster by the second to get what I want:
output_raster <- empty_raster
values(output_raster) <- getValues(tmp_raster) / getValues(pop_raster)
Any help would be much appreciated!
Example data:
library(terra)
f <- system.file("ex/lux.shp", package="terra")
v <- vect(f)
values(v) <- data.frame(population=1:12, value=round(c(2:13)/14, 2))
r <- rast(ext(v)+.05, ncols=4, nrows=6, names="cell")
Illustrate the data
p <- as.polygons(r)
plot(p, lwd=2, col="gray", border="light gray")
lines(v, col=rainbow(12), lwd=2)
txt <- paste0(v$value, " (", v$population, ")")
text(v, txt, cex=.8, halo=TRUE)
Solution:
# area of the polygons
v$area1 <- expanse(v)
# intersect with raster cell boundaries
values(r) <- 1:ncell(r)
p <- as.polygons(r)
pv <- intersect(p, v)
# area of the polygon parts
pv$area2 <- expanse(pv)
pv$frac <- pv$area2 / pv$area1
Now we just use the data.frame with the attributes of the polygons to compute the polygon-cover-weighted-population-weighted values.
z <- values(pv)
a <- aggregate(z[, "frac", drop=FALSE], z[,"cell",drop=FALSE], sum)
names(a)[2] <- 'fsum'
z <- merge(z, a)
z$weight <- z$population * z$frac / z$fsum
z$wvalue <- z$value * z$weight
b <- aggregate(z[, c("wvalue", "weight")], z[, "cell", drop=FALSE], sum)
b$bingo <- b$wvalue / b$weight
Assign values back to raster cells
x <- rast(r)
x[b$cell] <- b$bingo
Inspect results
plot(x)
lines(v)
text(x, digits=2, halo=TRUE, cex=.9)
text(v, "value", cex=.8, col="red", halo=TRUE)
This may not scale very well to large data sets, but you could perhaps do it in chunks.
This is fast and scalable:
library(data.table)
library(terra)
# make the 3 polygons with radius = 5km
center_points <- data.frame(lon = c(0.5, 0.65, 1),
lat = c(0.75, 0.65, 1),
Population = c(16, 18, 24),
Value = c(0.4, 0.1, 0.8))
polygon <- vect(center_points, crs = "EPSG:4326")
polygon <- buffer(polygon, 5000)
# make the raster
my_raster <- rast(nrow = 3, ncol = 3, xmin = 0, xmax = 1.5, ymin = 0, ymax = 1.5, crs = "EPSG:4326")
my_raster[] <- 0 # set the value to 0 for now
# find the fractions of cells in each polygon
# "cells" gives you the cell ID and "weights" (or "exact") gives you the cell fraction in the polygon
# using "exact" instead of "weights" is more accurate
my_Table <- extract(my_raster, polygon, cells = TRUE, weights = TRUE)
setDT(my_Table) # convert to datatable
# merge the polygon attributes to "my_Table"
poly_Table <- setDT(as.data.frame(polygon))
poly_Table[, ID := 1:nrow(poly_Table)] # add the IDs which are the row numbers
merged_Table <- merge(my_Table, poly_Table, by = "ID")
# find Frac_included
merged_Table[, Frac_included := weight / sum(weight), by = ID]
# find Pop_included
merged_Table[, Pop_included := Frac_included * Population]
# find Weight, to avoid confusion with "weight" produced above, I call this "my_Weight"
merged_Table[, my_Weight := Pop_included / sum(Pop_included), by = cell]
# final results
Result <- merged_Table[, .(Result = sum(Value * my_Weight)), by = cell]
# add the values to the raster
my_raster[Result$cell] <- Result$Result
plot(my_raster)
I have two raster grids in R with different resolutions which don't line up exactly. In actual fact I have hundreds of each so any answer must be easily run many times.
I want to scale the finer resolution grid up to the coarser resolution by taking an areal weighted mean of the grid cells.
I was hoping I could use projectRaster or resample but neither give the desired output and I cannot use aggregate as I need my new grids to align to the coarser resolution grid.
For my real data my finer grid is 0.005 deg intervals and coarser is at 0.02479172 deg intervals and extents/origins don't exactly match up.
I've made an extreme version as an example why neither resample or projectRaster work
library(raster)
#> Warning: package 'raster' was built under R version 3.5.3
#> Loading required package: sp
testproj <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
testmat <- matrix(1, nrow = 8, ncol = 8)
# testmat <- matrix(sample(1:10, 64, replace = T), nrow = 8, ncol = 8)
testmat[1,5] <- 400
testmat[8,4] <- -400
testsmallraster <- raster(testmat, xmn=0, xmx=8, ymn=0, ymx=8)
crs(testsmallraster) <- testproj
plot(testsmallraster)
testlarger <- raster(matrix(rep(NA,4), nrow = 2, ncol = 2), xmn=0.3, xmx=8.3, ymn=0, ymx=8)
crs(testlarger) <- testproj
tout_reproj <- projectRaster(testsmallraster, testlarger)
tout_resamp <- resample(testsmallraster, testlarger)
tout_resampngb <- resample(testsmallraster, testlarger, method = "ngb")
tout_agg <- aggregate(testsmallraster, fact = 4)
#reprojected values ignore all but 4 cells closest to new centre
values(tout_reproj)
#> [1] 1 1 1 1
#resample uses bilinear interpolation which weights the grids cells furthest from the new centre less than those closest
# I need all grid cells entirely contained in the new grid to have equal weighting
#bilinear interpolation also weights cells which do not fall within the new cell at all which I do not want
values(tout_resamp)
#> [1] 10.851852 15.777778 -7.911111 -12.366667
#aggregate gives close to the values I want but they are not in the new raster origin/resolution and therefore not splitting values that fall across grid boundaries
values(tout_agg)
#> [1] 1.0000 25.9375 -24.0625 1.0000
#using ngb was never really going to make any sense but thought I'd as it for completeness
values(tout_resampngb)
#> [1] 1 1 1 1
#desired output first cell only 0.3 of a grid cell covers the grid cell = 400 the rest equal 1
#desired output second cell 0.7 of a grid cell covers the grid cell = 400 the rest equal 1
#desired output third cell has exactly 1 grid cell of -400 and 15 of 1
#desired output fourth cell only overlap grid cells = 1
desiredoutput <- raster(matrix(c((15.7*1+0.3*400)/16,(15.3*1+0.7*400)/16,mean(c(-400, rep(1,15))),1),byrow = T, nrow = 2, ncol = 2), xmn=0.3, xmx=8.3, ymn=0, ymx=8)
values(desiredoutput)
#> [1] 8.48125 18.45625 -24.06250 1.00000
Created on 2020-07-02 by the reprex package (v0.3.0)
You can get closer to the desired result by using a similar spatial resolution for resample, and then aggregate the results
library(raster)
testproj <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +datum=WGS84"
testmat <- matrix(1, nrow = 8, ncol = 8)
testmat[1,5] <- 400
testmat[8,4] <- -400
testsmallraster <- raster(testmat, xmn=0, xmx=8, ymn=0, ymx=8, crs=testproj)
testlarger <- raster(matrix(rep(NA,4), nrow = 2, ncol = 2), xmn=0.3, xmx=8.3, ymn=0, ymx=8, crs = testproj)
y <- disaggregate(testlarger, 4)
z <- resample(testsmallraster, y)
za <- aggregate(z, 4)
values(za)
#[1] 8.48125 18.45625 -24.06250 1.00000
for much better speed, try terra
library(terra)
a <- rast(testsmallraster)
b <- rast(testlarger)
b <- disaggregate(b, 4)
d <- resample(a, b)
da <- aggregate(d, 4)
values(da)
# layer
#[1,] 8.48125
#[2,] 18.45625
#[3,] -24.06250
#[4,] 1.00000
This probably ought to be done automatically by resample and project(Raster). raster attempts to do some of this for resample, but in this case not very satisfactorily.
When I needed to do similar resampling, this worked for me. This example is a 4-cell destination grid at 1o x 1o spacing with centroids at half degrees (to match some satellite data), and an offset half-degree grid for source data (ECMWF weather). 'Resample' does the heavy lifting of interpolating on mismatched grids. The code below is basically a manual version of a 'weights=' option that doesn't exist for resample. We need relative, not absolute, areas to be correct for weighting, so the caveat on the precision of raster::area described in the help seems of low concern.
library(raster)
wgs84 <- "+init=epsg:4326"
polar.brick.source <- array(dim = c(5, 5, 2), rep(c(1, 2), each = 25))
dimnames(polar.brick.source)[[1]] <- seq(-1, 1, by = .5)
dimnames(polar.brick.source)[[2]] <- seq(80, 82, by = .5)
dimnames(polar.brick.source)[[3]] <- c("time.a", "time.b")
# Add some outliers to see their effects.
polar.brick.source[1, 2, ] <- c(25, 50)
polar.brick.source[3, 2, 2] <- -30
polar.brick <- brick(polar.brick.source, crs = CRS(wgs84),
xmn = min(as.numeric(dimnames(polar.brick.source)[[1]])) - .25,
xmx = max(as.numeric(dimnames(polar.brick.source)[[1]])) + .25,
ymn = min(as.numeric(dimnames(polar.brick.source)[[2]])) - .25,
ymx = max(as.numeric(dimnames(polar.brick.source)[[2]])) + .25)
fine.polar.area <- raster::area(polar.brick)
polar.one.degree.source <- data.frame(
lon = c(-.5, .5, -.5, .5),
lat = c(80.5, 80.5, 81.5, 81.5),
placeholder = rep(1, 4))
polar.one.degree.raster <- rasterFromXYZ(polar.one.degree.source, crs = CRS(wgs84))
polar.one.degree.area <- raster::area(polar.one.degree.raster)
as.data.frame(polar.one.degree.area, xy = T)
fine.clip.layer <- disaggregate(polar.one.degree.raster, 2)
clipped.fine.polar <-resample(polar.brick * fine.polar.area,
fine.clip.layer)
new.weighted.wx <- aggregate(clipped.fine.polar * 4, 2)
as.data.frame(new.weighted.wx, xy = T) # look at partial results.
new.weather <- new.weighted.wx / polar.one.degree.area
as.data.frame(new.weather, xy = T)
First, I managed to extract the average raster temperature values for each polygon, with the following program:
You can download the GIS layers on this link :
https://depots.univ-perp.fr/get?k=iTzEDSUkdyZVw2st78G
## load packages
library(raster); library(rgdal)
## Read rasters
ras_temp<-raster("ras_temp.tif")
plot(ras_temp)
ras_alti<-raster("ras_alti.tif")
## read polygon
polygon <- readOGR(dsn = getwd(), layer = "polygon")
plot(polygon,add=TRUE)
## extract mean value for each polygon
v1 <- extract( ras_temp, polygon, fun=mean, na.rm=TRUE)
nom <- sapply(polygon#polygons, slot, "ID")
v1 <- data.frame(ID = nom, Value = v1)
View(v1)
Then, I want to extract the mean values of the temperature for each polygon but only for the surfaces that exceed 600 m of altitude?
Unfortunately, I can not do it, my question how to integrate the altitude condition in my function "extract"?
Thanks in advance
You can easily do it like this:
# first resample the altitude raster to the temperature one so that they are
# "aligned"
ras_alti.new = resample(ras_alti, ras_temp, "bilinear")
# set to NA all data in ras_temp corresponding to cells in ras_alti.new below 600
# metre
ras_temp.new = ras_temp
ras_temp.new[ras_alti.new <= 600] = NA
# extract the data
v2 <- extract(ras_temp.new, polygon, fun=mean, na.rm=TRUE, sp = T)
v2#data
ID ras_temp
0 417 64.11342
1 433 68.53541
I have a LiDAR point cloud data for a dimension of 250*250 m^2 area (a forest region). I need to separate out individual trees using that data.
I created Canopy Height Model(CHM) using LASTools and used that CHM for tree delineation. I'm attaching that chm file (this raster will give the height information)
I tried to use rLiDAR package available in R.
I coded like this
library(rLiDAR)
schm <- CHMsmoothing(chm, "mean", 5)
# Setting the fws:
fws <- 5 # dimention 5x5
# Setting the specified height above ground for detectionbreak
minht <- 8.0
# Getting the individual tree detection list
treeList <- FindTreesCHM(schm, fws, minht)
But it's giving an error
Error: identicalCRS(x, y) is not TRUE
How can I overcome this?
In function FindTreesCHM, at lines 17-18, we find:
XYmax <- SpatialPoints(xyFromCell(setNull, Which(setNull ==
1, cells = TRUE)))
Which creates a SpatialPoints. The problem is that object has no projection set:
projection(XYmax)
# [1] NA
Then, the line 19
htExtract <- over(XYmax, as(chm, "SpatialGridDataFrame"))
Throws an error because XYmax has no projection set, while chm has:
projection(chm)
# [1] "+proj=utm +zone=11 +datum=WGS84 +units=m +no_defs +ellps=WGS84 +towgs84=0,0,0"
And as function over first check the projections of objects, we get the error:
identicalCRS(XYmax, as(chm, "SpatialGridDataFrame"))
# [1] FALSE
A workaround would be to write your own function, adding a line setting the projection of XYmax to the projection of chm.
Also, there is an error thrown by the line 22 because of line 21.
This function can be easily fixed, but I would highly recommend to contact the maintainer of the package (maintainer("rLiDAR")).
Here is one possible fix:
library(rLiDAR)
library(raster)
FindTreesCHM.fix <- function(chm, fws = 5, minht = 1.37)
{
if (class(chm)[1] != "RasterLayer") {
chm <- raster(chm)
}
if (class(fws) != "numeric") {
stop("The fws parameter is invalid. It is not a numeric input")
}
if (class(minht) != "numeric") {
stop("The minht parameter is invalid. It is not a numeric input")
}
w <- matrix(c(rep(1, fws * fws)), nrow = fws, ncol = fws)
chm[chm < minht] <- NA
f <- function(chm) max(chm)
rlocalmax <- focal(chm, fun = f, w = w, pad = TRUE, padValue = NA)
setNull <- chm == rlocalmax
XYmax <- SpatialPoints(xyFromCell(setNull, Which(setNull ==
1, cells = TRUE)))
projection(XYmax) <- projection(chm)
htExtract <- over(XYmax, as(chm, "SpatialGridDataFrame"))
treeList <- cbind(slot(XYmax, "coords"), htExtract)
colnames(treeList) <- c("x", "y", "height")
return(treeList)
}
chm <- raster("dem_test.tif")
schm <- CHMsmoothing(chm, "mean", 5)
fws <- 5
minht <- 8.0
treeList <- FindTreesCHM.fix(schm, fws, minht)
# x y height
# 1 256886.5 4110940 14.1200
# 2 256805.5 4110884 13.8384
# 3 256756.5 4110880 15.2004
# 4 256735.5 4110874 17.6100
# 5 256747.5 4110840 18.2592
# 6 256755.5 4110828 19.9252
# 7 256777.5 4110806 12.7180
# 8 256780.5 4110802 14.6512
# 9 256780.5 4110792 15.8532
# 10 256763.5 4110786 18.7128
# 11 256766.5 4110764 14.4972
I am a green-hand on R code. Now I meet some trouble in plotting contour figure by using R code.
I have checked help(filled.contour) which tells that if you want to plot the contour, x,y should be both in ascending order. Actually, I receive the data randomly, like:
latitude, longitude, value
37.651098 140.725082 9519
37.650765 140.725248 9519
37.692738 140.749118 23600
37.692737 140.749118 9911
37.692695 140.749107 16591
37.692462 140.74902 6350
37.692442 140.749052 5507
37.692413 140.749148 5476
37.692383 140.74929 7069
37.692357 140.749398 6152
37.692377 140.749445 6170
37.692355 140.749587 7163
37.692298 140.749672 6831
37.692292 140.749787 6194
37.692283 140.749903 6696
37.692342 140.750007 8204
37.692585 140.750037 2872
37.692648 140.749948 3907
37.692655 140.749827 4891
37.692667 140.749687 4899
How can I plot the contour figure!?
Here is my code:
args <- commandArgs(trailingOnly = TRUE)
data1 <- args[1]
outputDir <- args[2]
outputFig = paste(outputDir, "Cs13x.jpeg",sep="");
jpeg(file = outputFig, width = 800,height=600, pointsize=20)
pinkcol <- rgb(1,0.7,0.7)
gpsdata <- read.table(file=data1,sep=" ");
lat <- as.vector(gpsdata[,1]);
lon <- as.vector(gpsdata[,2]);
datas <- as.vector(gpsdata[,3]);
datas <- abs(datas)
#---Convert gpsdata into x,y coordinate---#
# Convert degree into value
lat_pi <- lat*pi/180;
lon_pi <- lon*pi/180;
# calculate the value into corresponding x,y coordinate
x = cos(lat_pi) * cos(lon_pi);
y = cos(lat_pi) * sin(lon_pi);
#----------#
dataMatrix = matrix(datas, nrow = length(datas), ncol=length(datas));
plot.new()
filled.contour(sort(x),sort(y, decreasing = TRUE),dataMatrix, col = rainbow(100), main="Contour Figure of Cs13x"); (**WRONG HERE!!!**)
dev.off()
<-------------- FINISH LINE ----------->
The 'akima' package will do it. It is designed to handle irregularly spaced z values. The first two points were widely separated from the rest and that made the results from the whole dataset look rather sketchy, so I omitted them.
require(akima)
gps.interp <- with( gpsdata[-(1:2), ], interp(x=latitude, y=longitude, z=value))
contour(gps.interp)