多个反应性过滤器和更新选择输入的问题 - 奇怪的行为

Issue with Multiple Reactive Filters and Updateselectinputs - Strange Behavior

我正在努力解决连续通过多个过滤器的问题,有时结果不如预期。在下面的示例中,有 7 只鹿、2 只熊、1 只美洲狮、1 只海狸、1 只臭鼬、1 只驼鹿和 3 只麋鹿。当您 select 一种或多种时,有时通过过滤器的行数与应有的不一样。

例如。当我 select Bear、Beaver 和 Cougar 时,它应该生成 4 行的数据集,但是,在显示行数的文本输出中,显示 nrow=3。添加更多 select 离子有时会通过剩余的过滤器,有时不会。有时,当 selecting Deer 时,您期望有 7 行数据,但只传递了 3 行。

查看下面的可重现示例。

服务器:

library(shiny)
library(dplyr)

shinyServer(function(input, output, session, clientData) {


  Accident.Date <- as.Date(c("2018-06-04", "2018-06-05", "2018-06-06", "2018-06-07", "2018-06-08", "2018-06-09", "2018-06-10", "2018-06-11", "2018-06-12", "2018-06-13", "2018-06-14", "2018-06-15", "2018-06-16", "2018-06-17", "2018-06-18", "2018-07-18"))
  Time.of.Kill <- as.character(c("DAWN", "DAY", "DARK", "UNKNOWN", "DUSK", "DAY", "DAY", "DAWN", "DAY", "DARK", "UNKNOWN", "DUSK", "DARK", "DUSK", "DARK", "DAY"))
  Sex <- as.character(c("MALE", "MALE", "FEMALE", "MALE", "FEMALE", "FEMALE", "MALE", "MALE", "FEMALE", "FEMALE", "MALE", "FEMALE", "MALE", "FEMALE", "FEMALE", "FEMALE"))
  Age <- as.character(c("ADULT", "YOUNG", "UNKNOWN", "ADULT", "UNKNOWN", "ADULT", "YOUNG", "YOUNG", "ADULT", "ADULT", "ADULT", "YOUNG", "ADULT", "YOUNG", "YOUNG", "ADULT"))
  Species <- as.character(c("Deer", "Deer", "Deer", "Bear", "Deer", "Cougar", "Bear", "Beaver", "Deer", "Skunk", "Moose", "Deer", "Deer", "Elk", "Elk", "Elk"))
  Year <- as.numeric(c("0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0"))


  data <- data.frame(Accident.Date, Time.of.Kill, Sex, Age, Species, stringsAsFactors = FALSE)
  data <- data %>% mutate(Data.Set = "Current")

  #A set of reactive filters. Only data that has passed all filters is passed to the map, graph, datatable etc. **Order goes datacheck > yearcheck > speccheck > sexcheck > timecheck > agecheck > indaterange


  bindata <- reactive({
    filter(data, Data.Set %in% input$datacheck)
  })

  yrdata <- reactive({
    filter(bindata(), Year %in% input$yearcheck)
  })

  specdata <- reactive({
    subset(yrdata(), Species %in% input$speccheck)
  })

  sexdata <- reactive({
    filter(specdata(), Sex %in% input$sexcheck)
  })

  timedata <- reactive({
    filter(sexdata(), Time.of.Kill %in% input$timecheck)
  })

  agedata <- reactive({
    filter(timedata(), Age %in% input$agecheck)
  })

  #Does the date range filter. Selects min and max from the two inputs of the observed indaterange filter.

  data1 <- reactive({ filter(agedata(),
                             Accident.Date >= input$inDateRange[[1]],
                             Accident.Date <= input$inDateRange[[2]])
  })

  #If statement for choosing between current and historical datasets. If current is selected, year is set to 0 and the selection box is hidden.

  observe({ if (input$datacheck == 'Current')
    updateSelectInput(session, "yearcheck", choices = c("0"), selected = c("0"))
    else
      updateSelectizeInput(session, "yearcheck", choices = sort(unique(bindata()$Year), decreasing = TRUE), server=TRUE)

  })

  observe({

    req((input$datacheck == 'Historical'))

    updateSelectizeInput(session, "speccheck", choices = sort(unique(yrdata()$Species)), server=TRUE)

  })


  #Creates the observed Species

  observeEvent(input$yearcheck, {

    x  <- input$yearcheck
    if (is.null(x))
      x <- character(0)

    updateSelectizeInput(session, "speccheck", choices = sort(unique(yrdata()$Species)), server=TRUE)

  })


  #Creates the observed Sex

  observeEvent(input$speccheck, {

    x  <- input$speccheck
    if (is.null(x))
      x <- character(0)

    updateCheckboxGroupInput(session, inputId = "sexcheck",
                             choices = unique(specdata()$Sex),
                             selected = unique(specdata()$Sex),
                             inline = TRUE)
  })


  #Creates the observed Time

  observeEvent(input$sexcheck,{

    x  <- input$sexcheck
    if (is.null(x))
      x <- character(0)

    updateCheckboxGroupInput(session, inputId = "timecheck",
                             choices = unique(sexdata()$Time.of.Kill),
                             selected = unique(sexdata()$Time.of.Kill),
                             inline = TRUE)
  })

  #Creates the observed Age

  observeEvent(input$timecheck,{

    x  <- input$timecheck
    if (is.null(x))
      x <- character(0)

    updateCheckboxGroupInput(session, inputId = "agecheck",
                             choices = unique(timedata()$Age),
                             selected = unique(timedata()$Age),
                             inline = TRUE)
  })

  #Creates the observed dates and suppresses warnings from the min max

  observeEvent(input$agecheck, {

    x  <- input$agecheck
    if (is.null(x))
      x <- character(0)

    #And update the date range values to match those of the dataset

    updateDateRangeInput(
      session = session,
      inputId = "inDateRange",
      start = min(suppressWarnings(agedata()$Accident.Date)),
      end = max(suppressWarnings(agedata()$Accident.Date))
    )
  })


  output$txt <-  renderText({nrow(data1())})


  })

