Linking Shiny Reactive inputs and input updates - r

Question

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)

Answer 1

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)