Where to place reactive() to render different plot types based on user input

shiny
1

Hello again. Hope somebody in here's a college basketball nerd...

I'm back and dealing with some confusion about where I need to add my reactive call in a Shiny app so that it follows a command to output a different plot depending whether input$playerSelector is NA or non-NA.

The first output in the server call is the troublesome one. I don't know if I picked a bad place for my reactive or if I'm just asking too much of the program with my case_when that changes the plot type based on the NA status of input$playerSelector

library(extrafont)
library(shiny)
library(tidyverse)
library(ncaahoopR)

# Define UI for application 
ui <- fluidPage(
  
  # Application title
  titlePanel("KU Dashboard"),
  
  # Sidebar with a checkbox input for game selection 
  sidebarLayout(
    sidebarPanel(
      checkboxGroupInput("dateBoxes", 
                         label = "Games to Include:",
                         choices = c("11-5 vs. Duke" = 401168155,
                                     "11-8 vs. UNCG" = 401169601,
                                     "11-15 vs. Monmouth" = 401169615,
                                     "11-19 vs. ETSU" = 401169621 ,
                                     "11-25 at Chaminade" = 401169630,
                                     "11-26 vs. BYU" = 401182627,
                                     "11-27 vs. Dayton" = 401182629,
                                     "12-7 vs. Colorado" = 401169646 ,
                                     "12-10 vs. Milwaukee" = 401169649,
                                     "12-14 vs. UMKC" = 401169657,
                                     "12-21 at Villanova" = 401169661,
                                     "12-29 at Stanford" = 401169669
                                      ),
                         selected = c(401168155, 401169601, 401169615, 
                                      401169621, 401169630, 401182627, 
                                      401182629, 401169646, 401169649,
                                      401169657, 401169661, 401169669
                         )
      ),
      
      # Radio button input for weighting 3-pointers    
      radioButtons("weightButton", 
                   label = "ASSIST NETWORK OPTIONS \n
                         Weighted 3-pointers?",
                   choices = c("Yes" = TRUE,
                               "No" = FALSE),
                   selected = TRUE
      ),
      
      # Numeric input box for involvement threshold
      numericInput("thresholdSelector", 
                   label = "Minimum Involvement % for Player Inclusion?",
                   min = 0,
                   max = 1,
                   step = 0.01,
                   value = 0.1
      ),
      
      #Selection input box for highlighting a player
      selectInput("playerSelector",
        label = "Player to highlight?",
        choices = c("None" = NA,
        "0 - Marcus Garrett" = "Marcus Garrett",
        "1 - Devon Dotson" = "Devon Dotson",
        "2 - Christian Braun" = "Christian Braun",
        "3 - Dajuan Harris" = "Dajuan Harris",
        "4 - Isaiah Moss" = "Isaiah Moss",
        "5 - Elijah Elliott" = "Elijah Elliott",
        "10 - Jalen Wilson" = "Jalen Wilson",
        "12 - Chris Teahan" = "Chris Teahan",
        "13 - Tristan Enaruna" = "Tristan Enaruna",
        "20 - Michael Jankovich" = "Michael Jankovich",
        "22 - Silvio De Sousa" = "Silvio De Sousa",
        "30 - Ochai Agbaji" = "Ochai Agbaji",
        "33 - David McCormack" = "David McCormack",
        "35 - Udoka Azubuike" = "Udoka Azubuike",
        "44 - Mitch Lightfoot" = "Mitch Lightfoot"),
        selected = "None"),
      
      #Radio button input for presenting shot chart as heatmap
      radioButtons("heatmapSelector",
                   label = "SHOT CHART OPTIONS \n
                         Heatmap?",
                   choices = c("Yes" = TRUE,
                               "No" = FALSE)
      )
    ),
    
    # Show a plot of the generated distribution
    mainPanel(
      fluidRow(
        plotOutput("assistNetworkPlot")
      ),
      fluidRow(
        plotOutput("kuShotChart"),
        plotOutput("oppShotChart")
      )
    )
  )
)

