Nothing
#' Count votes using the approval method
#'
#' See https://arxiv.org/abs/2102.05801
#'
#' @param votes,nseats,fsep,quiet,... undocumented
#'
#' @return undocumented
#' @export
approval <-
function(votes,
nseats = 1,
fsep = '\t',
quiet = FALSE,
...) {
votes <- prepare.votes(votes, fsep = fsep)
x <- check.votes(votes, "approval", quiet = quiet)
nseats <- check.nseats(nseats, ncol(x), ...)
res <- sumOfVotes(x)
elected <- names(rev(sort(res))[1:nseats])
result <- structure(list(
elected = elected,
totals = res,
data = x,
invalid.votes =
votes[setdiff(rownames(votes), rownames(x)), , drop = FALSE],
nseats = nseats
),
class = "vote.approval")
if (!quiet)
print(summary(result))
invisible(result)
}
#' Count votes using the plurality method
#'
#' See https://arxiv.org/abs/2102.05801
#'
#' @param votes,nseats,fsep,quiet,... undocumented
#'
#' @return undocumented
#' @export
plurality <-
function(votes,
nseats = 1,
fsep = '\t',
quiet = FALSE,
...) {
votes <- prepare.votes(votes, fsep = fsep)
x <- check.votes(votes, "plurality", quiet = quiet)
nseats <- check.nseats(nseats, ncol(x), ...)
res <- sumOfVotes(x)
elected <- names(rev(sort(res))[1:nseats])
result <- structure(list(
elected = elected,
totals = res,
data = x,
invalid.votes =
votes[setdiff(rownames(votes), rownames(x)), , drop = FALSE],
nseats = nseats
),
class = "vote.plurality")
if (!quiet)
print(summary(result))
invisible(result)
}
#' Count votes using the score (or range) method.
#'
#' See https://arxiv.org/abs/2102.05801
#'
#' @param votes,nseats,max.score,larger.wins,fsep,quiet,... undocumented
#'
#' @return undocumented
#' @export
score <-
function(votes,
nseats = 1,
max.score = NULL,
larger.wins = TRUE,
fsep = '\t',
quiet = FALSE,
...) {
votes <- prepare.votes(votes, fsep = fsep)
if (is.null(max.score) || max.score < 1) {
max.score <- max(votes)
warning("Invalid max.score. Set to observed maximum: ", max.score)
}
x <- check.votes(votes, "score", max.score, quiet = quiet)
nseats <- check.nseats(nseats, ncol(x), ...)
res <- sumOfVotes(x)
elected <- names(sort(res, decreasing = larger.wins)[1:nseats])
result <-
structure(
list(
elected = elected,
totals = res,
larger.wins = larger.wins,
data = x,
invalid.votes =
votes[setdiff(rownames(votes), rownames(x)), , drop = FALSE],
nseats = nseats
),
class = "vote.score"
)
if (!quiet)
print(summary(result))
invisible(result)
}
#' internal method, computes column-sums
#'
#' Renamed from 'sum.votes' to avoid confusion with the generic sum()
#'
#' @param votes ballots are rows, candidates are columns
#'
#' @return vector of votes for each candidate
sumOfVotes <- function(votes) {
vtot <- apply(votes, 2, sum)
return (vtot)
}
#' summarises vote-totals for subsequent printing
#'
#' @param object vector of total votes per candidate
#' @param larger.wins TRUE if candidates are "voted in" rather than voted-out
#' @param reorder TRUE if output data.frame columns should be in rank-order
#'
#' @return a data.frame with three columns and nc+1 rows, where
#' nc is the number of candidates. The first column contains candidate
#' names and a final entry named "Sum". The second column contains
#' vote totals. The third column is a vector of chars which indicate
#' whether the candidate has been elected. The data.frame has four named
#' attributes carrying election parameters.
#'
#' TODO: refactor into a modern dialect of R, perhaps by defining a
#' constructor for an election_info S3 object with a summary method and a
#' print method
.summary.SafeVote <-
function(object,
larger.wins = TRUE,
reorder = TRUE) {
df <-
data.frame(
Candidate = names(object$totals),
Total = object$totals,
Elected = "",
stringsAsFactors = FALSE
)
if (reorder) {
df <- df[order(df$Total, decreasing = larger.wins), ]
}
df[object$elected, "Elected"] <- "x"
rownames(df) <- NULL
df <- rbind(df, c('', sum(df$Total), ''))
rownames(df)[nrow(df)] <- "Sum"
attr(df, "align") <- c("l", "r", "c")
attr(df, "number.of.votes") <- nrow(object$data)
attr(df, "number.of.invalid.votes") <- nrow(object$invalid.votes)
attr(df, "number.of.candidates") <- length(object$totals)
# attr(df, "number.of.seats") <- length(object$elected)
# Amended Dec 2022. Will cause regressions on vote.2_3.2 to fail on elections
# which do not fill all available seats
attr(df, "number.of.seats") <- object$nseats
return(df)
}
#' summary method for approval results
#'
#' @param object,... undocumented
#'
#' @return undocumented
#' @export
summary.SafeVote.approval <- function(object, ...) {
df <- .summary.SafeVote(object)
class(df) <- c('summary.SafeVote.approval', class(df))
return(df)
}
#' prints the basic results of an election
#'
#' @param x basic election results, as named attributes of an R structure or
#' object
#'
#' @return data.frame : an invisible copy of the printed results
#'
#' TODO: refactor into a modern dialect of R, e.g. defining a constructor for an
#' election_info S3 object with a print method
election.info <- function(x) {
df <-
data.frame(sapply(c(
"number.of.votes",
"number.of.invalid.votes",
"number.of.candidates",
"number.of.seats"
),
function(a)
attr(x, a)))
rownames(df) <-
c(
"Number of valid votes:",
"Number of invalid votes:",
"Number of candidates:",
"Number of seats:"
)
colnames(df) <- NULL
print(df)
}
#' .print method for summary object
#'
#' @param x,... undocumented
#'
#' @return undocumented
.print.summary.SafeVote <- function(x, ...) {
election.info(x)
print(kable(x, align = attr(x, "align"), ...))
cat("\nElected:",
paste(x$Candidate[trimws(x$Elected) == "x"],
collapse = ", "),
"\n\n")
}
#' print method for summary object
#'
#' @param x,... undocumented
#'
#' @return undocumented
#' @export
print.summary.SafeVote.approval <- function(x, ...) {
cat("\nResults of Approval voting")
cat("\n==========================")
.print.summary.SafeVote(x, ...)
}
#' view method for approval object
#'
#' @param object,... undocumented
#'
#' @return undocumented
#' @export
view.SafeVote.approval <- function(object, ...) {
s <- summary(object)
col_formatter <-
formatter("span",
style =
x ~ style(
background =
ifelse(x %in% s$Candidate[trimws(s$Elected) == "x"],
"lightgreen",
"transparent")
# width = "20px" # doesn't work
))
formattable(s, list(Candidate = col_formatter), ...)
}
#' summary method for plurality object
#'
#' @param object,... undocumented
#'
#' @return descriptive dataframe
#' @export
summary.SafeVote.plurality <- function(object, ...) {
df <- .summary.SafeVote(object)
class(df) <- c('summary.SafeVote.plurality', class(df))
return(df)
}
#' print method for summary of plurality object
#'
#' @param x,... undocumented
#'
#' @return undocumented
#' @export
print.summary.SafeVote.plurality <- function(x, ...) {
cat("\nResults of Plurality voting")
cat("\n===========================")
.print.summary.SafeVote(x, ...)
}
#' view method for plurality object
#'
#' @param object,... undocumented
#'
#' @return undocumented
#' @export
view.SafeVote.plurality <- function(object, ...) {
view.SafeVote.approval(object, ...)
}
#' summary method for score object
#'
#' @param object,... undocumented
#'
#' @return undocumented
#' @export
summary.SafeVote.score <- function(object, ...) {
df <- .summary.SafeVote(object, larger.wins=object$larger.wins)
class(df) <- c('summary.SafeVote.score', class(df))
return(df)
}
#' print method for summary.score object
#'
#' @param x,... undocumented
#'
#' @return undocumented
#' @export
print.summary.SafeVote.score <- function(x, ...) {
cat("\nResults of Score voting")
cat("\n=======================")
.print.summary.SafeVote(x, ...)
}
#' view method for score object
#'
#' @param object,... undocumented
#'
#' @return undocumented
#' @export
view.SafeVote.score <- function(object, ...) {
view.SafeVote.approval(object, ...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.