skip wto on not enough seats for tied district winners

just warn instead of error

R/biproportional-wto.R

@@ -6,42 +6,39 @@ col_maxs = function(mtrx) {
     apply(mtrx, 2, max)
 }
 
-has_tied_district_winners = function(votes_matrix) {
-    district_winner_matrix(votes_matrix, TRUE)
-}
-
-district_winner_matrix = function(votes_matrix, return_check = FALSE) {
-    if(is.null(colnames(votes_matrix))) {
-        stop("votes matrix must have district column names", call. = FALSE)
-    }
+most_votes_in_district_matrix = function(votes_matrix) {
     .districts_max = unname(col_maxs(votes_matrix))
     .district_max_matrix = matrix(rep(.districts_max, each = nrow(votes_matrix)),
                                   nrow(votes_matrix))
-    district_winners = votes_matrix == .district_max_matrix
+    return(votes_matrix == .district_max_matrix)
+}
 
-    # find tied districts
-    tied_districts = which(colSums(district_winners) > 1)
-    if(return_check) {
-        return(length(tied_districts) > 0)
+create_wto_round_function = function(votes_matrix, seats_districts, 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)
     }
 
-    # error on tied districts
-    if(length(tied_districts) > 0) {
-        .ties_stop = paste(names(tied_districts), collapse = "', '")
-        .ties_stop <- paste0("'", .ties_stop, "'")
-        stop("Tied majority in ", .ties_stop, call. = FALSE)
-    }
+    district_winners = most_votes_in_district_matrix(votes_matrix)
 
-    return(district_winners)
-}
+    # Check if there are more winners than seats in any district
+    not_enough_district_seats = which(colSums(district_winners) > seats_districts)
+    if(length(not_enough_district_seats) > 0) {
+        district_winners[,not_enough_district_seats] <- FALSE
 
-create_wto_round_function = function(votes_matrix, seats_ua) {
-    if(is.null(votes_matrix) || is.null(rownames(votes_matrix))) {
-        stop("votes_matrix must have column and row names to handle district winners",
-             call. = FALSE)
+        warning("Not enough seats for tied parties with the most votes in: ",
+                collapse_names(names(not_enough_district_seats)),
+                "\nWinner take one condition is not applied in ",
+                ifelse(length(not_enough_district_seats) == 1, "this district.", "these districts."),
+                call. = FALSE)
     }
 
-    district_winners = district_winner_matrix(votes_matrix)
+    # check if there are enough seats for each party to satisfy winner constraint
+    not_enough_party_seats = which(rowSums(district_winners) > seats_parties)
+    if(length(not_enough_party_seats) > 0) {
+        stop("Not enough upper apportionment seats to give district winner seats to party/list: ",
+             collapse_names(names(not_enough_party_seats)), call. = FALSE)
+    }
 
     # "Dies wird erreicht, indem in jedem Wahlkreis bei der stimmenstärksten Liste -
     # und nur jeweils dort - der Quotient aus Parteistimmen und Wahlkreis- und
@@ -65,14 +62,5 @@ create_wto_round_function = function(votes_matrix, seats_ua) {
         return(y)
     }
 
-    # check if there are enough seats for each party to satisfy winner constraint
-    seats_dw = rowSums(district_winners)
-    if(!all(seats_dw<=seats_ua)) {
-        parties = names(seats_ua)[seats_dw>seats_ua]
-        parties <- paste(parties, collapse = ", ")
-        stop("Not enough upper apportionment seats to give district winner seats to party/list ",
-             parties, call. = FALSE)
-    }
-
     return(district_winner_round_func)
 }

R/biproportional.R

@@ -134,7 +134,7 @@ pukelsheim = function(votes_df, district_seats_df,
 #'           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 an example.}
+#'           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
@@ -332,7 +332,9 @@ weight_list_votes = function(votes_matrix, seats_district) {
 #'           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').
-#'           The function errors if two or more parties have the same number of votes.}
+#'           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).}
 #'     \item{It is possible to use any divisor method name listed in [proporz()].}
@@ -354,7 +356,7 @@ weight_list_votes = function(votes_matrix, seats_district) {
 #' lower_apportionment(votes_matrix, district_seats, party_seats)
 #'
 #'
-#' # using "winner takes one"
+#' # using "winner take one"
 #' vm = matrix(c(200,100,10,11), 2,
 #'             dimnames = list(c("Party A", "Party B"), c("I", "II")))
 #' district_seats = setNames(c(2,1), colnames(vm))
@@ -379,7 +381,7 @@ lower_apportionment = function(votes_matrix, seats_cols,
     } else if(method == "round") {
         round_func = function(x) ceil_at(x, 0.5)
     } else if(method == "wto") {
-        round_func = create_wto_round_function(votes_matrix, seats_rows)
+        round_func = create_wto_round_function(votes_matrix, seats_cols, seats_rows)
     } else {
         method_impl <- get_method_implementation(method)
         if(method_impl != "divisor_round") {

R/utils.R

@@ -102,3 +102,9 @@ assert = function(check) {
     }
     invisible()
 }
+
+collapse_names = function(x) {
+    y = paste(x, collapse = "', '")
+    y <- paste0("'", y, "'")
+    return(y)
+}

data-raw/readme_examples.R

@@ -65,6 +65,22 @@ reprex::reprex({
     largest_remainder_method(votes, 20)
 })
 
+# pr
+reprex::reprex({
+    (vm = matrix(c(200,100,10,11), 2, dimnames = list(c("Party A", "Party B"), c("I", "II"))))
+    district_seats = setNames(c(2,1), c("I", "II"))
+
+    biproporz(vm, district_seats, method = "wto")
+
+    biproporz(vm, district_seats, method = "round")
+})
+
+reprex::reprex({
+    library(proporz)
+    GR_2022 = proporz:::testdata$GR_2022
+    x = biproporz(t(GR_2022$votes_matrix), GR_2022$district_seats_df, method = "wto")
+})
+
 # unused
 reprex::reprex({
     library(proporz)

tests/testthat/test-biproportional-data.R

@@ -67,20 +67,10 @@ test_that("Grisons 2022", {
                   method = "wto")
     }
 
-    expect_true(has_tied_district_winners(t(grisons2022$votes_matrix)))
-    expect_error(biproporz(t(grisons2022$votes_matrix), grisons2022$district_seats_df,
-                           method = "wto"), "Tied majority in 'Rheinwald'")
-
-    gr2022 = grisons2022$votes_matrix
-    # fix tie, the winner was actually chosen by lot
-    gr2022["Rheinwald", "SP&Grüne"] <- gr2022["Rheinwald","SP&Grüne"]+1
-    # one vote more doesnt' influence the result (0.0003% of all list votes)
-    gr2022 <- t(gr2022)
-
-    seats_wto = biproporz_grisons(gr2022, grisons2022$district_seats_df)
-
-    seats_actual = as.matrix(t(seats_wto))
-    expect_equal(seats_actual, grisons2022$expected_result)
+    seats_wto = expect_warning(
+        biproporz_grisons(t(grisons2022$votes_matrix), grisons2022$district_seats_df),
+        "Not enough seats for tied parties with the most votes in: 'Rheinwald'\nWinner take one condition is not applied in this district.")
+    expect_equal(as.matrix(t(seats_wto)), grisons2022$expected_result)
 })
 
 test_that("Zurich 2019", {

tests/testthat/test-biproportional-wto.R

@@ -4,23 +4,16 @@ test_that("col/row max", {
     expect_equal(col_maxs(m), c(9,2))
 })
 
-test_that("district_winner_matrix", {
+test_that("most_votes_in_district_matrix", {
     votes_matrix = matrix(c(90, 50, 60, 50, 10, 50), ncol = 3)
-    expect_error(district_winner_matrix(votes_matrix), "votes matrix must have district column names")
     colnames(votes_matrix) <- c("A", "B", "C")
-    dw = district_winner_matrix(votes_matrix)
+    dw = most_votes_in_district_matrix(votes_matrix)
     dw <- unname(dw)
 
     expect_equal(dw, matrix(c(T,F,T,F,F,T), ncol = 3))
     expect_true(is.logical(dw))
     expect_equal(colSums(dw), c(1,1,1))
     expect_equal(sum(colSums(dw)), 3)
-
-    # ties
-    votes_matrix[1,2] <- 50
-    expect_error(district_winner_matrix(votes_matrix), "Tied majority in 'B'")
-    votes_matrix[2,3] <- 10
-    expect_error(district_winner_matrix(votes_matrix), "Tied majority in 'B', 'C'")
 })
 
 test_that("winner take one", {
@@ -30,7 +23,7 @@ test_that("winner take one", {
 
     vm = matrix(c(60,10,10,11), 2, dimnames = list(as.character(1:2), c("A", "B")))
     expect_error(biproporz(vm, setNames(c(1,1), colnames(vm)), method = "wto"),
-                 "Not enough upper apportionment seats to give district winner seats to party/list 2")
+                 "Not enough upper apportionment seats to give district winner seats to party/list: '2'")
 
     vm2 = matrix(c(200,100,10,11), 2, dimnames = list(as.character(1:2), c("A", "B")))
     seats2 = setNames(c(2,1), colnames(vm))
@@ -48,3 +41,20 @@ test_that("winner take one", {
     pk2 = pukelsheim(df, seatsdf, winner_take_one = TRUE)
     expect_equal(matrix(pk2[["seats"]], 2, 2, byrow = T), as.matrix(unname(bp2)))
 })
+
+test_that("two with ties and enough seats", {
+    vm12 = matrix(c(60,10,20,10,11,11), 3, dimnames = list(as.character(1:3), c("A", "B")))
+    seats1 = setNames(c(2,1), colnames(vm12))
+    seats2 = setNames(c(2,2), colnames(vm12))
+
+    expect_warning(biproporz(vm12, seats1, method = "wto"),
+                   "Not enough seats for tied parties with the most votes in: 'B'")
+    expect_s3_class(biproporz(vm12, seats2, method = "wto"), "proporz_matrix")
+
+    vm3 = vm12
+    vm3[3,1] <- 0
+    expect_warning(biproporz(vm3, seats1, method = "wto"),
+                   "Not enough seats for tied parties with the most votes in: 'B'")
+    expect_error(biproporz(vm3, seats2, method = "wto"),
+                 "Not enough upper apportionment seats to give district winner seats to party/list: '3'")
+})