Question

我使用Shiny创建了一个应用程序，该应用程序显示取决于两个不同输入的数据。我正在过滤反应函数中的数据，然后将其传递给绘图。

当没有基于输入的相关数据时，我想不出如何简单地隐藏图表（理想情况下显示有用的解释）的方法。如果我的数据在数据框中，则可以执行此操作，但是由于我已使用反应性函数对其进行了过滤，因此无法正常工作。

我目前在renderPlot函数中嵌套有validate函数，它引用了由反应函数过滤的数据框...

有人有什么想法吗？

可复制的代码（如果您选择“布里斯托尔”（Bristol）为默认日期范围，则说明存在此问题）：

library("tidyverse")

location <- as.character(c("London", "London", "Birmingham", "Bristol", "Birmingham", "Birmingham", "London", "Birmingham"))
dog_birthday <- as.POSIXct(c("01-01-2016", "02-02-2016", "03-03-2016", "04-04-2017", "05-05-2017", "06-06-2017", "08-08-2018", "07-07-2018"), format = "%d-%m-%Y")
dog_type <- as.character(c("Poodle", "Pug", "Labrador", "Poodle", "Poodle", "Labrador", "Pug", "Pug"))
dog_data <- data.frame(location, dog_birthday, dog_type)


ui<-       
  fluidPage(      
  sidebarLayout(        
    sidebarPanel(         
      dateRangeInput(
        "dates", label = h3("Birthdate range"), start = ("01-06-2018"),
        format = "dd-mm-yyyy", startview = "year"
      ),
    selectInput(
        "location", label = h3("Location"), choices = unique(dog_data$location),
        multiple = T, selectize = T
      )
    ),

    mainPanel(          
      plotOutput(outputId = "dog_type")         
    )
  )
)

server <- function(input, output) {
 city_selection <- reactive({
    req(input$location)
    choose_city <- subset(dog_data, dog_data$location %in% input$location)
    choose_city <- droplevels(choose_city)
    return(choose_city)
  })

  output$dog_type <- renderPlot({
    validate(
      need(nrow(dog_data) > 0, "No data for this selection.")
    )
    dog_type_plot <- city_selection() %>%
      filter(dog_birthday >= input$dates[1] & dog_birthday <= input$dates[2]) %>%
      count(dog_type) %>%
      arrange(-n) %>%
      mutate(dog_type = factor(dog_type, dog_type)) %>%
      ggplot(aes(dog_type, n)) +
      geom_bar(stat = "identity") 
    dog_type_plot
  })
}

shinyApp(ui, server)

Answer 1

您需要将日期过滤器移至city_selection反应式，并在validate中更新need条件-

server <- function(input, output) {
 city_selection <- reactive({
    req(input$location)
    choose_city <- subset(dog_data, dog_data$location %in% input$location) %>%
      filter(dog_birthday >= input$dates[1] & dog_birthday <= input$dates[2])
    choose_city <- droplevels(choose_city)
    return(choose_city)
  })

  output$dog_type <- renderPlot({
    validate(
      need(nrow(city_selection()) > 0, "No data for this selection.")
    )
    dog_type_plot <- city_selection() %>%
      count(dog_type) %>%
      arrange(-n) %>%
      mutate(dog_type = factor(dog_type, dog_type)) %>%
      ggplot(aes(dog_type, n)) +
      geom_bar(stat = "identity") 
    dog_type_plot
  })
}

Answer 2

尝试运行代码时也出现错误：

Warning: Error in count: Argument 'x' must be a vector: list

我注意到的其他一些事情：

对我来说，choose_city <- droplevels(choose_city)什么也没做，如果您要删除choose_city$location <- droplevels(choose_city$location)中未选择的因子水平，我认为您需要location
我认为@Shree的建议会有所帮助，但是此方法仍然仅检查位置，而不检查日期。（您的版本不执行任何操作的原因是因为dog_data是您的参考data.frame，并且您的子设置没有更改它） @Shree的更新答案移动了日期子集，现在是可能比这更好：）

我对您的代码进行了相当大的修改，以使其对我有用（只是因为我不使用管道，并且对data.table最熟悉）。显然，您可以删除data.table依赖项并使用管道进行过滤！

最主要的是，您想在绘制情节之前检查dog_type_plot的外观。我添加了reactiveVal来保存在边栏中输出的消息：

library("tidyverse")
library("data.table")

location <- as.character(c("London", "London", "Birmingham", "Bristol", "Birmingham", "Birmingham", "London", "Birmingham"))
dog_birthday <- as.POSIXct(c("01-01-2016", "02-02-2016", "03-03-2016", "04-04-2017", "05-05-2017", "06-06-2017", "08-08-2018", "07-07-2018"), format = "%d-%m-%Y")
dog_type <- as.character(c("Poodle", "Pug", "Labrador", "Poodle", "Poodle", "Labrador", "Pug", "Pug"))
dog_data <- data.frame(location, dog_birthday, dog_type)


ui<-       
  fluidPage(      
    sidebarLayout(        
      sidebarPanel(         
        dateRangeInput(
          "dates", label = h3("Birthdate range"), start = ("01-06-2018"),
          format = "dd-mm-yyyy", startview = "year"
        ),
        selectInput(
          "location", label = h3("Location"), choices = unique(dog_data$location),
          multiple = T, selectize = T
        ),
        textOutput(outputId = "noDataMsg")
      ),

      mainPanel(          
        plotOutput(outputId = "dog_type")         
      )
    )
  )

server <- function(input, output) {

  ## Subset base data.frame by user-selected location(s)
  city_selection <- reactive({
    req(input$location)
    choose_city <- subset(dog_data, dog_data$location %in% input$location)
    choose_city$location <- droplevels(choose_city$location)
    return(choose_city)
  })

  ## Value to hold message
  message_v <- reactiveVal(); message_v("blank")

  ## Make Histogram
  output$dog_type <- renderPlot({

      print("city_selection():")
      print(city_selection())
      cat("\n")

      ## Change to data.table
      data_dt <- as.data.table(city_selection())

      print("original data_dt:")
      print(data_dt)
      cat("\n")

      ## Subset by birthday
      dog_type_plot <- data_dt[dog_birthday >= input$dates[1] &
                                 dog_birthday <= input$dates[2],]

      print("subset by birthday")
      print(dog_type_plot)
      cat("\n")

      ## Get counts and sort
      dog_type_plot[, N := .N, by = dog_type]
      dog_type_plot <- dog_type_plot[order(-N)]

      print("add count:")
      print(dog_type_plot)
      cat("\n")

      ## Change dog type to factor
      dog_type_plot$dog_type <- factor(dog_type_plot$dog_type, levels = unique(dog_type_plot$dog_type))

      print("refactor of dog_type:")
      print(dog_type_plot$dog_type)
      cat("\n")

      ## Check for data to plot
      if (nrow(dog_type_plot) == 0) {
        message_v("No dogs to plot using these parameters")
        return(NULL)
      } else {
        ## Make plot
        plot_gg <- ggplot(data = dog_type_plot, aes(x = dog_type, y = N)) +
          geom_bar(stat = "identity")

        ## Return
        return(plot_gg)
      } # fi
  }) # renderPlot

  ## Message to user
  output$noDataMsg <- renderText({ if (message_v() == "blank") { return(NULL) } else { message_v() } })
}

shinyApp(ui, server)

使用反应函数（R）时，在Shiny中使用validate来隐藏图而没有相关数据

2 个答案: