How to find all minimal winning coalitions in a weighted-majority voting game in a fast way?

Question

EDIT: I found a solution thanks to the paper A survey of algorithms for calculating power indices of weighted majority games

I'd like to solve the following problem:

Given a set N={1,..,n} with a vector of weights W={w_1,..,w_n}, sorted in descending order and with total sum 1, find all subsets C (also called "coalitions") of N such that

1. C is "winning", that means that the sum of the weights of elements inside the subset C exceeds a certain threshold (e.g. 0.5)
2. C is "minimal", that means that removing any element from C will make the subset not "winning" anymore.

To clarify, an example could be: N={1,2,3} W={0.45,0.35,0.2}

1. The "winning" subsets here are {1,2},{2,3},{1,3} and {1,2,3} since they all exceed 0.5 total weight
2. only {1,2}, {2,3} and {1,3} are minimal, since in {1,2,3} you could remove one element and get the ones above.

From the paper cited above, I now implemented this code which recursively generates the list of all minimal winning coalitions

MWC = function(w,threshold=0.5){
  n = length(w)
  l = list()
  enumerate = function(S1,n1,b1){
    if(n1==n){
      return(list(c(S1,n1)))
    }else{
      if(sum(w[(n1+1):n]) >= b1){
        l = c(l,enumerate(S1,n1+1,b1))
      }
      if(w[n1] >= b1){
        l=c(l,list(c(S1,n1)))
      }else{
        l = c(l,enumerate(c(S1,n1),n1+1,b1-w[n1]))
        return(l)
      }
    }
  }
  return(enumerate(c(),1,threshold))
}

w = c(0.46,0.3,0.19,0.05)
MWC(w)

The code runs up to around n = 20, after the exponential complexity makes everything unfeasible.

Answer 1

One solution to your problem will be using while loop and applying the above constraints within the loop.

Below is the working code:

N = 1:10

W <- c(0.60, 0.40, 0.33, 0.30, 0.25, 0.20, 0.15, 0.10, 0.05, 0.03);

Winning_Sets <- c()

i <- 1

while (i != (length(N) - 1)) {
  if (i == 1) {
    Subsets <- combn(N, i)
  } else {
    Keep_Combs <- Subsets[,which(Intermediate_Sets == 'No_Match')]
    Subsets <- combn(N, i)
    if (i == 2) {
      Subsets <- apply(Subsets, 2, function(x) {
        x <- x[x[i - 1] %in% Keep_Combs]
      })
    } else {
      Subsets <- apply(Subsets, 2, function(x) {
        unlist(apply(Keep_Combs, 2, function(y) {
          if (identical(y, x[1:(i - 1)]) == TRUE) {
            x
            }
          }))
        })
    }
    Subsets <- do.call('cbind', Subsets)
  }
  Intermediate_Sets <- apply(Subsets, 2, function(x) {
    if (sum(W[x]) > 0.5) {
      paste('{', paste(x, collapse = ','), '}', sep = '')
    } else {
      'No_Match'
    }
    })
  Winning_Sets <- append(Winning_Sets, unlist(Intermediate_Sets[Intermediate_Sets != 'No_Match']))
  if (length(which(Intermediate_Sets == 'No_Match')) > 0) {
    i <- i + 1
  } else {
    i <- length(N) - 1
  }
}

Output:

Winning_Sets
 [1] "{1}"          "{2,3}"        "{2,4}"        "{2,5}"        "{2,6}"        "{2,7}"       
 [7] "{3,4}"        "{3,5}"        "{3,6}"        "{4,5}"        "{2,8,9}"      "{2,8,10}"    
[13] "{3,7,8}"      "{3,7,9}"      "{3,7,10}"     "{4,6,7}"      "{4,6,8}"      "{4,6,9}"     
[19] "{4,6,10}"     "{4,7,8}"      "{5,6,7}"      "{5,6,8}"      "{3,8,9,10}"   "{4,7,9,10}"  
[25] "{5,6,9,10}"   "{5,7,8,9}"    "{5,7,8,10}"   "{6,7,8,9,10}"