Code Editor for app.R

# Load required libraries
library(shiny)
library(shinydashboard)
#library(xgboost)
library(ggplot2)
library(reshape2)
library(dplyr)

# Load the xgb model object
xpass_xgb <- fastrmodels::xpass_model


implied_odds <- function(odds) {
   
   pos_or_neg <- sign(odds) == 1
   
   if(pos_or_neg) {
      
      x <- 100 / (odds + 100)
      
   } else {
      
      x <- -odds / (-odds + 100)
      
   }
   
   return(x)
   
}


# Define the UI for the dashboard ----
ui <- 
   dashboardPage(
      dashboardHeader(title = "XGBoost Prediction Tool"),
      dashboardSidebar(
         sidebarMenu(
            menuItem("Single Prediction", tabName = "single_prediction", icon = icon("calculator")),
            menuItem("Sensitivity Analysis", tabName = "sensitivity", icon = icon("chart-line"))
         )
      ),
      dashboardBody(
         tabItems(
            # Single Prediction Tab
            tabItem(tabName = "single_prediction",
                    fluidRow(
                       box(title = "Input Variables", status = "primary", solidHeader = TRUE,
                           column(6,
                                  sliderInput("down", "Down (1-4)", 
                                              min = 1, max = 4, value = 1, step = 1),
                                  sliderInput("ydstogo", "Yards to Go (1-99)", 
                                              min = 1, max = 20, value = 10, step = 1),
                                  sliderInput("yardline_100", "Yard Line (1-99)", 
                                              min = 1, max = 99, value = 50, step = 1),
                                  sliderInput("qtr", "Quarter (1-4)", 
                                              min = 1, max = 4, value = 1, step = 1),
                                  sliderInput("wp", "Win Probability (%)", 
                                              min = 0.01, max = 0.99, value = 0.50, step = 0.01)
                           ),
                           column(6,
                                  sliderInput("vegas_wp", "Vegas Win Probability (%)", 
                                              min = 0.01, max = 0.99, value = 0.50, step = 0.01),
                                  sliderInput("score_differential", "Score Differential (-28 to 28)", 
                                              min = -28, max = 28, value = 0, step = 1),
                                  sliderInput("half_seconds_remaining", "Seconds Remaining in Half (0-1800)", 
                                              min = 0, max = 1800, value = 900, step = 30),
                                  selectInput("home", "Home Team", 
                                              choices = c("No" = 0, "Yes" = 1), selected = 0),
                                  sliderInput("posteam_timeouts_remaining", "Offensive Team Timeouts (0-3)", 
                                              min = 0, max = 3, value = 2, step = 1),
                                  sliderInput("defteam_timeouts_remaining", "Defensive Team Timeouts (0-3)", 
                                              min = 0, max = 3, value = 2, step = 1)
                           )
                       ),
                       box(title = "Prediction Result", status = "success", solidHeader = TRUE, width = 2,
                           textOutput("prediction_output")
                       )#,
                       # box(title = "Sensitivity Analysis Setup", status = "primary", solidHeader = TRUE,
                       #     selectInput("sensitivity_var", "Select Variable for Analysis", 
                       #                 choices = list(
                       #                    "Down" = "down",
                       #                    "Yards to Go" = "ydstogo",
                       #                    "Yard Line" = "yardline_100",
                       #                    "Quarter" = "qtr",
                       #                    "Win Probability" = "wp",
                       #                    "Vegas Win Probability" = "vegas_wp",
                       #                    "Score Differential" = "score_differential",
                       #                    "Seconds Remaining" = "half_seconds_remaining",
                       #                    "Home Team" = "home",
                       #                    "Offensive Team Timeouts" = "posteam_timeouts_remaining",
                       #                    "Defensive Team Timeouts" = "defteam_timeouts_remaining"
                       #                 ), selected = "ydstogo"),
                       #     uiOutput("sensitivity_var_input")
                       # ),
                       # box(title = "Sensitivity Analysis Results", status = "success", solidHeader = TRUE,
                       #     plotOutput("sensitivity_plot")#,
                       #     #dataTableOutput("sensitivity_table")
                       # ),
                       # box(title = "Sensitivity Analysis Results", status = "success", solidHeader = TRUE,
                       #     dataTableOutput("sensitivity_table")
                       # )
                    )),
            
            # Sensitivity Analysis Tab
            tabItem(tabName = "sensitivity",
                    fluidRow(
                       box(title = "Sensitivity Analysis Setup", status = "primary", solidHeader = TRUE,
                           selectInput("sensitivity_var", "Select Variable for Analysis", 
                                       choices = list(
                                          "Down" = "down",
                                          "Yards to Go" = "ydstogo",
                                          "Yard Line" = "yardline_100",
                                          "Quarter" = "qtr",
                                          "Win Probability" = "wp",
                                          "Vegas Win Probability" = "vegas_wp",
                                          "Score Differential" = "score_differential",
                                          "Seconds Remaining" = "half_seconds_remaining",
                                          "Home Team" = "home",
                                          "Offensive Team Timeouts" = "posteam_timeouts_remaining",
                                          "Defensive Team Timeouts" = "defteam_timeouts_remaining"
                                       ), selected = "ydstogo"),
                           uiOutput("sensitivity_var_input")
                       ),
                       box(title = "Sensitivity Analysis Results", status = "success", solidHeader = TRUE,
                           plotOutput("sensitivity_plot"),
                           dataTableOutput("sensitivity_table")
                       )
                    )
            )
         )
      )
   )

