Merge branch 'dev/fix-cran-notes'

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) <doi:10.1016/j.mathsocsci.2008.01.004>
+    Oelbermann, K. F. (2016) <doi:10.1016/j.mathsocsci.2016.02.003>.
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true

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)
@@ -22,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)

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))
@@ -308,7 +314,7 @@ weigh_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()]
@@ -347,6 +353,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,15 +392,15 @@ 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)
         if(length(row_incr) == 1) {
             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,19 +409,33 @@ 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)
         if(length(col_incr) == 1) {
             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)
+        }
+    }
+
+    # 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
     names(attributes(output)$divisors$districts) <- colnames(M)
@@ -425,11 +446,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))

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))

R/round.R

@@ -1,13 +1,21 @@
-#' 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
+#'
+#' @returns the rounded vector
+#'
 #' @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))

_pkgdown.yml

@@ -41,3 +41,5 @@ reference:
   - get_divisors
   - pivot_to_matrix
   - pivot_to_df
+  - ceil_at
+  - weight_list_votes

cran-comments.md

@@ -1,5 +1,2 @@
-## R CMD check results
-
-0 errors | 0 warnings | 1 note
-
-* This is a new release.
+## Resubmission
+* added return value to `ceil_at` docs

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))
 })
 
@@ -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))
 })