From 6cf964a6fdd8d748797b255d0595805620413655 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:22:05 +0100 Subject: [PATCH 1/8] use round_func in find_divisor --- R/biproportional.R | 16 +++++++++------- tests/testthat/test-biproportional.R | 6 +++--- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/R/biproportional.R b/R/biproportional.R index 9fb4c23..beddbf7 100644 --- a/R/biproportional.R +++ b/R/biproportional.R @@ -347,6 +347,7 @@ lower_apportionment = function(votes_matrix, seats_cols, # divisor districts dD = round(colSums(M)/seats_cols) + dD[is.nan(dD)] <- 0 dD.min = floor(colSums(M)/(seats_cols+1) / max(dP.max)) dD.max = ceiling(colSums(M)/(seats_cols-1) / min(dP.min)) # handle districts with only one seat (otherwise leads to infinite dD.max) @@ -385,7 +386,7 @@ lower_apportionment = function(votes_matrix, seats_cols, dP[row_decr] <- find_divisor( M[row_decr,]/dD, dP[row_decr], dP.min[row_decr], - seats_rows[row_decr]) + seats_rows[row_decr], round_func) } row_incr = which.max0(mr(M,dD,dP) - seats_rows) @@ -393,7 +394,7 @@ lower_apportionment = function(votes_matrix, seats_cols, dP[row_incr] <- find_divisor( M[row_incr,]/dD, dP[row_incr], dP.max[row_incr], - seats_rows[row_incr]) + seats_rows[row_incr], round_func) } # change district divisors @@ -402,7 +403,7 @@ lower_apportionment = function(votes_matrix, seats_cols, dD[col_decr] <- find_divisor( M[,col_decr]/dP, dD[col_decr], dD.min[col_decr], - seats_cols[col_decr]) + seats_cols[col_decr], round_func) } col_incr = which.max0(mc(M,dD,dP) - seats_cols) @@ -410,11 +411,12 @@ lower_apportionment = function(votes_matrix, seats_cols, dD[col_incr] <- find_divisor( M[,col_incr]/dP, dD[col_incr], dD.max[col_incr], - seats_cols[col_incr]) + seats_cols[col_incr], round_func) } } - output = round(m.(M, dD, dP)) + output = round_func(m.(M, dD, dP)) + dimnames(output) <- dimnames(M) attributes(output)$divisors <- list() attributes(output)$divisors$districts <- dD names(attributes(output)$divisors$districts) <- colnames(M) @@ -425,11 +427,11 @@ lower_apportionment = function(votes_matrix, seats_cols, find_divisor = function(votes, divisor_from, divisor_to, - target_seats) { + target_seats, round_func) { stopifnot(length(target_seats) == 1) fun = function(divisor) { - target_seats - sum(round(votes/divisor)) + target_seats - sum(round_func(votes/divisor)) } divisor_range = sort(c(divisor_from, divisor_to)) diff --git a/tests/testthat/test-biproportional.R b/tests/testthat/test-biproportional.R index 217f87c..1e44805 100644 --- a/tests/testthat/test-biproportional.R +++ b/tests/testthat/test-biproportional.R @@ -298,13 +298,13 @@ test_that("find_divisor", { v = c(80,10,10) .check = function(div) round(v/div) - d0 = find_divisor(v, 0, 100, 10) + d0 = find_divisor(v, 0, 100, 10, function(x) ceil_at(x, 0.5)) expect_equal(.check(d0), .check(10)) # expand lower limit - d1 = find_divisor(v, 20, 100, 10) + d1 = find_divisor(v, 20, 100, 10, function(x) ceil_at(x, 0.5)) expect_equal(.check(d1), .check(10)) # expand upper limit - d2 = find_divisor(v, 1, 5, 10) + d2 = find_divisor(v, 1, 5, 10, function(x) ceil_at(x, 0.5)) expect_equal(.check(d2), .check(10)) }) From 09bf6a5c8e054944e09c85b0e183999e4bd8242a Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:22:14 +0100 Subject: [PATCH 2/8] generate prettier divisors --- R/biproportional.R | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/R/biproportional.R b/R/biproportional.R index beddbf7..64f0226 100644 --- a/R/biproportional.R +++ b/R/biproportional.R @@ -415,7 +415,20 @@ lower_apportionment = function(votes_matrix, seats_cols, } } - output = round_func(m.(M, dD, dP)) + # prettier divisors + expected = round_func(m.(M, dD, dP)) + for(k in seq_len(15)) { + .dD = round(dD, k) + .dP = round(dP, k) + if(identical(round_func(m.(M, .dD, .dP)), expected)) { + dD <- .dD + dP <- .dP + break + } + } + + # create output + output = round(m.(M, dD, dP)) dimnames(output) <- dimnames(M) attributes(output)$divisors <- list() attributes(output)$divisors$districts <- dD From f5afe1c7581497fc05f209b275ba576b6646b350 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:22:33 +0100 Subject: [PATCH 3/8] export ceil_at --- NAMESPACE | 1 + R/round.R | 20 +++++++++++++------- _pkgdown.yml | 1 + man/ceil_at.Rd | 18 +++++++++--------- 4 files changed, 24 insertions(+), 16 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a331007..2e66f5d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ S3method(as.matrix,proporz_matrix) S3method(print,proporz_matrix) export(biproporz) +export(ceil_at) export(divisor_ceiling) export(divisor_floor) export(divisor_geometric) diff --git a/R/round.R b/R/round.R index b627fda..238afcd 100644 --- a/R/round.R +++ b/R/round.R @@ -1,13 +1,19 @@ -#' Round with predefined thresholds -#' Round x up if `x-floor(x) >= threshold` -#' @param x numeric value -#' @param threshold threshold in \[0,1\] or "harmonic"/"geometric" for -#' threshold series +#' Rounding with predefined thresholds +#' +#' Round `x` up if `x-floor(x) >= threshold`, otherwise round down. +#' +#' @param x numeric vector >= 0 (`NaN` is not supported) +#' @param threshold threshold in \[0,1\] or "harmonic"/"geometric" to use +#' harmonic or geometric mean thresholds +#' #' @examples -#' proporz:::ceil_at(c(0.5, 1.5, 2.49, 2.5, 2.51), 0.5) +#' ceil_at(c(0.5, 1.5, 2.49, 2.5, 2.51), 0.5) #' # compare to #' round(c(0.5, 1.5, 2.49, 2.5, 2.51)) -#' @keywords internal +#' +#' ceil_at(c(1.45, 2.45, 3.45), 0) # like floor() +#' ceil_at(c(1.45, 2.45, 3.45, 0.2), "geometric") +#' @export ceil_at = function(x, threshold) { assert(length(threshold) == 1 && !is.na(threshold)) assert(all(!is.na(x)) && all(is.numeric(x)) && all(x >= 0)) diff --git a/_pkgdown.yml b/_pkgdown.yml index 0910410..2654415 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -41,3 +41,4 @@ reference: - get_divisors - pivot_to_matrix - pivot_to_df + - ceil_at diff --git a/man/ceil_at.Rd b/man/ceil_at.Rd index 247f912..966ab9a 100644 --- a/man/ceil_at.Rd +++ b/man/ceil_at.Rd @@ -2,24 +2,24 @@ % Please edit documentation in R/round.R \name{ceil_at} \alias{ceil_at} -\title{Round with predefined thresholds -Round x up if \code{x-floor(x) >= threshold}} +\title{Rounding with predefined thresholds} \usage{ ceil_at(x, threshold) } \arguments{ -\item{x}{numeric value} +\item{x}{numeric vector >= 0 (\code{NaN} is not supported)} -\item{threshold}{threshold in [0,1] or "harmonic"/"geometric" for -threshold series} +\item{threshold}{threshold in [0,1] or "harmonic"/"geometric" to use +harmonic or geometric mean thresholds} } \description{ -Round with predefined thresholds -Round x up if \code{x-floor(x) >= threshold} +Round \code{x} up if \code{x-floor(x) >= threshold}, otherwise round down. } \examples{ -proporz:::ceil_at(c(0.5, 1.5, 2.49, 2.5, 2.51), 0.5) +ceil_at(c(0.5, 1.5, 2.49, 2.5, 2.51), 0.5) # compare to round(c(0.5, 1.5, 2.49, 2.5, 2.51)) + +ceil_at(c(1.45, 2.45, 3.45), 0) # like floor() +ceil_at(c(1.45, 2.45, 3.45, 0.2), "geometric") } -\keyword{internal} From 9c6ea99655601c1fccce514ea490bb05007daec0 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:22:56 +0100 Subject: [PATCH 4/8] rename and export weight_list_votes add link in upper_apportionment --- NAMESPACE | 1 + R/biproportional.R | 24 +++++++++++++++--------- _pkgdown.yml | 1 + man/biproporz.Rd | 6 ++++-- man/upper_apportionment.Rd | 6 ++++-- man/weigh_list_votes.Rd | 25 ------------------------- man/weight_list_votes.Rd | 26 ++++++++++++++++++++++++++ tests/testthat/test-biproportional.R | 2 +- 8 files changed, 52 insertions(+), 39 deletions(-) delete mode 100644 man/weigh_list_votes.Rd create mode 100644 man/weight_list_votes.Rd diff --git a/NAMESPACE b/NAMESPACE index 2e66f5d..7399bac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,4 +23,5 @@ export(reached_quorum_any_district) export(reached_quorum_total) export(run_app) export(upper_apportionment) +export(weight_list_votes) importFrom(stats,setNames) diff --git a/R/biproportional.R b/R/biproportional.R index 64f0226..9768aab 100644 --- a/R/biproportional.R +++ b/R/biproportional.R @@ -192,8 +192,10 @@ biproporz = function(votes_matrix, #' 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. Set to `FALSE` if `votes_matrix` shows -#' the number of voters (e.g. they can only vote for one party), see [vignette()] +#' 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 +#' `votes_matrix` shows the number of voters (e.g. they can only cast one vote for one +#' party). #' @param method Apportion method that defines how seats are assigned, see [proporz()]. #' #' @seealso [biproporz()], [lower_apportionment()] @@ -234,7 +236,7 @@ upper_apportionment = function(votes_matrix, district_seats, # party seats if(use_list_votes) { - votes_matrix <- weigh_list_votes(votes_matrix, seats_district) + votes_matrix <- weight_list_votes(votes_matrix, seats_district) } seats_party = proporz(rowSums(votes_matrix), sum(seats_district), method) @@ -250,16 +252,20 @@ upper_apportionment = function(votes_matrix, district_seats, #' Create weighted votes matrix #' #' Weigh list votes by dividing the votes matrix entries by the number -#' of seats per district. No input checks are performed. +#' of seats per district. This method is used in [upper_apportionment()] if +#' `use_list_votes` is `TRUE` (default). #' #' @param votes_matrix votes matrix -#' @param seats_district seats per district (vector) +#' @param seats_district seats per district, vector with same length +#' as `ncol(votes_matrix)`) +#' #' @returns the weighted `votes_matrix` +#' #' @examples -#' vm = matrix(c(100,50,20,10), 2) -#' proporz:::weigh_list_votes(vm, c(10, 2)) -#' @keywords internal -weigh_list_votes = function(votes_matrix, seats_district) { +#' weight_list_votes(uri2020$votes_matrix, uri2020$seats_vector) +#' +#' @export +weight_list_votes = function(votes_matrix, seats_district) { M_seats_district = matrix( rep(seats_district, nrow(votes_matrix)), byrow = TRUE, ncol = length(seats_district)) diff --git a/_pkgdown.yml b/_pkgdown.yml index 2654415..3028538 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -42,3 +42,4 @@ reference: - pivot_to_matrix - pivot_to_df - ceil_at + - weight_list_votes diff --git a/man/biproporz.Rd b/man/biproporz.Rd index f8e9521..cf7b1c1 100644 --- a/man/biproporz.Rd +++ b/man/biproporz.Rd @@ -29,8 +29,10 @@ eligible for seats). The easiest way to do this is via \code{\link[=quorum_any]{ vector. No quorum is applied if parameter is missing or \code{NULL}.} \item{use_list_votes}{By default (\code{TRUE}) it's assumed that each voter in a district has -as many votes as there are seats in a district. Set to \code{FALSE} if \code{votes_matrix} shows -the number of voters (e.g. they can only vote for one party), see \code{\link[=vignette]{vignette()}}} +as many votes as there are seats in a district. Thus, votes are weighted according to +the number of available district seats with \code{\link[=weight_list_votes]{weight_list_votes()}}. Set to \code{FALSE} if +\code{votes_matrix} shows the number of voters (e.g. they can only cast one vote for one +party).} \item{method}{Defines the method how seats in upper and lower apportionment are assigned. For a different method for upper and lower apportionment use a vector with two entries. diff --git a/man/upper_apportionment.Rd b/man/upper_apportionment.Rd index 046b1b6..011d9ad 100644 --- a/man/upper_apportionment.Rd +++ b/man/upper_apportionment.Rd @@ -22,8 +22,10 @@ of votes (not the general use case), a single number for the total number of sea be used.} \item{use_list_votes}{By default (\code{TRUE}) it's assumed that each voter in a district has -as many votes as there are seats in a district. Set to \code{FALSE} if \code{votes_matrix} shows -the number of voters (e.g. they can only vote for one party), see \code{\link[=vignette]{vignette()}}} +as many votes as there are seats in a district. Thus, votes are weighted according to +the number of available district seats with \code{\link[=weight_list_votes]{weight_list_votes()}}. Set to \code{FALSE} if +\code{votes_matrix} shows the number of voters (e.g. they can only cast one vote for one +party).} \item{method}{Apportion method that defines how seats are assigned, see \code{\link[=proporz]{proporz()}}.} } diff --git a/man/weigh_list_votes.Rd b/man/weigh_list_votes.Rd deleted file mode 100644 index 026a9c2..0000000 --- a/man/weigh_list_votes.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/biproportional.R -\name{weigh_list_votes} -\alias{weigh_list_votes} -\title{Create weighted votes matrix} -\usage{ -weigh_list_votes(votes_matrix, seats_district) -} -\arguments{ -\item{votes_matrix}{votes matrix} - -\item{seats_district}{seats per district (vector)} -} -\value{ -the weighted \code{votes_matrix} -} -\description{ -Weigh list votes by dividing the votes matrix entries by the number -of seats per district. No input checks are performed. -} -\examples{ -vm = matrix(c(100,50,20,10), 2) -proporz:::weigh_list_votes(vm, c(10, 2)) -} -\keyword{internal} diff --git a/man/weight_list_votes.Rd b/man/weight_list_votes.Rd new file mode 100644 index 0000000..3ccd591 --- /dev/null +++ b/man/weight_list_votes.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/biproportional.R +\name{weight_list_votes} +\alias{weight_list_votes} +\title{Create weighted votes matrix} +\usage{ +weight_list_votes(votes_matrix, seats_district) +} +\arguments{ +\item{votes_matrix}{votes matrix} + +\item{seats_district}{seats per district, vector with same length +as \code{ncol(votes_matrix)})} +} +\value{ +the weighted \code{votes_matrix} +} +\description{ +Weigh list votes by dividing the votes matrix entries by the number +of seats per district. This method is used in \code{\link[=upper_apportionment]{upper_apportionment()}} if +\code{use_list_votes} is \code{TRUE} (default). +} +\examples{ +weight_list_votes(uri2020$votes_matrix, uri2020$seats_vector) + +} diff --git a/tests/testthat/test-biproportional.R b/tests/testthat/test-biproportional.R index 1e44805..de03dcc 100644 --- a/tests/testthat/test-biproportional.R +++ b/tests/testthat/test-biproportional.R @@ -408,6 +408,6 @@ test_that("error messages", { test_that("weight_list_votes", { vm = matrix(c(100,50,20,10), 2) - vmw = weigh_list_votes(vm, c(10, 2)) + vmw = weight_list_votes(vm, c(10, 2)) expect_equal(vmw, matrix(c(100/10,50/10,20/2,10/2), 2)) }) From 3317958ca8d71e73c6781e3310a7a1a7de866731 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:23:36 +0100 Subject: [PATCH 5/8] removed examples for reached_quorum --- R/quorum.R | 5 ----- man/reached_quorums.Rd | 6 ------ 2 files changed, 11 deletions(-) diff --git a/R/quorum.R b/R/quorum.R index 2dba571..c35021e 100644 --- a/R/quorum.R +++ b/R/quorum.R @@ -145,11 +145,6 @@ reached_quorum_any_district = function(votes_matrix, quorum_districts) { #' @seealso [quorum_all()], [quorum_any()] to create a list of quorum functions. #' #' @inherit reached_quorum_total return -#' @examples -#' votes_matrix = matrix(c(502, 55, 80, 10, 104, 55, 0, 1), ncol = 2) -#' -#' quorum_functions = quorum_any(any_district = 0.1, total = 100) -#' proporz:::reached_quorums(votes_matrix, quorum_functions) #' @keywords internal reached_quorums = function(votes_matrix, quorum_funcs) { assert(is.matrix(votes_matrix)) diff --git a/man/reached_quorums.Rd b/man/reached_quorums.Rd index 415185a..463034f 100644 --- a/man/reached_quorums.Rd +++ b/man/reached_quorums.Rd @@ -24,12 +24,6 @@ boolean vector with length equal to the number of lists/parties \description{ Apply a list of quorum functions to a votes matrix } -\examples{ -votes_matrix = matrix(c(502, 55, 80, 10, 104, 55, 0, 1), ncol = 2) - -quorum_functions = quorum_any(any_district = 0.1, total = 100) -proporz:::reached_quorums(votes_matrix, quorum_functions) -} \seealso{ \code{\link[=quorum_all]{quorum_all()}}, \code{\link[=quorum_any]{quorum_any()}} to create a list of quorum functions. } From e797f8d29ce880581f624d67f8d24210e3c36c15 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:23:45 +0100 Subject: [PATCH 6/8] add references to package description --- DESCRIPTION | 4 +++- R/biproportional.R | 2 +- man/lower_apportionment.Rd | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2802b53..fac4bf3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,7 +7,9 @@ Authors@R: c( Description: Calculate seat apportionment for legislative bodies with various methods. The algorithms include divisor or highest averages methods (e.g. Jefferson, Webster or Adams), largest remainder methods and - 'biproportional' apportionment. + biproportional apportionment. + Gaffke, N. & Pukelsheim, F. (2008) + Oelbermann, K. F. (2016) . License: GPL (>= 3) Encoding: UTF-8 LazyData: true diff --git a/R/biproportional.R b/R/biproportional.R index 9768aab..9f0821d 100644 --- a/R/biproportional.R +++ b/R/biproportional.R @@ -314,7 +314,7 @@ weight_list_votes = function(votes_matrix, seats_district) { #' @returns A seat matrix with district (columns) and party (rows) divisors stored in #' attributes. #' -#' @references Oelbermann, K. F. (2016). Alternate scaling algorithm for biproportional +#' @references Oelbermann, K. F. (2016): Alternate scaling algorithm for biproportional #' divisor methods. Mathematical Social Sciences, 80, 25-32. #' #' @seealso [biproporz()], [upper_apportionment()] diff --git a/man/lower_apportionment.Rd b/man/lower_apportionment.Rd index 5e913c5..5147260 100644 --- a/man/lower_apportionment.Rd +++ b/man/lower_apportionment.Rd @@ -55,7 +55,7 @@ lower_apportionment(votes_matrix, district_seats, party_seats) } \references{ -Oelbermann, K. F. (2016). Alternate scaling algorithm for biproportional +Oelbermann, K. F. (2016): Alternate scaling algorithm for biproportional divisor methods. Mathematical Social Sciences, 80, 25-32. } \seealso{ From 8b4307aec1de2e3f01b0b38f8f0f270bf5a6a5ad Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Wed, 28 Feb 2024 17:24:02 +0100 Subject: [PATCH 7/8] update cran-comments --- cran-comments.md | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index 858617d..da020a5 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,5 +1,6 @@ -## R CMD check results - -0 errors | 0 warnings | 1 note - -* This is a new release. +## Resubmission +Fixed the following notes: +* added references/doi to DESCRIPTION +* removed 'biproportional' single quotes in description +* exported `ceil_at` and `weight_list_votes` (renamed) +* removed example for internal `reached_quorums` From 3f330046372095b6f44c396d4ea35143e96eae0e Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Fri, 1 Mar 2024 07:11:59 +0100 Subject: [PATCH 8/8] add ceil_at returns --- R/round.R | 2 ++ cran-comments.md | 6 +----- man/ceil_at.Rd | 3 +++ 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/R/round.R b/R/round.R index 238afcd..1052267 100644 --- a/R/round.R +++ b/R/round.R @@ -6,6 +6,8 @@ #' @param threshold threshold in \[0,1\] or "harmonic"/"geometric" to use #' harmonic or geometric mean thresholds #' +#' @returns the rounded vector +#' #' @examples #' ceil_at(c(0.5, 1.5, 2.49, 2.5, 2.51), 0.5) #' # compare to diff --git a/cran-comments.md b/cran-comments.md index da020a5..275bb0c 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,6 +1,2 @@ ## Resubmission -Fixed the following notes: -* added references/doi to DESCRIPTION -* removed 'biproportional' single quotes in description -* exported `ceil_at` and `weight_list_votes` (renamed) -* removed example for internal `reached_quorums` +* added return value to `ceil_at` docs diff --git a/man/ceil_at.Rd b/man/ceil_at.Rd index 966ab9a..afb01bb 100644 --- a/man/ceil_at.Rd +++ b/man/ceil_at.Rd @@ -12,6 +12,9 @@ ceil_at(x, threshold) \item{threshold}{threshold in [0,1] or "harmonic"/"geometric" to use harmonic or geometric mean thresholds} } +\value{ +the rounded vector +} \description{ Round \code{x} up if \code{x-floor(x) >= threshold}, otherwise round down. }