I have an image stored as matrix with grayscale for each pixel.
On this image I use SLIC algorithm to divide it into areas.
So I get a simple feature (sf) with polygons, I am able to extract in well-known-text (wkt).
But what I really need is a matrix/mask (same dimension as my pixel-image-matrix) storing the id of the polygon each pixel belongs to. For example the pixel image[1,2] belongs to polygon 5, then mask[1,2] <- 5.
I add some code to give example of my porblem (for a random "image"):
mat <- array(runif(10000, min=0, max=500), dim=c(100,100))
# SLIC
library(supercells);
library(sf);
library(terra);
# make spatial raster from matrix
raster <- rast(mat);
rasterSLIC <- supercells(raster, k = 50, compactness = 1, dist_fun = "euclidean", avg_fun = "mean");
plot(raster);
plot(st_geometry(rasterSLIC), add = TRUE, lwd = 0.2);
point <- st_cast(rasterSLIC$geometry[2], to="POINT");
coord <- st_coordinates(point);
# what I want:
goal <- array(c(1,1,1,2,2,1,2,3,3), dim=c(3,3));
image(goal);
goal;
I would like to have something that helps me turning coords into such a mask/matrix I gave a small example for in goal.
You can use terra::rasterize
Example data
library(terra)
# polygons
f <- system.file("ex/lux.shp", package="terra")
v <- vect(f)
# arbitrary raster
r <- rast(v, res=.01)
Solution:
rid <- rasterize(v, r, 1:nrow(r))
#or
v$ID <- 1:nrow(v)
rid <- rasterize(v, r, "ID")
Illustration
plot(rid, type="classes")
text(v)
lines(v)
To get the a matrix of the raster values you can do
m <- as.matrix(rid, wide=TRUE)
With your more specific example, you could do
library(supercells);
library(terra)
set.seed(1)
mat <- array(runif(10000, min=0, max=500), dim=c(100,100))
r <- rast(mat)
SLIC <- supercells(r, k = 50, compactness = 1, dist_fun = "euclidean", avg_fun = "mean");
x <- rasterize(SLIC, r, "supercells")
xm <- as.matrix(x, wide=TRUE)
plot(x);
s <- vect(SLIC)
lines(s)
I want to select raster cells that are within a certain distance (for e.g. 1 km or 5 km) from the boundary of a polygon. I ultimately want to take an average of only those raster cells that are within the specified distance from the boundary of shapefile inwards.
The way I thought I would approach is to create a negative buffer inwards, and subtract the original polygon and the buffer. Then mask and crop the raster using the new polygon and take the average.
Here's sample data demonstrating what I want to do.
library(raster)
# raster
r <- raster(xmn=1035792, xmx= 1116792, ymn=825303.6, ymx=937803.6, resolution = 12.5,crs = "+init=epsg:3174")
r <- setValues(r, 0)
# polygon
x <- c(1199999, 1080000, 1093067, 1090190, 1087977, 1070419, 1180419)
y <- c(957803.6,937803.6, 894366.9, 872153.9, 853703.0, 825353.6, 805353.6)
poly.lake <- SpatialPolygons(list(Polygons(list(Polygon(data.frame(x,y))), ID = 1)))
r <- mask(r, poly.lake)
r <- crop(r, poly.lake)
plot(poly.lake)
plot(r, add = T)
Instead of taking average of the resulting raster r, I only want to average raster cells which are within a certain specified distance from the boundary.
The example data but using "terra"
library(terra)
r <- rast(xmin=1035792, xmax= 1116792, ymin=825303.6, ymax=937803.6, resolution = 125, crs = "epsg:3174")
values(r) <- 1:ncell(r)
# polygon
x <- c(1199999, 1080000, 1093067, 1090190, 1087977, 1070419, 1180419)
y <- c(957803.6,937803.6, 894366.9, 872153.9, 853703.0, 825353.6, 805353.6)
p <- vect(cbind(x, y), "polygons", crs = "epsg:3174")
r <- mask(r, p)
r <- crop(r, p)
You can now take the internal buffer of p
b <- buffer(p, -10000)
x <- mask(r, b, inverse=TRUE)
global(x, mean,na.rm=T)
# mean
#lyr.1 296549.9
Or you can take both sides like this
bb <- buffer(as.lines(p), 10000)
y <- mask(r, bb)
global(y, mean,na.rm=T)
# mean
#lyr.1 296751.3
So there is a slight difference between these two approaches; I think because the first uses inverse=TRUE; I would go with the second approach.
Your drawing (and Chris' answer) suggests that you only want the distance to the western border. In that case, you can first find the start and end nodes you need (from 2 to 6)
plot(p)
points(p)
text(as.points(p), pos=2)
Select the segments in between these nodes and create a line type SpatVector.
g <- geom(p)
k <- vect(g[2:6,], "lines", crs=crs(p))
lines(k, col="red", lwd=2)
And now do as above.
bk <- buffer(k, 10000)
z <- mask(r, bk)
global(z, mean,na.rm=T)
# mean
#lyr.1 297747
If you wanted to get the part of buffer bk that is inside the original polygon p you can do
bki <- intersect(bk, p)
To complete the plot
polys(bk, lty=3, border=NA, col=adjustcolor("light blue", alpha.f = 0.4))
lines(bki, lty=3)
Finding which segments of a polygon to buffer was what puzzled me, and this seems a decent approach cast_poly_to_subsegments. Taking your poly.lake as poly_sf:
geom <- lapply(
1:(length(st_coordinates(poly_sf)[, 1]) - 1),
function(i) {
rbind(
as.numeric(st_coordinates(poly_sf)[i, 1:2]),
as.numeric(st_coordinates(poly_sf)[i + 1, 1:2])
)
}
+ ) |>
st_multilinestring() |>
st_sfc(crs=st_crs(rt)) |>
st_cast('LINESTRING')
gives us
which is a little surprising, the 'green and red', that I assumed would be 'green'. It is wound clockwise so the desired segments to buffer are 4 & 5.
lns_buf4 <- st_buffer(st_geometry(geom)[4], 1000, singleSide = TRUE)
lns_buf5 <- st_buffer(st_geometry(geom)[5], 1000, singleSide= TRUE)
lns_buf5_neg <- st_buffer(st_geometry(geom)[5], -1000, singleSide= TRUE)
plot(st_geometry(geom), col = c('red', 'yellow', 'blue', 'green'))
plot(lns_buf4, col = 'black', add = TRUE)
plot(lns_buf5, col = 'green', add = TRUE)
plot(lns_buf5_neg, col = 'blue', add = TRUE)
Whether +/-1000 is sufficient is a further intersection test between the buffer poly(s) and the other boundary. If the desired sampling area is not rectangular, steps can be taken to construct a sampling polygon from the buffer and intersection.
#library(lwgeom)
# on poly_sf
new_line <- draw(x = 'line', col ='blue', lwd = 2, n = 10)
lns_buf5_10k_neg <- st_buffer(st_geometry(geom)[5], -10000, singleSide= TRUE)
new_line_sf <- st_as_sf(new_line, crs = st_crs(lns_buf5_10k_neg))
buf5_nline_split <- lwgeom::st_split(lns_buf5_10k_neg, new_line_sf$geometry)
irreg_smp_area <- st_collection_extract(buf5_nline_split)[1]
Though I'm happy to see it all done in terra.
I'm working on a project where I have a very large amount of points and I am looking to identify regions (defined by a lack of clustering) where the density of these points is statistically significantly less relative to others. Normally a visual would be enough but I have so many points that it is to difficult to tell where these empty spaces are and a density heat map doesn't help me zero in on smaller regions. Maybe I'm missing something very simpler here, but I am hoping someone can at least send me in the right direction of where to look. Below is a reproducible sample quick and dirty lets take these points from open data and map them to the borough file for NYC:
#libraries--------------------------
library(ggplot2)
library(ggmap)
library(sp)
library(jsonlite)
library(RJSONIO)
library(rgdal)
#call api data--------------------------
df = fromJSON("https://data.cityofnewyork.us/resource/24t3-xqyv.json?$query= SELECT Lat, Long_")
df <- data.frame(t(matrix(unlist(df),nrow=length(unlist(df[1])))))
names(df)[names(df) == 'X2'] = 'x'
names(df)[names(df) == 'X1'] = 'y'
df = df[, c("x", "y")]
df$x = as.numeric(as.character(df$x))
df$y = as.numeric(as.character(df$y))
df$x = round(df$x, 4)
df$y = round(df$y, 4)
df$x[df$x < -74.2] = NA
df$y[df$y < 40.5] = NA
df = na.omit(df)
#map data----------------------------
cd = readOGR("nybb.shp", layer = "nybb")
cd = spTransform(cd, CRS("+proj=longlat +datum=WGS84"))
cd_f = fortify(cd)
#map data
nyc = ggplot() +
geom_polygon(aes(x=long,
y=lat, group=group), fill='grey',
size=.2,color='black', data=cd_f, alpha=1)
nyc + geom_point(aes(x = x, y = y), data = df, size = 1)
#how would I go about finding the empty spaces? That is the regions where there are no clusters?
In this case there aren't a lot of points but for the sake of demonstration, how would I:
identify pockets of low density
potentially draw polygon boundaries on those pockets?
Appreciate the help!
One way to get polygonal areas of low density would be to construct the
Dirichlet/Voronoi tesselation and choose the largest ones.
Below I use spatstat and deldir (loaded by spatstat) to do this.
It is not so fast so with many more points I don't know how well it will
go.
To use the results in ggmap and other spatial packages you can convert
back from owin and ppp to the spatial classes from sp and use
spTransform to get lat, long coordinates.
First load the packages:
library(maptools)
library(spatstat)
library(jsonlite)
Map and points in coordinates of shapefile (note I read in data from
local files downloaded from www):
cd = readOGR("nybb.shp", layer = "nybb")
#> OGR data source with driver: ESRI Shapefile
#> Source: "nybb.shp", layer: "nybb"
#> with 5 features
#> It has 4 fields
df <- fromJSON("NYC_data.json")
df <- as.data.frame(matrix(as.numeric(unlist(df)), ncol = 2, byrow = TRUE))
df <- df[, c(2, 1)]
names(df) <- c("x", "y")
df <- df[df$x > -74.2 & df$y > 40.5, ]
coordinates(df) <- ~x+y
proj4string(df) <- CRS("+proj=longlat +datum=WGS84")
df2 <- spTransform(df, proj4string(cd))
Switch to spatstat classes:
cd2 <- as(cd, "SpatialPolygons")
W <- as(cd2, "owin")
X <- as(df2, "ppp")
Window(X) <- W
plot(X, main = "")
Compute Dirichlet tessellation and areas and plot the tessellation:
d <- dirichlet(X)
#> Warning: 96 duplicated points were removed
a <- tile.areas(d)
plot(d, main = "")
Combine the n_areas biggest areas of the tessellation:
n_areas <- 30
empty <- tess(tiles = d$tiles[tail(order(a), n = n_areas)])
empty2 <- as.owin(empty)
Plot the result:
plot(W, main = "")
plot(empty2, col = "red", add = TRUE)
plot(X, 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?
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.