R/galeshapley.R
In jtilly/matchingR: Matching Algorithms in R and C++
Defines functions
galeShapley.checkPreferences
galeShapley.checkStability
galeShapley.validate
galeShapley.collegeAdmissions
galeShapley
galeShapley.marriageMarket
Documented in
galeShapley
galeShapley.checkPreferences
galeShapley.checkStability
galeShapley.collegeAdmissions
galeShapley.marriageMarket
galeShapley.validate
# matchingR -- Matching Algorithms in R and C++
#
# Copyright (C) 2015 Jan Tilly <jtilly@econ.upenn.edu>
# Nick Janetos <njanetos@econ.upenn.edu>
#
# This file is part of matchingR.
#
# matchingR is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# matchingR is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#' Gale-Shapley Algorithm: Stable Marriage Problem
#'
#' This function computes the Gale-Shapley algorithm and finds a solution to the
#' stable marriage problem.
#'
#' The Gale-Shapley algorithm works as follows: Single men ("the proposers")
#' sequentially make proposals to each of their most preferred available women
#' ("the reviewers"). A woman can hold on to at most one proposal at a time. A
#' single woman will accept any proposal that is made to her. A woman that
#' already holds on to a proposal will reject any proposal by a man that she
#' values less than her current match. If a woman receives a proposal from a man
#' that she values more than her current match, then she will accept the
#' proposal and her previous match will join the line of bachelors. This process
#' continues until all men are matched to women.
#'
#' The Gale-Shapley Algorithm requires a complete specification of proposers'
#' and reviewers' preferences over each other. Preferences can be
#' passed on to the algorithm in ordinal form (e.g. man 3 prefers woman 1 over
#' woman 3 over woman 2) or in cardinal form (e.g. man 3 receives payoff 3.14 from
#' being matched to woman 1, payoff 2.51 from being matched to woman 3, and payoff
#' 2.15 from being matched to woman 2). Preferences must be complete, i.e.
#' all proposers must have fully specified preferences over all reviewers and
#' vice versa.
#'
#' In the version of the algorithm that is implemented here, all individuals --
#' proposers and reviewers -- prefer being matched to anyone to not being
#' matched at all.
#'
#' The algorithm still works with an unequal number of proposers and reviewers.
#' In that case some agents will remain unmatched.
#'
#' This function can also be called using \code{galeShapley}.
#'
#' @param proposerUtils is a matrix with cardinal utilities of the proposing
#' side of the market. If there are \code{n} proposers and \code{m} reviewers,
#' then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to the payoff that proposer \code{j} receives
#' from being matched to proposer \code{i}.
#' @param reviewerUtils is a matrix with cardinal utilities of the courted side
#' of the market. If there are \code{n} proposers and \code{m} reviewers, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to the payoff that reviewer \code{j} receives from being
#' matched to proposer \code{i}.
#' @param proposerPref is a matrix with the preference order of the proposing
#' side of the market. This argument is only required when
#' \code{proposerUtils} is not provided. If there are \code{n} proposers and
#' \code{m} reviewers in the market, then this matrix will be of dimension
#' \code{m} by \code{n}. The \code{i,j}th element refers to proposer \code{j}'s
#' \code{i}th most favorite reviewer. Preference orders can either be specified
#' using R-indexing (starting at 1) or C++ indexing (starting at 0).
#' @param reviewerPref is a matrix with the preference order of the courted side
#' of the market. This argument is only required when \code{reviewerUtils} is
#' not provided. If there are \code{n} proposers and \code{m} reviewers in the
#' market, then this matrix will be of dimension \code{n} by \code{m}. The
#' \code{i,j}th element refers to reviewer \code{j}'s \code{i}th most
#' favorite proposer. Preference orders can either be specified using
#' R-indexing (starting at 1) or C++ indexing (starting at 0).
#' @return A list with elements that specify who is matched to whom and who
#' remains unmatched. Suppose there are \code{n} proposers and \code{m}
#' reviewers. The list contains the following items:
#' \itemize{
#' \item{\code{proposals} is a vector of length \code{n} whose \code{i}th
#' element contains the number of the reviewer that proposer \code{i} is
#' matched to. Proposers that remain unmatched will be listed as being
#' matched to \code{NA}.}
#' \item{\code{engagements} is a vector of length \code{m} whose \code{j}th
#' element contains the number of the proposer that reviewer \code{j} is
#' matched to. Reviewers that remain unmatched will be listed as being matched
#' to \code{NA}.}
#' \item{\code{single.proposers} is a vector that lists the remaining single
#' proposers. This vector will be empty whenever \code{n<=m}}.
#' \item{\code{single.reviewers} is a vector that lists the remaining single
#' reviewers. This vector will be empty whenever \code{m<=n}}.
#' }
#' @examples
#' nmen <- 5
#' nwomen <- 4
#' # generate cardinal utilities
#' uM <- matrix(runif(nmen * nwomen), nrow = nwomen, ncol = nmen)
#' uW <- matrix(runif(nwomen * nmen), nrow = nmen, ncol = nwomen)
#' # run the algorithm using cardinal utilities as inputs
#' results <- galeShapley.marriageMarket(uM, uW)
#' results
#'
#' # transform the cardinal utilities into preference orders
#' prefM <- sortIndex(uM)
#' prefW <- sortIndex(uW)
#' # run the algorithm using preference orders as inputs
#' results <- galeShapley.marriageMarket(proposerPref = prefM, reviewerPref = prefW)
#' results
#' @seealso \code{\link{galeShapley.collegeAdmissions}}
#' @aliases galeShapley
#' @export
galeShapley.marriageMarket <- function(proposerUtils = NULL,
reviewerUtils = NULL,
proposerPref = NULL,
reviewerPref = NULL) {
# validate the inputs
args <- galeShapley.validate(proposerUtils, reviewerUtils, proposerPref, reviewerPref)
# use galeShapleyMatching to compute matching
res <- cpp_wrapper_galeshapley(args$proposerPref, args$reviewerUtils)
# number of proposals
M <- length(res$proposals)
# number of engagements
N <- length(res$engagements)
# turn these into R indices by adding +1
res <- c(res, list(
"single.proposers" = seq(from = 0, to = M - 1)[res$proposals == N] + 1,
"single.reviewers" = seq(from = 0, to = N - 1)[res$engagements == M] + 1
))
res$proposals <- matrix(res$proposals, ncol = 1) + 1
res$engagements <- matrix(res$engagements, ncol = 1) + 1
# return unmatched proposers and reviewers as matched to NA
res$proposals[res$proposals == (N + 1)] <- NA
res$engagements[res$engagements == (M + 1)] <- NA
return(res)
}
# see galeShapley.marriageMarket
galeShapley <- function(proposerUtils = NULL,
reviewerUtils = NULL,
proposerPref = NULL,
reviewerPref = NULL) {
return(galeShapley.marriageMarket(
proposerUtils = proposerUtils,
reviewerUtils = reviewerUtils,
proposerPref = proposerPref,
reviewerPref = reviewerPref
))
}
#' Gale-Shapley Algorithm: College Admissions Problem
#'
#' This function computes the Gale-Shapley algorithm and finds a solution to the
#' college admissions problem. In the student-optimal college admissions
#' problem, \code{n} students apply to \code{m} colleges, where each college has
#' \code{s} slots.
#'
#' The algorithm works analogously to \link{galeShapley.marriageMarket}. The
#' Gale-Shapley algorithm works as follows: Students ("the proposers")
#' sequentially make proposals to each of their most preferred available
#' colleges ("the reviewers"). A college can hold on to at most \code{s}
#' proposals at a time. A college with an open slot will accept any application
#' that it receives. A college that already holds on to \code{s} applications
#' will reject any application by a student that it values less than her current
#' set of applicants. If a college receives an application from a student that
#' it values more than its current set of applicants, then it will accept the
#' application and drop its least preferred current applicant. This process
#' continues until all students are matched to colleges.
#'
#' The Gale-Shapley Algorithm requires a complete specification of students' and
#' colleges' preferences over each other. Preferences can be passed on to the
#' algorithm in ordinal form (e.g. student 3 prefers college 1 over college 3
#' over college 2) or in cardinal form (e.g. student 3 receives payoff 3.14 from
#' being matched to college 1, payoff 2.51 from being matched to college 3 and
#' payoff 2.13 from being matched to college 2). Preferences must be complete,
#' i.e. all students must have fully specified preferences over all colleges and
#' vice versa.
#'
#' In the version of the algorithm that is implemented here, all individuals --
#' colleges and students -- prefer being matched to anyone to not being matched
#' at all.
#'
#' The algorithm still works with an unequal number of students and slots. In
#' that case some students will remain unmatched or some slots will remain open.
#'
#' @param studentUtils is a matrix with cardinal utilities of the students. If
#' there are \code{n} students and \code{m} colleges, then this matrix will be
#' of dimension \code{m} by \code{n}. The \code{i,j}th element refers to the
#' payoff that student \code{j} receives from being matched to college
#' \code{i}.
#' @param collegeUtils is a matrix with cardinal utilities of colleges. If there
#' are \code{n} students and \code{m} colleges, then this matrix will be of
#' dimension \code{n} by \code{m}. The \code{i,j}th element refers to the
#' payoff that college \code{j} receives from being matched to student
#' \code{i}.
#' @param studentPref is a matrix with the preference order of the proposing
#' side of the market (only required when \code{studentUtils} is not
#' provided). If there are \code{n} students and \code{m} colleges in the
#' market, then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to student \code{j}'s \code{i}th most favorite
#' college. Preference orders can either be specified using R-indexing
#' (starting at 1) or C++ indexing (starting at 0).
#' @param collegePref is a matrix with the preference order of the courted side
#' of the market (only required when \code{collegeUtils} is not provided). If
#' there are \code{n} students and \code{m} colleges in the market, then this
#' matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th element
#' refers to individual \code{j}'s \code{i}th most favorite partner.
#' Preference orders can either be specified using R-indexing (starting at 1)
#' or C++ indexing (starting at 0).
#' @param slots is the number of slots that each college has available. If this
#' is 1, then the algorithm is identical to
#' \code{\link{galeShapley.marriageMarket}}. \code{slots} can either be a
#' integer or a vector. If it is an integer, then all colleges have the
#' same number of slots. If it is a vector, it must have as many elements
#' as there are colleges where each element refers to the number of slots
#' at a particular college.
#' @param studentOptimal is \code{TRUE} if students apply to colleges. The
#' resulting match is student-optimal. \code{studentOptimal} is \code{FALSE}
#' if colleges apply to students. The resulting match is college-optimal.
#' @return A list with elements that specify which student is matched to which
#' college and who remains unmatched. Suppose there are \code{n} students and
#' \code{m} colleges with \code{s} slots. The list contains the following
#' items:
#' \itemize{
#' \item{\code{matched.students} is a vector of length \code{n} whose \code{i}th
#' element contains college that student \code{i} is
#' matched to. Students that remain unmatched will be listed as being
#' matched to college \code{NA}.}
#' \item{\code{matched.colleges} is a matrix of dimension \code{m} by
#' \code{s} whose \code{j}th row contains the students that were admitted to
#' college \code{j}. Slots that remain open show up as being matched to
#' student to \code{NA}.}
#' \item{\code{unmatched.students} is a vector that lists the remaining unmatched
#' students This vector will be empty when all students get matched.}
#' \item{\code{unmatched.colleges} is a vector that lists colleges with open
#' slots. If a college has multiple open slots, it will show up multiple
#' times. This vector will be empty whenever all college slots get filled.}
#' }
#' @examples
#' ncolleges <- 10
#' nstudents <- 25
#'
#' # randomly generate cardinal preferences of colleges and students
#' collegeUtils <- matrix(runif(ncolleges * nstudents), nrow = nstudents, ncol = ncolleges)
#' studentUtils <- matrix(runif(ncolleges * nstudents), nrow = ncolleges, ncol = nstudents)
#'
#' # run the student-optimal algorithm
#' results.studentoptimal <- galeShapley.collegeAdmissions(
#' studentUtils = studentUtils,
#' collegeUtils = collegeUtils,
#' slots = 2,
#' studentOptimal = TRUE
#' )
#' results.studentoptimal
#'
#' # run the college-optimal algorithm
#' results.collegeoptimal <- galeShapley.collegeAdmissions(
#' studentUtils = studentUtils,
#' collegeUtils = collegeUtils,
#' slots = 2,
#' studentOptimal = FALSE
#' )
#' results.collegeoptimal
#'
#' # transform the cardinal utilities into preference orders
#' collegePref <- sortIndex(collegeUtils)
#' studentPref <- sortIndex(studentUtils)
#'
#' # run the student-optimal algorithm
#' results.studentoptimal <- galeShapley.collegeAdmissions(
#' studentPref = studentPref,
#' collegePref = collegePref,
#' slots = 2,
#' studentOptimal = TRUE
#' )
#' results.studentoptimal
#'
#' # run the college-optimal algorithm
#' results.collegeoptimal <- galeShapley.collegeAdmissions(
#' studentPref = studentPref,
#' collegePref = collegePref,
#' slots = 2,
#' studentOptimal = FALSE
#' )
#' results.collegeoptimal
#' @export
galeShapley.collegeAdmissions <- function(studentUtils = NULL,
collegeUtils = NULL,
studentPref = NULL,
collegePref = NULL,
slots = 1,
studentOptimal = TRUE) {
if (length(slots) > 1) {
if (!is.null((collegePref)) & (length(slots) != NCOL(collegePref)) |
!is.null((collegeUtils)) & (length(slots) != NCOL(collegeUtils))) {
stop("slots must either be a scalar or have the same length as there are colleges.")
}
}
if (studentOptimal) {
# validate the inputs
args <- galeShapley.validate(studentUtils, collegeUtils, studentPref, collegePref)
# number of students
number_of_students <- NROW(args$reviewerUtils)
# number of colleges
number_of_colleges <- NCOL(args$reviewerUtils)
# expand slots
if (length(slots) == 1) {
slots <- rep(slots, number_of_colleges)
}
# expand cardinal utilities corresponding to the slot size
proposerUtils <- reprow(args$proposerUtils, slots)
reviewerUtils <- repcol(args$reviewerUtils, slots)
# create preference ordering
proposerPref <- sortIndex(as.matrix(proposerUtils))
# use galeShapleyMatching to compute matching
res <- cpp_wrapper_galeshapley(proposerPref, reviewerUtils)
# number of students
M <- length(res$proposals)
# number of positions
N <- length(res$engagements)
# collect results
res <- c(res, list(
"unmatched.students" = seq(from = 0, to = M - 1)[res$proposals == N] + 1,
"unmatched.colleges" = rep(NA, length = sum(res$engagements == M))
))
unmatched.colleges <- seq(from = 0, to = N - 1)[res$engagements == M] + 1
# assemble results
res$matched.colleges <- list()
# map engagements back into slots
cumsum.slotsLower <- cumsum(c(0, slots[-length(slots)])) + 1
cumsum.slotsUpper <- cumsum(slots)
for (jX in 1:number_of_colleges) {
# fill slots with student ids
res$matched.colleges[[jX]] <- res$engagements[cumsum.slotsLower[jX]:cumsum.slotsUpper[jX]] + 1
# set vacant slots to NA
res$matched.colleges[[jX]][res$matched.colleges[[jX]] == (number_of_students + 1)] <- NA
# unmatched colleges
res$unmatched.colleges[unmatched.colleges %in% (cumsum.slotsLower[jX]:cumsum.slotsUpper[jX])] <- jX
}
# remove unused information from res
res$engagements <- NULL
res$proposals <- NULL
} else {
# validate the inputs
args <- galeShapley.validate(collegeUtils, studentUtils, collegePref, studentPref)
# number of students
number_of_students <- NROW(args$proposerUtils)
# number of colleges
number_of_colleges <- NCOL(args$proposerUtils)
# expand slots
if (length(slots) == 1) {
slots <- rep(slots, number_of_colleges)
}
# expand cardinal utilities corresponding to the slot size
proposerUtils <- repcol(args$proposerUtils, slots)
reviewerUtils <- reprow(args$reviewerUtils, slots)
# create preference ordering
proposerPref <- sortIndex(as.matrix(proposerUtils))
# use galeShapleyMatching to compute matching
res <- cpp_wrapper_galeshapley(as.matrix(proposerPref), as.matrix(reviewerUtils))
# number of slots
M <- length(res$proposals)
# number of students
N <- length(res$engagements)
# collect results
res <- c(res, list(
"unmatched.colleges" = rep(NA, length = sum(res$proposals == N)),
"unmatched.students" = seq(from = 0, to = N - 1)[res$engagements == M] + 1
))
unmatched.colleges <- seq(from = 0, to = M - 1)[res$proposals == N] + 1
# assemble results
res$matched.colleges <- list()
# map proposals back into slots
cumsum.slotsLower <- cumsum(c(0, slots[-length(slots)])) + 1
cumsum.slotsUpper <- cumsum(slots)
for (jX in 1:number_of_colleges) {
# fill slots with student ids
res$matched.colleges[[jX]] <- res$proposals[cumsum.slotsLower[jX]:cumsum.slotsUpper[jX]] + 1
# set vacant slots to NA
res$matched.colleges[[jX]][res$matched.colleges[[jX]] == (number_of_students + 1)] <- NA
# unmatched colleges
res$unmatched.colleges[unmatched.colleges %in% (cumsum.slotsLower[jX]:cumsum.slotsUpper[jX])] <- jX
}
# remove unused information from res
res$engagements <- NULL
res$proposals <- NULL
}
# make a vector with matched students
res$matched.students <- matrix(NA, nrow = number_of_students, ncol = 1)
for (jX in 1:number_of_colleges) {
res$matched.students[res$matched.colleges[[jX]]] <- jX
}
# remove proposals (all relevant information is stored in res$matched.students)
res$engagements <- NULL
# if all colleges have the same number of slots return matched.colleges as matrix
# (otherwise it's a list)
if (all(slots == slots[1])) {
res$matched.colleges <- matrix(unlist(res$matched.colleges), nrow = number_of_colleges, ncol = slots[1], byrow = TRUE)
}
return(res)
}
#' Input validation of preferences
#'
#' This function parses and validates the arguments that are passed on to the
#' Gale-Shapley Algorithm. In particular, it checks if user-defined preference
#' orders are complete and returns an error otherwise. If user-defined orderings
#' are given in terms of R indices (starting at 1), then these are transformed
#' into C++ indices (starting at zero).
#'
#' @param proposerUtils is a matrix with cardinal utilities of the proposing
#' side of the market. If there are \code{n} proposers and \code{m} reviewers,
#' then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to the payoff that proposer \code{j} receives
#' from being matched to reviewer \code{i}.
#' @param reviewerUtils is a matrix with cardinal utilities of the courted side
#' of the market. If there are \code{n} proposers and \code{m} reviewers, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to the payoff that reviewer \code{j} receives from being
#' matched to proposer \code{i}.
#' @param proposerPref is a matrix with the preference order of the proposing
#' side of the market (only required when \code{proposerUtils} is not
#' provided). If there are \code{n} proposers and \code{m} reviewers in the
#' market, then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to proposer \code{j}'s \code{i}th most favorite
#' reviewer. Preference orders can either be specified using R-indexing
#' (starting at 1) or C++ indexing (starting at 0).
#' @param reviewerPref is a matrix with the preference order of the courted side
#' of the market (only required when \code{reviewerUtils} is not provided). If
#' there are \code{n} proposers and \code{m} reviewers in the market, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to reviewer \code{j}'s \code{i}th most favorite proposer.
#' Preference orders can either be specified using R-indexing (starting at 1)
#' or C++ indexing (starting at 0).
#' @return a list containing \code{proposerUtils}, \code{reviewerUtils},
#' \code{proposerPref} (\code{reviewerPref} are not required after they are
#' translated into \code{reviewerUtils}).
#' @examples
#' # market size
#' nmen <- 5
#' nwomen <- 4
#'
#' # generate cardinal utilities
#' uM <- matrix(runif(nmen * nwomen), nrow = nwomen, ncol = nmen)
#' uW <- matrix(runif(nwomen * nmen), nrow = nmen, ncol = nwomen)
#'
#' # turn cardinal utilities into ordinal preferences
#' prefM <- sortIndex(uM)
#' prefW <- sortIndex(uW)
#'
#' # validate cardinal preferences
#' preferences <- galeShapley.validate(uM, uW)
#' preferences
#'
#' # validate ordinal preferences
#' preferences <- galeShapley.validate(proposerPref = prefM, reviewerPref = prefW)
#' preferences
#'
#' # validate ordinal preferences when these are in R style indexing
#' # (instead of C++ style indexing)
#' preferences <- galeShapley.validate(proposerPref = prefM + 1, reviewerPref = prefW + 1)
#' preferences
#'
#' # validate preferences when proposer-side is cardinal and reviewer-side is ordinal
#' preferences <- galeShapley.validate(proposerUtils = uM, reviewerPref = prefW)
#' preferences
#' @export
galeShapley.validate <- function(proposerUtils = NULL, reviewerUtils = NULL, proposerPref = NULL, reviewerPref = NULL) {
if (!is.null(reviewerPref)) {
reviewerPref <- galeShapley.checkPreferences(reviewerPref)
if (is.null(reviewerPref)) {
stop(
"reviewerPref was defined by the user but is not a complete list of preference orderings."
)
}
}
if (!is.null(proposerPref)) {
proposerPref <- galeShapley.checkPreferences(proposerPref)
if (is.null(proposerPref)) {
stop("proposerPref was defined by the user but is not a complete list of preference orderings.")
}
}
# parse inputs
if (is.null(proposerPref) && !is.null(proposerUtils)) {
proposerPref <- sortIndex(as.matrix(proposerUtils))
}
if (is.null(proposerUtils) && !is.null(proposerPref)) {
proposerUtils <- -rankIndex(as.matrix(proposerPref))
}
if (is.null(reviewerUtils) && !is.null(reviewerPref)) {
reviewerUtils <- -rankIndex(as.matrix(reviewerPref))
}
if (is.null(proposerPref)) {
stop("missing proposer preferences")
}
if (is.null(reviewerUtils)) {
stop("missing reviewer utilities")
}
# check inputs
if (NROW(proposerPref) != NCOL(reviewerUtils)) {
stop(
"The number of rows in the matrix of proposers' ",
"preferences must equal the number of columns in ",
"the matrix of reviewers' preferences"
)
}
if (NCOL(proposerPref) != NROW(reviewerUtils)) {
stop(
"The number of columns in the matrix of proposers' ",
"preferences must equal the number of rows in the ",
"matrix of reviewers' preferences"
)
}
return(
list(
proposerPref = as.matrix(proposerPref),
proposerUtils = as.matrix(proposerUtils),
reviewerUtils = as.matrix(reviewerUtils)
)
)
}
#' Check if a two-sided matching is stable
#'
#' This function checks if a given matching is stable for a particular set of
#' preferences. This stability check can be applied to both the stable marriage
#' problem and the college admission problem. The function requires preferences
#' to be specified in cardinal form. If necessary, the function
#' \code{\link{rankIndex}} can be used to turn ordinal preferences into cardinal
#' utilities.
#'
#' @param proposerUtils is a matrix with cardinal utilities of the proposing
#' side of the market. If there are \code{n} proposers and \code{m} reviewers,
#' then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to the payoff that proposer \code{j} receives
#' from being matched to reviewer \code{i}.
#' @param reviewerUtils is a matrix with cardinal utilities of the courted side
#' of the market. If there are \code{n} proposers and \code{m} reviewers, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to the payoff that reviewer \code{j} receives from being
#' matched to proposer \code{i}.
#' @param proposals is a matrix that contains the number of the reviewer that a
#' given proposer is matched to: the first row contains the reviewer that is
#' matched to the first proposer, the second row contains the reviewer that is
#' matched to the second proposer, etc. The column dimension accommodates
#' proposers with multiple slots.
#' @param engagements is a matrix that contains the number of the proposer that
#' a given reviewer is matched to. The column dimension accommodates reviewers
#' with multiple slots.
#' @return true if the matching is stable, false otherwise
#' @examples
#' # define cardinal utilities
#' uM <- matrix(c(
#' 0.52, 0.85,
#' 0.96, 0.63,
#' 0.82, 0.08,
#' 0.55, 0.34
#' ), nrow = 4, byrow = TRUE)
#' uW <- matrix(c(
#' 0.76, 0.88, 0.74, 0.02,
#' 0.32, 0.21, 0.02, 0.79
#' ), ncol = 4, byrow = TRUE)
#' # define matching
#' results <- list(
#' proposals = matrix(c(2, 1), ncol = 1),
#' engagements = matrix(c(2, 1, NA, NA), ncol = 1)
#' )
#' # check stability
#' galeShapley.checkStability(uM, uW, results$proposals, results$engagements)
#'
#' # if preferences are in ordinal form, we can use galeShapley.validate
#' # to transform them into cardinal form and then use checkStability()
#' prefM <- matrix(c(
#' 2, 1,
#' 3, 2,
#' 4, 4,
#' 1, 3
#' ), nrow = 4, byrow = TRUE)
#' prefW <- matrix(c(
#' 1, 1, 1, 2,
#' 2, 2, 2, 1
#' ), ncol = 4, byrow = TRUE)
#' # define matching
#' results <- list(
#' proposals = matrix(c(2, 1), ncol = 1),
#' engagements = matrix(c(2, 1, NA, NA), ncol = 1)
#' )
#' # check stability
#' pref.validated <- galeShapley.validate(
#' proposerPref = prefM,
#' reviewerPref = prefW
#' )
#' galeShapley.checkStability(
#' pref.validated$proposerUtils,
#' pref.validated$reviewerUtils,
#' results$proposals,
#' results$engagements
#' )
#' @export
galeShapley.checkStability <- function(proposerUtils, reviewerUtils, proposals, engagements) {
if (is.list(proposals) | is.list(engagements)) {
stop("Proposals and engagements must be vectors/matrices.")
}
# replace NA for unmatched proposers (they are now matched to the number of reviewers + 1)
proposals[is.na(proposals)] <- NROW(proposerUtils) + 1
# replace NA for unmatched reviewers (they are now matched to the number of proposers + 1)
engagements[is.na(engagements)] <- NROW(reviewerUtils) + 1
# turn proposals and engagements into C++ style indexing
proposals <- proposals - 1
engagements <- engagements - 1
# call the C++ wrapper
cpp_wrapper_galeshapley_check_stability(proposerUtils, reviewerUtils, proposals, engagements)
}
#' Check if preference order is complete
#'
#' This function checks if a given preference ordering is complete. If needed,
#' it transforms the indices from R indices (starting at 1) to C++ indices
#' (starting at zero).
#'
#' @param pref is a matrix with ordinal preference orderings for one side of the
#' market. Suppose that \code{pref} refers to the preferences of \code{n}
#' women over \code{m} men. In that case, \code{pref} will be of dimension
#' \code{m} by \code{n}. The \code{i,j}th element refers to woman \code{j}'s
#' \code{i}th most favorite man. Preference orders can either be specified
#' using R-indexing (starting at 1) or C++ indexing (starting at 0).
#' @return a matrix with ordinal preference orderings with proper C++ indices or
#' NULL if the preference order is not complete.
#' @examples
#' # preferences in proper C++ indexing: galeShapley.checkPreferences(pref)
#' # will return pref
#' pref <- matrix(c(
#' 0, 1, 0,
#' 1, 0, 1
#' ), nrow = 2, ncol = 3, byrow = TRUE)
#' pref
#' galeShapley.checkPreferences(pref)
#'
#' # preferences in R indexing: galeShapley.checkPreferences(pref)
#' # will return pref-1
#' pref <- matrix(c(
#' 1, 2, 1,
#' 2, 1, 2
#' ), nrow = 2, ncol = 3, byrow = TRUE)
#' pref
#' galeShapley.checkPreferences(pref)
#'
#' # incomplete preferences: galeShapley.checkPreferences(pref)
#' # will return NULL
#' pref <- matrix(c(
#' 3, 2, 1,
#' 2, 1, 2
#' ), nrow = 2, ncol = 3, byrow = TRUE)
#' pref
#' galeShapley.checkPreferences(pref)
#' @export
galeShapley.checkPreferences <- function(pref) {
# check if pref is using R instead of C++ indexing
if (all(apply(pref, 2, sort) == array(1:(NROW(pref)), dim = dim(pref)))) {
return(pref - 1)
}
# check if pref has a complete listing otherwise given an error
if (all(apply(pref, 2, sort) == (array(1:(NROW(pref)), dim = dim(pref))) - 1)) {
return(pref)
}
return(NULL)
}
jtilly/matchingR documentation built on Feb. 15, 2023, 3:24 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions galeShapley.checkPreferences galeShapley.checkStability galeShapley.validate galeShapley.collegeAdmissions galeShapley galeShapley.marriageMarket
Documented in galeShapley galeShapley.checkPreferences galeShapley.checkStability galeShapley.collegeAdmissions galeShapley.marriageMarket galeShapley.validate
# matchingR -- Matching Algorithms in R and C++
#
# Copyright (C) 2015 Jan Tilly <jtilly@econ.upenn.edu>
# Nick Janetos <njanetos@econ.upenn.edu>
#
# This file is part of matchingR.
#
# matchingR is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# matchingR is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#' Gale-Shapley Algorithm: Stable Marriage Problem
#'
#' This function computes the Gale-Shapley algorithm and finds a solution to the
#' stable marriage problem.
#'
#' The Gale-Shapley algorithm works as follows: Single men ("the proposers")
#' sequentially make proposals to each of their most preferred available women
#' ("the reviewers"). A woman can hold on to at most one proposal at a time. A
#' single woman will accept any proposal that is made to her. A woman that
#' already holds on to a proposal will reject any proposal by a man that she
#' values less than her current match. If a woman receives a proposal from a man
#' that she values more than her current match, then she will accept the
#' proposal and her previous match will join the line of bachelors. This process
#' continues until all men are matched to women.
#'
#' The Gale-Shapley Algorithm requires a complete specification of proposers'
#' and reviewers' preferences over each other. Preferences can be
#' passed on to the algorithm in ordinal form (e.g. man 3 prefers woman 1 over
#' woman 3 over woman 2) or in cardinal form (e.g. man 3 receives payoff 3.14 from
#' being matched to woman 1, payoff 2.51 from being matched to woman 3, and payoff
#' 2.15 from being matched to woman 2). Preferences must be complete, i.e.
#' all proposers must have fully specified preferences over all reviewers and
#' vice versa.
#'
#' In the version of the algorithm that is implemented here, all individuals --
#' proposers and reviewers -- prefer being matched to anyone to not being
#' matched at all.
#'
#' The algorithm still works with an unequal number of proposers and reviewers.
#' In that case some agents will remain unmatched.
#'
#' This function can also be called using \code{galeShapley}.
#'
#' @param proposerUtils is a matrix with cardinal utilities of the proposing
#' side of the market. If there are \code{n} proposers and \code{m} reviewers,
#' then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to the payoff that proposer \code{j} receives
#' from being matched to proposer \code{i}.
#' @param reviewerUtils is a matrix with cardinal utilities of the courted side
#' of the market. If there are \code{n} proposers and \code{m} reviewers, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to the payoff that reviewer \code{j} receives from being
#' matched to proposer \code{i}.
#' @param proposerPref is a matrix with the preference order of the proposing
#' side of the market. This argument is only required when
#' \code{proposerUtils} is not provided. If there are \code{n} proposers and
#' \code{m} reviewers in the market, then this matrix will be of dimension
#' \code{m} by \code{n}. The \code{i,j}th element refers to proposer \code{j}'s
#' \code{i}th most favorite reviewer. Preference orders can either be specified
#' using R-indexing (starting at 1) or C++ indexing (starting at 0).
#' @param reviewerPref is a matrix with the preference order of the courted side
#' of the market. This argument is only required when \code{reviewerUtils} is
#' not provided. If there are \code{n} proposers and \code{m} reviewers in the
#' market, then this matrix will be of dimension \code{n} by \code{m}. The
#' \code{i,j}th element refers to reviewer \code{j}'s \code{i}th most
#' favorite proposer. Preference orders can either be specified using
#' R-indexing (starting at 1) or C++ indexing (starting at 0).
#' @return A list with elements that specify who is matched to whom and who
#' remains unmatched. Suppose there are \code{n} proposers and \code{m}
#' reviewers. The list contains the following items:
#' \itemize{
#' \item{\code{proposals} is a vector of length \code{n} whose \code{i}th
#' element contains the number of the reviewer that proposer \code{i} is
#' matched to. Proposers that remain unmatched will be listed as being
#' matched to \code{NA}.}
#' \item{\code{engagements} is a vector of length \code{m} whose \code{j}th
#' element contains the number of the proposer that reviewer \code{j} is
#' matched to. Reviewers that remain unmatched will be listed as being matched
#' to \code{NA}.}
#' \item{\code{single.proposers} is a vector that lists the remaining single
#' proposers. This vector will be empty whenever \code{n<=m}}.
#' \item{\code{single.reviewers} is a vector that lists the remaining single
#' reviewers. This vector will be empty whenever \code{m<=n}}.
#' }
#' @examples
#' nmen <- 5
#' nwomen <- 4
#' # generate cardinal utilities
#' uM <- matrix(runif(nmen * nwomen), nrow = nwomen, ncol = nmen)
#' uW <- matrix(runif(nwomen * nmen), nrow = nmen, ncol = nwomen)
#' # run the algorithm using cardinal utilities as inputs
#' results <- galeShapley.marriageMarket(uM, uW)
#' results
#'
#' # transform the cardinal utilities into preference orders
#' prefM <- sortIndex(uM)
#' prefW <- sortIndex(uW)
#' # run the algorithm using preference orders as inputs
#' results <- galeShapley.marriageMarket(proposerPref = prefM, reviewerPref = prefW)
#' results
#' @seealso \code{\link{galeShapley.collegeAdmissions}}
#' @aliases galeShapley
#' @export
galeShapley.marriageMarket <- function(proposerUtils = NULL,
reviewerUtils = NULL,
proposerPref = NULL,
reviewerPref = NULL) {
# validate the inputs
args <- galeShapley.validate(proposerUtils, reviewerUtils, proposerPref, reviewerPref)
# use galeShapleyMatching to compute matching
res <- cpp_wrapper_galeshapley(args$proposerPref, args$reviewerUtils)
# number of proposals
M <- length(res$proposals)
# number of engagements
N <- length(res$engagements)
# turn these into R indices by adding +1
res <- c(res, list(
"single.proposers" = seq(from = 0, to = M - 1)[res$proposals == N] + 1,
"single.reviewers" = seq(from = 0, to = N - 1)[res$engagements == M] + 1
))
res$proposals <- matrix(res$proposals, ncol = 1) + 1
res$engagements <- matrix(res$engagements, ncol = 1) + 1
# return unmatched proposers and reviewers as matched to NA
res$proposals[res$proposals == (N + 1)] <- NA
res$engagements[res$engagements == (M + 1)] <- NA
return(res)
}
# see galeShapley.marriageMarket
galeShapley <- function(proposerUtils = NULL,
reviewerUtils = NULL,
proposerPref = NULL,
reviewerPref = NULL) {
return(galeShapley.marriageMarket(
proposerUtils = proposerUtils,
reviewerUtils = reviewerUtils,
proposerPref = proposerPref,
reviewerPref = reviewerPref
))
}
#' Gale-Shapley Algorithm: College Admissions Problem
#'
#' This function computes the Gale-Shapley algorithm and finds a solution to the
#' college admissions problem. In the student-optimal college admissions
#' problem, \code{n} students apply to \code{m} colleges, where each college has
#' \code{s} slots.
#'
#' The algorithm works analogously to \link{galeShapley.marriageMarket}. The
#' Gale-Shapley algorithm works as follows: Students ("the proposers")
#' sequentially make proposals to each of their most preferred available
#' colleges ("the reviewers"). A college can hold on to at most \code{s}
#' proposals at a time. A college with an open slot will accept any application
#' that it receives. A college that already holds on to \code{s} applications
#' will reject any application by a student that it values less than her current
#' set of applicants. If a college receives an application from a student that
#' it values more than its current set of applicants, then it will accept the
#' application and drop its least preferred current applicant. This process
#' continues until all students are matched to colleges.
#'
#' The Gale-Shapley Algorithm requires a complete specification of students' and
#' colleges' preferences over each other. Preferences can be passed on to the
#' algorithm in ordinal form (e.g. student 3 prefers college 1 over college 3
#' over college 2) or in cardinal form (e.g. student 3 receives payoff 3.14 from
#' being matched to college 1, payoff 2.51 from being matched to college 3 and
#' payoff 2.13 from being matched to college 2). Preferences must be complete,
#' i.e. all students must have fully specified preferences over all colleges and
#' vice versa.
#'
#' In the version of the algorithm that is implemented here, all individuals --
#' colleges and students -- prefer being matched to anyone to not being matched
#' at all.
#'
#' The algorithm still works with an unequal number of students and slots. In
#' that case some students will remain unmatched or some slots will remain open.
#'
#' @param studentUtils is a matrix with cardinal utilities of the students. If
#' there are \code{n} students and \code{m} colleges, then this matrix will be
#' of dimension \code{m} by \code{n}. The \code{i,j}th element refers to the
#' payoff that student \code{j} receives from being matched to college
#' \code{i}.
#' @param collegeUtils is a matrix with cardinal utilities of colleges. If there
#' are \code{n} students and \code{m} colleges, then this matrix will be of
#' dimension \code{n} by \code{m}. The \code{i,j}th element refers to the
#' payoff that college \code{j} receives from being matched to student
#' \code{i}.
#' @param studentPref is a matrix with the preference order of the proposing
#' side of the market (only required when \code{studentUtils} is not
#' provided). If there are \code{n} students and \code{m} colleges in the
#' market, then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to student \code{j}'s \code{i}th most favorite
#' college. Preference orders can either be specified using R-indexing
#' (starting at 1) or C++ indexing (starting at 0).
#' @param collegePref is a matrix with the preference order of the courted side
#' of the market (only required when \code{collegeUtils} is not provided). If
#' there are \code{n} students and \code{m} colleges in the market, then this
#' matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th element
#' refers to individual \code{j}'s \code{i}th most favorite partner.
#' Preference orders can either be specified using R-indexing (starting at 1)
#' or C++ indexing (starting at 0).
#' @param slots is the number of slots that each college has available. If this
#' is 1, then the algorithm is identical to
#' \code{\link{galeShapley.marriageMarket}}. \code{slots} can either be a
#' integer or a vector. If it is an integer, then all colleges have the
#' same number of slots. If it is a vector, it must have as many elements
#' as there are colleges where each element refers to the number of slots
#' at a particular college.
#' @param studentOptimal is \code{TRUE} if students apply to colleges. The
#' resulting match is student-optimal. \code{studentOptimal} is \code{FALSE}
#' if colleges apply to students. The resulting match is college-optimal.
#' @return A list with elements that specify which student is matched to which
#' college and who remains unmatched. Suppose there are \code{n} students and
#' \code{m} colleges with \code{s} slots. The list contains the following
#' items:
#' \itemize{
#' \item{\code{matched.students} is a vector of length \code{n} whose \code{i}th
#' element contains college that student \code{i} is
#' matched to. Students that remain unmatched will be listed as being
#' matched to college \code{NA}.}
#' \item{\code{matched.colleges} is a matrix of dimension \code{m} by
#' \code{s} whose \code{j}th row contains the students that were admitted to
#' college \code{j}. Slots that remain open show up as being matched to
#' student to \code{NA}.}
#' \item{\code{unmatched.students} is a vector that lists the remaining unmatched
#' students This vector will be empty when all students get matched.}
#' \item{\code{unmatched.colleges} is a vector that lists colleges with open
#' slots. If a college has multiple open slots, it will show up multiple
#' times. This vector will be empty whenever all college slots get filled.}
#' }
#' @examples
#' ncolleges <- 10
#' nstudents <- 25
#'
#' # randomly generate cardinal preferences of colleges and students
#' collegeUtils <- matrix(runif(ncolleges * nstudents), nrow = nstudents, ncol = ncolleges)
#' studentUtils <- matrix(runif(ncolleges * nstudents), nrow = ncolleges, ncol = nstudents)
#'
#' # run the student-optimal algorithm
#' results.studentoptimal <- galeShapley.collegeAdmissions(
#' studentUtils = studentUtils,
#' collegeUtils = collegeUtils,
#' slots = 2,
#' studentOptimal = TRUE
#' )
#' results.studentoptimal
#'
#' # run the college-optimal algorithm
#' results.collegeoptimal <- galeShapley.collegeAdmissions(
#' studentUtils = studentUtils,
#' collegeUtils = collegeUtils,
#' slots = 2,
#' studentOptimal = FALSE
#' )
#' results.collegeoptimal
#'
#' # transform the cardinal utilities into preference orders
#' collegePref <- sortIndex(collegeUtils)
#' studentPref <- sortIndex(studentUtils)
#'
#' # run the student-optimal algorithm
#' results.studentoptimal <- galeShapley.collegeAdmissions(
#' studentPref = studentPref,
#' collegePref = collegePref,
#' slots = 2,
#' studentOptimal = TRUE
#' )
#' results.studentoptimal
#'
#' # run the college-optimal algorithm
#' results.collegeoptimal <- galeShapley.collegeAdmissions(
#' studentPref = studentPref,
#' collegePref = collegePref,
#' slots = 2,
#' studentOptimal = FALSE
#' )
#' results.collegeoptimal
#' @export
galeShapley.collegeAdmissions <- function(studentUtils = NULL,
collegeUtils = NULL,
studentPref = NULL,
collegePref = NULL,
slots = 1,
studentOptimal = TRUE) {
if (length(slots) > 1) {
if (!is.null((collegePref)) & (length(slots) != NCOL(collegePref)) |
!is.null((collegeUtils)) & (length(slots) != NCOL(collegeUtils))) {
stop("slots must either be a scalar or have the same length as there are colleges.")
}
}
if (studentOptimal) {
# validate the inputs
args <- galeShapley.validate(studentUtils, collegeUtils, studentPref, collegePref)
# number of students
number_of_students <- NROW(args$reviewerUtils)
# number of colleges
number_of_colleges <- NCOL(args$reviewerUtils)
# expand slots
if (length(slots) == 1) {
slots <- rep(slots, number_of_colleges)
}
# expand cardinal utilities corresponding to the slot size
proposerUtils <- reprow(args$proposerUtils, slots)
reviewerUtils <- repcol(args$reviewerUtils, slots)
# create preference ordering
proposerPref <- sortIndex(as.matrix(proposerUtils))
# use galeShapleyMatching to compute matching
res <- cpp_wrapper_galeshapley(proposerPref, reviewerUtils)
# number of students
M <- length(res$proposals)
# number of positions
N <- length(res$engagements)
# collect results
res <- c(res, list(
"unmatched.students" = seq(from = 0, to = M - 1)[res$proposals == N] + 1,
"unmatched.colleges" = rep(NA, length = sum(res$engagements == M))
))
unmatched.colleges <- seq(from = 0, to = N - 1)[res$engagements == M] + 1
# assemble results
res$matched.colleges <- list()
# map engagements back into slots
cumsum.slotsLower <- cumsum(c(0, slots[-length(slots)])) + 1
cumsum.slotsUpper <- cumsum(slots)
for (jX in 1:number_of_colleges) {
# fill slots with student ids
res$matched.colleges[[jX]] <- res$engagements[cumsum.slotsLower[jX]:cumsum.slotsUpper[jX]] + 1
# set vacant slots to NA
res$matched.colleges[[jX]][res$matched.colleges[[jX]] == (number_of_students + 1)] <- NA
# unmatched colleges
res$unmatched.colleges[unmatched.colleges %in% (cumsum.slotsLower[jX]:cumsum.slotsUpper[jX])] <- jX
}
# remove unused information from res
res$engagements <- NULL
res$proposals <- NULL
} else {
# validate the inputs
args <- galeShapley.validate(collegeUtils, studentUtils, collegePref, studentPref)
# number of students
number_of_students <- NROW(args$proposerUtils)
# number of colleges
number_of_colleges <- NCOL(args$proposerUtils)
# expand slots
if (length(slots) == 1) {
slots <- rep(slots, number_of_colleges)
}
# expand cardinal utilities corresponding to the slot size
proposerUtils <- repcol(args$proposerUtils, slots)
reviewerUtils <- reprow(args$reviewerUtils, slots)
# create preference ordering
proposerPref <- sortIndex(as.matrix(proposerUtils))
# use galeShapleyMatching to compute matching
res <- cpp_wrapper_galeshapley(as.matrix(proposerPref), as.matrix(reviewerUtils))
# number of slots
M <- length(res$proposals)
# number of students
N <- length(res$engagements)
# collect results
res <- c(res, list(
"unmatched.colleges" = rep(NA, length = sum(res$proposals == N)),
"unmatched.students" = seq(from = 0, to = N - 1)[res$engagements == M] + 1
))
unmatched.colleges <- seq(from = 0, to = M - 1)[res$proposals == N] + 1
# assemble results
res$matched.colleges <- list()
# map proposals back into slots
cumsum.slotsLower <- cumsum(c(0, slots[-length(slots)])) + 1
cumsum.slotsUpper <- cumsum(slots)
for (jX in 1:number_of_colleges) {
# fill slots with student ids
res$matched.colleges[[jX]] <- res$proposals[cumsum.slotsLower[jX]:cumsum.slotsUpper[jX]] + 1
# set vacant slots to NA
res$matched.colleges[[jX]][res$matched.colleges[[jX]] == (number_of_students + 1)] <- NA
# unmatched colleges
res$unmatched.colleges[unmatched.colleges %in% (cumsum.slotsLower[jX]:cumsum.slotsUpper[jX])] <- jX
}
# remove unused information from res
res$engagements <- NULL
res$proposals <- NULL
}
# make a vector with matched students
res$matched.students <- matrix(NA, nrow = number_of_students, ncol = 1)
for (jX in 1:number_of_colleges) {
res$matched.students[res$matched.colleges[[jX]]] <- jX
}
# remove proposals (all relevant information is stored in res$matched.students)
res$engagements <- NULL
# if all colleges have the same number of slots return matched.colleges as matrix
# (otherwise it's a list)
if (all(slots == slots[1])) {
res$matched.colleges <- matrix(unlist(res$matched.colleges), nrow = number_of_colleges, ncol = slots[1], byrow = TRUE)
}
return(res)
}
#' Input validation of preferences
#'
#' This function parses and validates the arguments that are passed on to the
#' Gale-Shapley Algorithm. In particular, it checks if user-defined preference
#' orders are complete and returns an error otherwise. If user-defined orderings
#' are given in terms of R indices (starting at 1), then these are transformed
#' into C++ indices (starting at zero).
#'
#' @param proposerUtils is a matrix with cardinal utilities of the proposing
#' side of the market. If there are \code{n} proposers and \code{m} reviewers,
#' then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to the payoff that proposer \code{j} receives
#' from being matched to reviewer \code{i}.
#' @param reviewerUtils is a matrix with cardinal utilities of the courted side
#' of the market. If there are \code{n} proposers and \code{m} reviewers, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to the payoff that reviewer \code{j} receives from being
#' matched to proposer \code{i}.
#' @param proposerPref is a matrix with the preference order of the proposing
#' side of the market (only required when \code{proposerUtils} is not
#' provided). If there are \code{n} proposers and \code{m} reviewers in the
#' market, then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to proposer \code{j}'s \code{i}th most favorite
#' reviewer. Preference orders can either be specified using R-indexing
#' (starting at 1) or C++ indexing (starting at 0).
#' @param reviewerPref is a matrix with the preference order of the courted side
#' of the market (only required when \code{reviewerUtils} is not provided). If
#' there are \code{n} proposers and \code{m} reviewers in the market, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to reviewer \code{j}'s \code{i}th most favorite proposer.
#' Preference orders can either be specified using R-indexing (starting at 1)
#' or C++ indexing (starting at 0).
#' @return a list containing \code{proposerUtils}, \code{reviewerUtils},
#' \code{proposerPref} (\code{reviewerPref} are not required after they are
#' translated into \code{reviewerUtils}).
#' @examples
#' # market size
#' nmen <- 5
#' nwomen <- 4
#'
#' # generate cardinal utilities
#' uM <- matrix(runif(nmen * nwomen), nrow = nwomen, ncol = nmen)
#' uW <- matrix(runif(nwomen * nmen), nrow = nmen, ncol = nwomen)
#'
#' # turn cardinal utilities into ordinal preferences
#' prefM <- sortIndex(uM)
#' prefW <- sortIndex(uW)
#'
#' # validate cardinal preferences
#' preferences <- galeShapley.validate(uM, uW)
#' preferences
#'
#' # validate ordinal preferences
#' preferences <- galeShapley.validate(proposerPref = prefM, reviewerPref = prefW)
#' preferences
#'
#' # validate ordinal preferences when these are in R style indexing
#' # (instead of C++ style indexing)
#' preferences <- galeShapley.validate(proposerPref = prefM + 1, reviewerPref = prefW + 1)
#' preferences
#'
#' # validate preferences when proposer-side is cardinal and reviewer-side is ordinal
#' preferences <- galeShapley.validate(proposerUtils = uM, reviewerPref = prefW)
#' preferences
#' @export
galeShapley.validate <- function(proposerUtils = NULL, reviewerUtils = NULL, proposerPref = NULL, reviewerPref = NULL) {
if (!is.null(reviewerPref)) {
reviewerPref <- galeShapley.checkPreferences(reviewerPref)
if (is.null(reviewerPref)) {
stop(
"reviewerPref was defined by the user but is not a complete list of preference orderings."
)
}
}
if (!is.null(proposerPref)) {
proposerPref <- galeShapley.checkPreferences(proposerPref)
if (is.null(proposerPref)) {
stop("proposerPref was defined by the user but is not a complete list of preference orderings.")
}
}
# parse inputs
if (is.null(proposerPref) && !is.null(proposerUtils)) {
proposerPref <- sortIndex(as.matrix(proposerUtils))
}
if (is.null(proposerUtils) && !is.null(proposerPref)) {
proposerUtils <- -rankIndex(as.matrix(proposerPref))
}
if (is.null(reviewerUtils) && !is.null(reviewerPref)) {
reviewerUtils <- -rankIndex(as.matrix(reviewerPref))
}
if (is.null(proposerPref)) {
stop("missing proposer preferences")
}
if (is.null(reviewerUtils)) {
stop("missing reviewer utilities")
}
# check inputs
if (NROW(proposerPref) != NCOL(reviewerUtils)) {
stop(
"The number of rows in the matrix of proposers' ",
"preferences must equal the number of columns in ",
"the matrix of reviewers' preferences"
)
}
if (NCOL(proposerPref) != NROW(reviewerUtils)) {
stop(
"The number of columns in the matrix of proposers' ",
"preferences must equal the number of rows in the ",
"matrix of reviewers' preferences"
)
}
return(
list(
proposerPref = as.matrix(proposerPref),
proposerUtils = as.matrix(proposerUtils),
reviewerUtils = as.matrix(reviewerUtils)
)
)
}
#' Check if a two-sided matching is stable
#'
#' This function checks if a given matching is stable for a particular set of
#' preferences. This stability check can be applied to both the stable marriage
#' problem and the college admission problem. The function requires preferences
#' to be specified in cardinal form. If necessary, the function
#' \code{\link{rankIndex}} can be used to turn ordinal preferences into cardinal
#' utilities.
#'
#' @param proposerUtils is a matrix with cardinal utilities of the proposing
#' side of the market. If there are \code{n} proposers and \code{m} reviewers,
#' then this matrix will be of dimension \code{m} by \code{n}. The
#' \code{i,j}th element refers to the payoff that proposer \code{j} receives
#' from being matched to reviewer \code{i}.
#' @param reviewerUtils is a matrix with cardinal utilities of the courted side
#' of the market. If there are \code{n} proposers and \code{m} reviewers, then
#' this matrix will be of dimension \code{n} by \code{m}. The \code{i,j}th
#' element refers to the payoff that reviewer \code{j} receives from being
#' matched to proposer \code{i}.
#' @param proposals is a matrix that contains the number of the reviewer that a
#' given proposer is matched to: the first row contains the reviewer that is
#' matched to the first proposer, the second row contains the reviewer that is
#' matched to the second proposer, etc. The column dimension accommodates
#' proposers with multiple slots.
#' @param engagements is a matrix that contains the number of the proposer that
#' a given reviewer is matched to. The column dimension accommodates reviewers
#' with multiple slots.
#' @return true if the matching is stable, false otherwise
#' @examples
#' # define cardinal utilities
#' uM <- matrix(c(
#' 0.52, 0.85,
#' 0.96, 0.63,
#' 0.82, 0.08,
#' 0.55, 0.34
#' ), nrow = 4, byrow = TRUE)
#' uW <- matrix(c(
#' 0.76, 0.88, 0.74, 0.02,
#' 0.32, 0.21, 0.02, 0.79
#' ), ncol = 4, byrow = TRUE)
#' # define matching
#' results <- list(
#' proposals = matrix(c(2, 1), ncol = 1),
#' engagements = matrix(c(2, 1, NA, NA), ncol = 1)
#' )
#' # check stability
#' galeShapley.checkStability(uM, uW, results$proposals, results$engagements)
#'
#' # if preferences are in ordinal form, we can use galeShapley.validate
#' # to transform them into cardinal form and then use checkStability()
#' prefM <- matrix(c(
#' 2, 1,
#' 3, 2,
#' 4, 4,
#' 1, 3
#' ), nrow = 4, byrow = TRUE)
#' prefW <- matrix(c(
#' 1, 1, 1, 2,
#' 2, 2, 2, 1
#' ), ncol = 4, byrow = TRUE)
#' # define matching
#' results <- list(
#' proposals = matrix(c(2, 1), ncol = 1),
#' engagements = matrix(c(2, 1, NA, NA), ncol = 1)
#' )
#' # check stability
#' pref.validated <- galeShapley.validate(
#' proposerPref = prefM,
#' reviewerPref = prefW
#' )
#' galeShapley.checkStability(
#' pref.validated$proposerUtils,
#' pref.validated$reviewerUtils,
#' results$proposals,
#' results$engagements
#' )
#' @export
galeShapley.checkStability <- function(proposerUtils, reviewerUtils, proposals, engagements) {
if (is.list(proposals) | is.list(engagements)) {
stop("Proposals and engagements must be vectors/matrices.")
}
# replace NA for unmatched proposers (they are now matched to the number of reviewers + 1)
proposals[is.na(proposals)] <- NROW(proposerUtils) + 1
# replace NA for unmatched reviewers (they are now matched to the number of proposers + 1)
engagements[is.na(engagements)] <- NROW(reviewerUtils) + 1
# turn proposals and engagements into C++ style indexing
proposals <- proposals - 1
engagements <- engagements - 1
# call the C++ wrapper
cpp_wrapper_galeshapley_check_stability(proposerUtils, reviewerUtils, proposals, engagements)
}
#' Check if preference order is complete
#'
#' This function checks if a given preference ordering is complete. If needed,
#' it transforms the indices from R indices (starting at 1) to C++ indices
#' (starting at zero).
#'
#' @param pref is a matrix with ordinal preference orderings for one side of the
#' market. Suppose that \code{pref} refers to the preferences of \code{n}
#' women over \code{m} men. In that case, \code{pref} will be of dimension
#' \code{m} by \code{n}. The \code{i,j}th element refers to woman \code{j}'s
#' \code{i}th most favorite man. Preference orders can either be specified
#' using R-indexing (starting at 1) or C++ indexing (starting at 0).
#' @return a matrix with ordinal preference orderings with proper C++ indices or
#' NULL if the preference order is not complete.
#' @examples
#' # preferences in proper C++ indexing: galeShapley.checkPreferences(pref)
#' # will return pref
#' pref <- matrix(c(
#' 0, 1, 0,
#' 1, 0, 1
#' ), nrow = 2, ncol = 3, byrow = TRUE)
#' pref
#' galeShapley.checkPreferences(pref)
#'
#' # preferences in R indexing: galeShapley.checkPreferences(pref)
#' # will return pref-1
#' pref <- matrix(c(
#' 1, 2, 1,
#' 2, 1, 2
#' ), nrow = 2, ncol = 3, byrow = TRUE)
#' pref
#' galeShapley.checkPreferences(pref)
#'
#' # incomplete preferences: galeShapley.checkPreferences(pref)
#' # will return NULL
#' pref <- matrix(c(
#' 3, 2, 1,
#' 2, 1, 2
#' ), nrow = 2, ncol = 3, byrow = TRUE)
#' pref
#' galeShapley.checkPreferences(pref)
#' @export
galeShapley.checkPreferences <- function(pref) {
# check if pref is using R instead of C++ indexing
if (all(apply(pref, 2, sort) == array(1:(NROW(pref)), dim = dim(pref)))) {
return(pref - 1)
}
# check if pref has a complete listing otherwise given an error
if (all(apply(pref, 2, sort) == (array(1:(NROW(pref)), dim = dim(pref))) - 1)) {
return(pref)
}
return(NULL)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.