# Define server logic required to draw plots
server <- function(input, output) {
  output$assistNetworkPlot <- reactive({
    case_when(
      !is.na(input$playerSelector)~
        renderPlot({
          circle_assist_net(team = "Kansas", 
                            season = input$dateBoxes,
                            three_weights = input$weightButton,
                            threshold = input$thresholdSelector, 
                            highlight_player = input$playerSelector,
                            highlight_color = "#0051BA")
          }),

      is.na(input$playerSelector)~  
        renderPlot({
          assist_net(team = "Kansas", 
                     node_col = "royalblue4", 
                     season = input$dateBoxes,
                     three_weights = input$weightButton,
                     threshold = input$thresholdSelector,
                     message = "ASSIST NETWORK")
          })
      )
    })  
  output$kuShotChart <- renderPlot({
    team_shot_chart(game_ids = input$dateBoxes,
                    team = "Kansas",
                    heatmap = input$heatmapSelector)
  })
  
  output$oppShotChart <- renderPlot({
    opp_shot_chart(game_ids = input$dateBoxes,
                   team = "Kansas",
                   heatmap = input$heatmapSelector)
  })
}

# Run the application 
shinyApp(ui = ui, server = server)
2

I don't think you need a call to reactive() at all, if I understand what you are trying to do. I made a simple example below. I could not get case_when to work. It seems it should and I suspect I was making a silly mistake but I have given that up for the moment. I used a simple if else statement, though that will be a pain if you have multiple conditions.