ui:

navbarPage("Test", id="nav",

           tabPanel("Map",

                        absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
                                      draggable = FALSE, top = 200, left = 5, right = "auto", bottom = "auto",
                                      width = "auto", height = "auto",


                                      radioButtons("datacheck", label = tags$div( HTML("<b>Dataset</b>")),
                                                   choices = c("Current" = "Current", "Historical" = "Historical"),
                                                   selected = c("Current"), inline = TRUE),



                                      conditionalPanel(condition = "input.datacheck != 'Current'",

                                                       #Only displays yearcheck for historical as there is no year column on current dataset. Current dataset has had all year values set to 0.             

                                                       selectizeInput("yearcheck", label = "Select Year (Only Available for Historical)", choices = NULL, options = list(placeholder = 'Select Year:', maxOptions = 40, maxItems = 40))),

                                      selectizeInput("speccheck", h3("Select Species:"), choices = NULL, options = list(placeholder = 'Select Species: (Max 12) ', maxOptions = 36, maxItems = 12)),


                                      conditionalPanel(condition = "input.speccheck >= '1'",
                                                       dateRangeInput("inDateRange", "Date range input:"),

                                                       checkboxGroupInput("sexcheck", label = tags$div( HTML("<b>Sex</b><br>"))),

                                                       checkboxGroupInput("agecheck", label = tags$div( HTML("<b>Age</b><br>"))),

                                                       checkboxGroupInput("timecheck", label = tags$div( HTML("<b>Time of Accident</b><br>")))
                                      ),
                                      verbatimTextOutput("txt")


)))

如有任何帮助,我们将不胜感激。一段时间以来,我一直在挠头。

此问题与您更新复选框的方式有关。使用您的代码:select 首先是 BEAR,输出看起来不错,是的,但是如果您添加 BEAVER,则什么也不会发生。为什么?因为当你的过滤器通过

   timedata <- reactive({
        filter(sexdata(),(Time.of.Kill %in% input$timecheck))
      })

因为 BEAR 没有作为 Time.of.Kill 的 DAWN,BEAVER 没有通过这个过滤器。

这是我的解决方案:

