R/hare.R

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

#' Hare formula
#'
#' @rdname ElecFuns
#'
#' @section Details: The hare function works with the same procedure as the 
#' droop function, but in this case Q = V/M. 
#' 
#' @export
#'
#' @examples
#'## Hare without threshold
#'
#' hare (v=example, m=3)
#' 
#'## Hare with 20% threshold
#' 
#' hare (v=example, m=3, threshold=0.2)
#' 
hare <- 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("Hare 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) # 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)) # PC: Add as.numeric because it was returning party names
  }
  dist.seats <- findSeats(v, threshold = threshold)
  names(dist.seats) <- colnames(v)
  return (dist.seats)
}