From 66277176a252873435710dfb69a0540376523e98 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Sat, 23 Mar 2024 14:19:59 +0100 Subject: [PATCH] skip wto on not enough seats for tied district winners just warn instead of error --- R/biproportional-wto.R | 58 +++++++++-------------- R/biproportional.R | 10 ++-- R/utils.R | 6 +++ data-raw/readme_examples.R | 16 +++++++ man/biproporz.Rd | 2 +- man/lower_apportionment.Rd | 6 ++- tests/testthat/test-biproportional-data.R | 18 ++----- tests/testthat/test-biproportional-wto.R | 30 ++++++++---- 8 files changed, 80 insertions(+), 66 deletions(-) diff --git a/R/biproportional-wto.R b/R/biproportional-wto.R index 78727da..c242d71 100644 --- a/R/biproportional-wto.R +++ b/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) } diff --git a/R/biproportional.R b/R/biproportional.R index 77ce44b..00bc997 100644 --- a/R/biproportional.R +++ b/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") { diff --git a/R/utils.R b/R/utils.R index cf1d352..064b0aa 100644 --- a/R/utils.R +++ b/R/utils.R @@ -102,3 +102,9 @@ assert = function(check) { } invisible() } + +collapse_names = function(x) { + y = paste(x, collapse = "', '") + y <- paste0("'", y, "'") + return(y) +} diff --git a/data-raw/readme_examples.R b/data-raw/readme_examples.R index 01b5a14..a033076 100644 --- a/data-raw/readme_examples.R +++ b/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) diff --git a/man/biproporz.Rd b/man/biproporz.Rd index 668080a..0be3f64 100644 --- a/man/biproporz.Rd +++ b/man/biproporz.Rd @@ -44,7 +44,7 @@ the only method guaranteed to terminate.} got the most votes in a district must get \emph{at least} one seat ('Majorzbedingung') in said district. Seats in the upper apportionment are assigned with Sainte-Laguë/Webster. \code{votes_matrix} must have row and column names to use this -method. See \code{\link[=lower_apportionment]{lower_apportionment()}} for an example.} +method. See \code{\link[=lower_apportionment]{lower_apportionment()}} for more details.} } It is also possible to use any divisor method name listed in \code{\link[=proporz]{proporz()}}. If you want to use a different method for the upper and lower apportionment, provide a list with two diff --git a/man/lower_apportionment.Rd b/man/lower_apportionment.Rd index f36808b..aa52773 100644 --- a/man/lower_apportionment.Rd +++ b/man/lower_apportionment.Rd @@ -24,7 +24,9 @@ following methods are supported: for biproportional apportionment and the only method guaranteed to terminate.} \item{\code{wto}: "winner take one" works like "round" with a condition that the party that got the most votes in a district must get \emph{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 \code{\link[=proporz]{proporz()}}.} @@ -64,7 +66,7 @@ party_seats = c(5,11,4) 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)) diff --git a/tests/testthat/test-biproportional-data.R b/tests/testthat/test-biproportional-data.R index 40dfae0..adfcceb 100644 --- a/tests/testthat/test-biproportional-data.R +++ b/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", { diff --git a/tests/testthat/test-biproportional-wto.R b/tests/testthat/test-biproportional-wto.R index 80ec08d..3e3e828 100644 --- a/tests/testthat/test-biproportional-wto.R +++ b/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'") +})