在 R 中计算投票权指数答案

【问题标题】：Calculating voting power indexes in R在 R 中计算投票权指数
【发布时间】：2011-04-13 19:09:52
【问题描述】：

我有一个项目，我需要能够在 R 中计算不同的投票权指数。作为第一次尝试，我编写了一个小函数来计算 banzhaf 指数。它需要两个参数，一个数据框有两列必须标记为成员和投票，以及需要多少票才能获得多数票（配额）：

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() 函数（我认为）。有谁知道如何让它运行得更快？

最好的，托马斯

P.S：如果您想对其进行测试，请使用以下数据，但请注意它可能会永远运行！

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

【问题讨论】：

四个嵌套的for 循环？哇哦。这四个太多了。
函数不起作用，因为piv没有在score[length(piv) + 1]中定义。
感谢 Joshua，为了便于阅读，我在发布时重命名了一些矢量，但我忘了更改那个。现在完成。

标签： r function permutation voting-system

【解决方案1】：

我的方法和 David 类似，使用批量矩阵运算来处理大小：

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 的矩阵并不可行！

【讨论】：

您能否详细说明这段代码在做什么，尤其是这一点？
这个位：lapply(as.integer(2^((1:n) - 1L)), function(j, k) (k %/% j) %% 2L, i)
酷。很高兴考虑到这种方法来提取位。谢谢！

【解决方案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 联合 Y 也高于配额。我不确定 R 是否非常适合遵循这种结构。

【讨论】：