add district_winner_matrix() function (#13)

DESCRIPTION

@@ -13,7 +13,7 @@ Description: Calculate seat apportionment for legislative bodies with
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Roxygen: list(markdown = TRUE)
 Depends: 
     R (>= 3.6.0)

NAMESPACE

@@ -4,6 +4,7 @@ S3method(as.matrix,proporz_matrix)
 S3method(print,proporz_matrix)
 export(biproporz)
 export(ceil_at)
+export(district_winner_matrix)
 export(divisor_ceiling)
 export(divisor_floor)
 export(divisor_geometric)

NEWS.md

@@ -1,5 +1,6 @@
 # proporz (development version)
 
+* add `district_winner_matrix()` function
 * returned seat values from proporz/biproporz functions are always integer
 
 # proporz 1.5.0

R/biproportional-wto.R

@@ -13,7 +13,7 @@ most_votes_in_district_matrix = function(votes_matrix) {
     return(votes_matrix == .district_max_matrix)
 }
 
-create_wto_round_function = function(votes_matrix, seats_districts, seats_parties) {
+create_wto_round_function = function(votes_matrix, district_seats, seats_parties) {
     if(is.null(colnames(votes_matrix)) || is.null(rownames(votes_matrix))) {
         stop("votes_matrix must have column and row names to handle district winners",
              call. = FALSE)
@@ -22,7 +22,7 @@ create_wto_round_function = function(votes_matrix, seats_districts, seats_partie
     district_winners = most_votes_in_district_matrix(votes_matrix)
 
     # Check if there are more winners than seats in any district
-    not_enough_district_seats = which(colSums(district_winners) > seats_districts)
+    not_enough_district_seats = which(colSums(district_winners) > district_seats)
     if(length(not_enough_district_seats) > 0) {
         district_winners[,not_enough_district_seats] <- FALSE
 
@@ -64,3 +64,50 @@ create_wto_round_function = function(votes_matrix, seats_districts, seats_partie
 
     return(district_winner_round_func)
 }
+
+#' Create a matrix that shows which party has the most votes in a district
+#'
+#' @inheritParams upper_apportionment
+#' @param district_seats Vector defining the number of seats per district. Must be the same
+#'   length as `ncol(votes_matrix)`. Values are name-matched to `votes_matrix` columns if both
+#'   are named. If a single value is supplied (like 1 as default), it is used as the number of
+#'   seats for every district.
+#'
+#' @return logical matrix with the same dimensions and names as `votes_matrix`
+#'
+#' @details If two or more parties are tied and there are not enough seats for each tied party,
+#'   the matrix value is `NA`.
+#'
+#' @export
+#'
+#' @examples
+#' (vm = matrix(c(60,30,0,20,10,30), nrow = 3, dimnames = list(1:3, c("A", "B"))))
+#'
+#' district_winner_matrix(vm)
+#'
+#' # NA values if parties are tied (here in district B)
+#' vm[1,2] <- 30
+#' district_winner_matrix(vm)
+#'
+#' # No NA values for tied parties if enough seats are available
+#' district_winner_matrix(vm, c(1, 2))
+district_winner_matrix = function(votes_matrix,
+                                  district_seats = 1L) {
+    if(length(district_seats) == 1L) {
+        district_seats <- rep(district_seats, ncol(votes_matrix))
+    }
+    if(is.null(names(district_seats))) names(district_seats) <- colnames(votes_matrix)
+    .votes_matrix.name = deparse(substitute(votes_matrix))
+    .district_seats.name = deparse(substitute(district_seats))
+    votes_matrix <- prep_votes_matrix(votes_matrix, .votes_matrix.name)
+    district_seats <- prep_district_seats(district_seats, votes_matrix, .district_seats.name, .votes_matrix.name)
+
+    most_votes = most_votes_in_district_matrix(votes_matrix)
+    not_enough_district_seats = which(colSums(most_votes) > district_seats)
+    if(length(not_enough_district_seats) > 0) {
+        ties_01 = (col(votes_matrix) %in% not_enough_district_seats) * most_votes
+        most_votes[ties_01 == 1] <- NA
+    }
+
+    return(most_votes)
+}

R/biproportional.R

@@ -36,7 +36,8 @@
 #'   as many votes as there are seats in a district. Set to `FALSE` if `votes_df` shows the
 #'   number of voters (e.g. they can only vote for one party).
 #' @param winner_take_one Set to `TRUE` if the party that got the most votes in a district
-#'   must get _at least_ one seat ('Majorzbedingung') in this district. Default is `FALSE`.
+#'   must get _at least_ one seat ('Majorzbedingung') in this district. This only applies if
+#'   they are entitled to a seat in the upper apportionment. Default is `FALSE`.
 #'
 #' @seealso This function calls [biproporz()] after preparing the input data.
 #'
@@ -132,9 +133,9 @@ pukelsheim = function(votes_df, district_seats_df,
 #'           the only method guaranteed to terminate.}
 #'     \item{`wto`: "winner take one" works like "round" with a condition that the party that
 #'           got the most votes in a district must get _at least_ one seat ('Majorzbedingung')
-#'           in said district. Seats in the upper apportionment are assigned with
-#'           Sainte-Laguë/Webster. `votes_matrix` must have row and column names to use this
-#'           method. See [lower_apportionment()] for more details.}
+#'           in said district. This only applies if they got enough seats in the upper
+#'           apportionment (which uses the Sainte-Laguë/Webster method). See
+#'           [lower_apportionment()] for more details.}
 #'   }
 #'   It is also possible to use any divisor method name listed in [proporz()]. If you want to
 #'   use a different method for the upper and lower apportionment, provide a list with two
@@ -203,10 +204,10 @@ biproporz = function(votes_matrix,
 #' @param votes_matrix Vote count matrix with votes by party in rows and votes by district
 #'   in columns
 #' @param district_seats Vector defining the number of seats per district. Must be the same
-#'   length as `ncol(votes_matrix)`. Values are name-matched to `votes_matrix` if both are
-#'   named. If the number of seats per district should be assigned according to the number
-#'   of votes (not the general use case), a single number for the total number of seats can
-#'   be used.
+#'   length as `ncol(votes_matrix)`. Values are name-matched to `votes_matrix` columns if both
+#'   are named. If the number of seats per district should be assigned according to the number
+#'   of votes (not the general use case), a single number for the total number of seats can be
+#'   used.
 #' @param use_list_votes By default (`TRUE`) it's assumed that each voter in a district has
 #'   as many votes as there are seats in a district. Thus, votes are weighted according to
 #'   the number of available district seats with [weight_list_votes()]. Set to `FALSE` if
@@ -273,7 +274,7 @@ upper_apportionment = function(votes_matrix, district_seats,
 #' `use_list_votes` is `TRUE` (default). The weighted votes are not rounded.
 #'
 #' @param votes_matrix votes matrix
-#' @param seats_district seats per district, vector with same length
+#' @param district_seats seats per district, vector with same length
 #'   as `ncol(votes_matrix)`)
 #'
 #' @returns the weighted `votes_matrix`
@@ -282,10 +283,10 @@ upper_apportionment = function(votes_matrix, district_seats,
 #' weight_list_votes(uri2020$votes_matrix, uri2020$seats_vector)
 #'
 #' @export
-weight_list_votes = function(votes_matrix, seats_district) {
+weight_list_votes = function(votes_matrix, district_seats) {
     M_seats_district = matrix(
-        rep(seats_district, nrow(votes_matrix)),
-        byrow = TRUE, ncol = length(seats_district))
+        rep(district_seats, nrow(votes_matrix)),
+        byrow = TRUE, ncol = length(district_seats))
 
     votes_matrix <- votes_matrix/M_seats_district
 
@@ -329,12 +330,16 @@ weight_list_votes = function(votes_matrix, seats_district) {
 #'     \item{`round`: The default Sainte-Laguë/Webster method is the standard
 #'           for biproportional apportionment and the only method guaranteed to terminate.}
 #'     \item{`wto`: "winner take one" works like "round" with a condition that the party that
-#'           got the most votes in a district must get _at least_ one seat ('Majorzbedingung').
+#'           got the most votes in a district must get _at least_ one seat ('Majorzbedingung',
+#'           also called 'strongest party constrained' rule (SPC)). `votes_matrix` must have
+#'           row and column names to use this method.
+#'           A district winner can only get a seat if they are entitled to one from the upper
+#'           apportionment (`seats_rows`).
 #'           The condition does not apply in a district if two or more parties have the same
 #'           number of votes and there are not enough seats for these parties. A warning is
 #'           issued in this case. Modify the votes matrix to explicitly break ties.}
 #'     \item{You can provide a custom function that rounds a matrix (i.e. the
-#'           the votes_matrix divided by party and list divisors).}
+#'           the votes_matrix divided by party and list divisors) without further parameters.}
 #'     \item{It is possible to use any divisor method name listed in [proporz()].}
 #'   }
 #'
@@ -344,7 +349,7 @@ weight_list_votes = function(votes_matrix, seats_district) {
 #' @references Oelbermann, K. F. (2016): Alternate scaling algorithm for biproportional
 #'   divisor methods. Mathematical Social Sciences, 80, 25-32.
 #'
-#' @seealso [biproporz()], [upper_apportionment()]
+#' @seealso [biproporz()], [upper_apportionment()], [district_winner_matrix()]
 #'
 #' @examples
 #' votes_matrix = matrix(c(123,912,312,45,714,255,815,414,215), nrow = 3)

_pkgdown.yml

@@ -39,6 +39,7 @@ reference:
 - title: "Helpers"
   contents:
   - get_divisors
+  - district_winner_matrix
   - pivot_to_matrix
   - pivot_to_df
   - ceil_at

tests/testthat/test-biproportional-wto.R

@@ -58,3 +58,27 @@ test_that("two with ties and enough seats", {
     expect_error(biproporz(vm3, seats2, method = "wto"),
                  "Not enough upper apportionment seats to give district winner seats to party/list: '3'")
 })
+
+test_that("district_winner_matrix", {
+    vm = matrix(c(60,30,0,20,10,20), 3, dimnames = list(as.character(1:3), c("A", "B")))
+
+    dwm_c = function(...) c(district_winner_matrix(...))
+
+    expect_equal(dwm_c(vm), c(TRUE,FALSE,FALSE,NA,FALSE,NA))
+    expect_equal(district_winner_matrix(vm, c(3,1)), district_winner_matrix(vm, c(B=1,A=3)))
+    expect_equal(dimnames(district_winner_matrix(vm, c(3,1))), dimnames(vm))
+
+    expect_equal(dwm_c(vm, c(0,1)), c(NA,FALSE,FALSE,NA,FALSE,NA))
+    expect_equal(dwm_c(vm, c(0,2)), c(NA,FALSE,FALSE,TRUE,FALSE,TRUE))
+    expect_equal(dwm_c(vm, c(0,0)), c(NA,FALSE,FALSE,NA,FALSE,NA))
+    expect_equal(dwm_c(vm, 0), c(NA,FALSE,FALSE,NA,FALSE,NA))
+
+    # Find ties
+    is.na(district_winner_matrix(vm))
+
+    # Find winners with ties if enough seats are avialable
+    district_winner_matrix(vm, c(1,2))
+
+    # Find entries with not enough seats and no ties (unrealistic example)
+    is.na(district_winner_matrix(vm, 0)) != is.na(district_winner_matrix(vm, 1))
+})