From 192a9cf1765c871818a6e0d99a9be3ccbaafec8f Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Sat, 1 Jul 2023 11:21:50 +0200 Subject: [PATCH] allow n_seats=0, add parameter checks --- DESCRIPTION | 2 +- R/divisor.R | 20 ++++++++++++-- R/quota.R | 25 +++++++++++++---- R/utils.R | 25 +++++++++++++++++ man/biproporz.Rd | 4 +++ tests/testthat/test-proporz.R | 52 ++++++++++++++++++++++++++++++----- tests/testthat/test-quota.R | 29 ++++++++++++++----- 7 files changed, 134 insertions(+), 23 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 08208c7..64a276a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -9,7 +9,7 @@ Description: Calculate seat apportionment for legislative bodies using License: GPL (>=3) Encoding: UTF-8 LazyData: true -RoxygenNote: 7.1.1 +RoxygenNote: 7.2.3 Depends: R (>= 3.6.0) Suggests: diff --git a/R/divisor.R b/R/divisor.R index 366e076..7a63d0e 100644 --- a/R/divisor.R +++ b/R/divisor.R @@ -16,10 +16,19 @@ #' #' @export highest_averages_method = function(party_votes, n_seats, divisors) { + check_votes(party_votes) + check_n_seats(n_seats) + if(length(party_votes) == 1) { return(n_seats) } + stopifnot(all(!is.na(party_votes))) + if(n_seats == 0) { return(rep(0, length(party_votes))) } + stopifnot(is.null(dim(divisors))) - if(length(divisors) == 1) divisors <- seq(from = divisors, by = 1, length.out = n_seats) + if(length(divisors) == 1) { + divisors <- seq(from = divisors, by = 1, length.out = n_seats) + } n_parties = length(party_votes) + # method mtrx_votes = matrix(rep(party_votes, each=n_seats), ncol = n_parties) mtrx_divisors = matrix(rep(divisors, ncol(mtrx_votes)), ncol = n_parties) @@ -30,6 +39,7 @@ highest_averages_method = function(party_votes, n_seats, divisors) { mtrx_seats[order(mtrx_quotient, decreasing = TRUE)[1:n_seats]] <- 1 vec = colSums(mtrx_seats) + vec[is.nan(vec)] <- 0 names(vec) <- names(party_votes) return(vec) @@ -91,10 +101,13 @@ divisor_ceiling = function(votes, n_seats, quorum = 0) { #' @seealso \code{\link{proporz}} #' @export divisor_harmonic = function(votes, n_seats, quorum = 0) { - nn = 1:n_seats + check_n_seats(n_seats) + + nn = seq(1, n_seats) divisors = 2/((1/nn)+(1/(nn-1))) divisors[0] <- 10e-12 votes <- quorum_votes(votes, quorum) + hzv(votes, n_seats, divisors) } @@ -106,9 +119,12 @@ divisor_harmonic = function(votes, n_seats, quorum = 0) { #' @seealso \code{\link{proporz}} #' @export divisor_geometric = function(votes, n_seats, quorum = 0) { + check_n_seats(n_seats) + nn = seq(1, n_seats) divisors = sqrt((nn-1)*nn) divisors[1] <- 10e-12 votes <- quorum_votes(votes, quorum) + hzv(votes, n_seats, divisors) } diff --git a/R/quota.R b/R/quota.R index 59c1730..0d8ca1a 100644 --- a/R/quota.R +++ b/R/quota.R @@ -9,16 +9,29 @@ #' @seealso \code{\link{proporz}} #' @export quota_largest_remainder = function(votes, n_seats, throw_equal_remainder_error = TRUE) { + check_n_seats(n_seats) + check_votes(votes) + + if(length(votes) == 1) { + return(n_seats) + } + if(n_seats == 0) { + return(rep(0, length(votes))) + } + quota = n_seats*votes/sum(votes) seats_base = floor(quota) + seats_rem = rep(0, length(votes)) - remainder = quota - seats_base - check_equal_entries(remainder, "remainder") + if(sum(seats_base) < n_seats) { + remainder = quota - seats_base + check_equal_entries(remainder[remainder > 0], "remainder") - n_seats_remaining = n_seats - sum(seats_base) - seats_rem <- rep(0, length(votes)) - order_index = order(remainder, decreasing = TRUE) - seats_rem[order_index[1:n_seats_remaining]] <- 1 + n_seats_remaining = n_seats - sum(seats_base) + seats_rem <- rep(0, length(votes)) + order_index = order(remainder, decreasing = TRUE) + seats_rem[order_index[1:n_seats_remaining]] <- 1 + } return(seats_base + seats_rem) } diff --git a/R/utils.R b/R/utils.R index 742729c..7a2a4e6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -7,6 +7,7 @@ check_equal_entries = function(vec, x = "value") { } quorum_votes = function(votes, quorum) { + check_votes(votes) stopifnot(length(quorum) == 1, is.numeric(quorum), quorum >= 0) if(quorum < 1) { @@ -81,3 +82,27 @@ pivot_to_df = function(matrix_wide, value_colname = "values") { new_df[[value_colname]] <- matrix_wide[values_indices] return(new_df) } + +check_n_seats = function(n_seats) { + if(length(n_seats) == 1 && !is.null(n_seats) && !is.na(n_seats) && n_seats >= 0) { + return() + } + stop("n_seats must be one number >= 0") +} + +check_votes = function(votes) { + if(is.numeric(votes) && all(!is.na(votes)) && all(votes >= 0)) { + return() + } + stop("votes must be numeric >= 0") +} + +.sample_votes = function(n_non_zero, n_zero) { + repeat { + x = round(stats::runif(n_non_zero, 10, 1000)) + if(length(unique(x)) == n_non_zero) { + break + } + } + return(c(x, rep(0, n_zero))) +} diff --git a/man/biproporz.Rd b/man/biproporz.Rd index 67c89c8..0fb4c00 100644 --- a/man/biproporz.Rd +++ b/man/biproporz.Rd @@ -65,6 +65,10 @@ steps: Parties failing to reach at least one quorum cannot get seats. } +\note{ +The iterative process in the lower apportionment is only guaranteed to terminate + with Sainte-Laguë/Webster method. +} \examples{ votes_df = unique(zug2018[c("list_id", "entity_id", "list_votes")]) votes_matrix = pivot_to_matrix(votes_df) diff --git a/tests/testthat/test-proporz.R b/tests/testthat/test-proporz.R index e0bfb89..5faa704 100644 --- a/tests/testthat/test-proporz.R +++ b/tests/testthat/test-proporz.R @@ -1,11 +1,49 @@ context("proporz") test_that("generic proporz", { - expect_equal( - proporz(c(216, 310, 32), 20, "jefferson"), - proporz(c(216, 310, 32), 20, "D'hondt")) - expect_equal( - proporz(c(216, 310, 32), 20, "Hagenbach-Bischoff"), - proporz(c(216, 310, 32), 20, "hare-niemeyer")) - expect_error(proporz(1,1, "unkown method")) + expect_equal( + proporz(c(216, 310, 32), 20, "jefferson"), + proporz(c(216, 310, 32), 20, "D'hondt")) + expect_equal( + proporz(c(216, 310, 32), 20, "Hagenbach-Bischoff"), + proporz(c(216, 310, 32), 20, "hare-niemeyer")) + expect_error(proporz(1,1, "unkown method")) +}) + +test_that("proporz parameter range", { + method_list = unique(unlist(apport_methods, use.names = F)) + + set.seed(0) + for(n_parties in 1:2) { + for(n_parties_zero in 0:2) { + for(n_seats in 0:6) { + for(method in method_list) { + votes = .sample_votes(n_parties, n_parties_zero) + seats = proporz(votes, n_seats, method) + + expect_equal(length(seats), length(votes)) + expect_equal(sum(seats), n_seats) + } + } + } + } + + # unsupported values + for(method in method_list) { + for(n_seats in list(NA, NULL, -1, c(1, 1))) { + expect_error(proporz(c(100, 10, 5), n_seats, method), "n_seats must be one number >= 0") + } + } + for(method in method_list) { + for(votes in list(NA, NULL, -1)) { + expect_error(proporz(votes, 3, method), "votes must be numeric >= 0", fixed = TRUE) + } + } +}) + +test_that("all method names", { + for(m in names(apport_methods)) { + x = proporz(c(10, 20, 5), 3, m) + expect_length(x, 3) + } }) diff --git a/tests/testthat/test-quota.R b/tests/testthat/test-quota.R index 691523b..8f6762b 100644 --- a/tests/testthat/test-quota.R +++ b/tests/testthat/test-quota.R @@ -2,11 +2,26 @@ context("quota") # https://de.wikipedia.org/wiki/Hare-Niemeyer-Verfahren test_that("quota_largest_remainder", { - v1 = c(216, 310, 22, 32) - n1 = 60 - e1 = c(23,32,2,3) - expect_equal(quota_largest_remainder(v1, n1), e1) - expect_equal(proporz(v1, n1, "hare-niemeyer"), e1) - expect_equal(proporz(v1, n1, "hamilton"), e1) - expect_equal(proporz(v1, n1, "vinton"), e1) + v1 = c(216, 310, 22, 32) + n1 = 60 + e1 = c(23,32,2,3) + expect_equal(quota_largest_remainder(v1, n1), e1) + expect_equal(proporz(v1, n1, "hare-niemeyer"), e1) + expect_equal(proporz(v1, n1, "hamilton"), e1) + expect_equal(proporz(v1, n1, "vinton"), e1) + + + # https://en.wikipedia.org/wiki/Largest_remainder_method + votes2 = c(47000, 16000, 15800, 12000, 6100, 3100) + seats_actual2 = quota_largest_remainder(votes2, 10) + seats_expected2 = c(5, 2, 1, 1, 1, 0) + expect_equal(seats_actual2, seats_expected2) + + # Wikipedia DE + votes3 = c(720257, 323524, 257466, 213138, 144392, 88315) + seats_expected3 = c(13, 6, 5, 4, 2, 1) + seats_actual3 = quota_largest_remainder(votes3, 31) + expect_equal(seats_actual3, seats_expected3) + + expect_error(quota_largest_remainder(numeric(), numeric())) })