shinyServer(function(input, output, session, clientData) {


  Accident.Date <- as.Date(c("2018-06-04", "2018-06-05", "2018-06-06", "2018-06-07", "2018-06-08", "2018-06-09", "2018-06-10", "2018-06-11", "2018-06-12", "2018-06-13", "2018-06-14", "2018-06-15", "2018-06-16", "2018-06-17", "2018-06-18", "2018-07-18"))
  Time.of.Kill <- as.character(c("DAWN", "DAY", "DARK", "UNKNOWN", "DUSK", "DAY", "DAY", "DAWN", "DAY", "DARK", "UNKNOWN", "DUSK", "DARK", "DUSK", "DARK", "DAY"))
  Sex <- as.character(c("MALE", "MALE", "FEMALE", "MALE", "FEMALE", "FEMALE", "MALE", "MALE", "FEMALE", "FEMALE", "MALE", "FEMALE", "MALE", "FEMALE", "FEMALE", "FEMALE"))
  Age <- as.character(c("ADULT", "YOUNG", "UNKNOWN", "ADULT", "UNKNOWN", "ADULT", "YOUNG", "YOUNG", "ADULT", "ADULT", "ADULT", "YOUNG", "ADULT", "YOUNG", "YOUNG", "ADULT"))
  Species <- as.character(c("Deer", "Deer", "Deer", "Bear", "Deer", "Cougar", "Bear", "Beaver", "Deer", "Skunk", "Moose", "Deer", "Deer", "Elk", "Elk", "Elk"))
  Year <- as.numeric(c("0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0"))


  data <- data.frame(Accident.Date, Time.of.Kill, Sex, Age, Species, stringsAsFactors = FALSE)
  data <- data %>% mutate(Data.Set = "Current")

  #A set of reactive filters. Only data that has passed all filters is passed to the map, graph, datatable etc. **Order goes datacheck > yearcheck > speccheck > sexcheck > timecheck > agecheck > indaterange


  bindata <- reactive({
    filter(data, Data.Set %in% input$datacheck)
  })

  yrdata <- reactive({
    filter(bindata(), Year %in% input$yearcheck)
  })

  specdata <- reactive({
    sub <- subset(yrdata(), Species %in% input$speccheck)

  })

  sexdata <- reactive({
    filter(specdata(), Sex %in% input$sexcheck)
  })

  timedata <- reactive({
    filter(sexdata(),(Time.of.Kill %in% input$timecheck))
  })

  agedata <- reactive({
    filter(timedata(), Age %in% input$agecheck)
  })

  #Does the date range filter. Selects min and max from the two inputs of the observed indaterange filter.

  data1 <- reactive({ filter(agedata(),
                             Accident.Date >= input$inDateRange[[1]],
                             Accident.Date <= input$inDateRange[[2]])
  })

  #If statement for choosing between current and historical datasets. If current is selected, year is set to 0 and the selection box is hidden.

  observe({ if (input$datacheck == 'Current')
    updateSelectInput(session, "yearcheck", choices = c("0"), selected = c("0"))
    else
      updateSelectizeInput(session, "yearcheck", choices = sort(unique(bindata()$Year), decreasing = TRUE), server=TRUE)

  })

  observe({

    req((input$datacheck == 'Historical'))

    updateSelectizeInput(session, "speccheck", choices = sort(unique(yrdata()$Species)), server=TRUE)

  })


  #Creates the observed Species

  observeEvent(input$yearcheck, {

    x  <- input$yearcheck
    if (is.null(x))
      x <- character(0)

    updateSelectizeInput(session, "speccheck", choices = sort(unique(yrdata()$Species)), server=TRUE)

  })


  #Creates the observed Sex

  observeEvent(input$speccheck, {

    x  <- input$speccheck
    if (is.null(x))
      x <- character(0)

    updateCheckboxGroupInput(session, inputId = "sexcheck",
                             choices = unique(bindata()$Sex),
                             selected = unique(bindata()$Sex),
                             inline = TRUE)
  })


  #Creates the observed Time

  observeEvent(input$sexcheck,{

    x  <- input$sexcheck
    if (is.null(x))
      x <- character(0)

    updateCheckboxGroupInput(session, inputId = "timecheck",
                             choices = unique(bindata()$Time.of.Kill),
                             selected = unique(bindata()$Time.of.Kill),
                             inline = TRUE)
  })

  #Creates the observed Age

  observeEvent(input$timecheck,{

    x  <- input$timecheck
    if (is.null(x))
      x <- character(0)

    updateCheckboxGroupInput(session, inputId = "agecheck",
                             choices = unique(bindata()$Age),
                             selected = unique(bindata()$Age),
                             inline = TRUE)
  })

  #Creates the observed dates and suppresses warnings from the min max

  observeEvent(input$agecheck, {

    x  <- input$agecheck
    if (is.null(x))
      x <- character(0)

    #And update the date range values to match those of the dataset

    updateDateRangeInput(
      session = session,
      inputId = "inDateRange",
      start = min(suppressWarnings(bindata()$Accident.Date)),
      end = max(suppressWarnings(bindata()$Accident.Date))
    )
  })


  output$txt <-  renderText({nrow(data1())})


})

我唯一的改变是使用 bindata() 来更新复选框,这将强制显示所有动物,因此不会预先过滤任何动物。 因此,我的解决方案是放弃创建动态检查并从你第一次 select 动物时开始显示所有内容。

解决方案很明显。只需将 updateinputs 放在 observe() 中,而不是尝试观察上游输入的变化,即可获得所需的效果。这适用于所有上游更新输入。

  observe({

    x  <- input$agecheck
    if (is.null(x))
      x <- character(0)

    #And update the date range values to match those of the dataset

    updateDateRangeInput(
      session = session,
      inputId = "inDateRange",
      start = suppressWarnings(min(agedata()$Accident.Date)),
      end = suppressWarnings(max(agedata()$Accident.Date))
    )
  })

这解决了问题!