Расчет показателей мощности голосования в R

Question

У меня есть проект, в котором мне нужно иметь возможность рассчитывать различные индексы голосов в R. Для первой попытки я написал небольшую функцию для расчета индекса Бэнжафа.Он принимает два аргумента: информационный фрейм с двумя столбцами, который должен быть помечен как член и голос, и сколько голосов необходимо для большинства (квота):

library(combinat)
banzhaf <- function(data,quota){
 f <- vector()
 m <- vector()
 score <- vector()
 name <- vector()
 pivot <- vector()
 for (n in 1:nrow(data)){
  y <- as.matrix(combn(data$member,n))
  for (i in 1:ncol(y)){
   for ( j in 1:n){
    f[j] <- data[data$member == y[j,i],]$vote
    m[j] <- as.character(data[data$member == y[j,i],]$member)
    o <- data.frame(member = m, vote = f)
    }

   if (sum(o$vote) >= quota){
    for (k in 1:length(o$member)){
     t <- o[-k,]
    if (sum(t$vote) < quota){
     pivot[length(pivot) + 1] <- as.character(o$member[k])
     }
    }
   }
  }
 }

 for (l in unique(pivot)){
  score[length(score) + 1] <- sum(pivot == l)
  name[length(name) + 1] <- l
  }
 out <- data.frame(name = name, score = score/length(pivot))
 return(out)
}

Проблема с этой функцией заключается в том, что она становитсяневероятно медленный, когда у меня более 8 членов в датафрейме.Это связано с функцией combn (), используемой в самом внешнем цикле (я думаю).Кто-нибудь знает, как сделать так, чтобы он работал быстрее?

Best, Thomas

PS: Если вы хотите протестировать его, используйте следующие данные, но знайте, что он может работать вечно!

x <- c("Germany","France","UK","Italy","Spain","Poland","Romania","Netherlands","Greece","Portugal","Belgium","Czech Rep.","Hungary","Sweden","Austria","Bulgaria","Denmark","Slovakia","Finland","Ireland","Lithuania","Latvia","Slovenia","Estonia","Cyprus","Luxembourg","Malta")
z <- c(29,29,29,29,27,27,14,13,12,12,12,12,12,10,10,10,7,7,7,7,7,4,4,4,4,4,3)

dat <- data.frame(member = as.character(x),vote = z)

oi <- banzhaf(dat, 255)
oi

Answer 1

Мой подход был аналогичен подходу Дэвида, использующему пакетные матричные операции для обработки размера:

banzhaf = function(votes, pass=sum(votes) %/% 2 + 1, batch.size=500000, quiet=batches == 1) {
  n = length(votes)
  batches = ceiling((2^n / batch.size))
  if (!quiet)
    cat('calculating...\n')
  Reduce(`+`, lapply(1:batches, function(b) {
    if (!quiet)
      cat('-', b, '/', batches, '\n')
    i = ((b - 1) * batch.size + 1):min(2^n, b * batch.size)
    m = do.call(cbind, lapply(as.integer(2^((1:n) - 1L)), function(j, k) (k %/% j) %% 2L, i))
    x = drop(m %*% votes)
    passed = x >= pass
    colSums((outer(x[passed] - pass, votes, `<`) * m[passed, , drop=F]))
  }))
}

Использует распространение имени R вместо data.frame, по возможности избегайте циклов и используйте целые числа вместо чиселесли возможно.Тем не менее, мне потребовалось более 6 минут для запуска на моем боксе:

# wikipedia examples
banzhaf(c(A=4, B=3, C=2, D=1), 6)
banzhaf(c('Hempstead #1'=9, 'Hempstead #2'=9, 'North Hempstead'=7, 'Oyster Bay'=3, 'Glen Cove'=1, 'Long Beach'=1), 16)

# stackoverflow data
system.time(banzhaf(setNames(as.integer(z), x), 255))

Мышление шло примерно так:

• 2 ^ n возможных результатов (2 результата на игрока, n независимых игроков)
• , представленный числами 1: 2 ^ n (cf 'i')
• , выражающими число в двоичном виде, дает голос каждого игрока.
• с использованием модуля и деления для извлечениябиты в матрице голосования (cf 'm') вместо побитовых операций (я полагаю, только недавно добавленные в R).

После этого я думаю, что он воспроизводится так же, как и у Дэвида,Единственная сложность заключалась в том, чтобы обеспечить использование целых чисел для повышения эффективности и добавить пакетную обработку данных, поскольку создание матрицы из 27: 2 ^ 27!

не представляется возможным.

Answer 2

Ваш примерный фрейм данных имеет 27 строк, и вы просматриваете каждый набор (кроме нулевого набора), так что это как минимум 2 ^ 27 - 1 = 134 217 727 операций ... это займет некоторое время.Тем не менее, вот что я считаю более эффективной версией вашего кода.Кажется, это соответствует статье Википедии, по крайней мере: http://en.wikipedia.org/wiki/Banzhaf_power_index

banzhaf1 <- function(data, quota) {
  n <- nrow(data)
  vote <- data$vote
  swingsPerIndex <- numeric(n)
  for (setSize in 1:n) {
    sets <- utils::combn(n, setSize)
    numSets <- ncol(sets)
    flatSets <- as.vector(sets)
    voteMatrix <- matrix(vote[flatSets], nrow=setSize, ncol=numSets)
    totals <- colSums(voteMatrix)
    aboveQuota <- totals >= quota
    totalsMatrix <- matrix(rep(totals, each=setSize), nrow=setSize, ncol=numSets)
    winDiffs <- totalsMatrix[, aboveQuota] - voteMatrix[, aboveQuota]
    winSets <- sets[, aboveQuota]
    swingers <- as.vector(winSets[winDiffs < quota])
    swingsPerIndex <- swingsPerIndex + tabulate(swingers, n)
  }
  return(data.frame(name=data$member, score=swingsPerIndex / sum(swingsPerIndex)))
}

(я не пробовал запускать это для полного набора данных).эффективно вам придется воспользоваться структурой проблемы.Например, если вы знаете, что в наборе X сумма голосов превышает квоту, то вы знаете, что X union Y также выше квоты.Я не уверен, что R хорошо подойдет для такой структуры.