Related
I am running Fuzzy C-Means Clustering using e1071 package. I want to decide the optimum number of clusters based on fuzzy performance index (FPI) (extent of fuzziness) and normalized classification entropy (NCE) (degree of disorganization of specific class) given in the following formula
where c is the number of clusters and n is the number of observations, μik is the fuzzy membership and loga is the natural logarithm.
I am using the following code
library(e1071)
x <- rbind(matrix(rnorm(100,sd=0.3),ncol=2),
matrix(rnorm(100,mean=1,sd=0.3),ncol=2))
cl <- cmeans(x,2,20,verbose=TRUE,method="cmeans")
cl$membership
I have been able to extract the μik i.e. fuzzy membership. Now, cmeans has to for different number of clusters e.g. 2 to 6 and the FPI and NCE has to be calculated to have a plot like the following
How can it be achieved in R?
Edit
I have tried the code provided by #nya for iris dataset using the following code
df <- scale(iris[-5])
FPI <- function(cmem){
c <- ncol(cmem)
n <- nrow(cmem)
1 - (c / (c - 1)) * (1 - sum(cmem^2) / n)
}
NCE <- function(cmem){
c <- ncol(cmem)
n <- nrow(cmem)
(n / (n - c)) * (- sum(cmem * log(cmem)) / n)
}
# prepare variables
cl <- list()
fpi <- nce <- NULL
# cycle through the desired number of clusters
for(i in 2:6){
cl[[i]] <- cmeans(df, i, 20, method = "cmeans")
fpi <- c(fpi, FPI(cl[[i]]$membership))
nce <- c(nce, NCE(cl[[i]]$membership))
}
# add space for the second axis label
par(mar = c(5,4,1,4) + .1)
# plot FPI
plot(2:6, fpi, lty = 2, pch = 18, type = "b", xlab = "Number of clusters", ylab = "FPI")
# plot NCE, manually adding the second axis
par(new = TRUE)
plot(2:6, nce, lty = 1, pch = 15, type = "b", xlab = "", ylab = "", axes = FALSE)
axis(4, at = pretty(range(nce)))
mtext("NCE", side = 4, line = 3)
# add legend
legend("top", legend = c("FPI", "NCE"), pch = c(18,15), lty = c(2,1), horiz = TRUE)
The minimum values of fuzzy performance index(FPI) and normalized classification entropy (NCE) were considered to decide the optimum number of clusters. NCE is always increasing and FPI is showing the decreasing value. Ideally it should have been
With available equations, we can program our own functions. Here, the two functions use equations present in the paper you suggested and one of the references the authors cite.
FPI <- function(cmem, method = c("FuzME", "McBrathney", "Rahul")){
method = match.arg(method)
C <- ncol(cmem)
N <- nrow(cmem)
# Rahul et al. 2019. https://doi.org/10.1080/03650340.2019.1578345
if(method == "Rahul"){
res <- 1 - (C / (C - 1)) * (1 - sum(cmem^2) / N)
}
# McBrathney & Moore 1985 https://doi.org/10.1016/0168-1923(85)90082-6
if(method == "McBrathney"){
F <- sum(cmem^2) / N
res <- 1 - (C * F - 1) / (F - 1)
}
# FuzME https://precision-agriculture.sydney.edu.au/resources/software/
# MATLAB code file fvalidity.m, downloaded on 11 Nov, 2021
if(method == "FuzME"){
F <- sum(cmem^2) / N
res <- 1 - (C * F - 1) / (C - 1)
}
return(res)
}
NCE <- function(cmem, method = c("FuzME", "McBrathney", "Rahul")){
method = match.arg(method)
C <- ncol(cmem)
N <- nrow(cmem)
if(method == "Rahul"){
res <- (N / (N - C)) * (- sum(cmem * log(cmem)) / N)
}
if(method %in% c("FuzME", "McBrathney")){
H <- -1 / N * sum(cmem * log(cmem))
res <- H / log(C)
}
return(res)
}
Then use those to calculate the indices from the degrees of membership from the cmeans function from the iris dataset.
# prepare variables
cl <- list()
fpi <- nce <- NULL
# cycle through the desired number of clusters
for(i in 2:6){
cl[[i]] <- e1071::cmeans(iris[, -5], i, 20, method = "cmeans")
fpi <- c(fpi, FPI(cl[[i]]$membership, method = "M"))
nce <- c(nce, NCE(cl[[i]]$membership, method = "M"))
}
Last, plot with two different axes in one plot.
# add space for the second axis label
par(mar = c(5,4,1,4) + .1)
# plot FPI
plot(2:6, fpi, lty = 2, pch = 18, type = "b", xlab = "Number of clusters", ylab = "FPI")
# plot NCE, manually adding the second axis
par(new = TRUE)
plot(2:6, nce, lty = 1, pch = 15, type = "b", xlab = "", ylab = "", axes = FALSE)
axis(4, at = pretty(range(nce)))
mtext("NCE", side = 4, line = 3)
# add legend
legend("top", legend = c("FPI", "NCE"), pch = c(18,15), lty = c(2,1), horiz = TRUE)
EDIT1: Updated the functions according to optional equations from two different publications and calculated the example on the iris dataset.
EDIT2: Added code for the FPI and NCE calculations specified in the FuzME MATLAB code available here.
Hope this could help
library(dplyr)
library(ggplot2)
f <- function(cl) {
C <- length(cl$size)
N <- sum(cl$size)
mu <- cl$membership
fpi <- 1 - C / (C - 1) * (1 - sum((mu)^2) / N)
nce <- N / (N - C) * (-sum(log(mu) * mu) / N)
c(FPI = fpi, NCE = nce)
}
data.frame(t(rbind(
K = 2:6,
sapply(
K,
function(k) f(cmeans(x, k, 20, verbose = TRUE, method = "cmeans"))
)
))) %>%
pivot_longer(cols = FPI:NCE, names_to = "Index") %>%
ggplot(aes(x = K, y = value, group = Index)) +
geom_line(aes(linetype = Index, color = Index)) +
geom_point() +
scale_y_continuous(
name = "FPI",
sec.axis = sec_axis(~., name = "NCE")
) +
theme(legend.position = "top")
As I understand it R lacks a methods to buffer polygons in a spatially exclusive way that preserves the topology of adjacent polygons. So I'm experimenting with an approach that generates voronoi polygons of the original polygon vertices. Results seem quite promising except for apparent errors in the voronoi generation.
Fairly old school R, so it's possible a tidier alternative may work better. This reproducible example uses US/Canada, but note the problem is one of mathematical geometry so marine boundaries are not relevant:
require(rworldmap)
require(rgeos)
require(dismo)
require(purrr)
require(dplyr)
par(mai = rep(0,4))
p = rworldmap::countriesCoarse[,'ADMIN']
p = p[p$ADMIN %in% c('United States of America', 'Canada'),]
p$ADMIN = as.character(p$ADMIN)
p = rgeos::gBuffer(p, byid=T, width = 0) # precaution to ensure no badly-formed polygon nonsense
# Not critical to the problem, but consider we have points we want to assign to enclosing or nearest polygon
set.seed(42)
pts = data.frame(x = runif(1000, min = p#bbox[1,1], max = p#bbox[1,2]),
y = runif(1000, min = p#bbox[2,1], max = p#bbox[2,2]))
coordinates(pts) = pts
pts#proj4string = p#proj4string
# point in polygon classification.
pts$admin = sp::over(pts, p)$ADMIN
pts$admin = replace(pts$admin, is.na(pts$admin), 'unclass')
plot(p)
plot(pts, pch=16, cex=.4, col = c('red','grey','blue')[factor(pts$admin)], add=T)
Let's say we want to bin the grey points to nearest polygon. I think the most elegant approach would be to create a new expanded set of polygons. This avoids lots of n-squared nearest neighbour calculations. Next we try a voronoi tesselation of the original polygon vertices:
vertices1 = map_df(p#polygons, ~ map2_df(.x#Polygons, rep(.x#ID, length(.x#Polygons)),
~ as.data.frame(..1#coords) %>% `names<-`(c('x','y')) %>% mutate(id = ..2)))
print(head(vertices1))
#> x y id
#> 1 -56.13404 50.68701 Canada
#> 2 -56.79588 49.81231 Canada
#> 3 -56.14311 50.15012 Canada
#> 4 -55.47149 49.93582 Canada
#> 5 -55.82240 49.58713 Canada
#> 6 -54.93514 49.31301 Canada
coordinates(vertices1) = vertices1[,1:2]
# voronois
vor1 = dismo::voronoi(vertices1)
# visualise
plot(p)
plot(vertices1, add=T, pch=16, cex=.5, col = c('red','blue')[factor(vertices1$id)])
plot(vor1, add=T, border='#00000010', col = c('#FF000040','#0000FF40')[factor(vor1$id)])
Lots of errors in here. Maybe due to different polygons sharing some vertices. Let's try small negative buffer to help the algorithm:
p_buff2 = rgeos::gBuffer(p, byid=T, width = -.00002) # order of 1 metre
vertices2 = map_df(p_buff2#polygons, ~ map2_df(.x#Polygons, rep(.x#ID, length(.x#Polygons)),
~ as.data.frame(..1#coords) %>% `names<-`(c('x','y')) %>% mutate(id = ..2)))
coordinates(vertices2) = vertices2[,1:2]
vor2 = dismo::voronoi(vertices2)
plot(p_buff2)
plot(vertices2, add=T, pch=16, cex=.4, col = c('red','blue')[factor(vertices2$id)])
plot(vor2, add=T, border='#00000010', col = c('#FF000040','#0000FF40')[factor(vor2$id)])
Some improvements - almost validating the approach I think. But again we still have some errors, e.g. blue chunk of British Colombia and a thin pink strip of easter border area in Alaska. Lastly I plot with a bigger buffer to help show what is happening with individual vertices (click for bigger resolution):
p_buff3 = rgeos::gBuffer(p, byid=T, width = -.5, ) # order of 30kms I think
vertices3 = map_df(p_buff3#polygons, ~ map2_df(.x#Polygons, rep(.x#ID, length(.x#Polygons)),
~ as.data.frame(..1#coords) %>% `names<-`(c('x','y')) %>% mutate(id = ..2)))
coordinates(vertices3) = vertices3[,1:2]
vor3 = dismo::voronoi(vertices3)
plot(p_buff3)
plot(vertices3, add=T, pch=16, cex=.4, col = c('red','blue')[factor(vertices3$id)])
plot(vor3, add=T, border='#00000010', col = c('#FF000040','#0000FF40')[factor(vor3$id)])
Is anyone able to shed light on the problem, or possible suggest an alternative voronoi method that works? I've tried ggvoronoi but struggled to get that working. Any assistance appreciated.
That is an interesting, and important, problem; and I think it is a good idea to use voronoi. The apparent errors arise from the distribution of the vertices. For example, the border between Canada and the USA hardly has vertices in the west. This leads to undesired results, but they are not wrong. A step in the right direction might be to add vertices, using geosphere::makePoly
library(dismo)
library(geosphere)
library(rworldmap)
library(rgeos)
w <- rworldmap::countriesCoarse[,'ADMIN']
w <- w[w$ADMIN %in% c('United States of America', 'Canada'),]
p <- geosphere::makePoly(w, 25000)
p$ADMIN = as.character(p$ADMIN)
p <- buffer(p, width = 0, dissolve=FALSE)
p_buff <- buffer(p, width = -.00002, dissolve=FALSE) # order of 1 metre
g <- geom(p_buff)
g <- unique(g)
vor <- dismo::voronoi(g[,c("x", "y")])
plot(p_buff)
points(g[,c("x", "y")], pch=16, cex=.4, col= c('red','blue')[g[,"object"]])
plot(vor, add=T, border='#00000010', col = c('#FF000040','#0000FF40')[g[,"object"]])
Dissolve the polygons by country and remove holes
v <- aggregate(vor, list(g[,"object"]), FUN=length)
gg <- data.frame(geom(v))
v <- as(gg[gg$hole==0, ], "SpatialPolygons")
lines(v, col="yellow", lwd=4)
Now use this to cut the buffer by country
pp <- buffer(p, width = 10)
buf <- v * (pp - p) # intersect(v, erase(pp, p))
buf <- SpatialPolygonsDataFrame(buf, data=data.frame(p), match.ID = FALSE)
x <- bind(p, buf)
z <- aggregate(x, "ADMIN")
lines(z, lwd=2, col="dark green")
And now for something more focused. The below does essentially the same as the above, but focuses just on the regions that matter (coastal borders) making it computationally less intensive --- although not so much for this example with a rather large buffer.
library(dismo)
library(rworldmap)
library(rgeos)
w <- rworldmap::countriesCoarse[,'ADMIN']
w <- w[w$ADMIN %in% c('United States of America', 'Canada', 'Mexico'),]
p <- geosphere::makePoly(w, 25000)
p$ADMIN = as.character(p$ADMIN)
p <- buffer(p, width = 0, dissolve=FALSE)
#p <- buffer(p, width = -.00002, dissolve=FALSE) # order of 1 metre
bsz <- 10
mbuf <- buffer(p, width = bsz, dissolve=FALSE)
# e <- mbuf[1,] * mbuf[2,]
# -----------
# general solution for e?
poly_combs = expand.grid(p1 = seq_along(mbuf), p2 = seq_along(mbuf))
poly_combs = poly_combs[poly_combs$p1 < poly_combs$p2,]
# pairwise overlaps
e_pw = plyr::compact(lapply(1:nrow(poly_combs), FUN = function(i){
pair = poly_combs[i,]
pairing = suppressWarnings(mbuf[pair$p1,] * mbuf[pair$p2,])
return(pairing)
}))
e = e_pw[[1]]
for(i in 2:length(e_pw)) e = e + e_pw[[i]]
# -----------
f <- e - p
b <- buffer(f, bsz)
# bp is the area that matters
bp <- b * p
g <- data.frame(geom(bp))
# getting rid of duplicated and shared vertices
g <- aggregate(g[,1,drop=FALSE], g[,5:6], min)
v <- dismo::voronoi(g[,c("x", "y")], extent(p)+ 2 * bsz)
v <- aggregate(v, list(g[,"object"]), FUN=length)
v <- v- p
buf1 <- buffer(p, width = bsz, dissolve=TRUE)
v <- v * buf1
v#data <- p#data
plot(v, col=c("red", "blue", "green"))
Slight adaptation from Robert's, for discussion.
library(dismo)
library(rworldmap)
library(rgeos)
w <- rworldmap::countriesCoarse[,'ADMIN']
# w <- w[w$ADMIN %in% c('United States of America', 'Canada'),]
w <- w[w$ADMIN %in% c('Guyana', 'Suriname','French Guiana'),]
p <- geosphere::makePoly(w, 25000)
p$ADMIN = as.character(p$ADMIN)
p <- buffer(p, width = 0, dissolve=FALSE)
#p <- buffer(p, width = -.00002, dissolve=FALSE) # order of 1 metre
bsz <- .5
# outward buffer
mbuf = buffer(p, width = bsz, dissolve=F)
# overlay between two country buffers
# e <- mbuf[1,] * mbuf[2,]
poly_combs = expand.grid(p1 = seq_along(mbuf), p2 = seq_along(mbuf))
poly_combs = poly_combs[poly_combs$p1 < poly_combs$p2,]
# pairwise overlaps
e_pw = plyr::compact(lapply(1:nrow(poly_combs), FUN = function(i){
pair = poly_combs[i,]
pairing = suppressWarnings(mbuf[pair$p1,] * mbuf[pair$p2,])
return(pairing)
}))
e = e_pw[[1]]
for(i in 2:length(e_pw)) e = e + e_pw[[i]]
# contested buffer zones - overlap minus original polys
f <- e - p
f#data = data.frame(id = seq_along(f))
# buffer the contested zones
b <- buffer(f, bsz)
# bp is the area that matters
bp <- b * p
# vertices
bp = buffer(bp, width = -0.00002, dissolve=F)
g0 <- data.frame(data.frame(geom(bp)))
# getting rid of duplicated and shared vertices
# g <- aggregate(g0[,'object', drop=FALSE], g0[,c('x','y')], min)
g = unique(g0)
v0 <- dismo::voronoi(g[,c("x", "y")], extend(extent(p), 2 * bsz))
v0$id = g$object
v <- raster::aggregate(v0, list(g[,"object"]), FUN=length)
v#proj4string = p#proj4string
v = v * f
v#data = data.frame(ADMIN = p$ADMIN[v$Group.1])
# full buffer
fb = raster::bind(mbuf - p - f, v, p)
fb = raster::aggregate(fb, list(fb$ADMIN), FUN = function(x)x[1])[,'ADMIN']
fb#proj4string = p#proj4string
#----------------------------------
par(mai=c(0,0,0,0))
plot(p, border='grey')
plot(mbuf, add=T, border='pink')
plot(e, add=T, col='#00000010', border=NA)
plot(f, add=T, border='purple', lwd=1.5)
plot(b, add=T, border='red')
plot(bp, add=T, col='#ffff0040', border=NA)
# plot(v, add=T, col=c("#ff770020", "#0077ff20"), border=c("#ff7700", "#0077ff"))
plot(fb, add=T, col=c("#ff000020", "#00ff0020", "#0000ff20"), border=NA)
I'd like to automatically derive transects, perpendicular to the coastline. I need to be able to control their length and spacing and their oriëntation needs to be on the "correct" side of the line. I came up with a way to do that, but especially selecting the "correct" (it needs to point to the ocean) can be done better. General approach:
For each line segment in a SpatialLineDataFrame define transect
locations
define transect: in both directions perpendicular to coastline: create points that determine the transect
Create a polygon based on the coastline, add extra points to grow the polygon in a direction that is known and use that to clip the points that are inside (considered as land, and therefore not of interest)
Create transect based on remaining point
Especially part 3 is of interest. I'd like a more robust method to determine the correct orientation of the transect. This is what i'm using now:
library(rgdal)
library(raster)
library(sf)
library(ggplot2)
library(rgeos) # create lines and spatial objects
# create testing lines
l1 <- cbind(c(1, 2, 3), c(3, 2, 2))
l2 <- cbind(c(1, 2, 3), c(1, 1.5, 1))
Sl1 <- Line(l1)
Sl2 <- Line(l2)
S1 <- Lines(list(Sl1), ID = "a")
S2 <- Lines(list(Sl2), ID = "b")
line <- SpatialLines(list(S1, S2))
plot(line)
# for testing:
sep <- 0.1
start <- 0
AllTransects <- vector('list', 100000) # DB that should contain all transects
for (i in 1: length(line)){
# i <- 2
###### Define transect locations
# Define geometry subset
subset_geometry <- data.frame(geom(line[i,]))[, c('x', 'y')]
# plot(SpatialPoints(data.frame(x = subset_geometry[,'x'], y = subset_geometry[,'y'])), axes = T, add = T)
dx <- c(0, diff(subset_geometry[,'x'])) # Calculate difference at each cell comapred to next cell
dy <- c(0, diff(subset_geometry[,'y']))
dseg <- sqrt(dx^2+dy^2) # get rid of negatives and transfer to uniform distance per segment (pythagoras)
dtotal <- cumsum(dseg) # cumulative sum total distance of segments
linelength = sum(dseg) # total linelength
pos = seq(start,linelength, by=sep) # Array with postions numbers in meters
whichseg = unlist(lapply(pos, function(x){sum(dtotal<=x)})) # Segments corresponding to distance
pos=data.frame(pos=pos, # keep only
whichseg=whichseg, # Position in meters on line
x0=subset_geometry[whichseg,1], # x-coordinate on line
y0=subset_geometry[whichseg,2], # y-coordinate on line
dseg = dseg[whichseg+1], # segment length selected (sum of all dseg in that segment)
dtotal = dtotal[whichseg], # Accumulated length
x1=subset_geometry[whichseg+1,1], # Get X coordinate on line for next point
y1=subset_geometry[whichseg+1,2] # Get Y coordinate on line for next point
)
pos$further = pos$pos - pos$dtotal # which is the next position (in meters)
pos$f = pos$further/pos$dseg # fraction next segment of its distance
pos$x = pos$x0 + pos$f * (pos$x1-pos$x0) # X Position of point on line which is x meters away from x0
pos$y = pos$y0 + pos$f * (pos$y1-pos$y0) # Y Position of point on line which is x meters away from y0
pos$theta = atan2(pos$y0-pos$y1,pos$x0-pos$x1) # Angle between points on the line in radians
pos$object = i
###### Define transects
tlen <- 0.5
pos$thetaT = pos$theta+pi/2 # Get the angle
dx_poi <- tlen*cos(pos$thetaT) # coordinates of point of interest as defined by position length (sep)
dy_poi <- tlen*sin(pos$thetaT)
# tabel met alleen de POI informatie
# transect is defined by x0,y0 and x1,y1 with x,y the coordinate on the line
output <- data.frame(pos = pos$pos,
x0 = pos$x + dx_poi, # X coordinate away from line
y0 = pos$y + dy_poi, # Y coordinate away from line
x1 = pos$x - dx_poi, # X coordinate away from line
y1 = pos$y - dy_poi, # X coordinate away from line
theta = pos$thetaT, # angle
x = pos$x, # Line coordinate X
y = pos$y, # Line coordinate Y
object = pos$object,
nextx = pos$x1,
nexty = pos$y1)
# create polygon from object to select correct segment of the transect (coastal side only)
points_for_polygon <- rbind(output[,c('x', 'y','nextx', 'nexty')])# select points
pol_for_intersect <- SpatialPolygons( list( Polygons(list(Polygon(points_for_polygon[,1:2])),1)))
# plot(pol_for_intersect, axes = T, add = T)
# Find a way to increase the polygon - should depend on the shape&direction of the polygon
# for the purpose of cropping the transects
firstForPlot <- data.frame(x = points_for_polygon$x[1], y = points_for_polygon$y[1])
lastForPlot <- data.frame(x = points_for_polygon$x[length(points_for_polygon$x)],
y = points_for_polygon$y[length(points_for_polygon$y)])
plot_first <- SpatialPoints(firstForPlot)
plot_last <- SpatialPoints(lastForPlot)
# plot(plot_first, add = T, col = 'red')
# plot(plot_last, add = T, col = 'blue')
## Corners of shape dependent bounding box
## absolute values should be depended on the shape beginning and end point relative to each other??
LX <- min(subset_geometry$x)
UX <- max(subset_geometry$x)
LY <- min(subset_geometry$y)
UY <- max(subset_geometry$y)
# polygon(x = c(LX, UX, UX, LX), y = c(LY, LY, UY, UY), lty = 2)
# polygon(x = c(LX, UX, LX), y = c(LY, LY, UY), lty = 2)
# if corners are changed to much the plot$near becomes a problem: the new points are to far away
# Different points are selected
LL_corner <- data.frame(x = LX-0.5, y = LY - 1)
LR_corner <- data.frame(x = UX + 0.5 , y = LY - 1)
UR_corner <- data.frame(x = LX, y = UY)
corners <- rbind(LL_corner, LR_corner)
bbox_add <- SpatialPoints(rbind(LL_corner, LR_corner))
# plot(bbox_add ,col = 'green', axes = T, add = T)
# Select nearest point for drawing order to avoid weird shapes
firstForPlot$near <-apply(gDistance(bbox_add,plot_last, byid = T), 1, which.min)
lastForPlot$near <- apply(gDistance(bbox_add,plot_first, byid = T), 1, which.min)
# increase polygon with corresponding points
points_for_polygon_incr <- rbind(points_for_polygon[1:2], corners[firstForPlot$near,], corners[lastForPlot$near,])
pol_for_intersect_incr <- SpatialPolygons( list( Polygons(list(Polygon(points_for_polygon_incr)),1)))
plot(pol_for_intersect_incr, col = 'blue', axes = T)
# Coordinates of points first side
coordsx1y1 <- data.frame(x = output$x1, y = output$y1)
plotx1y1 <- SpatialPoints(coordsx1y1)
plot(plotx1y1, add = T)
coordsx0y0 <- data.frame(x = output$x0, y = output$y0)
plotx0y0 <- SpatialPoints(coordsx0y0)
plot(plotx0y0, add = T, col = 'red')
# Intersect
output[, "x1y1"] <- over(plotx1y1, pol_for_intersect_incr)
output[, "x0y0"] <- over(plotx0y0, pol_for_intersect_incr)
x1y1NA <- sum(is.na(output$x1y1)) # Count Na
x0y0NA <- sum(is.na(output$x1y1)) # Count NA
# inefficient way of selecting the correct end point
# e.g. either left or right, depending on intersect
indexx0y0 <- with(output, !is.na(output$x0y0))
output[indexx0y0, 'endx'] <- output[indexx0y0, 'x1']
output[indexx0y0, 'endy'] <- output[indexx0y0, 'y1']
index <- with(output, is.na(output$x0y0))
output[index, 'endx'] <- output[index, 'x0']
output[index, 'endy'] <- output[index, 'y0']
AllTransects = rbind(AllTransects, output)
}
# Create the transects
lines <- vector('list', nrow(AllTransects))
for(n in 1: nrow(AllTransects)){
# n = 30
begin_coords <- data.frame(lon = AllTransects$x, lat = AllTransects$y) # Coordinates on the original line
end_coords <- data.frame(lon = AllTransects$endx, lat = AllTransects$endy) # coordinates as determined by the over: remove implement in row below by selecting correct column from output
col_names <- list('lon', 'lat')
row_names <- list('begin', 'end')
# dimnames < list(row_names, col_names)
x <- as.matrix(rbind(begin_coords[n,], end_coords[n,]))
dimnames(x) <- list(row_names, col_names)
lines[[n]] <- Lines(list(Line(x)), ID = as.character(n))
}
lines_sf <- SpatialLines(lines)
# plot(lines_sf)
df <- SpatialLinesDataFrame(lines_sf, data.frame(AllTransects))
plot(df, axes = T)
As long as i'm able to correctly define the bounding box and grow the polygon correctly this works. But I'd like to try this on multiple coastlines and parts of coastlines, each with its own orientation. In the example below the growing of the polygon is made for the bottom coastline segment, as a result the top one has transects in the wrong direction.
Anybody has an idea in what directio to look? I was considering to perhaps use external data but when possible i'd like to avoid that.
I used your code for my question (measure line inside a polygon) but maybe this works for you:
Took a spatial polygon or line
Extract the coordinates of the element
Make a combination of coordinates to create straight lines, from with you can derivate perpendicular lines (e.g. ((x1,x3)(y1, y3)) or ((x2,x4)(y2, y4)) )
Iterate along with all the pairs of coordinates
Apply the code you did, especially the result of the 'output' table.
I did this for a polygon, so I could generate perpendicular lines based on the straight line I create taking an arbitrary (1, 3) set of coordinates.
#Define a polygon
pol <- rip[1, 1] # I took the first polygon from my Shapefile
polcoords <- pol#polygons[[1]]#Polygons[[1]]#coords
# define how to create your coords pairing. My case: 1st with 3rd, 2nd with 4th, ...
pairs <- data.frame(a = 1:( nrow(polcoords) - 1),
b = c(2:(nrow(polcoords)-1)+1, 1) )
# Empty list to store the lines
lnDfls <- list()
for (j in 1:nrow(pairs)){ # j = 1
# Select the pairs
pp <- polcoords[c(pairs$a[j], pairs$b[j]), ]
#Extract mean coord, from where the perp. line will start
midpt <- apply(pp, 2, mean)
# points(pp, col = 3, pch = 20 )
# points(midpt[1], midpt[2], col = 4, pch = 20)
x <- midpt[1]
y <- midpt[2]
theta = atan2(y = pp[2, 2] - pp[1, 2], pp[2, 1] - pp[1, 1]) # Angle between points on the line in radians
# pos$theta = atan2(y = pos$y0-pos$y1 , pos$x0-pos$x1) # Angle between points on the line in radians
###### Define transects
tlen <- 1000 # distance in m
thetaT = theta+pi/2 # Get the angle
dx_poi <- tlen*cos(thetaT) # coordinates of point of interest as defined by position length (sep)
dy_poi <- tlen*sin(thetaT)
# tabel met alleen de POI informatie
# transect is defined by x0,y0 and x1,y1 with x,y the coordinate on the line
output2 <- data.frame(#pos = pos,
x0 = x + dx_poi, # X coordinate away from line
y0 = y + dy_poi, # Y coordinate away from line
x1 = x - dx_poi, # X coordinate away from line
y1 = y - dy_poi # X coordinate away from line
#theta = thetaT, # angle
#x = x, # Line coordinate X
#y = y # Line coordinate Y
)
# points(output2$x1, output2$y1, col = 2)
#segments(x, y, output2$x1[1], output2$y1[1], col = 2)
mat <- as.matrix(cbind( c( x, output2$x1[1] ) , c( y, output2$y1[1] ) ))
LL <- Lines(list(Line( mat )), ID = as.character(j))
# plot(SpatialLinesDataFrame(LL, data.frame (a = 1)), add = TRUE, col = 2)
# plot(SpatialLines(list(LL)), add = TRUE, col = 2)
#lnList[[j]] <- LL
lnDfls[[j]] <- SpatialLinesDataFrame( SpatialLines(LinesList = list(LL)) ,
match.ID = FALSE,
data.frame(id = as.character(j ) ) )
# line = st_sfc(st_linestring(mat))
# st_length(line)
# ln <- (SpatialLines(LinesList = list(LL)))
# lndf <- SpatialLinesDataFrame( lndf , data.frame(id = j ))
# sf::st_length(ln)
# # plot(lines_sf)
}
compDf <- do.call(what = sp::rbind.SpatialLines, args = lnDfls)
plot(pol)
plot(compDf, add = TRUE, col = 2)
plot(inDfLn, add = TRUE, col = 3)
I am looking for a procedure that allows me to generate a sequence of equidistant points (coordinates) along the sides of an arbitrary polygon.
Imaging a polygon defined by the coordinates of its vertexes:
poly.mat <- matrix(c(0,0,
0,1,
0.5,1.5,
0.5,0,
0,0 # last row included to close the polygon
), byrow = T, ncol = 2)
colnames(poly.mat) <- c("x", "y")
plot(poly.mat, type = "l")
If the length of the sequence I want to generate is n (adjustable), how I can produce a sequence, starting at (0,0), of equidistant coordinates.
I got as far as calculating the perimeter of the shape with the geosphere package (which I believe I need)
library(geosphere)
n <- 50 # sequence of length set to be 50
perim <- perimeter(poly.mat)
perim/n # looks like every section needs to be 8210.768 something in length
You will have to write the code yourself. Sorry, there isn't a library function for every last detail of every last assignment. Assuming that each pair of points defines a line segment, you could just generate N points along each segment, as in
begin = [xbegin, ybegin ];
end = [xend, yend ];
xdist = ( xend - xbegin ) / nintervals;
ydist = ( yend - ybegin ) / nintervals;
then your points are given by [ xbegin + i * xdist, ybegin + i * ydist ]
Here is the solution I came up with.
pointDistance <- function(p1, p2){
sqrt((p2[,1]-p1[,1])^2) + sqrt((p2[,2]-p1[,2])^2)
}
getPos <- function(shp.mat, ll){
greaterLL <- shp.mat$cumdis > ll
if(all(greaterLL == FALSE)) return(poly.mat[nrow(poly.mat), c("x", "y")])
smallRow <- min(which(greaterLL)) # the smallest coordinate that has greater length
p.start <- shp.mat[smallRow-1, c("x","y")]
p.end <- shp.mat[smallRow, c("x","y")]
cumVal <- shp.mat$cumdis[smallRow]
prop <- (ll-shp.mat$cumdis[smallRow-1])/(shp.mat$cumdis[smallRow]-shp.mat$cumdis[smallRow-1])
p.start + (prop)* (p.end-p.start)
}
# shp1
poly.mat <- matrix(c(0,0,
0,1,
0.5,1.5,
0.5,0,
0,0
),byrow = T, ncol = 2)
colnames(poly.mat) <- c("x", "y")
poly.mat <- as.data.frame(poly.mat)
# Main fun
pointsOnPath <- function(shp.mat, n){
dist <- vector(mode = "numeric", length = nrow(shp.mat)-1)
for(i in 2:nrow(shp.mat)){
dist[i] <- pointDistance(p1 = shp.mat[i,], p2 = shp.mat[i-1,])
}
shp.mat$dist <- dist
shp.mat$cumdis <- cumsum(shp.mat$dist)
dis <- matrix(seq(from = 0, to = max(shp.mat$cumdis), length.out = n+1), ncol = 1)
out <- lapply(dis, function(x) getPos(shp.mat = shp.mat, ll = x))
out <- do.call("rbind", out)
out$dis <- dis
out[-nrow(out),]
}
df <- pointsOnPath(shp.mat = poly.mat, 5)
# Plot
plot(poly.mat$x, poly.mat$y, type = "l", xlim = c(0,1.5), ylim = c(0,1.5))
points(df$x, df$y, col = "red", lwd = 2)
There is room for improving the code, but it should return the correct result
I am trying to obtain a steady state for a spatially-explicit Lotka-Volterra competition model of two competing species (with spatial diffusion). Here is the model (without diffusion term):
http://en.wikipedia.org/wiki/Competitive_Lotka%E2%80%93Volterra_equations
where I let r1 = r2 = rG & alpha12 = alpha 21 = a. The carrying capacity of species 1 is assumed to vary linearly across space x i.e. K1 = x (while K2 = 0.5). And we assume Neumann BC. The spatial domain x is from 0 to 1.
Here is the example of coding in R for this model:
LVcomp1D <- function (time, state, parms, N, Da, x, dx) {
with (as.list(parms), {
S1 <- state[1:N]
S2 <- state[(N+1):(2*N)]
## Dispersive fluxes; zero-gradient boundaries
FluxS1 <- -Da * diff(c(S1[1], S1, S1[N]))/dx
FluxS2 <- -Da * diff(c(S2[1], S2, S2[N]))/dx
## LV Competition
InteractS1 <- rG * S1 * (1- (S1/x)- ((a*S2)/x))
InteractS2 <- rG * S2 * (1- (S2/(K2))- ((a*S1)/(K2)))
## Rate of change = -Flux gradient + Interaction
dS1 <- -diff(FluxS1)/dx + InteractS1
dS2 <- -diff(FluxS2)/dx + InteractS2
return (list(c(dS1, dS2)))
})
}
pars <- c(rG = 1.0, a = 0.8, K2 = 0.5)
dx <- 0.001
x <- seq(0, 1, by = dx)
N <- length(x)
Da <- 0.001
state <- c(rep(0.5, N), rep(0.5, N))
print(system.time(
out <- steady.1D (y = state, func = LVcomp1D, parms = pars,
nspec = 2, N = N, x = x, dx = dx, Da = Da, pos = TRUE)
))
mf <- par(mfrow = c(2, 2))
plot(out, grid = x, xlab = "x", mfrow = NULL,
ylab = "N(x)", main = c("Species 1", "Species 2"), type = "l")
par(mfrow = mf)
The problem is I cannot get the steady state solutions of the model. I keep getting a horizontal line passing through x-axis. Can you please help me since I do not know what is wrong with this code.
Thank you