Переключите строки в data.table для создания универсальной переменной

Question

• 1000 ). Пока что у меня есть следующий сценарий, который приводит к некоторым улучшениям, но я подозреваю, что это не оптимальный алгоритм для достижения этой цели. Есть идеи получше?

    test <- data.table(sowid=c(12,23,25,45,65,12,58,85,96,85,45,23),pen=c(1,1,1,1,2,2,2,2,3,3,3,3),pigletid=c(1,2,3,4,5,6,7,8,9,10,11,12),weight=c(6.5,5.9,6.2,5.8,7.5,7.2,7.8,6.9,9.5,10.2,9.8,6.4))

count <- 0
switch <- c(0,0)
cutoff <- 0.1

while(count == 0){
  meanPP <- test [,mean(weight),.(pen)]
  names(meanPP) <- c("pen","Mean")
  meanPP <- meanPP[order(Mean)]

  if (max(meanPP$Mean) - min(meanPP$Mean) <= cutoff){
    test <- test[order(pen)]
    count <- count + 1
  }else{
    count2 <- 0
    i <- 0
    while (count2 == 0 & i <= nrow(meanPP)){
      maxH <- meanPP$pen[nrow(meanPP)-i] 
      for (j in (nrow(test)/nrow(meanPP)):1){
        maxA <- test[pen==maxH]
        maxA <- maxA[order(weight)]$pigletid[j]
        if ((test$sowid[which(test$pigletid == maxA)] %in% test$sowid[-which(test$pigletid == maxA)]) && test[sowid == test$sowid[which(test$pigletid == maxA)],min(weight)] < test[pigletid == maxA,weight]){
          maxA <- which(test$pigletid == maxA)
          count2 <- count2 +1
          break
        }
      }
      i <- i + 1
    }

    for (i in 1:nrow(meanPP)) {
      minH <- meanPP$pen[i]
      minA <- test[pen==minH]
      if (test$sowid[maxA] %in% minA$sowid && minA[sowid==test$sowid[maxA]]$weight < test$weight[maxA]){
        minA <- minA[sowid==test$sowid[maxA]]
        minA <- minA[sowid==test$sowid[maxA]]$pigletid
        minA <- which(test$pigletid == minA)
        break
      }
    }

    if (minA == switch[2] & maxA == switch[1]){
      count <- count +1
    }

    switch <- c(minA,maxA)

    tempRow <- test$pen[maxA]
    test$pen[maxA] <- test$pen[minA]
    test$pen[minA] <- tempRow

    test <- test[order(pen)]
  }
}

В ответ Анурагу Н. Шарме я хотел бы вывести примерно следующее: разница примерно в 0,1 с другими ручками.

Answer 1

Я бы посоветовал попробовать (сточасти c) локальный поиск, чтобы решить эту проблему. По сути, вы произвольно переключаетесь на распределение поросят и оставляете тех, которые уменьшают разницу в весе.

Возможны альтернативные представления, но одна из возможностей такова: возможное решение - это вектор, который отображает поросят на ручки; так что ваш столбец pen будет начальным решением. k -й элемент такого решения дает загон, в котором ходит поросенок k .

Давайте сопоставим это исходное решение с качеством решения, т.е. напишем цель function OF.

df <- data.frame(sowid = c(12,23,25,45,65,12,58,85,96,85,45,23),
                 pen   = c(1,1,1,1,2,2,2,2,3,3,3,3),
                 pigletid = c(1,2,3,4,5,6,7,8,9,10,11,12),
                 weight   = c(6.5,5.9,6.2,5.8,7.5,7.2,7.8,6.9,9.5,10.2,9.8,6.4))

x <- df$pen
OF <- function(x, df, ...)
    sd(tapply(df$weight, x, mean))
OF(x, df)
## [1] 1.44157

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

Теперь для случайной выборки: случайным образом выберите одну свиноматку s с более чем одним поросенком; случайным образом выберите двух поросят, принадлежащих к s ; обменяться своими позициями. Обратите внимание, что я предварительно вычисляю sowids, чтобы не получить свиноматок только с одним поросенком.

sowids <- as.numeric(names(table(df$sowid)[table(df$sowid) > 1]))

nb <- function(x, df, sowids) {
    s <- sowids[sample(length(sowids), 1)]
    ij <- sample(which(df$sowid == s))[1:2]
    x[ij] <- x[rev(ij)]
    x    
}

nb (что означает «сосед») реализует эту выборку. Функция принимает решение-кандидат x и возвращает немного измененное решение.

x
## [1] 1 1 1 1 2 2 2 2 3 3 3 3
nb(x, df, sowids)
## [1] 1 1 1 2 2 1 2 2 3 3 3 3
nb(nb(x, df, sowids), df, sowids)
## [1] 2 1 1 1 2 2 1 2 3 3 3 3

Теперь мы можем запустить локальный поиск. Я использую реализацию из пакета NMOF (из которых я являюсь сопровождающим).

library("NMOF")
sol.ls <- LSopt(OF, list(x0 = df$pen,
                         neighbour = nb,
                         nI = 1000),
                df = df, sowids = sowids)
## Local Search.
## Initial solution:  1.44157 
## Best solution overall: 0.3307189

Мы можем сравнить окончательное решение с исходным: средние веса пером.

tapply(df$weight, df$pen, mean)
##     1     2     3 
## 6.100 7.350 8.975 
tapply(df$weight, sol.ls$xbest, mean)
##     1     2     3 
## 7.225 7.350 7.850 

И проверка: правильные ли мы сохранили совиды?

sort(df$sowid[test$pen == 1])
sort(df$sowid[which(sol.ls$xbest == 1)])

sort(df$sowid[test$pen == 2])
sort(df$sowid[which(sol.ls$xbest == 2)])

sort(df$sowid[test$pen == 3])
sort(df$sowid[which(sol.ls$xbest == 3)])