Draw names for a Secret Santa gift exchange

secret_santa.R

# James Keirstead
# 20 November 2016

library(TSP)

#' Draw names for a Secret Santa gift exchange
#' 
#' In a 'Secret Santa' gift exchange, a group of people are randomly divided 
#' into pairs.  These pairs could be drawn in many different ways, depending on 
#' whether the pairs are reciprocal and whether all pairs combinations are 
#' valid.
#' 
#' This code draws names for a simple version of the Secret Santa problem.  It 
#' uses the Travelling Salesman problem so that gift pairs are not reciprocal 
#' (if Mary draws John, then John can't draw Mary) and optionally named couples 
#' can be excluded from the set of valid solutions.
#' 
#' @param people a character vector giving the names of all people in the draw
#' @param couples (optional) a list giving pairs of names that can't be chosen.
#' @return a matrix giving the Secret Santa pairs in each row
secret_santa <- function(people, couples = NULL) {
  
  n <- length(people)
  
  # Calculate random distances for off-diagonal
  vals <- runif(n * (n - 1) / 2)
  
  # Create a symmetric matrix
  m <- matrix(rep(0, n ^ 2), ncol = n)
  m[lower.tri(m)] <- vals
  m[upper.tri(m)] <- t(m)[upper.tri(m)]
  
  # People can't choose themselves
  big_M <- 1000
  diag(m) <- big_M
  
  # Exclude couples
  if (!is.null(couples)) {
    sapply(couples, function(pair) {
      a <- which(people == pair[1])
      b <- which(people == pair[2])
      m[a, b] <<- big_M
      m[b, a] <<- big_M
    })
  }
  
  # Solve the tour
  t <- TSP(m, labels = people)
  tour <- solve_TSP(t)
  
  if (tour_length(tour) > big_M) {
    stop("Unable to pick valid combinations.")
  }
  
  x <- people[tour]
  result <- cbind(x[-length(x)], x[-1])
  result <- rbind(result, c(x[length(x)], x[1]))
  colnames(result) <- c("from", "to")
  return(result)
}

# An example
all_people <- c("John", "Mary", "Fred", "Sue")
couples <- list(c("John", "Sue"), c("Fred", "Mary"))

gift_list <- secret_santa(all_people, couples)
print(gift_list)