Why are you doing this? There are enough secret santa services
Last Christmas my wife was left giftless on my side of the family due to a faulty secret santa generator. In trying to earn brownie points the arrogant nerd in me thought he could do better, so I decided to program one in R (I’d rather know exactly what’s going on in the background anyways). I also found it hard this year to find a service that prevented specific pairs of people from gifting each other.
But beyond my petty personal reasons, a friend suggested that this would be a good opportunity to learn how to build Shiny apps. So I’ll use this post to explain the basics of the code, and how you can turn it into a Shiny app (disclaimer: this being my first Shiny app means that the setup is crude, so I definitely recommend checking out the great official examples that Shiny provides).
Update 11/30/18: of course I found this blog post the day after I posted mine, which shows that the script and idea had been mostly done before by a combination of coders. Even some of the language that I have here ended up being too similar to what David writes, unfortunately. Even more, Tristan Mahr already solved the problem of pair constraints through a graph implementation that, while too busy for my taste and to implement in Shiny, made for a pretty cool post. Still, I’ll keep this up since there are some novel elements to the way I went about it (that I know of, at least), and I couldn’t find another Shiny app that did the trick.
So, how does it work?
The setup is simple. Let’s look at the function:
xmaspairs <- function(Members = 1, Spouses = 1, Secret = T) {
# Make sure that members were provided..
if (length(Members) == 1) {stop("No members indicated...")}
# If spouse pairing should be avoided..
if (length(Spouses) == length(Members)) {
# Make sure that a single group isn't more than 50% of the members
if(max(table(input$Spouses)) > length(input$Members)/2) {stop("A group can't be more than 50% of the total members...")}
# Iterate over possible pairings until no SOs are paired
Affiliated <- T
while (Affiliated) {
m <- sample(Members)
df <- data.frame(Member = m,
Gift_to = c(tail(m, n = 1), m[seq(length(m)-1)])) # sure there's a better way to do this..
Spouse1 <- Spouses[match(df$Member, Members)]
Spouse2 <- Spouses[match(df$Gift_to, Members)]
Affiliated <- T %in% (Spouse1 == Spouse2)
}
# Otherwise just produce whatever pairing comes out from a single sampling
} else {
m <- sample(Members)
df <- data.frame(Member = m,
Pair = c(tail(m, n = 1), m[seq(length(m)-1)]))
}
# If the person running it should be blinded to the pairs, create individual txt files
if (Secret) {
for (i in seq(nrow(df))) {
write.table(paste("Your secret santa is: ", df[i, 2], "!", sep = ""),
file = paste(df[i,1],".txt", sep = ""),
row.names = F,
col.names = F)
}
# or for groups who don't care about social subtleties
} else {
return(df)
}
}Basically, the function takes in a mandatory character vector of members, an optional grouping vector (either numeric of string), and the choice of whether to hide the final pairings from everyone. The way it works is simple: shuffle the members, then create a new vector with everyone shifted by 1 position (this is the equivalent of randomly sitting people in a circle and telling them to gift the person to their right).
Now, if you wanted to prevent 2 members from gifting each other, all you do is feed a grouping vector into Spouses. So, let’s say you have Mom, Dad, Cindy, you, and Dormamu the Destroyer on your members list, and of course you don’t want your parents gifting each other. Then all you have to do is create a vector like c(Parent, Parent, 1, 2, Immortal) to feed to the function. This will force the function to iterate through combinations of gifters/receivers until the pairs don’t share the same grouping characteristic. Note that since I use an equivalence, pretty much anything can be used as a grouping variable. If you don’t care about this, just write NA or anything that doesn’t match the length of the members list.
Finally, if you select Secret = T the function won’t generate a dataframe. Instead, it will download a text file for each member on your current directory, indicating to whom they should gift. I know it would be easier to email people rather than having to send them their text files manually, but I was a bit lazy and didn’t want to deal with SMTP setups.
Shiny implementation
It might be helfpul to get acquainted with how everything looks before digging into the code. You can go ahead and play with the app if you’d like, or check it out online.
Alright then, how is it made?
The core of a Shiny app is way simpler than I expected. You have three components: a ui to dictate the arrangement of elements, a server to produce its contents, and a simple shinyApp function that brings these two together.
This is what the ui portion looks like:
# ui <- fluidPage(
#
# titlePanel("Secret Santa GeneratR"),
#
# p("Welcome to yet another secret santa generator! The advantage of this one is that it gives you the option to keep the pairings secret or not, as well as avoiding pairs of people who should not gift each other! Perfect if you have inter-dimensional friends that can't physically interact with each other."),
#
# #Sidebar layout with input and output definitions ----
# sidebarLayout(
#
# # Sidebar panel for inputs ----
# sidebarPanel(
#
# # Input: Text for providing a caption ----
# textInput(inputId = "Members",
# label = "Group member names:",
# value = "A, B, C, D, E, F"),
#
# # Explanation of spouse matching
# p("If you want to prevent specific pairs of people from gifting each other, write down some characteristic that pairs them below (in the order they're written above). In the example below, A/B and C/D are part of 'Couple' and 'Couple2', respectively, and won't gift within couples; but E and F have their own group and can give/receive with anyone (note that the number of entries must match the number of members). Write 'NA' if you don't care about this."),
#
# # Set pairs to avoid
# textInput(inputId = "Spouses",
# label = "Avoidance list:",
# value = "Couple, Couple, Couple2, Couple2, S1, S2"),
#
# # Apply changes
# submitButton("Update List"),
#
# # Empty space
# p(),
#
# # Note on making it secret
# p("If you want to keep it secret, a file for each member will be created telling them who they should gift based on a new, unseen pairing. Just send each person their file!"),
#
# # and the respective download button for the zip file
# downloadButton("download", "Make Secret")
#
# ),
#
# # Main panel for displaying outputs ----
# mainPanel(
#
# p("Here are the current santa pairs. Note that if you click on 'Make Secret' a completely new scheme will be produced that you won't see here."),
#
# # Output: HTML table with requested number of observations ----
# tableOutput("view")
#
# )
# )
# )All we are doing here is defining what goes up top (titlePanel and the first paragraph p), which user inputs to place in the sidebar (sidebarPanel within sidebarLayout), and what goes on the main area of the site (mainPanel within sidebarLayout). Things to note here: functions like textInput ask the user for input, and you give them IDs so you can call the values in the server portion (see next). Here I place default values just to give the user an example. On the other hand, tableOutput and downloadButton seem to be getting input from somewhere (here “view” and “download”). These are output variables generated by the server! So all that’s happening is that the ui passes on inputs that are then processed and returned by the server to be placed on the GUI. That’s it.
One last thing about ui and Shiny in general: these widgets are reactive, meaning that they will update the output whenever any changes are made. This can be problematic, so we add a submitButton called ‘Update List’ to apply the changes the user makes.
Next, what does the server look like?
# server <- function(input, output){
#
#
# # Function that does the pairings
# xmaspairs <- function(Members = 1, Spouses = 1, Secret = T) {
#
# # This crude function will pair group members for secret santa
# # If your family would like to avoid pairing significant others,
# # define Spouses to be a vector of groupings (i.e. numeric).
# # The script will then iterate over pairings until no SOs are paired.
#
# # Perform the actual pairing
# # If spouse pairing should be avoided..
# if (length(Spouses) == length(Members)) {
# # Once this turns false, we are in business
# Affiliated <- T
# # Iterate over possible pairings until no SOs are paired
# while (Affiliated) {
# m <- sample(Members)
# df <- data.frame(Member = m,
# Gift_to = c(tail(m, n = 1), m[seq(length(m)-1)])) # sure there's a better way to do this..
# Spouse1 <- Spouses[match(df$Member, Members)]
# Spouse2 <- Spouses[match(df$Gift_to, Members)]
# Affiliated <- T %in% (Spouse1 == Spouse2)
# }
# # Otherwise just produce whatever pairing comes out from a single sampling
# } else {
# m <- sample(Members)
# df <- data.frame(Member = m,
# Gift_to = c(tail(m, n = 1), m[seq(length(m)-1)]))
# }
#
# # spit out the pairs
# return(df)
#
# }
#
#
# # Download a zip file with each pair
# output$download <- downloadHandler(
#
# # Name of the download
# filename = function() {"SecretSantaPairs.zip"},
#
# # Prep the zip file
# content = function(file) {
# # Parse the strings
# m <- unlist(strsplit(gsub(" ", "", input$Members, fixed=T), ","))
# s <- unlist(strsplit(gsub(" ", "", input$Spouses, fixed=T), ","))
# # Make sure the groupings don't break the code by having a group be over 50% of members
# validate(need(try(max(table(s)) < length(m)/2), "A group can't have more than 50% of the members"))
# #Pairing
# df <- xmaspairs(Members = m,
# Spouses = s)
# # Write files per person indicating to whom they have to gift
# owd <- setwd(tempdir()) # temporary dir to store the files
# on.exit(setwd(owd))
# files <- list()
# lapply(seq(nrow(df)), function(i) {
# write.table(paste("Your secret santa is: ", df[i, 2], "!", sep = ""),
# file = paste(df[i,1],".txt", sep = ""),
# row.names = F,
# col.names = F)})
# zip(file, paste(unlist(strsplit(gsub(" ", "", input$Members, fixed=T), ",")), ".txt", sep = "")) # and zip
# }
#
# )
#
#
# # render the resulting table
# output$view <- renderTable({
#
# # Parse the strings
# m <- unlist(strsplit(gsub(" ", "", input$Members, fixed=T), ","))
# s <- unlist(strsplit(gsub(" ", "", input$Spouses, fixed=T), ","))
# # Make sure that enough members are entered
# validate(need(length(m) > 1, "Not enough members!"))
# # Make sure the groupings don't break the code by having a group be over 50% of members
# validate(need(try(max(table(s)) <= length(m)/2), "A group can't have more than 50% of the members"))
# # Produce pairings to display
# xmaspairs(Members = m,
# Spouses = s,
# Secret = input$Secret)
#
# })
# }You probably already saw that the server function works with input and output, as we just discussed. The next thing you’ll see is a shortened version of the xmaspairs function, but without the ability to download files. Why is that? Well, Shiny comes with a handy widget to download files, and this saves us the pain of asking the user to write down a local path that the app might not have access to. The way this works is that you’ll store what to return to the ui in an outputs list. First we define outputs$download (this is the “download” that gets passed onto downloadButton in the ui above). This widget requires you to define the filename (“SecretSantaPairs.zip”) and the content. Within content you can write whatever code will generate the information that you want the user to download. All I did here was to run the file-writing part of my original function separately from creating the pairs, storing the files on a temporary directory, and compressing them into a single zip file that will be downloaded (this is because downloadButton can only handle one file at a time). Note that xmaspairs takes in the ui values contained within the inputs list (with the IDs that we defined above as the variable names). This is a cleaner way to cue the user to produce a secret listing.
At the end of server you’ll find renderTable being stored within output$view (yes, the “view” that’s used in the ui). This will show a table with the pairings according to the conditions specified. This will always appear (even if we click the download button), but note that since pressing the button generates an independent list, the user is still technically blinded from knowing who got who. Also worth noting is that I used validate(need()) to send out an error message to the user if either not enough members were entered, or if too many members were grouped together. If you use R’s classic stop, Shiny will throw an ugly crashing error once published.
Ok, now that we set up our interacting server and ui we can put them together. All you need to do is run
# library(shiny)
# shinyApp(ui = ui, server = server) This will open a new window with your app! (normally you put all these elements within the same file: app.R) This will also give you the option to publish you app to shinyapps.io by clicking ‘publish’ on your pop-up window. Of course this requires registering for an account there, but otherwise Shiny makes it seemless to upload your app so you can share it with everyone!
Closing
There are enough great tutorials on how to build Shiny apps, but I hope this will be useful for someone. If anything, there is one thing I would like whoever reads this to know: You don’t need an extravagant project to try something new. If you would like to play with the code, it’s available on my GitHub site.