voronoi镶嵌中的层次结构

Question

我正在使用voronoi镶嵌细分。我有不同的多边形表示镶嵌中的区域。

以下几点用于绘制图中的曲面细分。

tessdata
    [,1]       [,2]
1  -0.4960583 -0.3529047
2  -2.4986929  0.8897895
3   3.6514561 -1.3533369
4  -1.7263101 -5.5341202
5   2.2140143  0.3883696
6  -2.5208933 -1.4881461
7  -3.2556913  4.4535629
8   0.6423109 -2.8350062
9  -0.4160715  1.2676151
10  4.4059361  4.5641771

使用tessdata作为输入来绘制曲面细分，如下所示：

library(deldir)
dd<-deldir(tessdata[,1], tessdata[,2])
plot(dd,wlines="tess")

Sammon坐标在下面。

       [,1]        [,2]
1   3.14162704 -1.45728604
2   2.35422623  2.46437927
3  -0.85051049  2.71503294
4   1.94310458 -0.45936958
5   0.08737757  3.74324701
6   1.23007799  1.34443842
7   0.01571924  2.19322032
8   1.43320754  2.64818631
9  -0.05463431  0.66980876
10   1.51344967  5.03351176

我想构建输入了sammon坐标点的镶嵌细分。使用这些点的曲面细分应该在所示图中的一个区域内，为此，应该缩放上述点，或者我们可以限制上图中某个区域内曲面细分的图。

希望我已经涵盖了所有必要的数据。

P.S：

sammon的投影出现在“MASS”套餐中。 来自“deldir”包的voronoi镶嵌。

deldir函数输出的dirsgs参数将给出在曲面细分中形成线条的点的坐标。

包图形的段函数可用于连接其坐标从dirsgs中提取的2个点。

Answer 1

如果要限制第二组点数 到曲面板的其中一个瓷砖， 您可以使用tile.list来描述每个磁贴， 然后检查此图块中的哪些点 （有很多功能可以这样做： 在以下示例中，我使用secr::pointsInPolygon）。

# Sample data
x <- matrix( rnorm(20), nc = 2 )
y <- matrix( rnorm(1000), nc=2 )

# Tessellation
library(deldir)
d <- deldir(x[,1], x[,2])
plot(d, wlines="tess")

# Pick a cell at random 
cell <- sample( tile.list(d), 1 )[[1]]
points( cell$pt[1], cell$pt[2], pch=16 )
polygon( cell$x, cell$y, lwd=3 )

# Select the points inside that cell
library(secr)
i <- pointsInPolygon(
  y, 
  cbind( 
    c(cell$x,cell$x[1]), 
    c(cell$y,cell$y[1])
  )
)
points(y[!i,], pch=".")
points(y[i,], pch="+")

# Compute a tessellation of those points
dd <- deldir(y[i,1], y[i,2])
plot(dd, wlines="tess", add=TRUE)

相反，如果您要翻译并重新缩放积分 把它们装进瓷砖，这比较棘手。

我们需要以某种方式估计积分离瓷砖有多远： 为此，让我们定义一些辅助函数来计算， 首先是从一个点到一个段的距离， 那么从一个点到多边形的距离。

distance_to_segment <- function(M, A, B) {
  norm <- function(u) sqrt(sum(u^2))
  lambda <- sum( (B-A) * (M-A) ) / norm(B-A)^2
  if( lambda <= 0 ) {
    norm(M-A)
  } else if( lambda >= 1 ) {
    norm(M-B)
  } else {
    N <- A + lambda * (B-A)
    norm(M-N)
  }
}
A <- c(-.5,0)
B <- c(.5,.5)
x <- seq(-1,1,length=100)
y <- seq(-1,1,length=100)
z <- apply(
  expand.grid(x,y), 
  1, 
  function(u) distance_to_segment( u, A, B )
)
par(las=1)
image(x, y, matrix(z,nr=length(x)))
box()
segments(A[1],A[2],B[1],B[2],lwd=3)

library(secr)
distance_to_polygon <- function(x, poly) {
  closed_polygon <- rbind(poly, poly[1,])
  if( pointsInPolygon( t(x), closed_polygon ) )
    return(0)
  d <- rep(Inf, nrow(poly))
  for(i in 1:nrow(poly)) {
    A <- closed_polygon[i,]
    B <- closed_polygon[i+1,]
    d[i] <- distance_to_segment(x,A,B)
  }
  min(d)
}
x <- matrix(rnorm(20),nc=2)
poly <- x[chull(x),]
x <- seq(-5,5,length=100)
y <- seq(-5,5,length=100)
z <- apply(
  expand.grid(x,y), 
  1, 
  function(u) distance_to_polygon( u, poly )
)
par(las=1)
image(x, y, matrix(z,nr=length(x)))
box()
polygon(poly, lwd=3)

我们现在可以寻找表格的转换

x --> lambda * x + a
y --> lambda * y + b

最小化到多边形的（平方和）距离。 这实际上是不够的：我们可能最终得到缩放因子 lambda等于（或接近）零。 为避免这种情况，如果lambda很小，我们可以添加一个惩罚。

# Sample data 
x <- matrix(rnorm(20),nc=2)
x <- x[chull(x),]
y <- matrix( c(1,2) + 5*rnorm(20), nc=2 )
plot(y, axes=FALSE, xlab="", ylab="")
polygon(x)

# Function to minimize:
# either the sum of the squares of the distances to the polygon, 
# if at least one point is outside, 
# or minus the square of the scaling factor.
# It is not continuous, but (surprisingly) that does not seem to be a problem.
f <- function( p ) {
  lambda <- log( 1 + exp(p[1]) )
  a <- p[2:3]
  y0 <- colMeans(y)
  transformed_points <- t( lambda * (t(y)-y0) + a )
  distances <- apply(
    transformed_points, 
    1, 
    function(u) distance_to_polygon(u, x)
  )
  if( all(distances == 0) ) - lambda^2
  else                      sum( distances^2 )
}
# Minimize this function
p <- optim(c(1,0,0), f)$par
# Compute the optimal parameters
lambda <- log( 1 + exp(p[1]) )
a <- p[2:3]
y0 <- colMeans(y)
# Compute the new coordinates
transformed_points <- t( lambda * (t(y)-y0) + a )
# Plot them
segments( y[,1], y[,2], transformed_points[,1], transformed_points[,2], lty=3 )
points( transformed_points, pch=3 )
library(deldir)
plot( 
  deldir( transformed_points[,1], transformed_points[,2] ), 
  wlines="tess", add=TRUE 
)