链接 Shiny Reactive 输入和输入更新

Question

我有一个婴儿名字数据集，每年按受欢迎程度排名。

我目前拥有的是：一个简单闪亮的应用程序，它基于一个滑块和一个选择按钮来过滤年份，该按钮确定哪一列是要使用的排名列（它还会创建一个颜色突出显示）。这实际上将是两个数据集，一个用于标记为 M 的性别或标记为 F 的性别，但我在这里的示例中将其简化。

我想做的是：将其更新为对滑块的值做出反应，然后滑块更新选择选项以选择要排序和突出显示的文件列。

目前的方法是为了简单起见，但如果它是一个不再存在于滑块选择范围内的值，那么年份的焦点选择器显然会抛出错误。

我已经四处寻找并尝试了一些方法，但我只是无法让反应性部分成功工作。我敢肯定我错过了一些基本的东西但是碰壁了。感谢您的任何输入。

例子：

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

您可以设置一个 observeEvent 来监视 sliderInput 的变化。然后，如果您选择的输入不在滑块的范围内。更新选择。

注意：您需要将会话参数添加到服务器功能。

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({
    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)