library(shiny)
library(dplyr)
# Define UI for application that draws a histogram
ui <- fluidPage(
  
  # Application title
  titlePanel("Old Faithful Geyser Data"),
  
  # Sidebar with a slider input for number of bins 
  sidebarLayout(
    sidebarPanel(
      sliderInput("bins",
                  "Number of bins:",
                  min = 1,
                  max = 50,
                  value = 30),
      selectInput("ColorSel", "Color", 
                  choices = c("None" = NA,  "R" =" red", "B" = "blue", "G" = "green"))
    ),
    
    # Show a plot of the generated distribution
    mainPanel(
      plotOutput("distPlot")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  
  output$distPlot <- renderPlot({
    # generate bins based on input$bins from ui.R
    x    <- faithful[, 2]
    bins <- seq(min(x), max(x), length.out = input$bins + 1)
    #case_when (
    if(input$ColorSel == "NA") hist(x, breaks = bins, col = 'darkgray', border = 'white')
    else hist(x, breaks = bins, col = input$ColorSel, border = 'white')
    #)
  })
}

# Run the application 
shinyApp(ui = ui, server = server)
4

Thanks for the reply!

Turned out that renderPlot served the purpose I thought I needed reactive for, and ifelse worked out better than case_when .

Gonna post what successfully worked shortly after this for others' reference. Thanks for nudging me in the right way.

5

I finally got things to work with some tweaking. Here's what I learned (reference for anyone else stumbling in a similar situation):

renderPlot already serves as a reactivity trigger, so adding reactive wasn't helping anything. I just needed to move the renderPlot call higher in the order.

It was more of an ordering issue than anything. Note in the working version below the ifelse that determines which plot to select immediately follows the renderPlot call. Also, as @FJCC helped me realize, I needed to make the condition as input$playerSelector == "NA" because is.na(input$playerSelector) was creating problems.

library(extrafont)
library(shiny)
library(tidyverse)
library(ncaahoopR)

# Define UI for application 
ui <- fluidPage(

    # Application title
    titlePanel("KU Dashboard"),

    # Sidebar with a checkbox input for game selection 
    sidebarLayout(
        sidebarPanel(
            checkboxGroupInput("dateBoxes", 
                               label = "Games to Include:",
                                choices = c("11-5 vs. Duke" = 401168155,
                                    "11-8 vs. UNCG" = 401169601,
                                     "11-15 vs. Monmouth" = 401169615,
                                    "11-19 vs. ETSU" = 401169621 ,
                                    "11-25 at Chaminade" = 401169630,
                                    "11-26 vs. BYU" = 401182627,
                                    "11-27 vs. Dayton" = 401182629,
                                    "12-7 vs. Colorado" = 401169646 ,
                                    "12-10 vs. Milwaukee" = 401169649,
                                    "12-14 vs. UMKC" = 401169657,
                                    "12-21 at Villanova" = 401169661,
                                     "12-29 at Stanford" = 401169669 #,
#                                    "1-4 vs. West Virginia" = 401169679,
#                                    "1-8 vs. at Iowa St." = 401169686,
#                                    "1-11 vs. Baylor" = 401169688,
#                                    "1-14 at Oklahoma" = 401169693,
#                                    "1-18 at Texas" = 401169699,
#                                    "1-21 vs. Kansas St." = 401169705,
#                                    "1-25 vs. Tennessee" = 401169713,
#                                    "1-27 at Oklahoma St." = 401169718,
#                                    "2-1 vs. Texas Tech" = 401169726,
#                                    "2-3 vs. Texas" = 401169729,
#                                    "2-8 at TCU" = 401169733,
#                                    "2-12 at West Virginia" = 401169741,
#                                    "2-15 vs. Oklahoma" = 401169743,
#                                    "2-17 vs. Iowa St." = 401169748,
#                                    "2-22 at Baylor" = 401169753,
#                                    "2-24 vs. Oklahoma St." = 401169759,
#                                    "2-29 at Kansas St." = 401169764,
#                                    "3-4 vs. TCU" = 401169772,
#                                    "3-7 at Texas Tech" = 401169774
                                     ),
                                    selected = c(401168155, 401169601, 401169615, 
                                                 401169621, 401169630, 401182627, 
                                                 401182629, 401169646, 401169649,
                                                 401169657, 401169661, 401169669
                                                 )
                        ),
            
            # Radio button input for weighting 3-pointers    
            radioButtons("weightButton", 
                         label = "ASSIST NETWORK OPTIONS \n
                         Weighted 3-pointers?",
                         choices = c("Yes" = TRUE,
                                     "No" = FALSE),
                         selected = TRUE
            ),
            
            # Numeric input box for involvement threshold
            numericInput("thresholdSelector", 
                         label = "Minimum Involvement % for Player Inclusion?",
                        min = 0,
                        max = 1,
                        step = 0.01,
                        value = 0.1
                        ),
            
            #Selection input box for highlighting a player
            selectInput("playerSelector",
                        label = "Player to highlight?",
                        choices = c("None" = NA,
                                    "0 - Marcus Garrett" = "Marcus Garrett",
                                    "1 - Devon Dotson" = "Devon Dotson",
                                    "2 - Christian Braun" = "Christian Braun",
                                    "3 - Dajuan Harris" = "Dajuan Harris",
                                    "4 - Isaiah Moss" = "Isaiah Moss",
                                    "5 - Elijah Elliott" = "Elijah Elliott",
                                    "10 - Jalen Wilson" = "Jalen Wilson",
                                    "12 - Chris Teahan" = "Chris Teahan",
                                    "13 - Tristan Enaruna" = "Tristan Enaruna",
                                    "20 - Michael Jankovich" = "Michael Jankovich",
                                    "22 - Silvio De Sousa" = "Silvio De Sousa",
                                    "30 - Ochai Agbaji" = "Ochai Agbaji",
                                    "33 - David McCormack" = "David McCormack",
                                    "35 - Udoka Azubuike" = "Udoka Azubuike",
                                    "44 - Mitch Lightfoot" = "Mitch Lightfoot"),
                        selected = "None"),
            
            #Radio button input for presenting shot chart as heatmap
            radioButtons("heatmapSelector",
                         label = "SHOT CHART OPTIONS \n
                         Heatmap?",
                         choices = c("Yes" = TRUE,
                                     "No" = FALSE)
                         )
        ),

        # Show a plot of the generated distribution
        mainPanel(
            fluidRow(
                plotOutput("assistNetworkPlot")
            ),
            fluidRow(
                plotOutput("kuShotChart"),
                plotOutput("oppShotChart")
            )
        )
    )
)

# Define server logic required to draw a plots
server <- function(input, output) {

  output$assistNetworkPlot <-  renderPlot({
    ifelse(input$playerSelector == "NA", 
           {circle_assist_net(team = "Kansas", 
                              season = input$dateBoxes,
                              three_weights = input$weightButton,
                              threshold = input$thresholdSelector,
                              message = "ASSIST NETWORK")},
           
           {circle_assist_net(team = "Kansas", 
                              season = input$dateBoxes,
                              three_weights = input$weightButton,
                              threshold = input$thresholdSelector,
                              highlight_player = input$playerSelector,
                              highlight_color = "#0051BA",
                              message = "ASSIST NETWORK"
           )}
    )
  })
    
    output$kuShotChart <- renderPlot({
        team_shot_chart(game_ids = input$dateBoxes,
                        team = "Kansas",
                        heatmap = input$heatmapSelector)
    })
    
    output$oppShotChart <- renderPlot({
        opp_shot_chart(game_ids = input$dateBoxes,
                        team = "Kansas",
                        heatmap = input$heatmapSelector)
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

(One quick note that doesn't affect the original issue, I changed the style of the else plot to better match what I wanted out of this project)

Curious what I was making? Check out the Shiny app.

6

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.