inst/doc/modifying_biproporz.R

In proporz: Proportional Apportionment

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

## ----setup--------------------------------------------------------------------
library(proporz)

# Define a custom dataset for this vignette
votes_matrix = matrix(
  c( 800, 2802, 4095,  0, 150,
     3900,  814, 3990, 20,  60,
     1400, 1302, 4305, 10,  80,
     0,    0,    0, 50,   0,
     610,  500, 1001, 40, 120),
  ncol = 5, byrow = TRUE,
  dimnames = list(
    party = c("A", "B", "C", "D", "E"),
    district = c("City 1", "City 2", "City 3", "Region 4", "Region 5")
  ))

district_seats = setNames(c(5, 5, 14, 1, 1), colnames(votes_matrix))

## ----weight_votes-------------------------------------------------------------
votes_matrix

(voters = weight_votes_matrix(votes_matrix, district_seats))

## ----standard-----------------------------------------------------------------
seats_biproporz_standard = biproporz(votes_matrix, district_seats)

# Number of seats per party
rowSums(seats_biproporz_standard)

## ----summary------------------------------------------------------------------
summary(seats_biproporz_standard)

# You can transpose the matrix
# summary(t(seats_biproporz_standard))

## ----standard_quorum----------------------------------------------------------
biproporz(votes_matrix, district_seats, quorum_any(total = 0.05))

## ----alternative_methods------------------------------------------------------
biproporz(votes_matrix, district_seats, method = list("adams", "round"))

## ----custom_rounding----------------------------------------------------------
custom_rounding_func = function(x) {
  stopifnot(all(x >= 0))
  lt0.7 = x < 0.7
  x[lt0.7] <- 0
  x[!lt0.7] <- ceil_at(x[!lt0.7], 0.5)
  x
}

# The function must work with a matrix
custom_rounding_func(matrix(c(0.5, 0.6, 1.5, 2.5), 2))

# Apply custom rounding function in lower apportionment
biproporz(votes_matrix, district_seats, 
          method = list("adams", custom_rounding_func))

## ----wto----------------------------------------------------------------------
try(biproporz(votes_matrix, district_seats, method = "wto"))

## ----wto_quorum---------------------------------------------------------------
biproporz(votes_matrix, district_seats, method = "wto",
          quorum = quorum_any(total = 0.01))

## ----wto_other_method---------------------------------------------------------
biproporz(votes_matrix, district_seats, method = list("adams", "wto"))

## ----wto_ties-----------------------------------------------------------------
(tied_votes = matrix(
  c(1000, 500, 150, 150), 2, 
  dimnames = list(party = c("X", "Y"), district = 1:2)))
tied_votes_seats = setNames(c(2,1), colnames(tied_votes))

try(biproporz(tied_votes, tied_votes_seats, method = "wto"))

## ----wto_tiebreak-------------------------------------------------------------
tied_districts = district_winner_matrix(tied_votes, tied_votes_seats)
set.seed(4)
for(d in seq_len(ncol(tied_votes))) {
  if(anyNA(tied_districts[,d])) {
    tied_parties = which(is.na(tied_districts[,d]))
    
    # break tie randomly
    tiebreak_winner = sample(tied_parties, 1)
    cat("party", names(tiebreak_winner), "wins district", d)
    
    # assuming the impact of a small vote difference on 
    # the overall result is negligible
    tied_votes[tiebreak_winner,d] <- tied_votes[tiebreak_winner,d]+1e-9
  }
}

biproporz(tied_votes, tied_votes_seats, method = "wto")

## ----absolute_wto_function----------------------------------------------------
biproporz_absolute_wto = function(votes_matrix, district_seats,
                                  quorum = NULL, weight_votes = TRUE) {
  # 1) Identify unambiguous district winners
  # Note: This step could also happen after the quorum has been applied
  # (depending on the desired method implementation)
  district_winners = district_winner_matrix(votes_matrix, district_seats)
  district_winners[is.na(district_winners)] <- FALSE # Ignore ties
  
  # 2) Apply quorum if specified
  if(!is.null(quorum)) {
    votes_matrix <- apply_quorum(votes_matrix, quorum)
  }
  
  # 3) Assign party seats in upper apportionment
  ua = upper_apportionment(votes_matrix, district_seats, 
                           weight_votes, method = "round")
  
  # 4.1) Assign seats to district winners without 
  # enough upper apportionment seats
  seats_without_ua = district_winners * 1L
  seats_without_ua[rowSums(district_winners) <= ua$party, ] <- 0L
  
  # 4.2) Biproportional apportionment for remaining seats
  # Build votes matrix, set votes for district winners 
  # without enough upper apportionment seats to zero
  biprop_votes_matrix = votes_matrix
  biprop_votes_matrix[seats_without_ua > 0] <- 0
  
  # Reduce the number of seats for districts that 
  # already had a "insufficient district winner" seat assigned
  biprop_district_seats = district_seats - colSums(seats_without_ua)
  
  # Run biproporz
  seats_biproporz = biproporz(biprop_votes_matrix, 
                              biprop_district_seats, 
                              method = "wto")
  
  # Remove divisor attributes, as they're no longer 
  # meaningful for the combined distribution
  seats_biproporz <- as.matrix(seats_biproporz)
  
  # 5) Return final seat distribution,
  #    combining the two apportionments 
  return(seats_biproporz + seats_without_ua)
}

## ----absolute_wto-------------------------------------------------------------
seats_biproporz_absolute_wto = biproporz_absolute_wto(votes_matrix, 
                                                      district_seats)

# Show the difference to the standard apportionment
seats_biproporz_absolute_wto - seats_biproporz_standard