Nothing
#' Implement STV Counting Systems
#'
#' Analyze a data frame of STV election ballot rankings and return
#' the elected voters and details of the steps in the election counting.
#'
#' Revise the details:
#' \code{stv()} first validates \code{x} by running the \code{validateBallots()} function.
#' Once validation is complete, it implements the selected single transferable vote
#' counting method. Each round of counting starts with idetification of active
#' ballots. Then a quota is calculated (currently only supports Droop method
#' \code{floor(votes/(seats + 1)) + 1} and Hare method \code{floor(votes/seats)})
#' with or without the \code{floor()} rounding. A tally of each candidate's vote share
#' is obtained using top choices of active ballots, where a ballot stays active until it
#' runs out of marked choices or gets removed during surplus reallocation. If a candidate
#' reaches the quota, she/he is elected and associated surplus ballots are reallocated
#' (currently only supports Cambridge and Fractional methods). If multiple candidates reach
#' the quota, all of them are elected and their surpluses are all reallocated. If no candidate
#' reaches the quota, then the candidate with the minimum number of votes is eliminated.
#' If multiple candidates tie for minimum number of votes, one of them is selected at random
#' and eliminated. The process is repeated until all of the seats are filled or the number of
#' candidates still in race equals the number of unfilled seats. In the later case,
#' all of the active candidates are elected.
#'
#' @param x a data frame with rows of ballots and columns for each
#' candidate. \code{x} must pass all checks from
#' \code{\link{validateBallots}}.
#' @param seats an integer (default = 1) indicating candidates to elect.
#' @param file a character string naming a file; \code{""} (default) indicates
#' output to the console only (default), otherwise a CSV file is created
#' (and thus \code{file} should end with \code{".csv"}).
#' @param surplusMethod a character string indicating which method to use for
#' surplus allocation. Currently supports \code{"Cambridge"} (default) and
#' \code{"Fractional"}.
#' @param quotaMethod a character string indicating which method to use for
#' calculation of quota. Currently supports \code{"Droop"} (default) and
#' \code{"Hare"}.
#' @param quotaFloor a logical value indicating that candidates must reach
#' the integer part of the quota in order to be elected if \code{"TRUE"}
#' (default) or that they must reach the exact quota which may be
#' fractional if \code{"FALSE"}.
#'
#' @return The object returned is a list consisting of two components: a
#' vector of the elected candidates, and a data frame with rows containing
#' detailed results from each round of STV counting.
#'
#' For every round of vote counting, a row of the detailed information
#' contains: number of active ballots, seats to remaining to be filled,
#' the current quota, the maximum and minimum votes obtained by each
#' candidate, who was eliminated (if applicable), whether there was a
#' tie for elimination (indicated by how many tied), who was elected
#' (if applicable), the surplus if elected (or multiple surpluses if
#' multiple candidates were elected), and each candidate's votes tally
#' for that round.
#'
#' @examples
#' data(ballots)
#' cballots <- cleanBallots(ballots)
#'
#' set.seed(1)
#' result1 <- stv(cballots, seats = 4)
#' names(result1)
#' result1$elected
#'
#' set.seed(4)
#' result2 <- stv(cballots, seats = 4)
#' result2$elected
#'
#' \dontrun{
#' result3 <- stv(cballots, seats = 4, surplusMethod = "Fractional")
#' result3$elected
#'
#' result4 <- stv(cballots, seats = 4, surplusMethod = "Fractional",
#' quotaMethod = "Hare")
#' result4$elected
#'
#' result5 <- stv(cballots, seats = 4, surplusMethod = "Cambridge",
#' quotaMethod = "Hare")
#' result5$elected
#' }
#'
#' @export
stv <- function(x, seats = 1, file = "", surplusMethod = "Cambridge",
quotaMethod = "Droop", quotaFloor = TRUE) {
# Ensure supported surpluse and quota methods are selected
if (is.null(surplusMethod) | is.null(quotaMethod) | is.null(quotaFloor))
stop("surplusMethod, quotaMethod, and quotaFloor must all be specified.")
if (c(!surplusMethod %in% c("Cambridge", "Fractional") | length(surplusMethod) != 1)[1])
stop("Please set surplusMethod = 'Cambridge' or 'Fractional'. These are currently the only supported methods.")
if (c(!quotaMethod %in% c("Droop", "Hare") | length(quotaMethod) != 1)[1])
stop("Please set quotaMethod = 'Droop' or 'Hare'. These are currently the only supported methods.")
if (c(!quotaFloor %in% c(TRUE, FALSE) | length(quotaFloor) != 1)[1])
stop("Please set quotaFloor = TRUE or FALSE.")
junk <- validateBallots(x)
if(seats > ncol(x))
stop("Number of seats must be less than or equal to the number of candidates.")
# Initialize various things:
elim <- c() # Store names of eliminated candidates
elect <- c() # Store names of elected candidates
if (surplusMethod == "Cambridge") {
included.ballots <- rep(TRUE, nrow(x)) # Ballots included at a given round
}
if (surplusMethod == "Fractional") {
ballot.weights <- rep(1, nrow(x)) # Each ballot's weight at a given round
}
unfilled <- seats # Vacant seats at a given round
Nround <- 0 # Current round number
res <- data.frame(matrix(NA, ncol = 9 + ncol(x), nrow = 0))
names(res) <- c("ballots", "seats.to.fill", "quota", "max.vote.count", "min.vote.count",
"elim.cand", "tied.for.elim", "elect.cand", "surplus", names(x))
# Iteratively elect/eliminate candidates until all seats are filled:
while (unfilled > 0) {
Nround <- Nround + 1
res[Nround, ] <- rep(NA, ncol(res))
res$seats.to.fill[Nround] <- unfilled
curr.candidates <- setdiff(names(x), c(elim, elect))
# Check if #remaining candidates already equal #unfilled seats:
if (unfilled == length(curr.candidates)) {
elect <- c(elect, curr.candidates)
res$elect.cand[Nround] <- paste(curr.candidates, collapse = "; ")
res$seats.to.fill[Nround] <- 0
res[Nround, elect] <- "Elected"
res[Nround, elim] <- "Eliminated"
res$quota[Nround] <- "Won by elim"
if (file != "") {
if (substr(file, nchar(file)-3, nchar(file)) != ".csv")
warning("File name provided does not include .csv extention")
write.table(res, file = file, sep = ",", row.names = FALSE)
}
return(list("elected" = elect, "details" = res))
}
# For remaining candidates, get valid ballots (1. not empty 2. not excluded in prior round)
if (surplusMethod == "Cambridge") {
curr.ballots <- (rowSums(!is.na(x[ ,curr.candidates])) > 0) & included.ballots
ballot.size <- sum(curr.ballots)
}
if (surplusMethod == "Fractional") {
curr.ballots <- rowSums(!is.na(x[ ,curr.candidates])) > 0
ballot.size <- floor(sum(curr.ballots*ballot.weights))
}
res$ballots[Nround] <- ballot.size
# Calculate Quota:
if (quotaFloor) {
if (quotaMethod == "Droop") quota <- floor(ballot.size/(unfilled + 1)) + 1
if (quotaMethod == "Hare") quota <- floor(ballot.size/unfilled)
} else {
if (quotaMethod == "Droop") quota <- ballot.size/(unfilled + 1) + 1
if (quotaMethod == "Hare") quota <- ballot.size/unfilled
}
res$quota[Nround] <- round(quota, 2)
# Get top choice for each valid ballot then tabulate it (i.e. get vote count for each candidate):
top.choice <- apply(x[ ,curr.candidates], 1, function(i.row) names(x[ ,curr.candidates])[which.min(i.row)])
top.choice[!curr.ballots] <- NA
vote.counts <- table(factor(top.choice, levels = curr.candidates))
if (surplusMethod == "Fractional") {
for (i in 1:length(vote.counts)) {
weighted.votes <- (names(vote.counts[i]) == top.choice)*ballot.weights
vote.counts[i] <- sum(weighted.votes, na.rm = TRUE)
}
}
res[Nround, names(vote.counts)] <- round(vote.counts, 2)
res$max.vote.count[Nround] <- round(max(vote.counts), 2)
res$min.vote.count[Nround] <- round(min(vote.counts), 2)
res[Nround, elect] <- "Elected"
res[Nround, elim] <- "Eliminated"
# Check for elected candidate(s): If quota crossed, surplus distribution.
# else: eliminate a candidate and redistribute votes
if (any(vote.counts >= quota)) {
curr.elected <- vote.counts[vote.counts >= quota]
if(length(curr.elected) > unfilled) {
warning(paste0("In round ", Nround, ", more candidates met the quota than can be elected to open seats. Ties were broken randomly."))
curr.elected <- sample(curr.elected, unfilled)
}
elect <- c(elect, names(curr.elected))
unfilled <- seats - length(elect)
res$elect.cand[Nround] <- paste(names(curr.elected), collapse = "; ")
res$surplus[Nround] <- paste(round(curr.elected - quota, 2), collapse = "; ")
# Redistribute surplus votes
for (i in names(curr.elected)) {
cand.ballots <- which(top.choice == i)
if (surplusMethod == "Cambridge") {
included.ballots[sample(cand.ballots, quota)] <- FALSE
}
if (surplusMethod == "Fractional") {
ballot.weights[cand.ballots] <- ballot.weights[cand.ballots]*(vote.counts[i] - quota)/vote.counts[i]
}
} # CLOSE surplus realocation
} else {
curr.elim <- names(which(vote.counts == min(vote.counts)))
if (length(curr.elim) > 1) res$tied.for.elim[Nround] <- paste("Yes: ", length(curr.elim), sep = "")
elim <- c(elim, sample(curr.elim, 1))
res$elim.cand[Nround] <- tail(elim, 1)
} # CLOSE elim/elect if-else function
} # CLOSE while-loop
if (file != "") {
if (substr(file, nchar(file)-3, nchar(file)) != ".csv")
warning("File name provided does not include .csv extention")
write.table(res, file = file, sep = ",", row.names = FALSE)
}
return(list("elected" = elect, "details" = res))
}
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.