Linking Shiny Reactive inputs and input updates-CodePudding

I have a dataset of baby names that are ranked by popularity for each year.

What I currently have: a simple shiny app that filters on year based on a slider and a select button that identifies which column is the rank column to use (which also creates a color highlight). This will be two datasets in actuality, one for gender marked as M or gender marked as F, but I've left it simple for the example here.

What I would like to do: update this to be reactive to the values of a slider, which then updates a select option for which file column to sort and highlight.

The current approach works for simplicity, but the focus selector for the year obviously throws an error if it's a value that no longer exists in the slider selected range.

I've dug around and tried a few approaches, but I just haven't been able to get the reactivity portion to work successfully. I'm sure I'm missing something elementary but hitting a wall. Thank you for any input.

Example:

library(shiny)
library(tidyverse)
library(DT)

#Fake Data
dat <- structure(list(Name = c("Bill", "Sean", "Kirby", "Philbert", 
  "Bob", "Lucius", "Fry", "Tyron", "Lionel", "Alister", "Newt", 
  "Craig", "A-Aron", "Bill", "Sean", "Kirby", "Philbert", "Bob", 
  "Lucius", "Fry", "Tyron", "Lionel", "Alister", "Newt", "Craig", 
  "A-Aron", "Bill", "Sean", "Kirby", "Philbert", "Bob", "Lucius", 
  "Fry", "Tyron", "Lionel", "Alister", "Newt", "Craig", "A-Aron"
), rank = c(8L, 1L, 2L, 3L, 4L, 6L, 5L, 9L, 7L, 25L, 10L, 35L, 
  99L, 4L, 1L, 3L, 2L, 5L, 6L, 7L, 11L, 5L, 12L, 8L, 9L, 10L, 4L, 
  2L, 3L, 10L, 8L, 11L, 5L, 6L, 12L, 7L, 13L, 9L, 1L), year = c(2008L, 
    2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 
    2008L, 2008L, 2008L, 2009L, 2009L, 2009L, 2009L, 2009L, 2009L, 
    2009L, 2009L, 2009L, 2009L, 2009L, 2009L, 2009L, 2010L, 2010L, 
    2010L, 2010L, 2010L, 2010L, 2010L, 2010L, 2010L, 2010L, 2010L, 
    2010L, 2010L)), class = "data.frame", row.names = c(NA, -39L))

#Get years
years <- unique(dat$year)


ui <- fluidPage(
  titlePanel("Top Ten Male Baby Names"),
  sliderInput("range",
    label = "Choose year range",
    min = min(as.numeric(years)),
    max = max(as.numeric(years)),
    sep = "",
    value = c(max(as.numeric(years))-1,max(as.numeric(years)))
  ),
  
  selectInput("year", 
    label = "Choose year for rank",
    choices = as.numeric(years),
    selected = max(as.numeric(years))
  )
  ,
  
  mainPanel(
    dataTableOutput("DataTable")
  )
  
)


server <- function(input, output) {
  output$DataTable <- renderDataTable({
    dat1 <- dat %>%
      filter((year >= input$range[1] & year <= input$range[2]) ) %>%
      pivot_wider(id_cols = Name,
        values_from = rank,
        names_from = year) %>%
      filter(.[colnames(.) == as.character(input$year)] <11) %>%
      arrange(.[colnames(.)== as.character(input$year)])
    
    datatable(dat1,
      options = list(ordering=F,
        lengthChange = F,
        pageLength = -1)) %>%
      formatStyle(input$year,
        backgroundColor = "lightgreen"
      )
  })
  
}

shinyApp(ui, server)

CodePudding user response：

You could set up an observeEvent to watch for changes to the sliderInput. Then if your select input is not in the range of the slider. Update the selection.

Note: you need to add the session param to the server function.

Also since output$DataTable is filtered by the range and the year. I've added a validate statement incase the user were to manually chose a year that is not in the current range.

server <- function(input, output, session) {
  
  # Observe for a change to slider input
  observeEvent(input$range, {
    sel = input$year
    # update selection if original selected year is not in range
    if(!(sel %in% input$range)) {
      sel = min(input$range)
      
      updateSelectInput(session, "year", selected = sel)
    }
  })
  
  output$DataTable <- renderDataTable({
    validate(need(input$year %in% input$range,"Current selection not in range"))

    dat1 <- dat %>%
      filter((year >= input$range[1] & year <= input$range[2]) ) %>%
      pivot_wider(id_cols = Name,
        values_from = rank,
        names_from = year) %>%
      filter(.[colnames(.) == as.character(input$year)] <11) %>%
      arrange(.[colnames(.)== as.character(input$year)])
    
    datatable(dat1,
      options = list(ordering=F,
        lengthChange = F,
        pageLength = -1)) %>%
      formatStyle(input$year,
        backgroundColor = "lightgreen"
      )
  })
  
}

shinyApp(ui, server)