# Define the server logic ----
server <- function(input, output, session) {
   
   # Dynamic input for sensitivity analysis based on selected variable
   output$sensitivity_var_input <- renderUI({
      
      var <- input$sensitivity_var
      
      # Define ranges and step sizes for different variables
      var_ranges <- list(
         "down" = list(min = 1, max = 4, step = 1, value = c(1, 4)),
         "ydstogo" = list(min = 1, max = 20, step = 1, value = c(1, 20)),
         "yardline_100" = list(min = 1, max = 99, step = 1, value = c(1, 99)),
         "qtr" = list(min = 1, max = 4, step = 1, value = c(1, 4)),
         "wp" = list(min = .01, max = .99, step = .01, value = c(.01, .99)),
         "vegas_wp" = list(min = .01, max = .99, step = .01, value = c(.01, .99)),
         "score_differential" = list(min = -28, max = 28, step = 1, value = c(-28, 28)),
         "half_seconds_remaining" = list(min = 0, max = 1800, step = 30, value = c(0, 1800)),
         "home" = list(min = 0, max = 1, step = 1, value = c(0, 1)),
         "posteam_timeouts_remaining" = list(min = 0, max = 3, step = 1, value = c(0, 3)),
         "defteam_timeouts_remaining" = list(min = 0, max = 3, step = 1, value = c(0, 3))
      )
      
      # Create range slider for the selected variable
      do.call(sliderInput, c(
         inputId = "sensitivity_range", 
         label = paste("Select range for", var),
         var_ranges[[var]]
      ))
   })
   
   # Single Prediction Reactive Function
   prediction_df <- reactive({
      df <- data.frame(
         down = input$down,
         ydstogo = input$ydstogo,
         yardline_100 = input$yardline_100,
         qtr = input$qtr,
         wp = input$wp,
         vegas_wp = input$vegas_wp,
         era2 = 0,
         era3 = 0,
         era4 = 1,
         score_differential = input$score_differential,
         home = as.numeric(input$home),
         half_seconds_remaining = input$half_seconds_remaining,
         posteam_timeouts_remaining = input$posteam_timeouts_remaining,
         defteam_timeouts_remaining = input$defteam_timeouts_remaining,
         outdoors = 1,
         retractable = 0,
         dome = 0
      )
      return(df)
   })
   
   # Single Prediction Output
   output$prediction_output <- renderText({
      req(exists("xpass_xgb"))
      df <- prediction_df()
      pred <- predict(xpass_xgb, as.matrix(df))
      paste("Predicted Pass Probability:\n", round(pred, 4)*100, "%")
   })
   
   # Sensitivity Analysis Reactive Function
   sensitivity_analysis <- reactive({
      req(input$sensitivity_range, input$sensitivity_var)
      req(exists("xpass_xgb"))
      
      # Create base dataframe with constant values
      base_df <- data.frame(
         down = input$down,
         ydstogo = input$ydstogo,
         yardline_100 = input$yardline_100,
         qtr = input$qtr,
         wp = input$wp,
         vegas_wp = input$vegas_wp,
         era2 = 0,
         era3 = 0,
         era4 = 1,
         score_differential = input$score_differential,
         home = as.numeric(input$home),
         half_seconds_remaining = input$half_seconds_remaining,
         posteam_timeouts_remaining = input$posteam_timeouts_remaining,
         defteam_timeouts_remaining = input$defteam_timeouts_remaining,
         outdoors = 1,
         retractable = 0,
         dome = 0
      )
      
      # Generate range of values for the selected variable
      var <- input$sensitivity_var
      var_range <- seq(input$sensitivity_range[1], 
                       input$sensitivity_range[2], 
                       length.out = ifelse(as.integer(input$sensitivity_range[1]) == input$sensitivity_range[1],
                                           input$sensitivity_range[2] - input$sensitivity_range[1] + 1,
                                           input$sensitivity_range[2]*100L - input$sensitivity_range[1]*100L + 1L
                                       )
                       )
      
      # Create predictions for each value in the range
      predictions <- sapply(var_range, function(x) {
         test_df <- base_df
         test_df[[var]] <- x
         predict(xpass_xgb, as.matrix(test_df))
      })
      
      tibble(
         Variable_Value = var_range,
         Prediction = round(predictions, digits = 3)*100
      )
   })
   
   # Sensitivity Plot
   output$sensitivity_plot <- renderPlot({
      result <- sensitivity_analysis()
      ggplot(result, aes(x = Variable_Value, y = Prediction)) +
         geom_line(color = "blue") +
         geom_point(color = "red") +
         ylim(c(0,100)) +
         labs(
            title = paste("Sensitivity of Prediction to", input$sensitivity_var),
            x = input$sensitivity_var,
            y = "Predicted Pass Probability"
         ) +
         theme_minimal()
   })
   
   # Sensitivity Table
   output$sensitivity_table <- renderDataTable({
      sensitivity_analysis()
   })
}

# Run the application 
shinyApp(ui, server)