Skip to content

Commit

Permalink
update docs
Browse files Browse the repository at this point in the history 
use roxygen markdown,  use 4 space indentation everywhere
  • Loading branch information
@polettif
polettif committed Dec 12, 2023
1 parent e31e0a6 commit 25dbae3
Show file tree
Hide file tree
Showing 27 changed files with 437 additions and 440 deletions.
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ License: GPL (>=3)
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.2.3
Roxygen: list(markdown = TRUE)
Depends:
R (>= 3.6.0)
Suggests:
Expand Down
2 changes: 1 addition & 1 deletion R/S3.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@ print.proporz_matrix = function(x, ...) {

#' @export
as.matrix.proporz_matrix = function(x, ...) {
matrix(x, nrow = nrow(x), dimnames = dimnames(x))
matrix(x, nrow = nrow(x), dimnames = dimnames(x))
}

#' Get district and party divisors
Expand Down
2 changes: 1 addition & 1 deletion R/biproportional-check.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -86,7 +86,7 @@ prep_district_seats = function(district_seats, votes_matrix,
return(district_seats)
}

prep_district_seats_df <- function(district_seats_df) {
prep_district_seats_df = function(district_seats_df) {
ds_df = district_seats_df[order(district_seats_df[[1]]),]
district_seats <- ds_df[[2]]
names(district_seats) <- ds_df[[1]]
Expand Down
6 changes: 2 additions & 4 deletions R/biproportional.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -69,7 +69,6 @@
#' #> SDP UUS 97107 6
#' #> KOK UUS 114243 7
#'
#' @md
#' @export
pukelsheim = function(votes_df, district_seats_df,
quorum,
Expand Down Expand Up @@ -214,7 +213,6 @@ pukelsheim = function(votes_df, district_seats_df,
#'
#'
#' @importFrom stats setNames
#' @md
#' @export
biproportional = function(votes_matrix,
district_seats,
Expand Down Expand Up @@ -277,7 +275,7 @@ biproporz = biproportional
#' @param method Apportion method that defines how seats are assigned,
#' see \link{proporz}.
#'
#' @seealso \link{biproportional}, \link{lower_apportionment}
#' @seealso \code{\link{biproportional}}, \code{\link{lower_apportionment}}
#'
#' @return named list with column/district seats and row/party seats
#' @export
Expand Down Expand Up @@ -356,7 +354,7 @@ upper_apportionment = function(votes_matrix, district_seats,
#'
#' @return seat matrix with column and row divisors stored in attributes
#'
#' @seealso \link{biproportional}, \link{upper_apportionment}
#' @seealso \code{\link{biproportional}}, \code{\link{lower_apportionment}}
#'
#' @references Oelbermann, K. F. (2016). Alternate scaling algorithm for
#' biproportional divisor methods. Mathematical Social Sciences, 80, 25-32.
Expand Down
18 changes: 9 additions & 9 deletions R/divisor.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,15 +16,15 @@
#'
#' @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))) }
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)
divisors <- seq(from = divisors, by = 1, length.out = n_seats)
}
n_parties = length(party_votes)

Expand Down Expand Up @@ -82,7 +82,7 @@ divisor_round = function(votes, n_seats, quorum = 0) {
hzv(votes, n_seats, 0.5)
}

#' #' Divisor method rounding up
#' Divisor method rounding up
#'
#' Also known as: Adams method
#'
Expand All @@ -102,7 +102,7 @@ divisor_ceiling = function(votes, n_seats, quorum = 0) {
#' @seealso \code{\link{proporz}}
#' @export
divisor_harmonic = function(votes, n_seats, quorum = 0) {
check_n_seats(n_seats)
check_n_seats(n_seats)
if(n_seats < length(votes[votes > 0])) {
stop("With harmonic rounding there must be at least as many seats as there are parties with non-zero votes", call. = F)
}
Expand All @@ -123,7 +123,7 @@ 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)
check_n_seats(n_seats)

nn = seq(1, n_seats)
divisors = sqrt((nn-1)*nn)
Expand Down
54 changes: 27 additions & 27 deletions R/methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,35 +29,35 @@
#'
#' @export
apport_methods = list(
"divisor_floor" = "floor",
"d'hondt" = "floor",
"jefferson" = "floor",
"divisor_round" = "round",
"sainte-lague" = "round",
"webster" = "round",
"divisor_ceiling" = "ceiling",
"adams" = "ceiling",
"dean" = "harmonic",
"huntington-hill" = "geometric",
"hill-huntington" = "geometric",
"hare-niemeyer" = "quota_largest_remainder",
"hamilton" = "quota_largest_remainder",
"vinton" = "quota_largest_remainder",
"hagenbach-bischoff" = "floor",
"ceiling" = "ceiling",
"round" = "round",
"floor" = "floor",
"harmonic" = "harmonic",
"geometric" = "geometric",
"quota_largest_remainder" = "quota_largest_remainder"
"divisor_floor" = "floor",
"d'hondt" = "floor",
"jefferson" = "floor",
"divisor_round" = "round",
"sainte-lague" = "round",
"webster" = "round",
"divisor_ceiling" = "ceiling",
"adams" = "ceiling",
"dean" = "harmonic",
"huntington-hill" = "geometric",
"hill-huntington" = "geometric",
"hare-niemeyer" = "quota_largest_remainder",
"hamilton" = "quota_largest_remainder",
"vinton" = "quota_largest_remainder",
"hagenbach-bischoff" = "floor",
"ceiling" = "ceiling",
"round" = "round",
"floor" = "floor",
"harmonic" = "harmonic",
"geometric" = "geometric",
"quota_largest_remainder" = "quota_largest_remainder"
)

get_apport_method = function(method_name) {
method_name <- tolower(method_name)
if(!method_name %in% names(apport_methods)) {
stop("Unknown apportion method: ", method_name, ".\nAvailable: ",
paste0(names(apport_methods), collapse=", "))
}
method_name <- tolower(method_name)
if(!method_name %in% names(apport_methods)) {
stop("Unknown apportion method: ", method_name, ".\nAvailable: ",
paste0(names(apport_methods), collapse=", "))
}

apport_methods[[method_name]]
apport_methods[[method_name]]
}
16 changes: 7 additions & 9 deletions R/quorum.R
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
#' Create a quorum function where \emph{all} quorums must be reached
#'
#' \code{quorum_any} and \code{quorum_all} are normally used in [biproportional()]
#' `quorum_any` and `quorum_all` are normally used in [biproportional()]
#' or [pukelsheim()]. Missing quorum parameters are ignored.
#'
#' @param any_district Vote threshold a party must reach in \emph{at least}
Expand All @@ -13,7 +13,7 @@
#' as number of votes. Must be greater than 0.
#' Uses [reached_quorum_total()].
#'
#' @seealso [quorum_any()]
#' @seealso \code{\link{quorum_any}}
#'
#' @note Currently only two quorums are implemented (any_district and total).
#' If you only use one quorum, [quorum_any()] and [quorum_all()] are identical.
Expand Down Expand Up @@ -71,22 +71,21 @@
#' #> C 0 0
#' #> D 0 0
#'
#' @md
#' @export
quorum_all = function(any_district, total) {
create_quorum_function_list("ALL", any_district, total)
}

#' Create a quorum function where \emph{at least one} quorum must be reached
#'
#' \code{quorum_any} and \code{quorum_all} are normally used in [biproportional()]
#' `quorum_any` and `quorum_all` are normally used in [biproportional()]
#' or [pukelsheim()]. Missing quorum parameters are ignored.
#'
#' @returns a function(votes_matrix) which then returns a boolean vector with
#' length equal to the number of lists/parties (votes_matrix rows),
#' denoting whether a party has reached at least one quorum.
#'
#' @seealso [quorum_all()]
#' @seealso `quorum_all`
#'
#' @note Currently only two quorums are implemented.
#'
Expand Down Expand Up @@ -126,15 +125,15 @@ create_quorum_function_list = function(type, any_district, total) {
#' as number of votes. Must be greater than 0.
#'
#' @returns boolean vector with length equal to the number of lists/parties
#' (votes_matrix rows) whether they reached the quorum or not
#' (`votes_matrix` rows) whether they reached the quorum or not

#' @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)
#' reached_quorums(votes_matrix, quorum_functions)
#' #> [1] TRUE TRUE TRUE FALSE
#'
#' @md
#' @export
reached_quorum_total = function(votes_matrix, quorum_total) {
stopifnot(quorum_total > 0)
Expand All @@ -157,7 +156,6 @@ reached_quorum_total = function(votes_matrix, quorum_total) {
#' Must be greater than 0.
#'
#' @inherit reached_quorum_total return
#' @md
#' @export
reached_quorum_any_district = function(votes_matrix, quorum_districts) {
stopifnot(quorum_districts > 0)
Expand All @@ -174,7 +172,7 @@ reached_quorum_any_district = function(votes_matrix, quorum_districts) {
#'
#' @param votes_matrix votes matrix
#' @param quorum_funcs List of quorum functions. If list, the attribute "type"
#' must be set which indicates whether "ALL" or "ANY"
#' must be set which indicates whether `ALL` or `ANY`
#' (i.e. at least one) quorum must be reached.
#'
#' @note This is a low-level implementation for quorum calculations and is
Expand Down
34 changes: 17 additions & 17 deletions R/quota.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,29 +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)
check_n_seats(n_seats)
check_votes(votes)

if(length(votes) == 1) {
return(n_seats)
}
if(n_seats == 0) {
return(rep(0, length(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))
seats_rem = rep(0, length(votes))

if(sum(seats_base) < n_seats) {
remainder = quota - seats_base
check_equal_entries(remainder[remainder > 0])
if(sum(seats_base) < n_seats) {
remainder = quota - seats_base
check_equal_entries(remainder[remainder > 0])

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)
}
62 changes: 31 additions & 31 deletions R/round.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,48 +2,48 @@
#' @param x numeric value
#' @param threshold threshold in 0..1
ceil_at = function(x, threshold) {
stopifnot(!is.na(threshold))
stopifnot(!is.na(threshold))
if(any(x < 0)) {
stop("x cannot be negative")
}
stop("x cannot be negative")
}
values = c(x)

if(is.numeric(threshold)) {
if(threshold < 0 || threshold > 1) {
stop("Threshold argument must be in [0,1]")
}
if(threshold < 0 || threshold > 1) {
stop("Threshold argument must be in [0,1]")
}
threshold <- floor(values) + threshold
} else if(threshold == "harmonic") {
threshold <- threshold_harmonic(values)
} else if(threshold == "geometric") {
threshold <- threshold_geometric(values)
} else {
stop('Numeric value, "harmonic" or "geometric" expected for threshold argument')
}
} else if(threshold == "harmonic") {
threshold <- threshold_harmonic(values)
} else if(threshold == "geometric") {
threshold <- threshold_geometric(values)
} else {
stop('Numeric value, "harmonic" or "geometric" expected for threshold argument')
}

ceiled = ceiling(values)
floor_index = values < threshold
ceiled[floor_index] <- floor(values)[floor_index]
ceiled = ceiling(values)
floor_index = values < threshold
ceiled[floor_index] <- floor(values)[floor_index]

if(is.matrix(x)) {
ceiled_matrix = matrix(ceiled, nrow = nrow(x), ncol = ncol(x))
return(ceiled_matrix)
} else {
return(ceiled)
}
if(is.matrix(x)) {
ceiled_matrix = matrix(ceiled, nrow = nrow(x), ncol = ncol(x))
return(ceiled_matrix)
} else {
return(ceiled)
}
}

get_round_function = function(method_name) {
m = get_apport_method(method_name)
method_thresholds = list(
"ceiling" = 0,
"round" = 0.5,
"floor" = 1,
"harmonic" = "harmonic",
"geometric" = "geometric"
)
m = get_apport_method(method_name)
method_thresholds = list(
"ceiling" = 0,
"round" = 0.5,
"floor" = 1,
"harmonic" = "harmonic",
"geometric" = "geometric"
)

function(x) ceil_at(x, method_thresholds[[m]])
function(x) ceil_at(x, method_thresholds[[m]])
}

threshold_harmonic = function(x) {
Expand Down
Loading

0 comments on commit 25dbae3

Please sign in to comment.