In R, we can take a raster and turn it into a SpatialLinesDataFrame with the function rasterToCountour:
library(raster)
f <- system.file("external/test.grd", package="raster")
r <- raster(f)
x <- rasterToContour(r)
class(x)
[1] "SpatialLinesDataFrame"
attr(,"package")
[1] "sp"
spplot(x)
Within R, is there a way to do the opposite? Something like contourToRaster?
We can simply grab the field values associated with each point along the line, but I'm looking for something more general that interpolates between the lines and produces a full raster over a defined domain.
library(raster)
f <- system.file("external/test.grd", package="raster")
r <- raster(f)
x <- rasterToContour(r)
You can rasterize the values. In this case after extracting them from the factor labels first.
x$value <- as.numeric(as.character(x$level))
rr <- rasterize(x, r, "value")
And then extract the cell values and interpolate these
xyz <- rasterToPoints(rr)
(if you want to skip rasterize and rasterToPoints (as mikoontz suggests) you could instead do
#g <- geom(x)
#xyz = cbind(g[, c("x", "y")], x$value[g[,1]])
at the expense of a more complex model)
Now interpolate, for example with Tps
library(fields)
tps <- Tps(xyz[,1:2], xyz[,3])
p <- raster(r)
p <- interpolate(p, tps)
m <- mask(p, r)
plot(m)
Do you only have access to the object created by rasterToContour()?
If you still have access to the original raster, you can create the contours as complete polygons first (instead of creating them as lines). Then the "contourToRaster"-like function is just rasterize() (or fasterize()).
Some code borrowed from here: How does one turn contour lines into filled contours?
library(fasterize)
rc <- cut(r, breaks= 10)
cut_vals <- cut(r[], breaks = 10, dig.lab = 5)
pols <- rasterToPolygons(rc, dissolve=T) %>%
st_as_sf()
r_template <- raster(pols, res = res(r))
back_to_raster <- fasterize(pols, r_template, field = "layer")
par(oma = c(0, 0, 0, 5))
plot(back_to_raster, legend = FALSE)
plot(back_to_raster, legend.only=TRUE, legend.width = 1,
axis.args=list(at=1:nlevels(cut_vals),
labels=levels(cut_vals)))
Produces:
EDIT:
I like Robert's approach to this if you want to interpolate. I'd skip the rasterize() step, which can be pretty slow, in favor of casting the multilinestrings to points directly:
library(tidyverse)
library(sf)
library(raster)
library(fields)
f <- system.file("external/test.grd", package="raster")
r <- raster(f)
x <- rasterToContour(r)
class(x)
x_sf <- x %>% st_as_sf() %>% st_cast("LINESTRING") %>% st_cast("MULTIPOINT") %>% st_cast("POINT")
tps <- Tps(x = st_coordinates(x_sf), Y = as.numeric(as.character(x_sf$level)))
p <- interpolate(r, tps) %>% mask(r)
plot(p)
Note that both of these methods rely access to the original raster object.
SO-gurues!
I am trying to count the densities of surviving units in different gridcells.
I have two shapefiles with points from the two survey periods in question (one before and one after the mortality event). What I intend is to see whether there is a difference in survival rates and link the proportion of survival to any climatic variable obtained from the raster value of the desired grid. In the code snippet below I have created some random raster and shapefiles.
packs = c('raster', 'rgdal', 'spatstat', 'sp' ,'dplyr')
sapply(packs, FUN = 'require', character.only = TRUE)
xy <- matrix(rnorm(1024),32,32) #Creating the desired raster
image(xy)
rast <- raster(xy)
extent(rast) <- c(36,37,-3,-2)
projection(rast) <- CRS("+proj=longlat +datum=WGS84")
points <- runifpoint(n =4000, c(36,37,-3,-2)) # Creating the points
x <- points$x
y <- points$y
values <- c(rep(1, 900), rep(0, 3100))
xy <- cbind(x, y)
points <- cbind(x, y, values)
points <- data.frame(points)
shp <- SpatialPointsDataFrame(coords = xy, data = data.frame(values) ) # creating shpfiles
projection(shp) <- CRS("+proj=longlat +datum=WGS84")
subs <- filter(points, values == 1)
suxy <- select(subs, x,y)
shpsub <- SpatialPointsDataFrame(coords = suxy, data = data.frame(subs$values)) # creating shpfiles
projection(shpsub) <- CRS("+proj=longlat +datum=WGS84")
When I attempt to extract the points I use the following lines of code
shp <- spTransform(shp, projection(rast)) # make sure they have same transformation
shpsub <- spTransform(shpsub, projection(rast))
XY <- xyFromCell(rast, cell = 1:ncell(rast))
v <- as.data.frame(rast) #Extract values from raster
XY <- data.frame(XY, v) # Creating a data frame containing coord., cellno and value
XY$cell <- c(1:ncell(rast))
cells <- cellFromXY(rast,shp) # find which cells the points are in
cells <- rle(cells) # returns a value and a length, fast for counting
cellsfound <- cellFromXY(rast,shpsub)
cellsfound <- rle(cellsfound)
Proportion <- data.frame(cell = cells$values, shp = cells$lengths)
test <- data.frame(cell = rep(NA,NROW(Proportion)), shpsub = rep(NA, NROW(Proportion)))
test$cell <- c(cellsfound$values, rep(NA, nrow(test) - length(cellsfound$values)))
test$shpsub <- c(cellsfound$lengths, rep(NA, NROW(test) - length(cellsfound$lengths)))
Proportion <- full_join(Proportion, test, by = "cell")
test.Proportion <- mutate(Proportion, Proportion = shpsub/shp) #Calculating Proportion
XY <- left_join(XY, test.Proportion, by = "cell") # Adding Proportion to coord and cell no.
XY.m <- summarise(XY, )
XY <- na.omit(XY) ; XY <- XY[,-4]
As I see it. Using rle() returns the same cells multiple times instead of counting the no of points within each individual cell as was my intention. Can anyone please explain me how to do this in a way that retrieves the information on the number of occurrences in the individual cells?
Is there a way to generate regularly spaced (e.g., 500 meters apart) points within a polygon using R? I have been trying to use the sp package but can't seem to define a set of points that are spaced a certain distance apart from one another. My aim is to generate the points, then extract their lat/long coordinates into a new dataframe. Any help would be much appreciated! Thanks
Quite straight forward and almost out-of-the-box.
As OP did not share data, buckle up, put your seats in a vertical position and let us fly to Paris. There, we will adapt a geosphere function, and with its help we will divide up Paris' shape into lon / lat coordinates that are 500 meters apart each (vertically and horizontally).
# Load necessary libraries.
library(raster)
library(geosphere)
library(tidyverse)
library(sp)
# This is an adapted version of geosphere's destPoint() function that works with
# changing d (distance).
destPoint_v <- function (x, y, b, d, a = 6378137, f = 1/298.257223563, ...)
{
r <- list(...)$r
if (!is.null(r)) {
return(.old_destPoint(x, y, b, d, r = r))
}
b <- as.vector(b)
d <- as.vector(d)
x <- as.vector(x)
y <- as.vector(y)
p <- cbind(x, y, b, d)
r <- .Call("_geodesic", as.double(p[, 1]), as.double(p[, 2]),
as.double(p[, 3]), as.double(p[, 4]),
as.double(a), as.double(f),
PACKAGE = "geosphere")
r <- matrix(r, ncol = 3, byrow = TRUE)
colnames(r) <- c("lon", "lat", "finalbearing")
return(r[, 1:2, drop = FALSE])
}
# Data can be downloaded from
# http://osm13.openstreetmap.fr/~cquest/openfla/export/communes-20190101-shp.zip
# or
# https://www.data.gouv.fr/en/datasets/decoupage-administratif-communal-francais-issu-d-openstreetmap/
# ("Export simple de janvier 2019 (225Mo)")
# Load shapefile.
# shp <- raster::shapefile("Dropbox/work/crema/communes-20190101-shp/communes-20190101.shp")
# Extract Paris.
paris <- shp[shp$nom == "Paris", ]
# Set distance of points in meters.
dist <- 500
# Extract bounding box from Paris' SpatialPolygonDataFrame.
bbox <- raster::extent(paris)
# Calculate number of points on the vertical axis.
ny <- ceiling(geosphere::distGeo(p1 = c(bbox#xmin, bbox#ymin),
p2 = c(bbox#xmin, bbox#ymax)) / dist)
# Calculate maximum number of points on the horizontal axis.
# This needs to be calculated for the lowermost and uppermost horizontal lines
# as the distance between latitudinal lines varies when the longitude changes.
nx <- ceiling(max(geosphere::distGeo(p1 = c(bbox#xmin, bbox#ymin),
p2 = c(bbox#xmax, bbox#ymin)) / dist,
geosphere::distGeo(p1 = c(bbox#xmin, bbox#ymax),
p2 = c(bbox#xmax, bbox#ymax)) / dist))
# Create result data frame with number of points on vertical axis.
df <- data.frame(ny = 1:ny)
# Calculate coordinates along the vertical axis.
pts <- geosphere::destPoint(p = c(bbox#xmin, bbox#ymin),
b = 0, d = dist * (1:ny - 1))
df$x <- pts[, 1]
df$y <- pts[, 2]
# Add points on horizontal axis.
df <- tidyr::crossing(nx = 1:nx, df)
# Calculate coordinates.
pts <- destPoint_v(df$x, df$y, b = 90, 500 * (df$nx - 1))
# Turn coordinates into SpatialPoints.
pts <- SpatialPoints(cbind(pts[, 1], pts[, 2]), proj4string = CRS(proj4string(paris)))
# Cut to boundaries of Paris.
result <- raster::intersect(pts, paris)
# Plot result.
plot(result)
title("Paris in Points")
Kind of looks like a fish, doesn't it?
Here is a way to do assuming you have a lonlat polygon by first transforming it to a planar crs (not as nifty as Roman's solution with destPoint).
Packages and example data
library(raster)
library(rgdal)
p <- shapefile(system.file("external/lux.shp", package="raster"))[1,]
Transform to planar crs (pick one that matches your data!)
putm <- spTransform(p, "+proj=utm +zone=32 +datum=WGS84")
Create a raster with 500 m resolution, rasterize the polygon and transform to points
r <- raster(putm, res=500)
r <- rasterize(putm, r)
pts <- rasterToPoints(r, spatial=TRUE)
Transform the points to lon/lat and plot the results
pts_lonlat <- spTransform(pts, "+proj=longlat +datum=WGS84")
result <- coordinates(pts_lonlat)
plot(p)
points(result, pch="+", cex=.5)
(looks like an elephant)
I have got wind data for some stations. The data includes station latitude, longitude, wind speed and wind direction for each station in a csv file. This data is not regularly spaced data. I have a requirement to draw streamlines for this data in R language.
I tried couple of packages rasterVis for STREAMPLOT(), TeachingDemos for My.Symbols by searching through internet, however I was not successful.
Here is an example plot I was talking about.
http://wx.gmu.edu/dev/clim301/850stream.png
Also here is some sample data from csv file that I got for which I was trying to draw streamlines.
longitude,latitude,windspeed,winddirection
84.01,20,1.843478261,126.6521739
77.13,28.48,3.752380952,138.952381
77.2,28.68,2.413333333,140.2666667
78.16,31.32,1.994444444,185.0555556
77.112,31.531,2.492,149.96
77,28.11,7.6,103
77.09,31.5,1.752631579,214.8947368
76.57,31.43,1.28,193.6
77.02,32.34,3.881818182,264.4545455
77.15,28.7,2.444,146.12
77.35,30.55,3.663157895,131.3684211
75.5,29.52,4.175,169.75
72.43,24.17,2.095,279.3
76.19,25.1,1.816666667,170
76.517,30.975,1.284210526,125.6315789
76.13,28.8,4.995,126.7
75.04,29.54,4.09,151.85
72.3,24.32,0,359
72.13,23.86,1.961111111,284.7777778
74.95,30.19,3.032,137.32
73.16,22.36,1.37,251.8
75.84,30.78,3.604347826,125.8695652
73.52,21.86,1.816666667,228.9166667
70.44,21.5,2.076,274.08
69.75,21.36,3.81875,230
78.05,30.32,0.85625,138.5625
Can someone please help me out in drawing streamlines for the irregular wind data?
Like you, I wanted to visualize the same kind of data as streamlnes and I failed to find a function that would do the trick...so I worked up my own crude function:
streamlines <- function(x, y, u, v, step.dist=NULL,
max.dist=NULL, col.ramp=c("white","black"),
fade.col=NULL, length=0.05, ...) {
## Function for adding smoothed vector lines to a plot.
## Interpolation powered by akima package
## step.distance - distance between interpolated locations (user coords)
## max.dist - maximum length of interpolated line (user coords)
## col.ramp - colours to be passed to colorRampPalette
## fade.col - NULL or colour to add fade effect to interpolated line
## ... - further arguments to pass to arrows
## build smoothed lines using interp function
maxiter <- max.dist/step.dist
l <- replicate(5, matrix(NA, length(x), maxiter), simplify=FALSE)
names(l) <- c("x","y","u","v","col")
l$x[,1] <- x
l$y[,1] <- y
l$u[,1] <- u
l$v[,1] <- v
for(i in seq(maxiter)[-1]) {
l$x[,i] <- l$x[,i-1]+(l$u[,i-1]*step.dist)
l$y[,i] <- l$y[,i-1]+(l$v[,i-1]*step.dist)
r <- which(l$x[,i]==l$x[,i-1] & l$y[,i]==l$y[,i-1])
l$x[r,i] <- NA
l$y[r,i] <- NA
for(j in seq(length(x))) {
if(!is.na(l$x[j,i])) {
l$u[j,i] <- c(interp(x, y, u, xo=l$x[j,i], yo=l$y[j,i])$z)
l$v[j,i] <- c(interp(x, y, v, xo=l$x[j,i], yo=l$y[j,i])$z)
}
}
}
## make colour a function of speed and fade line
spd <- sqrt(l$u^2 + l$v^2) # speed
spd <- apply(spd, 1, mean, na.rm=TRUE) # mean speed for each line
spd.int <- seq(min(spd, na.rm=TRUE), max(spd, na.rm=TRUE), length.out=maxiter)
cr <- colorRampPalette(col.ramp)
cols <- as.numeric(cut(spd, spd.int))
ncols <- max(cols, na.rm=TRUE)
cols <- cr(ncols)[cols]
if(is.null(fade.col)) {
l$col <- replicate(maxiter, cols)
} else {
nfade <- apply(!is.na(l$x), 1, sum)
for(j in seq(length(x))) {
l$col[j,seq(nfade[j])] <- colorRampPalette(c(fade.col, cols[j]))(nfade[j])
}
}
## draw arrows
for(j in seq(length(x))) {
arrows(l$x[j,], l$y[j,], c(l$x[j,-1], NA), c(l$y[j,-1], NA),
col=l$col[j,], length=0, ...)
i <- which.max(which(!is.na(l$x[j,]))) # draw arrow at end of line
if(i>1) {
arrows(l$x[j,i-1], l$y[j,i-1], l$x[j,i], l$y[j,i],
col=l$col[j,i-1], length=length, ...)
}
}
}
The function is powered by the interp function in the akima package and, with some fiddling, it can produce some half decent visuals:
dat <- "longitude,latitude,windspeed,winddirection
84.01,20,1.843478261,126.6521739
77.13,28.48,3.752380952,138.952381
77.2,28.68,2.413333333,140.2666667
78.16,31.32,1.994444444,185.0555556
77.112,31.531,2.492,149.96
77,28.11,7.6,103
77.09,31.5,1.752631579,214.8947368
76.57,31.43,1.28,193.6
77.02,32.34,3.881818182,264.4545455
77.15,28.7,2.444,146.12
77.35,30.55,3.663157895,131.3684211
75.5,29.52,4.175,169.75
72.43,24.17,2.095,279.3
76.19,25.1,1.816666667,170
76.517,30.975,1.284210526,125.6315789
76.13,28.8,4.995,126.7
75.04,29.54,4.09,151.85
72.3,24.32,0,359
72.13,23.86,1.961111111,284.7777778
74.95,30.19,3.032,137.32
73.16,22.36,1.37,251.8
75.84,30.78,3.604347826,125.8695652
73.52,21.86,1.816666667,228.9166667
70.44,21.5,2.076,274.08
69.75,21.36,3.81875,230
78.05,30.32,0.85625,138.5625"
tf <- tempfile()
writeLines(dat, tf)
dat <- read.csv(tf)
library(rgdal) # for projecting locations to utm coords
library(akima) # for interpolation
## add utm coords
xy <- as.data.frame(project(cbind(dat$longitude, dat$latitude), "+proj=utm +zone=43 +datum=NAD83"))
names(xy) <- c("easting","northing")
dat <- cbind(dat, xy)
## add u and v coords
dat$u <- -dat$windspeed*sin(dat$winddirection*pi/180)
dat$v <- -dat$windspeed*cos(dat$winddirection*pi/180)
#par(bg="black", fg="white", col.lab="white", col.axis="white")
plot(northing~easting, data=dat, type="n", xlab="Easting (m)", ylab="Northing (m)")
streamlines(dat$easting, dat$northing, dat$u, dat$v,
step.dist=1000, max.dist=50000, col.ramp=c("blue","green","yellow","red"),
fade.col="white", length=0, lwd=5)
I do not think this would be enough data to do what you request:
require(plotrix)
require(maps)
map("world",xlim=c(69,85),ylim= c(20,35))
with(dat,
vectorField(windspeed, winddirection, longitude, latitude , vecspec="deg") )
After staring at the output a bit, I think there may be problems with how I am using that function or with the function itself. The orientations of the arrows seems wrong. Likewise I think the TeachingDemos vector field is not well done, but here is what I get:
require(TeachingDemos)
map("world",xlim=c(69,85),ylim= c(20,35))
with(dat, my.symbols(x=longitude, y=latitude,
symb= ms.arrows, length=windspeed/10, angle=2*pi*winddirection/360))
This plot seems to have sufficient variation in direction but the arrow heads seem to vary erratically in size. In any event neither of these plots suggests that this data can be used to construct streamlines. The data is both too sparse and internally contradictory as far as wid direction at adjacent locations.