如何根据 R 中每个集群的固定容量创建集群？

Question

所以我有一个包含 600 个点、它们的纬度、经度和需求的数据集。我必须创建集群，使每个集群的点彼此靠近，并且该集群的总容量不会超过某个限制。

问题的示例数据集：

set.seed(123)
id<- seq(1:600)
lon <- rnorm(600, 88.5, 0.125)
lat <- rnorm(600, 22.4, 0.15)
demand <- round(rnorm(600, 40, 20))

df<- data.frame(id, lon, lat, demand)

我大概想要的是：

我得到了什么（簇边界是近似的）：

我写的代码：

library(tidyverse)
constrained_cluster <- function(df,capacity=170){
  lon_max <- max(df$lon)
  lat_max <- max(df$lat)

#Calculating the distance between an extreme point and all other points

  df$distance<-6377.83*acos(sin(lat_max*p)*sin(df$lat*p) + cos(lat_max*p)*cos(df$lat*p) * cos((lon_max-df$lon)*p))
  df<- df[order(df$distance, decreasing = FALSE),]
  d<-0
  cluster_number<-1
  cluster_list<- c()
  i<-1
#Writing a loop to form the cluster which will fill up the cluster_list accordingly
  while (i <= length(df$distance)){
    d <- d+ df$demand[i]
    if(d<=capacity){
      cluster_list[i] <- cluster_number
      i<- i+1
    }
    else{
      cluster_number <- cluster_number+1
      d <- 0
      i<-i
    }
  }
#Return a dataframe with the list of clusters
  return(cbind(df,as.data.frame(cluster_list)))
}

df_with_cluster<- constrained_cluster(df, capacity = 1000)

Answer 1

这样的事情可能会让您入门？

nmax <- 100
num.centers <- 1
km <- kmeans(cbind(df$lat, df$lon), centers = num.centers)
#check if there are no clusters larger than nmax
while (prod(km$size < nmax) == 0) {
  num.centers <- num.centers + 1
  km <- kmeans(cbind(df$lat, df$lon), centers = num.centers)
}
plot(df$lon, df$lat, col = km$cluster, pch = 20)

Answer 2

这是一种可能的方法，我直接将问题视为优化问题。

假设您有一个可行的行分组。不一定是好的，但不违反约束的。对于每一个组（集群），你计算中心。然后你计算一组中所有点到组的中心，并将它们相加。这样，你就有了一个衡量初始分区的质量。

现在，随机选择一行，并将其移动到另一行团体。你得到新的解决方案。完成步骤和以前一样，并将新解决方案的质量与上一个。如果更好，请保留它。如果它是更糟的是，继续使用旧的解决方案。现在重复这个固定迭代次数的整个过程。

此过程称为本地搜索。当然是这样不保证它会带你到最佳状态解决方案。但它可能会给你一个很好的解决方案。（注意 k-means 实现是通常也是随机的，并且没有保证对于“最佳”分区。）

本地搜索的好处在于它提供你有多大的灵活性。例如，我假设你从一个可行的解决方案开始。假设你做一个随机移动（即将一行移动到另一个集群），但是现在这个新集群太大了。您现在可以简单地放弃这个新的、不可行的解决方案，并绘制一个新的解决方案。

这是一个代码示例，实际上只是一个大纲；但幸运的是它对你有用。

set.seed(123)
id<- seq(1:600)
lon <- rnorm(600, 88.5, 0.125)
lat <- rnorm(600, 22.4, 0.15)
demand <- round(rnorm(600, 40, 20))

df<- data.frame(id, lon, lat, demand)

修复多个簇，k.

k <- 5

从 kmeans 开始并绘制解决方案。

par(mfrow = c(1, 3))
km <- kmeans(cbind(df$lat, df$lon), centers = k)

cols <- hcl.colors(n = k, "Cold")
plot(df$lon,
     df$lat,
     type = "p", pch = 19, cex = 0.5,
     main = "kmeans")
for (i in seq_len(k)) {
    lines(df$lon[km$cluster == i],
          df$lat[km$cluster == i],
          type = "p", pch = 19,
          col = cols[i])
}

现在是本地搜索。我在包 NMOF（我维护）中使用了一个实现。

library("NMOF")

## a random initial solution
x0 <- sample(1:k, length(id), replace = TRUE)
X <- as.matrix(df[, 2:3])

objective 函数：它采用分区 x 并计算所有集群的距离总和。

sum_diff <- function(x, X, k, ...) {
    groups <- seq_len(k)
    d_centre <- numeric(k)
    for (g in groups) {
        centre <- colMeans(X[x == g, ], )
        d <- t(X[x == g, ]) - centre
        d_centre[g] <- sum(sqrt(colSums(d * d)))
    }
    sum(d_centre)
}

邻域函数：它需要一个分区并移动一行到另一个集群。

nb <- function(x, k, ...) {
    groups <- seq_len(k)

    x_new <- x
    p <- sample.int(length(x), 1)
    g_ <- groups[-x_new[p]]    
    x_new[p] <- g_[sample.int(length(g_), 1)]
    x_new
}

运行本地搜索。我实际上使用了一种称为阈值接受的方法，它基于局部搜索，但可以远离局部最小值。有关该方法的参考，请参阅 ?NMOF::TAopt。

sol <- TAopt(sum_diff,
             list(x0 = x0,
                  nI = 20000,
                  neighbour = nb),
             X = as.matrix(df[, 2:3]),
             k = k)

绘制解决方案。

plot(df$lon,
     df$lat,
     type = "p", pch = 19, cex = 0.5,
     main = "Local search")
for (i in seq_len(k)) {
    lines(df$lon[sol$xbest == i],
          df$lat[sol$xbest == i],
          type = "p", pch = 19, 
          col = cols[i])
}

现在，添加容量限制的一种方法。我们从一个可行的解决方案开始。

## CAPACITY-CONSTRAINED
max.demand <- 6600
all(tapply(df$demand, x0, sum) < max.demand)
## TRUE

约束在附近处理。如果新的解决方案超过容量，则将其丢弃。

nb_constr <- function(x, k, demand, max.demand,...) {
    groups <- seq_len(k)
    x_new <- x
    p <- sample.int(length(x), 1)
    g_ <- groups[-x_new[p]]    
    x_new[p] <- g_[sample.int(length(g_), 1)]

    ## if capacity is exceeded, return
    ## original solution
    if (sum(demand[x_new == x_new[p]]) > max.demand)
        x
    else
        x_new
}

运行方法与结果比较

sol <- TAopt(sum_diff,
             list(x0 = x0,
                  nI = 20000,
                  neighbour = nb_constr),
             X = as.matrix(df[, 2:3]),
             k = k,
             demand = df$demand,
             max.demand = max.demand)

plot(df$lon,
     df$lat,
     type = "p", pch = 19, cex = 0.5,
     main = "Local search w/ constraint")
for (i in seq_len(k)) {
    lines(df$lon[sol$xbest == i],
          df$lat[sol$xbest == i],
          type = "p", pch = 19,
          col = cols[i])
}

all(tapply(df$demand, sol$xbest, sum) < max.demand)
## TRUE

这实际上只是一个示例，还可以改进。例如，这里的 objective 函数重新计算所有组的距离，而它只需要查看更改后的组。

如何根据 R 中每个集群的固定容量创建集群？

How do I make clusters based on a fixed capacity of each cluster in R?

r

optimization

cluster-analysis

hierarchical-clustering

operations-research