I am trying to model overland (surface) water flow from specified origin points to a single downslope goal point using the gdistance shortestPath function. I need help with defining the appropriate transitionFunction for this, as I need to make sure the least cost path only allows water to flow along the path to elevation cells of equal or lesser value than the previous cell. The transitionFunction in the example below selects the minimum elevation cell but, based on the transitionFunction I have defined, this value may still be greater than the previous cell value.
I realize that, when the above is defined as I want it, the path may terminate before reaching the goal point. This is fine, although I would ideally like to be able to preserve the path from the origin to wherever it terminates if possible.
Also, if anyone knows of a different R package capable of modelling this kind of thing, please let me know.
library(gdistance)
library(raster)
library(elevatr)
library(sp)
#load example DEM raster
data(lake)
elevation <- get_elev_raster(lake, z = 9)
#remove negative elevation values from raster
elevation[elevation < 0] <- NA
#create origin and goal points with same projection as elevation raster
origin <- SpatialPoints(cbind(1790000, 640000), proj4string = CRS("+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0"))
goal <- SpatialPoints(cbind(1820000, 540000), proj4string = CRS("+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0"))
#create df data and convert to SpatialPointsDataFrame
odf <- data.frame("flowreg" = 1)
gdf <- data.frame("flowreg" = 2)
origindf <- SpatialPointsDataFrame(origin, odf)
goaldf <- SpatialPointsDataFrame(goal, gdf)
trCost1 <- transition(elevation, transitionFunction=function(x) 1/min(x), directions=8)
trCost1gc <- geoCorrection(trCost1, type="c")
plot(raster(trCost1))
sPath1 <- shortestPath(trCost1, origin, goal,
output="SpatialLines")
plot(elevation)
plot(origindf, add = TRUE, col='red', cex = 5)
plot(goaldf, add = TRUE, col='green', cex = 5)
lines(sPath1)
I have found the GRASS GIS (accessed in R using rgrass7) r.drain function OR raster::flowPath achieve what I am trying to do in the above question.
Related
I would like to project one raster onto another and while doing so I think the values are changing their position "to the north".
Is this an expected behavior?
I was hoping to create a longlat raster to use it for lookups and GeoJSON generation.
Strangely (or maybe expected, I don't know) resulting GeoJSON positions are shifted (what feels like 10km) to the north.
Do I have a logical mistake somewhere?
This is an example:
x <- raster(ncol=900, nrow=900)
x_proj <- "+proj=stere +lat_0=90 +lat_ts=90 +lon_0=10 +k=0.93301270189 +x_0=0 +y_0=0 +a=6378137 +b=6356752.3142451802 +to_meter=1000 +no_defs "
proj <- CRS(x_proj)
extent(x) <- extent(-523.4622, 376.5378, -4658.645, -3758.645)
projection(x) <- x_proj
x[seq(450,455),seq(1,900)]<-1
new_raster<-raster(ncols=900,nrows=900)
new_raster_crs<- "+proj=longlat +datum=WGS84 +zone=34 +no_defs +ellps=WGS84"
new_raster_proj <- CRS(new_raster_crs)
extent(new_raster) <- extent(3.5889,14.6209, 47.0705, 54.7405)
projection(new_raster) <- new_raster_proj
new_raster<-projectRaster(x,new_raster,method = "bilinear")
Plot of raster x
Plot of Raster new_raster
Is there something I could to with source/dest raster to create a "true" longlat lookup / GeoJSON possibility?
Is there a mistake somewhere ?
Can i maybe change +y_0=0 value to correct this?
If thats the case how can I get the exact value of shift?
Currently I only see the change visually.
That is as expected. Map projections distort (at least one of) shape, size, distance, and direction. In this case, you observe a change in shape.
You do make a mistake here:
new_raster_crs <- "+proj=longlat +datum=WGS84 +zone=34 +no_defs +ellps=WGS84"
"zone" is only relevant for the "UTM" coordinate reference system (and perhaps others), and if you define a datum, you should not also define an ellipsoid. So it should be
new_raster_crs <- "+proj=longlat +datum=WGS84"
But it seems that the other parts you add are simply ignored.
Another mistake is that you still use raster, as it has been replaced by terra. With terra it goes like this:
library(terra)
x <- rast(ncol=900, nrow=900, ext=c(-523.4622, 376.5378, -4658.645, -3758.645),
crs="+proj=stere +lat_0=90 +lat_ts=90 +lon_0=10 +k=0.93301270189 +x_0=0 +y_0=0 +a=6378137 +b=6356752.3142451802 +to_meter=1000 +no_defs")
x[seq(450,455),seq(1,900)]<-1
y <- rast(ncols=900, nrows=900, ext= c(3.5889,14.6209, 47.0705, 54.7405), crs="+proj=longlat +datum=WGS84")
z <- project(x, y)
plot(z)
I want to stack 6 rasters in a list called allrasters but first must fix crs and extent inconsistencies. Here is my code attempt to set the second raster in list to the crs of the third raster in list:
projectRaster(allrasters[[2]], crs=crs(allrasters[[3]]))
However when I run this code and check, allrasters[[2]] is still proj.merc and nothing has changed...
Raster information:
crs(allrasters[[2]])
CRS arguments:
+proj=merc +a=6378137 +b=6378137 +lat_ts=0 +lon_0=0
+x_0=0 +y_0=0 +k=1 +units=m +nadgrids=#null +wktext
+no_defs
crs(allrasters[[3]])
CRS arguments:
+proj=aea +lat_0=0 +lon_0=-120 +lat_1=34 +lat_2=40.5
+x_0=0 +y_0=-4000000 +datum=NAD83 +units=m +no_defs
I assume that what you are after is:
allrasters[[2]] <- projectRaster(allrasters[[2]], crs=crs(allrasters[[3]]))
That is, you forgot to assign the output of projectRaster
I think you need a few steps:
you need to get all of your rasters in the same projection
you need to find the full extent of all rasters as if they were mosaicked together
you need to resample your rasters so that they have the same extent, resolution, and projection
you will stack your rasters.
Here is an example I created with some fake data that should help you accomplish this:
##Loading necessary packages##
library(raster)
library(rgeos)
library(tmaptools)
#For reproducibility#
set.seed(52)
##Creating fake rasters with different extents and projections##
R1<-raster(nrow=100, ncol=100, xmn=44.52, xmx=45.1, ymn=-122.1, ymx=-121.2, crs=crs("+init=epsg:4267"))
R2<-raster(nrow=100, ncol=100, xmn=44.49, xmx=45.8, ymn=-122.0, ymx=-121.3, crs=crs("+init=epsg:4326"))
R3<-raster(nrow=100, ncol=100, xmn=44.48, xmx=45.1, ymn=-122.5, ymx=-121.5, crs=crs("+init=epsg:4979"))
R4<-raster(nrow=100, ncol=100, xmn=44.55, xmx=45.6, ymn=-122.2, ymx=-121.0, crs=crs("+init=epsg:4269"))
values(R1)<-rnorm(10000, 500, 10)
values(R2)<-rnorm(10000, 1000, 60)
values(R3)<-rnorm(10000, 300, 10)
values(R4)<-rnorm(10000, 2500, 70)
##Creating a list of the rasters##
tmp<-list(R1,R2,R3,R4)
##Looping to reproject the rasters all into the same projection##
allras<-list()
for (i in 1:length(tmp)){
if(i==1){
allras[[i]]<-tmp[[i]]
}else{
allras[[i]]<-projectRaster(tmp[[i]], crs=crs(tmp[[1]]))
}
}
##Creating a function to make a polygon of each raster's extent##
fxn<-function(ras){
bb<-bbox(ras)
bbpoly<-bb_poly(bb)
st_crs(bbpoly)<-crs(ras)
return(as_Spatial(bbpoly))
}
ext<-lapply(allras, fxn)
##Aggregating and dissolving all extents to get the full extent of all rasters##
full.ext<-aggregate(do.call(bind, ext), dissolve=TRUE)
##Creating a blank raster with the full extent, the desired final projection, and the desired resolution##
blank<-raster(ext=extent(full.ext), nrow=allras[[1]]#nrows, ncol=allras[[1]]#ncols, crs=allras[[1]]#crs)
##Resampling all rasters in the list to the desired extent and resolution##
rastostack<-lapply(allras, resample, y=blank)
##Stacking the rasters##
Ras<-stack(rastostack)
I have a SpatialPoints object with the coordinates for several points of interest.
I also have several shapefiles (polygons) with information about the presence of slums. The polygons with info about slums in each of these shapefiles can overlap (they provide somewhat the same information about the presence of slums, but come from different sources).
For each of the points in my SpatialPoints object, I have used the function spCircle to create a circular polygon around each point. What I need to do next is to check what percentage of the area of the circular polygon contains slums. If any of the shapefiles indicates that the slum is present, I will consider that there is a slum in the area.
I have created the following image to help explain my issue. The circles represent the polygon around a single point. For this single point, each of the four shapefiles indicates that the slum is present in somewhat different areas (sometimes they overlap, and sometimes they do not). I want to be able to find the red area (where none of the shapefiles indicate the presence of the slum, and then calculate the percentage of the circle that has slums.
The following code is an attempt to do that:
# Create data with coordinates
lat = c(-22.868879628748203,-22.88511,-22.82166,-22.89692,-22.67945)
long = c(-43.237195000177564,-43.34278,-43.04717,-43.35168,-43.59667)
data_points = cbind.data.frame(lat,long)
coordinates(data_points) = c("lat","long")
proj4string(data_points) = CRS("+init=epsg:4326")
# Transform projection of points to UTM
utmStr <- "+proj=utm +zone=%d +datum=NAD83 +units=m +no_defs +ellps=GRS80"
crs <- CRS(sprintf(utmStr, 23))
data_points = spTransform(data_points, crs)
# Create a list with circular polygons around each point (radius = 2000 meters)
circular_grid = list()
for (i in 1:length(data_points)){
spc = spCircle(radius = 2000, centerPoint = c(x=as.numeric(data_points#coords[i,1]), y=as.numeric(data_points#coords[i,2])), spID=i,
spUnits = CRS("+proj=utm +zone=23 +datum=NAD83 +units=m +no_defs"))
circular_grid[[i]] = spc
}
# For each circle, check the percentage that overlaps with several different shapefiles:
# I first use gUnion to merge all the shapefiles with info about slums together
allShapes = gUnion(shape1,shape2)
allShapes = gUnion(allShapes, shape3)
allShapes = gUnion(allShapes, shape4)
allShapes = gUnion(allShapes, shape5)
allShapes = gUnion(allShapes, shape6)
allShapes = as(allShapes, "SpatialPolygonsDataFrame")
allShapes = spTransform(allShapes, CRS("+proj=utm +zone=23 +datum=NAD83 +units=m +no_defs"))
# I am unable to reproduce the object "allShapes" (I do not know how),
# but this is its information
# class : SpatialPolygonsDataFrame
# features : 1
# extent : 633347.1, 724692.1, -2547787, -2513212 (xmin, xmax, ymin, ymax)
# crs : +proj=utm +zone=23 +datum=NAD83 +units=m +no_defs
# variables : 1
# names : dummy
# value : 0
# Next, to get the intersection, I tried the following:
intersection_circle_shape = list()
for (i in 1:length(circular_grid)){
circle = circular_grid[[i]][["spCircle"]]
inter = intersect(circle, allShapes)
intersection_circle_shape[[i]] = inter
}
# The list "intersection_circle_shape" is empty because the command
# "intersect" says that there is no intersection, but I know there is.
Any ideas?
Apparently NOAA and the NWS use a non-traditional projection for some of their rainfall data and don't offer a lot of help in terms of projecting it to a traditional format for other users. I've had a bit of success in getting the raster to overlay for part of the United States but it still isn't quite right.
I'm hoping someone can help me decipher what I am missing and correct the projection of this data.
You can find more information of this data here: https://polyploid.net/blog/?p=216
https://water.weather.gov/precip/download.php
library(tidyverse)
library(raster)
library(rgdal)
library(sp)
setwd("C:/Users/MPE_Data/")
file_list <- list.files("201809")
grib0<-raster::brick("201809//ST4_2018091307_24h.nc", varname="APCP_SFC")[[1]]
grib0#crs
crs(grib0) <- "+proj=longlat +a=6371200 +b=6371200 +no_defs"
crs(grib0) <- "+proj=stere +lat_0=90 +lat_ts=60 +lon_0=-105 +x_0=0 +y_0=0 +a=6371200 +b=6371200 +units=m +no_defs"
us_shp <- rgdal::readOGR("C:/Users/cb_2017_us_state_500k/US_clipped.shp")
shp <- rgdal::readOGR("C:/Users/nc_sc_counties_wgs1984.shp")
wgs<-"+proj=longlat +datum=WGS84 +ellps=WGS84 +no_defs"
wgsraster <- projectRaster(grib0, crs=wgs)
plot(wgsraster)
shp <- spTransform(shp, CRS(wgs))
us_shp <- spTransform(us_shp, CRS(wgs))
plot(shp,add=TRUE)
plot(us_shp,add=TRUE)
I couldn't find your exact map but here is an example using recent precipitation data. You don't need to assign a CRS as the netCDF file already has a CRS associated with it, you can simply projectRaster. Also the NOAA website has the option to download to geoTIFF which I would recommend if you are more comfortable with that.
require(raster)
require(ncdf4)
require(maptools)
data(wrld_simpl)
us_shp=wrld_simpl[which(wrld_simpl$NAME=="United States"),]
rs=raster::brick("./nws_precip_1day_20200509_netcdf/nws_precip_1day_20200509_conus.nc",varname="observation")[[1]]
rs#crs ##note already has a crs associated with it
+proj=stere +lat_0=90 +lat_ts=60 +lon_0=-105 +x_0=0 +y_0=0 +a=6371200
+b=6371200 +units=m +no_defs
##assign the pixels with -10000 to NA.
NAvalue(rs) = -10000
##reproject to longlat WGS84
rs=projectRaster(rs,crs=crs(us_shp))
plot(rs,col=rainbow(100))
lines(us_shp)
##note the data extends outside the bounds of country
##use mask to remove data that is not over the land area
rs=mask(rs,us_shp)
plot(rs,col=rainbow(100)
lines(us_shp)
Note that the maximum value of rs changed from 7.8 to 7.0 due to the bilinear interpolation method used in projectRaster. You need to consider whether you require bilinear or nearest neighbour interpolation and if you need to be specific about the output raster resolution and extent I would suggest supplying a model raster for the to argument.
Edited to incorporate #Robert Hijmans' suggestion.
sI have the dataset (pts) like this:
x <- seq(-124.25,length=115,by=0.5)
y <- seq(26.25,length=46,by=0.5)
z = 1:5290
longlat <- expand.grid(x = x, y = y) # Create an X,Y grid
pts=data.frame(longlat,z)
names(pts) <- c( "x","y","data")
I knew that I can map the dataframe (pts） into a map by doing:
library(sp)
library(rgdal)
library(raster)
library(maps)
coordinates(pts)=~x+y
proj4string(pts)=CRS("+init=epsg:4326") # set it to long, lat
pts = spTransform(pts,CRS(" +init=epsg:4326 +proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0"))
pts <- as(pts, "SpatialPixelsDataFrame")
r = raster(pts)
projection(r) = CRS(" +init=epsg:4326 +proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0")
plot(r)
map("usa",add=T)
Now I would like to create a separate map which shows the means of pts across different regions. The shapefile I want to use is from ftp://ftp.epa.gov/wed/ecoregions/cec_na/NA_CEC_Eco_Level2.zip , however, this is a north america map. How can I create the map showing only US based on this north america map? Or is there another better way to do this? thanks so much.
I think that cutting out the non-US data based on the data in the shapefile alone would be hard, since the regions do not correspond to political boundaries - that could be done with rgeos though.
Assuming that "eco" is a SpatialPolygonsDataFrame read in by rgdal::readOGR or maptools::readShapeSpatial, see the available key data for indexing:
sapply(as.data.frame(eco), function(x) if(!is.numeric(x)) unique(x) else NULL)
If you just want to plot it, set up a map with only the US region to start with and then overplot.
library(maps)
map("usa", col = "transparent")
We see that the data is in Lambert Azimuthal Equal Area:
proj4string(eco)
[1] " +proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 +b=6370997 +units=m +no_defs"
So
require(rgdal)
eco.laea <- spTransform(eco, CRS("+proj=longlat +ellpse=WGS84"))
plot(eco.laea, add = TRUE)
If you want to plot in the original Lambert Azimuthal Equal Area you'll need to get the bounding box in that projection and start the plot based on that, I just used existing data to make an easy example. I'm pretty sure the data could also be cropped with rgeos against another boundary too, but depends what you actually want.