Блестящие участки по условию

Question

Я немного озадачен этим и большую часть утра искал и читал. Пробовали кое-что, но не могу понять.

Я пытаюсь создать график shiny, который создает ggplot на основе ui выбранных входов.

Вот пример того, с чем я работаю:

library(tidyverse)
library(shiny)
library(shinyWidgets)

subject <- c("A", "A", "A", "B", "B", "B", "C", "C", "C", "D", "D", "D", "E", "E")
grp <- c(rep("One", times = 6), rep("Two", times = 8))
date <- c(rep(c("8/1/2020", "8/2/2020", "8/3/2020"), times = 4), "8/1/2020", "8/2/2020")
var <- round(rnorm(n = length(subject), mean = 0, sd = 2), 3)

df <- data.frame(subject, grp, date, var)
df$date <- as.Date(df$date, "%m/%d/%Y")

Я определяю свой ui на основе выбранных мной элементов по порядку: Дата, Группа, Тема, с возможностью построения нескольких тем :

UI

ui <- fluidPage(
  
  selectInput(inputId = "date",
              label = "date",
              choices = df %>% distinct(date) %>% pull(date),
              selected = min(df$date)),
  
  selectInput(inputId = "grp",
              label = "grp",
              choices = df %>% distinct(grp) %>% pull(grp),
              selected = "One"),
  
  selectizeInput(inputId = "subject",
              label = "subject",
              choices = df %>% distinct(subject) %>% pull(subject),
              multiple = T),
  
  plotOutput(outputId = "plt")
)

В моем server я пытаюсь сделать два фильтра. Первый фильтр - получить дату и группу. второй - затем выбрать только субъектов в выбранной группе. К сожалению, shiny сохраняет все предметы.

Сервер

server <- function(input, output){
  
  output1 <- reactive({
    d <- df %>%
      filter(date == input$date,
             (grp == input$grp))
    d
  })
  
  output2 <- reactive({
    d <- output1() %>%
      filter(grp == input$grp &
               subject %in% input$subject)
    d
  })
  
  output$plt <- renderPlot({
    d <- output2()
    
    plt <- d %>%
      ggplot(aes(x = subject, y = var)) +
      geom_col()
    
    plt
  })
  
}


shinyApp(ui, server)

Я чувствую, что то, что у меня выше, довольно прямолинейно, но я не могу понять, почему он не возвращает то, что я хочу . Спасибо.

Answer 1

Две вещи:

1. Я думаю, вы пере- filter в своих двух output* блоках. Я предполагаю, что output1 должен возвращать только тот фрейм, который имеет это date, а затем убедитесь, что раскрывающееся меню grp включает только доступные группы; аналогично для второго раскрывающегося списка тем. Для этого я упрощу фильтрацию.

2. Когда вы знаете, какие группы и темы доступны, updateSelectizeInput применимое раскрывающееся меню с доступным choices. Для этого мы также добавим session к определению server.

Попробуйте следующее:

ui <- fluidPage(
  
  selectInput(inputId = "date",
              label = "date",
              choices = df %>% distinct(date) %>% pull(date),
              selected = min(df$date)),
  
  selectInput(inputId = "grp",
              label = "grp",
              choices = df %>% distinct(grp) %>% pull(grp),
              selected = "One"),
  
  selectizeInput(inputId = "subject",
              label = "subject",
              choices = df %>% distinct(subject) %>% pull(subject),
              multiple = T),
  
  plotOutput(outputId = "plt")
)

server <- function(input, output, session) {
  
  output1 <- reactive({
    d <- df %>%
      filter(date == input$date)
    updateSelectizeInput(session, "grp", choices = unique(d$grp))
    d
  })
  
  output2 <- reactive({
    d <- req(output1()) %>%
      filter(grp == input$grp)
    updateSelectizeInput(session, "subject", choices = unique(d$subject))
    d
  })
  
  output$plt <- renderPlot({
    d <- req(output2()) %>%
      filter(subject %in% input$subject)
    plt <- ggplot(d, aes(x = subject, y = var)) +
      geom_col()
    plt
  })
  
}

FYI: я также добавил вызывает req, что предотвращает запуск и завершение блоков, когда входные данные недопустимы, отсутствуют или просто нестабильны. В небольших приложениях этого обычно не происходит, но если / когда реактивность становится немного большой, это происходит достаточно часто. Даже если это происходит случайно, наличие req(...) может предотвратить временное / ненужное генерирование ошибкой renderPlot. (Это, конечно, ничему не повредит.)