Creating a Shiny App for Fantasy Football Draft Optimization - r

Question

I've written some R code to produce the optimal fantasy football lineup (maximize projected points scored) constrained on user inputted roster sizes and draft budget based on a data frame called "players" that consists of player, position, fantasy points, and draft value.
The idea is to use this tool prior to drafting (to have the ideal lineup in mind) and then to update it live while drafting since this never goes to plan.
From there, I want to be able to remove players from the players dataset (when they're drafted by others) and add players to my lineup as I draft them (so they appear in every future optimal lineup). I have added the functionality and th remove player button seems to work fairly well (for some reason the lineup vanishes when you input a new player each time, but then re-appears properly once a new player is removed) but it definitely doesn't seem to draft a player to the team properly. I'm definitely thinking it has something to do with the last snippet of code before running the app, but I'm having trouble thinking through the logic there.
The dataframe is:
players <- structure(list(Player = c("Josh Allen", "Patrick Mahomes", "Justin Herbert",
"Lamar Jackson", "Kyler Murray", "Jalen Hurts", "Tom Brady",
"Dak Prescott", "Joe Burrow", "Russell Wilson", "Aaron Rodgers",
"Trey Lance", "Matthew Stafford", "Kirk Cousins", "Derek Carr",
"Tua Tagovailoa", "Justin Fields", "Trevor Lawrence", "Ryan Tannehill",
"Daniel Jones", "Matt Ryan", "Jameis Winston", "Carson Wentz",
"Mac Jones", "Jared Goff", "Zach Wilson", "Davis Mills", "Baker Mayfield",
"Marcus Mariota", "Deshaun Watson", "Mitchell Trubisky", "Geno Smith",
"Drew Lock", "Kenny Pickett", "Jacoby Brissett", "Desmond Ridder",
"Travis Kelce", "Mark Andrews", "Kyle Pitts", "Darren Waller",
"George Kittle", "Dalton Schultz", "T.J. Hockenson", "Dallas Goedert",
"Zach Ertz", "Dawson Knox", "Hunter Henry", "Mike Gesicki", "Pat Freiermuth",
"Cole Kmet", "Irv Smith Jr.", "Noah Fant", "Tyler Higbee", "David Njoku",
"Albert Okwuegbunam", "Gerald Everett", "Robert Tonyan", "Jonathan Taylor",
"Christian McCaffrey", "Derrick Henry", "Austin Ekeler", "Dalvin Cook",
"Joe Mixon", "Najee Harris", "Alvin Kamara", "D'Andre Swift",
"Leonard Fournette", "Saquon Barkley", "Aaron Jones", "Nick Chubb",
"James Conner", "Javonte Williams", "Ezekiel Elliott", "David Montgomery",
"Cam Akers", "Travis Etienne Jr.", "Breece Hall", "J.K. Dobbins",
"Josh Jacobs", "Antonio Gibson", "Elijah Mitchell", "AJ Dillon",
"Cordarrelle Patterson", "Damien Harris", "Miles Sanders", "Clyde Edwards-Helaire",
"Tony Pollard", "Devin Singletary", "Kareem Hunt", "Chase Edmonds",
"Rashaad Penny", "Rhamondre Stevenson", "Kenneth Walker III",
"Melvin Gordon III", "Darrell Henderson Jr.", "James Robinson",
"James Cook", "Dameon Pierce", "Michael Carter", "Jamaal Williams",
"Nyheim Hines", "J.D. McKissic", "Kenneth Gainwell", "Alexander Mattison",
"Isaiah Spiller", "Raheem Mostert", "Mark Ingram II", "Marlon Mack",
"Brian Robinson", "Gus Edwards", "Rex Burkhead", "Rachaad White",
"Khalil Herbert", "Damien Williams", "Tyler Allgeier", "D'Onta Foreman",
"Jerick McKinnon", "Cooper Kupp", "Justin Jefferson", "Ja'Marr Chase",
"Davante Adams", "Stefon Diggs", "Deebo Samuel", "CeeDee Lamb",
"Mike Evans", "Tyreek Hill", "Tee Higgins", "Keenan Allen", "DJ Moore",
"A.J. Brown", "Michael Pittman Jr.", "Mike Williams", "Brandin Cooks",
"Jaylen Waddle", "Diontae Johnson", "Terry McLaurin", "DK Metcalf",
"Courtland Sutton", "Amon-Ra St. Brown", "Darnell Mooney", "Allen Robinson II",
"Marquise Brown", "Amari Cooper", "Gabriel Davis", "Chris Godwin",
"Michael Thomas", "Jerry Jeudy", "Adam Thielen", "JuJu Smith-Schuster",
"Hunter Renfrow", "Rashod Bateman", "Elijah Moore", "Tyler Lockett",
"Christian Kirk", "Robert Woods", "DeVonta Smith", "Drake London",
"Allen Lazard", "Brandon Aiyuk", "Chase Claypool", "Kadarius Toney",
"Tyler Boyd", "Garrett Wilson", "DeVante Parker", "Chris Olave",
"Kenny Golladay", "Jakobi Meyers", "Russell Gage", "Marquez Valdes-Scantling",
"DeAndre Hopkins", "Marvin Jones Jr.", "Treylon Burks", "Michael Gallup",
"Robbie Anderson", "DJ Chark", "Jahan Dotson", "Mecole Hardman"
), Position = c("QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB",
"QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB",
"QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB", "QB",
"QB", "QB", "QB", "QB", "QB", "QB", "TE", "TE", "TE", "TE", "TE",
"TE", "TE", "TE", "TE", "TE", "TE", "TE", "TE", "TE", "TE", "TE",
"TE", "TE", "TE", "TE", "TE", "RB", "RB", "RB", "RB", "RB", "RB",
"RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB",
"RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB",
"RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB",
"RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB",
"RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "RB", "WR",
"WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR",
"WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR",
"WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR",
"WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR",
"WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR", "WR",
"WR", "WR", "WR", "WR"), FantasyPoints = c(445, 410, 407, 348,
351, 359, 354, 364, 402, 368, 353, 347, 349, 335, 366, 325, 297,
313, 273, 283, 302, 284, 275, 296, 291, 0, 247, 286, 276, 0,
0, 0, 0, 269, 0, 0, 252, 231, 206, 171, 185, 177, 174, 169, 169,
171, 139, 131, 170, 170, 162, 129, 162, 119, 130, 126, 130, 340,
285, 260, 278, 277, 271, 277, 247, 271, 225, 247, 249, 230, 196,
268, 205, 199, 213, 231, 220, 177, 176, 159, 178, 185, 155, 181,
157, 190, 177, 164, 156, 166, 169, 179, 158, 129, 147, 99, 158,
176, 150, 100, 157, 128, 156, 124, 98, 95, 75, 90, 136, 80, 82,
143, 128, 0, 147, 97, 63, 326, 337, 308, 299, 269, 267, 271,
242, 243, 241, 239, 243, 242, 244, 209, 220, 233, 239, 221, 198,
221, 209, 220, 209, 218, 178, 224, 183, 186, 203, 188, 164, 207,
211, 202, 173, 188, 163, 199, 171, 181, 182, 140, 170, 175, 144,
142, 164, 147, 131, 170, 160, 182, 136, 153, 157, 152, 148, 175,
144), DraftValue = c(31, 23, 20, 15, 16, 14, 16, 11, 12, 10,
10, 3, 7, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 37, 34, 22, 20, 17, 16, 12, 11, 9, 6, 4, 4,
5, 5, 2, 2, 2, 1, 1, 1, 1, 56, 55, 44, 48, 38, 38, 40, 38, 36,
34, 34, 33, 27, 30, 28, 27, 23, 21, 23, 21, 19, 18, 10, 15, 16,
16, 12, 12, 14, 13, 10, 11, 12, 8, 9, 1, 6, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 56, 48, 41,
40, 37, 31, 34, 29, 30, 28, 28, 26, 24, 26, 23, 23, 22, 21, 20,
18, 19, 20, 17, 18, 17, 15, 15, 17, 17, 16, 16, 15, 15, 13, 12,
12, 12, 11, 9, 9, 9, 7, 5, 6, 4, 2, 2, 2, 1, 3, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA,
-177L))
and the code is below:
library(shiny)
library(lpSolve)
library(rsconnect)
# Define the UI for the app
ui <- fluidPage(
titlePanel("Fantasy Football Lineup Optimizer"),
sidebarLayout(
sidebarPanel(
numericInput("num_qb", "Enter the number of QBs:", 1, min = 1, max = 5),
numericInput("num_rb", "Enter the number of RBs:", 2, min = 1, max = 5),
numericInput("num_wr", "Enter the number of WRs:", 3, min = 1, max = 5),
numericInput("num_te", "Enter the number of TEs:", 1, min = 1, max = 5),
numericInput("num_value", "Enter your draft budget:", 200),
numericInput("num_players", "Adding in your flex spots, enter the total number of starters:", 9, min = 1, max = 15),
selectInput("remove", "Remove a player:", choices = c("",as.character(players$Player)), multiple = TRUE),
actionButton("update", "Update Team"),
selectInput("draft", "Draft Player", choices = c("",as.character(players$Player)), multiple = TRUE),
actionButton("draft_button", "Draft")
),
mainPanel(
tableOutput("team")
)
)
)
# Define the server logic
server <- function(input, output) {
players <- players
# Create a new column indicating the player's position
players$QB <- ifelse(players$Position == "QB", 1, 0)
players$RB <- ifelse(players$Position == "RB", 1, 0)
players$WR <- ifelse(players$Position == "WR", 1, 0)
players$TE <- ifelse(players$Position == "TE", 1, 0)
players$Total <- 1
rv <- reactiveValues(players=players)
# Define the objective function (maximize fantasy points)
obj <- players$FantasyPoints
# Define the constraints (position limits and draft value limit)
con <- reactive({
matrix(c(
# QB constraint
rv$players$QB,
# RB constraint
rv$players$RB,
# WR constraint
rv$players$WR,
# TE constraint
rv$players$TE,
# Draft value constraint
rv$players$DraftValue,
#Total players constraint
rv$players$Total
), ncol = nrow(rv$players), byrow = TRUE)
})
# Define the variables for the lp
dir <- c("<=", rep(">=",3),"<=","<=")
# Define the initial optimal lineup
initialLineup <- reactive({
rhs <- reactive({
c(input$num_qb, input$num_rb, input$num_wr, input$num_te, input$num_value, input$num_players)
})
result <- lp("max", obj, con(), dir, rhs(), all.bin = TRUE)
rv$players[result$solution == 1,]
})
# Show the updated optimal team in a table for any constraint change
output$team <- renderTable({
lineupResult()[, c("Player", "Position", "DraftValue", "FantasyPoints")]
})
# Define the function to run when the "update" button is pressed
updateLineup <- eventReactive(input$update, {
removedPlayer <- input$remove
rv$players <- rv$players[rv$players$Player != removedPlayer,]
obj <- rv$players$FantasyPoints
rhs <- reactive({
c(input$num_qb, input$num_rb, input$num_wr, input$num_te, input$num_value, input$num_players)
})
result <- lp("max", obj, con(), dir, rhs(), all.bin = TRUE)
rv$players[result$solution == 1,]
})
# Define the function to run when the "draft player" button is pressed
draftPlayer <- eventReactive(input$draft, {
draftedPlayer <- input$draft_player
draftedPlayers <- rv$players[rv$players$Player == draftedPlayer,]
rv$players <- rv$players[rv$players$Player != draftedPlayer,]
rv$draftedPlayers <- rbind(rv$draftedPlayers, draftedPlayers)
rhs <- reactive({
c(input$num_qb, input$num_rb, input$num_wr, input$num_te, input$num_value, input$num_players)
})
result <- lp("max", obj, con(), dir, rhs(), all.bin = TRUE)
rv$players[result$solution == 1,]
rv$players <- rbind(rv$players, rv$draftedPlayers)
})
# Show the updated optimal team in a table when the "update" button is pressed
output$team <- renderTable({
if (is.null(input$draft_player)) {
if (is.null(input$remove)) {
initialLineup()[, c("Player", "Position", "FantasyPoints", "DraftValue")]
} else {
updateLineup()[, c("Player", "Position", "FantasyPoints", "DraftValue")]
}
} else {
draftPlayer()[, c("Player", "Position", "FantasyPoints", "DraftValue")]
}
})
}
# Run the app
shinyApp(ui, server)

Answer 1

I gave this one a shot. I modified your code quite a bit to reduce some of the complexity to it but first I'll point out a few issues I saw before I rewrote portions of it.
The reason why your lineup vanishes and then re-appears at times is due to how you link up your renderTable to your inputs and eventReactives.
output$team has dependencies on input$draft_player and input$remove. First off I don't see input$draft_player in your UI so I assume this is meant to be input$draft_button. With that said, when removing a player, the renderTable function invalidates first when you enter a player into the select input. But updateLineup() is dependent on input$update so it doesn't return anything until you click "Update Team". Thus causing the delay.
In your draftPlayer expression you haven't set obj to be the new value of rv$players$FantasyPoints so instead lp() takes the value of obj in the parent environment which has the full set of players and thus err's out.
One additional thing I noticed is in both functions you return rv$players[result$solution == 1,]. Personally, I think the problem with this is you'll always output the most optimized full lineup regardless of your own draft selections. Intuitively, I would think you'd want to return the best lineup not including the positions you've already drafted. So if a QB and 2 WR's have been drafted. Then you'd return a lineup with only 6 players since 3 have already been drafted.
Below, I've written some code that takes that last piece into account as well as reduce the number of output functions. This is just what made sense to me and maybe I'm off base here, but hopefully it's along the same lines of what you're trying to accomplish!
Let me know if you have any questions.
The goal with the code below, is to include your draft picks alongside the optimized selection. When a player is drafted, we need to do a few things.
remove the player from the pool
update const.rhs with new constraints
subtract the position requirement by 1
subtract the overall number of players by 1
subtract the draft budget by the players draftValue
When a player is removed they are simply 'removed' from the player pool and lp will run without that player.
With the new constraints in place, lp will return a new lineup with the number of available players and positions that have yet to be drafted using a modified draft budget. After a player has been drafted or removed, they will be removed from the select inputs so you can't accidentally choose them in the future.
Restrictions
In my version I have a few constraints to be aware of. For simplicity sake, you can only remove or draft one player at a time. Due to how const.rhs is calculated, the sum of the position inputs MUST match the total number of starters. I know that could be an issue as after the 5 or 6th round, I'll debate on whether to pick up an RB or WR depending on who's available. Also I would advise not changing any input above remove player once the draft has started since that will likely screw things up.
App Code
library(shiny)
library(lpSolve)
library(purrr)
# Define the UI for the app
ui <- fluidPage(
titlePanel("Fantasy Football Lineup Optimizer"),
sidebarLayout(
sidebarPanel(
numericInput("num_qb", "Enter the number of QBs:", 1, min = 1, max = 5),
numericInput("num_rb", "Enter the number of RBs:", 3, min = 1, max = 5),
numericInput("num_wr", "Enter the number of WRs:", 3, min = 1, max = 5),
numericInput("num_te", "Enter the number of TEs:", 2, min = 1, max = 5),
numericInput("num_value", "Enter your draft budget:", 200),
numericInput("num_players", "Adding in your flex spots, enter the total number of starters:", 9, min = 1, max = 15),
selectInput("remove", "Remove a player:", choices = c("",as.character(players$Player)), multiple = FALSE),
selectInput("draft_player", "Draft Player", choices = c("",as.character(players$Player)), multiple = FALSE),
actionButton("update", "Update Lineup")
),
mainPanel(
tableOutput("team")
)
)
)
# Define the server logic
server <- function(input, output, session) {
players <- players
# New col to indicate if a player has been drafted
players$Drafted = "No"
# Create a new column indicating the player's position
players$QB <- ifelse(players$Position == "QB", 1, 0)
players$RB <- ifelse(players$Position == "RB", 1, 0)
players$WR <- ifelse(players$Position == "WR", 1, 0)
players$TE <- ifelse(players$Position == "TE", 1, 0)
players$Total <- 1
rv <- reactiveValues(players=players)
# Set up reactive table for lineup output
updateLineup = reactiveVal(NULL)
# Define the objective function (maximize fantasy points)
obj <- players$FantasyPoints
# Define the constraints (position limits and draft value limit)
con <- reactive({
matrix(c(
# QB constraint
rv$players$QB,
# RB constraint
rv$players$RB,
# WR constraint
rv$players$WR,
# TE constraint
rv$players$TE,
# Draft value constraint
rv$players$DraftValue,
#Total players constraint
rv$players$Total
), ncol = nrow(rv$players), byrow = TRUE)
})
# Define the variables for the lp
dir <- c("<=", rep(">=",3),"<=","<=")
# Define initial 'const.rhs'
init_rhs <- reactive({
list(
QB = input$num_qb,
RB = input$num_rb,
WR = input$num_wr,
TE = input$num_te,
n_val = input$num_value,
n_players = input$num_players
)
})
# Define reactive 'const.rhs'
rhs = reactiveValues(const = list())
# Run once to get the initial values and set them to reactiveValues
# so they can be changed later
observeEvent(init_rhs(),{
rhs$const = init_rhs()
}, once = TRUE)
# Define the initial optimal lineup
initialLineup <- reactive({
result <- lp("max", obj, con(), dir, init_rhs(), all.bin = TRUE)
rv$players[result$solution == 1,]
})
# Define the function to run when the "update" button is pressed
observeEvent(input$update, {
# Remove player here
if(input$remove != "") {
removedPlayer <- input$remove
rv$players <- rv$players[rv$players$Player != removedPlayer,]
obj <- rv$players$FantasyPoints
}
# Draft player
if(input$draft_player != "") {
draftedPlayer <- input$draft_player
draftedPlayer_details <- rv$players[rv$players$Player == draftedPlayer,]
draftedPlayer_details$Drafted = "Yes"
rv$players <- rv$players[rv$players$Player != draftedPlayer,]
rv$draftedPlayers <- rbind(rv$draftedPlayers, draftedPlayer_details)
obj <- rv$players$FantasyPoints # missing object
# Subtract constraints: position and n_players by 1 and draft budget by the players 'DraftValue'
# Necessary so "result" outputs a table with the remaining positions left
# otherwise it will return an entirely new lineup
rhs$const = purrr::imap(rhs$const, function(cs, nm) {
if(nm == draftedPlayer_details$Position) {cs = cs - 1}
if(nm == "n_players") {cs = cs - 1}
if(nm == "n_val") {cs = cs - draftedPlayer_details$DraftValue}
return(cs)
})
}
# Update select inputs to remove players after "Update Lineup" is clicked
if(input$remove != "" || input$draft_player != "") {
updateSelectInput(session, inputId = "remove", choices = c("",rv$players), selected = "")
updateSelectInput(session, inputId = "draft_player", choices = c("",rv$players), selected = "")
}
# Define result with updated arguments
result <- lp("max", obj, con(), dir, rhs$const, all.bin = TRUE)
# Assign new table to the reactiveVal 'updateLineup'
updateLineup(rbind(rv$draftedPlayers, rv$players[result$solution == 1,]))
})
output$team <- renderTable({
if (input$update == 0) {
initialLineup()[, c("Player", "Position", "FantasyPoints", "DraftValue", "Drafted")]
} else {
updateLineup()[, c("Player", "Position", "FantasyPoints", "DraftValue", "Drafted")]
}
})
}
# Run the app
shinyApp(ui, server)