Блог

Итак, у меня есть набор данных с 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)

 

Вот один из возможных подходов, в котором я рассматриваю проблему непосредственно как проблему оптимизации.

Предположим, у вас есть допустимое разделение строк на группы. Не обязательно хороший, но такой, который не нарушает ограничений. Для каждой группы (кластера) вы вычисляете центр. Затем вы вычисляете расстояния всех точек в группе до центра группы и суммируете их. Таким образом, у вас есть показатель качества вашего начального раздела.

Теперь случайным образом выберите строку и переместите ее в другую группу. Вы получаете новое решение. Выполните действия, как и раньше, и сравните качество нового решения с предыдущим. Если так будет лучше, оставь его себе. Если будет хуже, оставайтесь со старым решением. Теперь повторите всю эту процедуру для фиксированного числа итераций.

Этот процесс называется Локальным поиском. Конечно, это не гарантирует, что это приведет вас к оптимальному решению. Но это, скорее всего, даст вам хорошее решение. (Обратите внимание, что реализации k-средних, как правило, также являются стохастическими, и нет гарантии «оптимального» разбиения.)

Хорошая вещь в локальном поиске заключается в том, что он дает вам большую гибкость. Например, я предположил, что вы начали с возможного решения. Предположим, вы делаете случайное перемещение (т. Е. перемещаете одну строку в другой кластер), но теперь этот новый кластер стал большим. Теперь вы можете просто отказаться от этого нового, неосуществимого решения и нарисовать новое.

Вот пример кода, на самом деле просто набросок; но, если повезет, он вам пригодится.

 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])
 

Целевая функция: она берет разбиение 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
 

Это действительно просто пример, и его можно было бы улучшить. Например, целевая функция здесь пересчитывает расстояние между всеми группами, когда ей нужно было бы только посмотреть на измененные группы.

Что-то вроде этого может помочь вам начать?

 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)