Проблема с несколькими реактивными фильтрами и обновлениями выбора входов - странное поведение

Question

Я изо всех сил пытаюсь решить проблему с передачей нескольких фильтров подряд, и иногда результат не соответствует ожидаемому. В приведенном ниже примере есть 7 оленей, 2 медведя, 1 пума, 1 бобр, 1 скунс, 1 лось и 3 лося. Когда вы выбираете один или несколько видов, иногда количество строк, пропущенных через фильтры, не совпадает с должным.

Например. Когда я выбираю Bear, Beaver и Cougar, он должен создать набор данных из 4 строк, однако в текстовом выводе, отображающем количество строк, отображается nrow = 3. Добавление в дополнительные выборы иногда пропускает остальные фильтры, иногда нет. Иногда при выборе Олень, где вы ожидаете 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())})


  })

щ

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")


)))

Любая помощь будет оценена. Я почесал голову на это некоторое время.

Answer 1

Решение было довольно очевидным. Желаемый эффект был получен, просто поместив входы обновления внутри наблюдателя () вместо того, чтобы пытаться наблюдать входные данные восходящего потока при их изменении. Это было применено ко всем восходящим обновлениям.

  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))
    )
  })

Это решило проблему!

Answer 2

Проблема связана с тем, как вы обновляете свой флажок. Используя ваш код: выберите сначала BEAR, результат выглядит великолепно, да, но если вы добавите BEAVER, то ничего не произойдет. Зачем? Потому что, когда ваш фильтр проходит

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

Поскольку BEAR не имеет РАССВЕТ как Time.of.Kill, 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() для обновления флажков, это заставит всех появляться, поэтому ни одно животное не будет предварительно отфильтровано. Поэтому мое решение состоит в том, чтобы отказаться от создания динамических проверок и показать все с самого первого выбора животного.