I have a polygon that consists of 1,000 points. Is it possible to calculate the curvature at each point? The polygon originally contains only 13 points:
43748.72 40714.19
43743.99 40716.16
43741.36 40720.19
43740.95 40726.46
43742.67 40729.28
43745.52 40730.97
43748.72 40731.14
43752.86 40729.43
43756.77 40723.24
43757.19 40719.73
43755.27 40716.68
43752.23 40714.76
43748.72 40714.19
Then I use the smooth function in smoothr package for interpolation now that the polygon has 1,000 points and looks like:
And now I want to calculate curvature at each point. But since this is a closed object, how to actually perform the calculation?
EDIT
I finally found a cell with protrusions to test the robustness. The cell looks like:
And the corresponding K values are:
Indeed, this plot captures two protrusions but can the curvature value be that high? I read a paper and seems like their values are all within 1:
paper link: https://www.biorxiv.org/content/10.1101/623793v1.full
Your example is not fully reproducible on its own, though it can be made so with reference to your previous question:
library(sf)
library(smoothr)
library(ggplot2)
data <- structure(list(x = c(43740.95, 43741.36, 43742.67, 43743.99,
43745.52, 43748.72, 43748.72, 43748.72, 43752.23, 43752.86, 43755.27,
43756.77, 43757.19), y = c(40726.46, 40720.19, 40729.28, 40716.16,
40730.97, 40714.19, 40731.14, 40714.19, 40714.76, 40729.43, 40716.68,
40723.24, 40719.73)), class = "data.frame", row.names = c(NA, -13L))
smooth_poly <- data %>%
st_as_sf(coords=c("x", "y")) %>%
st_union() %>%
st_convex_hull() %>%
smooth(method='spline', n=1000)
smooth_df <- as.data.frame(sf::st_coordinates(smooth_poly))
ggplot(smooth_df, aes(X, Y)) +
geom_polygon(alpha = 0, colour = "black", size = 1) +
coord_equal()
Now we have all the X and Y co-ordinates of the smoothed polygon in a data frame called smooth_df. We can calculate the x and y components of the curvature vectors like this:
dx <- diff(c(smooth_df$X, smooth_df$X[1])) # Distance between x coords with wrap-around
dy <- diff(c(smooth_df$Y, smooth_df$Y[1])) # Distance between y coords with wrap-around
ds <- sqrt(dx^2 + dy^2) # Segment size between points
ddx <- dx/ds # Ratio of x distance to segment size
ddy <- dy/ds # Ratio of y distance to segment size
ds2 <- (ds + c(ds[-1], ds[1]))/2 # Mean segment length either side per point
smooth_df$Cx <- diff(c(ddx, ddx[1]))/ds2 # Change in ddx per unit length
smooth_df$Cy <- diff(c(ddy, ddy[1]))/ds2 # Change in ddy per unit length
These last two are the x and y components of the curvature vectors at each point on the periphery of the polygon. Since this polygon is smooth, the curvatures are small:
head(smooth_df)
#> X Y L1 L2 Cx Cy
#> 1 43748.72 40714.19 1 1 0.02288753 0.1419567
#> 2 43748.67 40714.20 1 1 0.02324771 0.1375075
#> 3 43748.61 40714.21 1 1 0.02356064 0.1332985
#> 4 43748.56 40714.22 1 1 0.02383216 0.1293156
#> 5 43748.51 40714.23 1 1 0.02406747 0.1255458
#> 6 43748.45 40714.24 1 1 0.02427127 0.1219768
Adding these vectors to a plot would just give the inside of the polygon some "fur", since there are so many of them and they are so small, so instead we can show that the directions are correct by plotting a subset of them, magnified by 10, with arrowheads. The arrows should start on the periphery and point directly in the direction of the concavity of the polygon at that point. We should also see longer arrows where the curves are tight, and shorter arrows where the polygon is flat.
smooth_df$Cx_plot <- 10 * smooth_df$Cx + smooth_df$X
smooth_df$Cy_plot <- 10 * smooth_df$Cy + smooth_df$Y
ggplot(smooth_df, aes(X, Y)) +
geom_polygon(alpha = 0, colour = "black", size = 1) +
geom_segment(data = smooth_df[seq(1, nrow(smooth_df), 50),],
mapping = aes(xend = Cx_plot, yend = Cy_plot),
arrow = arrow(length = unit(0.3, "cm"))) +
coord_equal()
If you want the curvature as a single dimensional number đťśż, you can do:
smooth_df$K <- (ddy * smooth_df$Cx - ddx * smooth_df$Cy)/
((ddx^2 + ddy^2)^(3/2))
Which then allows you to plot the curvature as a colour. This will also give negative values when the curve is concave outwards, though I have here just plotted the convex hull again. The red indicates areas with high curvature, the blue areas are flatter.
ggplot(smooth_df, aes(X, Y)) +
geom_point(aes(colour = K)) +
coord_equal() + scale_colour_gradient(low = "skyblue", high = "red")
Related
I have a bunch of movement vectors with a direction (compass angle from 0-360), and velocity (km/hour, for example), and I want to summarize them into one average vector, and I can't seem to find a good way. Basically I want to be able to say "the average movement for this group is ___ degrees at ___ km/hour."
I've found some piecemeal ways to do it, but there has to be an easier way. I'm trying to scale this up, and it will eventually be applied to vectors not starting from the origin, and eventually vectors in geographic space (with CRS and stuff), so I'm trying to simplify as much as possible right now.
example code:
# data frame of vectors all starting at one origin with a compass angle and velocity
df <- data.frame(
x=0,
y=0,
# compass degrees where 0 is north and moves clockwise
compassdegree = c(270,275,277,280,285,330, 40),
velocity = c(2,2,2,2,1,1,1)
) %>%
# we will plot with geom_spoke, which takes radians,
# so some transformations are necessary
mutate(
# convert to radian degrees:
# (0 degrees points right from origin and goes counterclockwise)
radiandegree = ((-compassdegree) + 450) %% 360 ,
# convert from radiandegrees to radians
radian = DescTools::DegToRad(radiandegree))
# plot the vectors
plot <- df %>%
ggplot(aes(x=x,y=y)) +
geom_spoke(aes(angle = radian,
radius = velocity)) +
coord_equal(xlim = c(-2,2),
ylim = c(-2,2))
plot
# find mean angle with circular::weighted.mean.circular
weighted.mean <- circular::weighted.mean.circular(
x = circular::circular(df$radian, unit = "radians"),
w = df$velocity
) %>% as.data.frame() %>%
rename(radians = x) %>%
# convert back to radian degrees, then to compass degrees
mutate(radianDegree = circular::deg(radians),
compassDegree = ((-radianDegree) + 450) %% 360 )
# alternatively, we could have used the radiandegrees
# directly in the weighted.mean.circular function, but I'll still need it
# in radians to plot, so this isn't really saving much
weighted.mean2 <- circular::weighted.mean.circular(
x = circular::circular(df$radiandegree, unit = "degrees"),
w = df$velocity
) %>% as.data.frame() %>%
rename(radianDegree = x) %>%
# convert back to radian degrees, then to compass degrees
mutate(compassDegree = ((-radianDegree) + 450) %% 360 )
# great, so now we have the average compassDegree: 286.85°,
# but we still don't know the mean velocity
# try by finding endpoints of all original vectors, and finding the
# centroid of them by summing all X and all Y values
# find endpoints of all vectors
df_endpoints <- df %>%
mutate(x_end = x + (velocity * cos(radian)),
y_end = y + (velocity * sin(radian)))
# find mean endpoint
mean_endpoint <- df_endpoints %>%
summarize(x = mean(x_end),
y = mean(y_end))
# find mean velocity by finding distance from averaged endpoint to origin
# using the pythagorean theorem
mean_vel <- sqrt(mean_endpoint$x^2 + mean_endpoint$y^2)
# now we have the mean velocity
plot +
geom_point(data = mean_endpoint,
aes(x=x,y=y),
color = "red", size = 2) +
geom_spoke(aes(x = 0, y = 0,
angle = weighted.mean$radians,
radius = mean_vel),
color = "red", linetype = "longdash", size = .75)
Now we have the trajectories in black, and the average trajectory in red.
Is there not just a function that I can feed in a df of angles and velocities and receive this information (mean angle and mean velocity) directly out? Will the above method still apply when I move to spatial data (assuming I keep in mind distortion from projections and CRS)?
Here's an approach using the average x-y delta and converting that back to radians and velocity.
df_avg <- df %>%
mutate(x_delta = velocity * cos(radian),
y_delta = velocity * sin(radian)) %>%
summarize(across(c(x, y, x_delta:y_delta), mean)) %>%
mutate(velocity = sqrt(x_delta^2 + y_delta^2),
radian = atan(y_delta/x_delta) + pi,
src = "avg")
ggplot(bind_rows(df, df_avg),
aes(x=x,y=y, color = src)) +
geom_spoke(aes(angle = radian,
radius = velocity)) +
coord_equal(xlim = c(-2,2),
ylim = c(-2,2))
I have a raster type object in R that is a lat/long grid and each cell has a value that is the depth or elevation of that cell (downloaded from marmap's getNOAA.bathy(), bathymap in toy example).
Then I have a list of points with lat,long coordinates (points). For each point, I want to find the closest grid cell to the point that has a negative (depth) value. If there are multiple cells, then I want to pick one of them randomly. Once I have the/one nearest negative grid cell, then I want to find and save a random lat,long that falls within this cell.
The end goal here is to "move" each point to a random location within the nearest cell that has a negative value.
Note that these points nor the bathymap are not currently projected. They are just lats and lons in decimal degrees.
Here is a toy set-up to work with:
library(marmap)
library(ggplot2)
#get a map
bathymap <- getNOAA.bathy(lat1 = -30, lon1 = 65, lat2 = 55, lon2 = 155, resolution = 10, keep = FALSE, antimeridian = FALSE, path = NULL)
#sample points
points = data.frame("x" = c(138.605,139), "y" = c(35.0833,35.6))
#visualize the problem/set-up
ggplot() +
#build map
geom_raster(data = bathymap, aes(x=x, y=y, fill=z)) +
geom_contour(data = bathymap, aes(x=x, y=y, z=z),
breaks=0, #contour for land
colour="black", size=0.3) +
scale_fill_gradient2(low="skyblue", mid="white", high="navy", midpoint = 0) +
#add points
geom_point(data = points, aes(x=x, y=y), color = "blue", alpha = 1, size = 1) +
lims(x = c(138,139.5),
y = c(34,36)) +
coord_fixed() +
geom_text(data = bathymap, aes(x=x, y=y, fill=z, label=z), size = 2)```
Here is a solution. Basically, for each original geographical point, I did the following:
I used marmap::dist2isobath() to locate the closest point with a negative value along a given isobath.
Since the location of isobaths can be rather imprecise with low resolution bathymetries, a negative isobath sometimes crosses cells with positive values. So, I checked the depth of each point identified above with marmap::get.depth(). If the depth returned is negative, this is a success, if not, I go back to step 1 and look for the closest point along a deeper isobath (hence the depth_increment argument). This is thus an incremental process that stops only when a point is finally located in a negative cell.
I packaged all this in the find_closest_negative() function that you can apply to every point in a dataset with purrr::map2_df().
The function returns a table with:
the original coordinates of each point,
the coordinates of the closest point in the closest negative cell, and
the depth at the new location.
Points that were originally located in negative cells are not affected by the function. Be careful: it can be rather time-consuming with large bathymetries and many points...
library(marmap)
library(tidyverse)
# Custom function to get location of closest point along a given isobath
# bathy: bathymetric object from marmap::getNOAA.bathy
# x, y: longitude and latitude of a single point
# isobath: negative integer. Minimum depth at which the point should be located
# depth_increment: positive integer to look for deeper cells. Big values allow
# the function to run faster but might lead to more imprecise results
find_closest_negative <- function(bathy, x, y, isobath = -1, depth_increment = 50) {
# Duplicate point to avoid weird dist2isobath() error message
point <- data.frame(x, y)
a <- point[c(1,1), ]
depth_a <- get.depth(bathy, a, locator = FALSE)
depth <- unique(depth_a$depth)
if (depth < 0) {
return(unique(depth_a))
} else {
while(depth >= 0 ) {
b <- dist2isobath(bathy, a, isobath = isobath)
depth_b <- get.depth(bathy, b[,4:5], locator = FALSE)
depth <- unique(depth_b$depth)
isobath <- isobath - depth_increment
}
return(unique(depth_b))
}
}
# Get (a small) bathymetric data
bathymap <- getNOAA.bathy(lat1 = 34, lon1 = 138, lat2 = 36, lon2 = 140,
resolution = 10)
# Sample points
points <- data.frame("x" = c(138.605, 139, 138.5, 138.85, 138.95, 139.5),
"y" = c(35.0833, 35.6, 34.2, 35.0, 34.8, 34.4))
# For each point, find the closest location within a negative cell
points2 <- points %>%
mutate(map2_df(x, y, .f = ~find_closest_negative(bathymap, .x, .y,
isobath = -1,
depth_increment = 50)))
points2
#> x y lon lat depth
#> 1 138.605 35.0833 138.5455 34.99248 -1111
#> 2 139.000 35.6000 139.2727 35.36346 -311
#> 3 138.500 34.2000 138.5000 34.20000 -2717
#> 4 138.850 35.0000 138.7882 35.00619 -101
#> 5 138.950 34.8000 139.0053 34.79250 -501
#> 6 139.500 34.4000 139.5000 34.40000 -181
# Some data wrangling to plot lines between pairs of points below
origin <- points2 %>%
mutate(id = row_number()) %>%
select(lon = x, lat = y, id)
destination <- points2 %>%
mutate(id = row_number()) %>%
select(lon, lat, id)
global <- bind_rows(origin, destination)
# Plot the original points and their new location
bathymap %>%
ggplot(aes(x, y)) +
geom_tile(aes(fill = z)) +
geom_contour(aes(z = z), breaks = 0, colour = 1, size = 0.3) +
geom_text(aes(label = z), size = 2) +
geom_point(data = points2, aes(x = lon, y = lat), color = "red", size = 2) +
geom_point(data = points2, aes(x = x, y = y), color = "blue") +
geom_line(data = global, aes(x = lon, y = lat, group = id), size = 0.4) +
scale_fill_gradient2(low = "skyblue", mid = "white", high = "navy",
midpoint = 0) +
coord_fixed()
Problem:
1.) I have a shapefile that looks like this:
Extreme values for coordinates are: xmin = 300,000, xmax = 620,000, ymin = 31,000 and ymax = 190,000.
2.) I have a dataset of approx. 2mio points (every point is inside the given polygon) - each one is in one of a 5 different categories.
Now, for every point inside the border (distance between points has to be 10, so that would give us 580,800,000 points) I want to determine color, depending on a category of the nearest point in a dataset.
In the end I would like to draw a ggplot, where the color of every point is dependent on its category (so I'll use 5 different colors).
What I have so far:
My ideas for solution are not optimized and it takes R forever to determine categories for every point inside the polygon.
1.) I created a new dataset with points in a shape of a rectangle with extreme values of coordinates, with 10 units between points. From a new dataset I selected points that have fallen inside the border of polygons (with a function pnt.in.poly from package SDMTools). Then I wanted to find nearest points (from dataset) of every point in a polygon and determined category, but I never manage to get a subset from 580,800,000 points (obviously).
2.) I tried to take 2mio points and color an area around them, dependent on their category, but that did not work right.
I know that it is not possible to plot so many points and see the difference between plot with 200,000,000 points and plot with 1,000,000 points, but I would like to have an accurate coloring when zooming (drawing) only one little spot in a polygon (size of 100 x 100 for example).
Question: Is there any better a way of coloring so many points in a polygon (with creating a new shapefile or grouping points)?
Thank you for your ideas!
It’s really helpful if you include some data with your question, even (especially) if it’s a toy data set. As you don’t, I’ve made a toy example. First, I define a simple shape data frame and a data frame of synthetic data that includes x, y, and grp (i.e., a categorical variable with 5 levels). I crop the latter to the former and plot the results,
# Dummy shape function
df_shape <- data.frame(x = c(0, 0.5, 1, 0.5, 0),
y = c(0, 0.2, 1, 0.8, 0))
# Load library
library(ggplot2)
library(sgeostat) # For in.polygon function
# Data frame of synthetic data: random [x, y] and category (grp)
df_synth <- data.frame(x = runif(500),
y = runif(500),
grp = factor(sample(1:5, 500, replace = TRUE)))
# Remove points outside polygon
df_synth <- df_synth[in.polygon(df_synth$x, df_synth$y, df_shape$x, df_shape$y), ]
# Plot shape and synthetic data
g <- ggplot(df_shape, aes(x = x, y = y)) + geom_path(colour = "#FF3300", size = 1.5)
g <- g + ggthemes::theme_clean()
g <- g + geom_point(data = df_synth, aes(x = x, y = y, colour = grp))
g
Next, I create a regular grid and crop that using the polygon.
# Create a grid
df_grid <- expand.grid(x = seq(0, 1, length.out = 50),
y = seq(0, 1, length.out = 50))
# Check if grid points are in polygon
df_grid <- df_grid[in.polygon(df_grid$x, df_grid$y, df_shape$x, df_shape$y), ]
# Plot shape and show points are inside
g <- ggplot(df_shape, aes(x = x, y = y)) + geom_path(colour = "#FF3300", size = 1.5)
g <- g + ggthemes::theme_clean()
g <- g + geom_point(data = df_grid, aes(x = x, y = y))
g
To classify each point on this grid by the nearest point in the synthetic data set, I use knn or k-nearest-neighbours with k = 1. That gives something like this.
# Classify grid points according to synthetic data set using k-nearest neighbour
df_grid$grp <- class::knn(df_synth[, 1:2], df_grid, df_synth[, 3])
# Show categorised points
g <- ggplot()
g <- g + ggthemes::theme_clean()
g <- g + geom_point(data = df_grid, aes(x = x, y = y, colour = grp))
g
So, that's how I'd address that part of your question about classifying points on a grid.
The other part of your question seems to be about resolution. If I understand correctly, you want the same resolution even if you're zoomed in. Also, you don't want to plot so many points when zoomed out, as you can't even see them. Here, I create a plotting function that lets you specify the resolution. First, I plot all the points in the shape with 50 points in each direction. Then, I plot a subregion (i.e., zoom), but keep the same number of points in each direction the same so that it looks pretty much the same as the previous plot in terms of numbers of dots.
res_plot <- function(xlim, xn, ylim, yn, df_data, df_sh){
# Create a grid
df_gr <- expand.grid(x = seq(xlim[1], xlim[2], length.out = xn),
y = seq(ylim[1], ylim[2], length.out = yn))
# Check if grid points are in polygon
df_gr <- df_gr[in.polygon(df_gr$x, df_gr$y, df_sh$x, df_sh$y), ]
# Classify grid points according to synthetic data set using k-nearest neighbour
df_gr$grp <- class::knn(df_data[, 1:2], df_gr, df_data[, 3])
g <- ggplot()
g <- g + ggthemes::theme_clean()
g <- g + geom_point(data = df_gr, aes(x = x, y = y, colour = grp))
g <- g + xlim(xlim) + ylim(ylim)
g
}
# Example plot
res_plot(c(0, 1), 50, c(0, 1), 50, df_synth, df_shape)
# Same resolution, but different limits
res_plot(c(0.25, 0.75), 50, c(0, 1), 50, df_synth, df_shape)
Created on 2019-05-31 by the reprex package (v0.3.0)
Hopefully, that addresses your question.
I am trying to create a tesselation of filled hexagons (polygons centered around a hexagonally-spaced lattice) in ggplot2. I have accomplished this using the 'plot' command but am struggling transitioning this to ggplot.
Here is the code for the set-up:
# Generate a lattice of points equally spaced in the centers of a hexagonal lattice
dist = 1 # distance between the centers of hexagons
nx = dist*15 # horizontal extent
ny = dist*15 # vertical extent
MakeHexLattice = function(nx, ny, dist, origin=c(0,0)) {
locations = cbind(location = 1:(nx*ny),
x = sort(c(rep(seq(from=0, by=dist, length.out=nx),each=ceiling(ny/2)),
rep(seq(from=dist/2, by=dist, length.out=nx),
each=floor(ny/2)))) + origin[1],
y = rep(c(seq(from=0, by = dist*sqrt(3), length.out=ceiling(ny/2)),
seq(from=dist*sqrt(3)/2, by=dist*sqrt(3),
length.out=floor(ny/2))) + origin[2], times=nx))
class(locations) = c(class(locations), "lattice")
attr(locations, "gridsize") = dist
return(locations)
}
Here is the code for creating the image using 'plot', which looks very nice:
landscape = MakeHexLattice(nx=nx,ny=ny,dist=dist,origin=c(0,0))
# Plot hexagonal lattice as points
plot(x=landscape[,2],y=landscape[,3], pch=19, col="black", cex=0.5, asp=1/1)
# Separate x and y coordinates
lx = landscape[,2] # x-coordinates
ly = landscape[,3] # y-coordinates
# Plot hexagonal lattice as filled hexagons
hex.x = cbind(lx + 0, lx + 0.5, lx + 0.5, lx + 0, lx - 0.5, lx - 0.5)
hex.y = cbind(ly - 1/(sqrt(3)), ly - 1/(2*sqrt(3)), ly + 1/(2*sqrt(3)), ly + 1/(sqrt(3)), ly + 1/(2*sqrt(3)), ly - 1/(2*sqrt(3)))
hex.vectors = cbind(hex.x, hex.y)
for(i in 1:(length(hex.vectors)/12)){
polygon(x=hex.vectors[i,1:6], y=hex.vectors[i,7:12], angle = 120, border=NULL, col="wheat",
lty = par("lty"), fillOddEven = FALSE)
}
Any tips on how to accomplish this same thing using ggplot2 (which I am transitioning to using)? I have tried using geom_polygon but can't seem to work out the for-loop. (Also, please don't tell me to use 'hexbin' -- not the goal that I am trying to accomplish!)
Thank for the help!
As with most things in ggplot, the plotting is actually extremely straightforward, most of the work is getting your data in the right shape so that it makes sense. A for loop is entirely unnecessary, geom_polygon() just needs a dataframe with the x and y coordinates, and a variable defining which group they belong to. With your data:
library(ggplot2)
library(reshape2)
#Get your coordinates in long format with an id
hexdat.x <- melt(cbind(id = 1:length(hex.x), as.data.frame(hex.x)), id.vars = "id", value.name = "x")
hexdat.y <- melt(cbind(id = 1:length(hex.y), as.data.frame(hex.y)), id.vars = "id", value.name = "y")
#Merge them into the same dataframe
hexdat <- merge(hexdat.x, hexdat.y)
head(hexdat)
# id variable x y
# 1 1 V1 0.0 -0.5773503
# 2 1 V2 0.5 -0.2886751
# 3 1 V3 0.5 0.2886751
# 4 1 V4 0.0 0.5773503
# 5 1 V5 -0.5 0.2886751
# 6 1 V6 -0.5 -0.2886751
Now to plot the hexagons, you just need to give ggplot the x and y coordinates, and specify the group each one belongs to:
ggplot(hexdat, aes(x, y)) +
geom_polygon(aes(group = id), fill = "wheat", colour = "black")
I don't have any code yet because I am trying to figure out where to begin.
I am using map('state, 'texas) to draw Texas and am geoplotting universities on it. I want R to figure out the sphere of influence that university has with in the state and map it out.
Eventually I will geoplot high schools on the map as well and I would like for R to see who's sphere of influence that high school is in.
Does anyone know what package to begin with?
Your description matches with the concept of a voronoi diagram. It partitions an area into polygons based on the locations of points (e.g. your high schools). All the points in the polygon are closer to that particular high school than to all other high schools.
An example using ggplot2, copied from this link:
library(ggplot2)
library(deldir)
library(scales)
library(reshape2)
library(plyr)
# make fake points
n <- 50
k <- 4
mat <- cbind(rnorm(n), rnorm(n))
df <- as.data.frame(mat)
names(df) <- c('x','y')
# triangulate
xrng <- expand_range(range(df$x), .05)
yrng <- expand_range(range(df$y), .05)
deldir <- deldir(df, rw = c(xrng, yrng))
# voronoi
qplot(x, y, data = df) +
geom_segment(
aes(x = x1, y = y1, xend = x2, yend = y2), size = .25,
data = deldir$dirsgs, linetype = 2
) +
scale_x_continuous(expand = c(0,0)) +
scale_y_continuous(expand = c(0,0))