I would like to calculate the total length of the linestrings within each raster cell. I have a cumbersome workaround, but I think there is a more efficient way to do this directly with the rasterize function. The following MWE shows what I would like and my working solution thus far.
library(sf)
library(raster)
## Base Raster
base_rast <- raster( matrix(runif(100, max=10),10,10))
## LineStrings
ls <- st_linestring(rbind(c(0,0),c(1,1),c(2,1)))
mls <- st_multilinestring(list(rbind(c(2,2),c(1,3)), rbind(c(0,0),c(1,1),c(2,1))))
sfc <- st_sf( geometry=st_sfc(ls,mls) )
sfc$ID <- 1:length(sfc)
## Would Like To Do Something Like
new_fun <- function(j){ sum(sapply(j, st_length)) }
i_length <- rasterize(sfc, base_rast, fun=new_fun)
## Cumbersome Workaround
base_polygon <- rasterToPolygons(base_rast)
base_polygon <- st_as_sf(base_polygon)
base_polygon$baseID <- 1:nrow(base_polygon)
i_poly <- st_intersection(i_poly, sfc)
i_poly_list <- split(i_poly, i_poly$baseID)
i_length <- sapply(i_poly_list, function(j) sum(st_length(j)))
i_mat <- cbind(baseID=as.numeric(names(i_poly_list)), i_length)
lengths <- merge(base_polygon, i_mat, by='baseID', all=T)
i_df <- data.frame(
st_coordinates(st_centroid(lengths))[,c('X','Y')],
river_length=lengths$i_length)
coordinates(i_df) <- ~X+Y
gridded(i_df) <- TRUE
i_length <- raster(i_df)
Related
I have a set of lists which I would like to convert into the nested list of a certain structure. My initial data look like list_1_1 ... list_2_2. I would like them to be like final_desired_output.
I can do this step by step by extracting desired variable and appending to the output list one by one. However, this dummy example contains only 2 data subsets (first_lists and list second_lists), while the real life data are far >1 GB. Thus, I would like to do it with a function, which I unfortunatly do not know how to do, as nested lists are not well covered in tutorials. Any assistance?
# some dummy data
one_1 <- c(1:10)
one_2 <- c(2:15)
one_3 <- c(3:20)
starting_one_1 <- 1
starting_one_2 <- 2
starting_one_3 <- 3
ending_one_1 <- c(11)
ending_one_2 <- c(16)
ending_one_3 <- c(21)
two_1 <- c(1:100)
two_2 <- c(1:15)
starting_two_1 <- 5
starting_two_2 <- 10
ending_two_1 <- c(101)
ending_two_2 <- c(16)
# lists mimicking output I currently have
list_1_1 <- list(one_1, one_2, one_3)
list_1_2 <- list(starting_one_1, starting_one_2, starting_one_3)
list_1_3 <- list(ending_one_1, ending_one_2, ending_one_3)
list_2_1 <- list(two_1, two_2)
list_2_2 <- list(starting_two_1, starting_two_2)
list_2_3 <- list(ending_two_1, ending_two_2)
# producing desired otput
list_1_1_desired <- list()
list_1_1_desired[["sequence"]] <- one_1
list_1_1_desired[["starting"]] <- starting_one_1
list_1_1_desired[["ending"]] <- ending_one_1
list_1_2_desired <- list()
list_1_2_desired[["sequence"]] <- one_2
list_1_2_desired[["starting"]] <- starting_one_2
list_1_2_desired[["ending"]] <- ending_one_2
list_1_3_desired <- list()
list_1_3_desired[["sequence"]] <- one_3
list_1_3_desired[["starting"]] <- starting_one_3
list_1_3_desired[["ending"]] <- ending_one_3
list_2_1_desired <- list()
list_2_1_desired[["sequence"]] <- two_1
list_2_1_desired[["starting"]] <- starting_two_1
list_2_1_desired[["ending"]] <- ending_two_1
list_2_2_desired <- list()
list_2_2_desired[["sequence"]] <- two_2
list_2_2_desired[["starting"]] <- starting_two_2
list_2_2_desired[["ending"]] <- ending_two_2
first_lists <- list(list_1_1_desired, list_1_2_desired, list_1_3_desired)
names(first_lists) <- c("one_1", "one_2", "one_3")
second_lists <- list(list_2_1_desired, list_2_2_desired)
names(second_lists) <- c("two_1", "two_2")
# this is what I would like to obtain
final_desired_output <- list()
final_desired_output[["one"]] <- first_lists
final_desired_output[["two"]] <- second_lists
You could use purrr::transpose:
out <- mget(ls(pattern = '^list.*\\d$')) %>%
split(sub("_\\d+$", '', names(.))) %>%
map(~transpose(set_names(.,c('sequence', 'starting', 'ending'))))
all.equal(out, final_desired_output, check.attributes = FALSE)
[1] TRUE
I am attempting to use terra::distance as I would use raster::distanceFromPoints. However, terra::distance only reports the distance from the point(s) to NA cells. Is this the intended result? I include sample code with my workaround.
Raster plot with point for distance calculation
Plot of terra::distance for point
Desired output
r <- terra::rast(ncols=10, nrows=10)
valR <- rep(1, length = 100)
valR[c(1,12,23,34,45,56,67,78,89,100)] <- NA
terra::values(r) <- valR
xp <- c(50)
yp <- c(50)
xyp <- cbind(xp, yp)
vecP <- terra::vect(xyp)
terra::plot(r)
terra::plot(vecP, add=T)
rDist <- terra::distance(r, vecP)
terra::plot(rDist) #only NA cells have the distance value
# WORKAROUND
r1 = r*0
r1[is.na(r1)] <- 100
r1[r1<1] <- NA
r1Dist <- terra::distance(r1, vecP)
terra::plot(r1Dist)
####################
# using raster::distanceFromPoints
####################
rR <- raster::raster(ncols=10, nrows=10)
raster::values(rR) <- valR
raster::plot(rR)
rRDist <- raster::distanceFromPoints(rR, xyp)
rRDist <- raster::mask(rRDist, rR)
raster::plot(rRDist)
I tested this using distance to a SpatVector of lines rather than points. That seems to work as expected. I assume that maybe it has not been implemented for points yet.
So, another workaround you could use is to calculate distance to lines of zero length (which are basically equivalent to points):
x1 <- rbind(c(50,50), c(50,50))
colnames(x1) <- c('x', 'y')
lns <- vect(x1, "lines")
rDist <- distance(r, lns)
plot(rDist)
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.
I have a big list of SpatialPolygonsDataFrame objects I created using lapply and gdal_polygonizeR (code here: https://johnbaumgartner.wordpress.com/2012/07/26/getting-rasters-into-shape-from-r/) on a list of RasterLayer objects. I now want to union the boundaries of the polygon parts that touch within each SpatialPolygonsDataFrame using unionSpatialPolygons (maptools). I have tested this by calling an individual SpatialPolygonsDataFrame object, and it seems to work. But, when I try to do it for the list of all SpatialPolygonsDataFrame using lapply, I get an error. See code below (very sorry my example is not reproducible) and please provide a solution using lapply or alternative. Thanks
#convert RasterLayers to SpatialPolygonsDataFrame objects
polyl <- lapply(rastl, gdal_polygonizeR)
#test union of polygon parts within individual SpatialPolygonsDataFrame
tmp = unionSpatialPolygons(polyl[[10]], polyl[[10]]$DN)
polyl[[10]] #n = 360 features
tmp #n = 8 features
#run union on all SpatialPolygonsDataFrame in list
polyl_union <- lapply(polyl, unionSpatialPolygons, SpP =
polyl, IDs = polyl$DN)
#Error in FUN(X[[i]], ...) : not a SpatialPolygons object
I do not know what causes the error. An alternative path you could try is
library(raster)
x <- bind(poly)
y <- aggregate(x, "DN")
With example data:
set.seed(0)
r <- raster(ncol=5, nrow=5, xmn=0, xmx=1, ymn=0, ymx=1)
values(r) = sample(5, ncell(r), replace=TRUE)
rr <- list()
rr[[1]] <- crop(r, extent(0,0.5,0,0.5))
rr[[2]] <- crop(r, extent(0.5,1,0.5,1))
rr[[3]] <- crop(r, extent(0,0.5,0.5,1))
rr[[4]] <- crop(r, extent(0.5,1,0,0.5))
x <- list(r1, r2, r3, r4)
y <- lapply(x, rasterToPolygons)
b <- bind(y)
a <- aggregate(b, 'layer')
plot(r)
plot(a, add=TRUE)
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?