R/hagenbachbischoff.R

In i3pack: Incentives for Inter- And Intra-Party Electoral Competition

#' Hagenbach-Bischoff formula
#'
#' @rdname ElecFuns
#' @param v Matrix with candidates/parties (the interpretation depends
#' on the function) in the columns. Each cell has the number of votes cast for
#' each candidate/party. For AV and STV, the matrix should have ranked votes, 
#' with each rank in a separate row. 
#' @param m Number of seats to be awarded. 
#' @param threshold Proportion of votes that a party (or candidate) needs to
#' surpass in order to be eligible to receive seats.
#' @param ... Additional optional arguments (currently ignored).
#'
#' @section Details: The hagenbachbischoff function works with the same 
#' procedure as the droop function, but in this case Q = V/(M+1). 
#' 
#' @export 
#'
#' @examples 
#' ## Hagenbach-Bischoff without threshold: 
#' 
#' hagenbachbischoff(v=example, m=3)
#' 
#' ## Hagenbach-Bischoff with 20% threshold: 
#' 
#' hagenbachbischoff(v=example, m=3, threshold=0.2) 
#' 
hagenbachbischoff <- function(v,
                              m,
                              threshold = 0.0,
                              ...){
  # this snippet uses hare with largest remainders (as opposed to average remainders)
  # m is district magnitude
  if(nrow(v) > 1){
    stop("Hagenbach-Bischoff undefined for ranked votes.")
  }
  if(threshold > max(v)/sum(v)){
    stop("Threshold is higher than maximum proportion of votes")
  }
  findSeats <- function (x, threshold = threshold) {
    # apply threshold
    if(sum(prop.table(x[1, ]) < threshold) != ncol(x)){
      x[1, prop.table(x[1, ]) < threshold]  <- 0         
    } 
    quota <- sum(x)/(m + 1) # hagenbach-bischoff quota is total votes/(m + 1)
    quota.integer <-  x %/% quota  # Seats immediately awarded
    quota.remainder <- x %% quota # largest remainders
    remaining.seats <- m - sum(quota.integer) # total seats awarded to remainders
    if(remaining.seats < 0){ # if sum(quota.integer) > m
      temp.integer <- quota.integer[1, quota.integer[1,] !=  0]
      temp.remainder <- quota.remainder[1, quota.integer[1,] !=  0]
      quota.integer[1, ] <- 0
      while(remaining.seats < 0){
        temp.integer[which.min(temp.remainder)] <-  temp.integer[which.min(temp.remainder)] - 1
        temp.remainder[which.min(temp.remainder)] <- temp.remainder[which.min(temp.remainder)] + quota
        remaining.seats <- remaining.seats + 1
      }
      quota.integer <- colSums(dplyr::bind_rows(quota.integer[1,], temp.integer))
      quota.integer[is.na(quota.integer)] <- 0
      extra.seats <- 0
    } else if(remaining.seats > 0){
      remaining.seats.winners <- order(-quota.remainder)[1:remaining.seats] # winners of remainders
      extra.seats <- rep (0, length(x))
      extra.seats[remaining.seats.winners] <- 1
    } else {
      extra.seats <- 0
    }
    seats <- c(quota.integer + extra.seats)  # total seats
    return (as.numeric(seats)) 
  }
  dist.seats <- findSeats(v, threshold = threshold)
  names(dist.seats) <- colnames(v)
  return (dist.seats)
}