缩凸壳

问题描述

我在2D空间中有一堆点，并为它们计算了一个凸包。我现在想“拧紧”船体，使其不再必然包含所有要点。在典型的带橡皮板钉子的比喻中，我想要实现的是能够调整橡皮筋的弹性并允许钉子在高于某个极限的压力下弯曲。这只是一个类比，这里没有真正的物理学。如果删除给定点，这可能与船体面积的减少有关，但并不是完全一样，因为可能存在两个彼此非常接近的点。这不一定与离群值检测有关，因为您可以想象一个模式，如果钉子在狭窄的线上，很大一部分钉子会弯曲（例如，想象成锤子形）。所有这一切必须相当快地达到数千个点。有什么提示我应该在算法方面看吗？用R实现是完美的，但不是必需的。

评论后编辑：我所标记的三个点是那些如果不包括在内则具有最大的减小船体面积的潜力。在图中，没有其他三点会导致更大的面积减少。我正在寻找的一个简单的实现可能是随机采样点的一部分，计算船体面积，迭代地移除船体上的每个点，重新计算面积，重复多次并移除可能导致高面积减少。也许可以在一些随机森林变体中实现？不过，这不太正确，因为我希望一点一点地删除点，以便获得以下结果。如果您一目了然地查看了所有点，则最好从“锤头”的边缘进行修剪。

解决方法

假设我有如下几点：

set.seed(69)

x <- runif(20)
y <- runif(20)

plot(x,y)

然后可以很容易地找到位于凸包上的子集点：

ss <- chull(x,y)

这意味着我们可以通过以下方式绘制凸包：

lines(x[c(ss,ss[1])],y[c(ss,col = "red")

现在，我们可以执行以下操作，随机移除凸包上的任一点（即“弯曲钉子”）：

bend <- ss[sample(ss,1)]

x <- x[-bend]
y <- y[-bend]

然后我们可以重复寻找新点集的凸包的过程：

ss <- chull(x,y)
lines(x[c(ss,col = "blue",lty = 2)

要弄清点，将其移除时会导致最大的面积减少，其中一个选项是以下功能：

library(sp)

shrink <- function(coords)
{
  ss <- chull(coords[,1],coords[,2])
  outlier <- ss[which.min(sapply(seq_along(ss),function(i) Polygon(coords[ss[-i],],hole = FALSE)@area))]
  coords[-outlier,]
}

因此您可以执行以下操作：

coords <- cbind(x,y)

new_coords <- shrink(coords)

new_chull <- new_coords[chull(new_coords[,new_coords[,2]),]
new_chull <- rbind(new_chull,new_chull[1,])

plot(x,y)

lines(new_chull[,new_chull[,2],col = "red")

当然，您可以循环执行此操作，以便将new_coords多次反馈到shrink中。

,

在MASS中使用mcd.cov并从其得出每个点的马哈拉诺比斯距离（在心理中使用mahalanobis）来计算鲁棒的中心和方差。然后，我们使用PlotMD来自modi的马哈拉诺比斯距离的分位数图，并且在第二个图中以红色显示了相关的离群值。 （modi中还有其他功能可能也很有趣。）

library(MASS)
library(modi)
library(psych)

set.seed(69)   
x <- runif(20)
y <- runif(20)
m <- cbind(x,y)

mcd <- cov.mcd(m)
md <- mahalanobis(m,mcd$center,mcd$cov)
stats <- PlotMD(md,2,alpha = 0.90)

给予：

（截图后续）

，我们使用线条和红色的离群值显示凸包：

plot(m)    
ix <- chull(m)
lines(m[c(ix,ix[1]),])

wx <- which(md > stats$halpha)
points(m[wx,col = "red",pch = 20)

,

谢谢你们！我尝试了各种方法进行离群值检测，但这并不是我想要的。由于我的集群形状怪异，所以它们工作不佳。我知道我谈论过凸包区域，但是我认为对段长度进行过滤会产生更好的结果，并且更接近于我真正想要的。然后看起来像这样：

shrink <- function(xy,max_length = 30){
      to_keep <- 1:(dim(xy)[1])
      centroid <- c(mean(xy[,1]),mean(xy[,2]))

      while (TRUE){
        ss <- chull(xy[,xy[,2])
        ss <- c(ss,ss[1])
        lengths <- sapply(1:(length(ss)-1),function(i) sum((xy[ss[i+1],] - xy[ss[i],])^2))

        # This gets the point with the longest convex hull segment. chull returns points
        # in clockwise order,so the point to remove is either this one or the one
        # after it. Remove the one furthest from the centroid.
        max_point <- which.max(lengths)
        if (lengths[max_point] < max_length) return(to_keep)

        if (sum((xy[ss[max_point],] - centroid)^2) > sum((xy[ss[max_point + 1],] - centroid)^2)){
          xy <- xy[-ss[max_point],]
          to_keep <- to_keep[-ss[max_point]]
        }else{
          xy <- xy[-ss[max_point + 1],]
          to_keep <- to_keep[-ss[max_point + 1]]
        }
      }
    }

这不是最佳选择，因为它会影响到质心的距离，我想避免这种情况，并且有一个max_length参数应该从数据中计算出来，而不要进行硬编码。

没有过滤器：

看起来像这样，因为这里有50万个单元，当从大约20000尺寸投影到2时，许多最终以“错误”告终。

过滤器：

请注意，它会过滤掉某些聚类的尖端的点。这不是最理想的，但是还可以。一些簇之间的重叠是正确的，应该存在。