为什么这个 dplyr 过滤器不能在有光泽的情况下工作，但在没有闪亮的情况下运行良好？

Question

下面的代码在没有 Shiny 的情况下运行，可以很好地通过 2 种不同的测量时间范围的方法（按日历月（“Period_1”）和自元素起源以来经过的月份（“Period_2”））对数据进行分组，并用于扩展按 Period_2 分组时将数据框用于校正周期：

library(tidyverse)

data <- data.frame(
    ID = c(1,1,2,2,2,2),
    Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
    Period_2 = c(1, 2, 1, 2, 3, 4),
    ColA = c(10, 20, 30, 40, 50, 52),
    ColB = c(15, 25, 35, 45, 55, 87)
    )

### Expand the dataframe to including missing rows ###
    dataExpand <- 
      data %>%
        tidyr::complete(ID, nesting(Period_2)) %>%
        tidyr::fill(ColA, ColB, .direction = "down")

### Run the expanded data frame through grouping code ###

  # Group by calendar month (Period_1)
    groupData_1 <- 
      dataExpand %>%
      group_by(Period_1) %>%
      select("ColA","ColB") %>%
      summarise(across(everything(), sum)) %>%
      filter(!is.na(Period_1)) # << Add this code to delete NA row for calendar period
      
  # Group by vintage month (Period_2)  
    groupData_2 <- 
      dataExpand %>%
      group_by(Period_2) %>%
      select("ColA","ColB") %>%
      summarise(across(everything(), sum, na.rm = TRUE)) 

结果（运行上述代码时正确）：

> groupData_1
# A tibble: 4 x 3
  Period_1  ColA  ColB
  <chr>    <dbl> <dbl>
1 2020-01     30    35
2 2020-02     40    45
3 2020-03     60    70
4 2020-04     72   112

> groupData_2
# A tibble: 4 x 3
  Period_2  ColA  ColB
     <dbl> <dbl> <dbl>
1        1    40    50
2        2    60    70
3        3    70    80
4        4    72   112

但是，当我将上述内容放入 Shiny 时，用户可以单击单选按钮选择按 Period_1 或 Period_2 分组，应用程序崩溃。问题似乎出在if(input$grouping == 'Period_1'... 行中，因为当我将其注释掉时，应用程序会运行（但没有像这条线那样删除不适用的 Period_1）。如何解决这个问题？

   library(shiny)
   library(tidyverse)
        
   ui <-
     fluidPage(
       h3("Data table:"),
       tableOutput("data"),
       h3("Sum the data table columns:"),
       radioButtons(
         inputId = "grouping",
         label = NULL,
         choiceNames = c("By period 1", "By period 2"),
         choiceValues = c("Period_1", "Period_2"),
         selected = "Period_1",
         inline = TRUE
       ),
       tableOutput("sums")
     )
        
   server <- function(input, output, session) {
     data <- reactive({
       data.frame(
         ID = c(1,1,2,2,2,2),
         Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
         Period_2 = c(1, 2, 1, 2, 3, 4),
         ColA = c(10, 20, 30, 40, 50, 52),
         ColB = c(15, 25, 35, 45, 55, 87)
       )
     })
          
     dataExpand <- reactive({
       data() %>%
       tidyr::complete(ID, nesting(Period_2)) %>%
       tidyr::fill(ColA, ColB, .direction = "down")
     })  
          
     summed_data <- reactive({
       dataExpand() %>%
         group_by(!!sym(input$grouping)) %>%
         select("ColA","ColB") %>%
         summarise(across(everything(), sum, na.rm = TRUE)) #%>%
 
         # Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
         if(input$grouping == 'Period_1'){filter(!is.na(Period_1))}
          })
          
     output$data <- renderTable(data())
     output$sums <- renderTable(summed_data())
   }
        
   shinyApp(ui, server)

Answer 1

这更接近您的需要吗？

library(shiny)
library(tidyverse)

ui <-
  fluidPage(
    h3("Data table:"),
    tableOutput("data"),
    h3("Sum the data table columns:"),
    radioButtons(
      inputId = "grouping",
      label = NULL,
      choiceNames = c("By period 1", "By period 2"),
      choiceValues = c("Period_1", "Period_2"),
      selected = "Period_1",
      inline = TRUE
    ),
    tableOutput("sums")
  )

server <- function(input, output, session) {
  data <- reactive({
    data.frame(
      ID = c(1,1,2,2,2,2),
      Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
      Period_2 = c(1, 2, 1, 2, 3, 4),
      ColA = c(10, 20, 30, 40, 50, 52),
      ColB = c(15, 25, 35, 45, 55, 87)
    )
  })
  
  dataExpand <- reactive({
    data() %>%
      tidyr::complete(ID, nesting(Period_2)) %>%
      tidyr::fill(ColA, ColB, .direction = "down")
  })  
  
  choice <- reactive(input$grouping)
  
  summed_data <- reactive({
    dataExpand() %>%
      group_by(across(choice())) %>%
      select("ColA","ColB") %>%
      summarise(across(everything(), sum, na.rm = TRUE)) |> 
      filter(across(1,.fns = ~ .x |> negate(is.na)() ))
    
    # Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
    
  })
  
  
  
  output$data <- renderTable(data())
  output$sums <- renderTable(summed_data())
}

shinyApp(ui, server)

Answer 2

您的 summed_data 块不会返回任何内容。

summed_data <- reactive({
  dataExpand() %>%
    group_by(!!sym(input$grouping)) %>%
    select("ColA","ColB") %>%
    summarise(across(everything(), sum, na.rm = TRUE)) %>%
    # Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
    if(input$grouping == 'Period_1'){ filter(!is.na(Period_1)) }
})

事实上应该是因为错误而失败。

input <- list(grouping = "Period_2")
mtcars %>%
  if (input$grouping == "Period_1") filter(cyl == 4L)
# Warning in if (.) F else filter(is.na(cyl)) :
#   the condition has length > 1 and only the first element will be used
# Error in if (.) F else filter(is.na(cyl)) : 
#   argument is not interpretable as logical

解决这个问题的一种方法是

mtcars %>%
  { if (input$grouping == "Period_1") filter(., cyl == 4) else .; }

在那里完成：

1. 用大括号包裹{ ... }；
2. 在对filter的调用中使用了特殊的.，使其实际上有数据可以操作；和
3. 添加了else，否则将返回所有数据。

另一种方法：

mtcars %>%
  filter(input$grouping != "Period_1" | cyl == 4L)

注意事项：

1. 请注意，我颠倒了逻辑。也就是说，您的逻辑是仅在分组为 Period_1 时进行过滤；在这里，input$grouping != "Period_1" 在不是 Period_1 时返回 TRUE，这意味着 cyl == 4 中的任何内容都无关紧要，一切都将是真实的；如果它是 Period_1，则返回false，然后cyl == 4会产生影响。

您的代码的另一个问题是您处理管道data_Expand() %>% ... summarize(.)，但是因为您没有将该表达式捕获到变量中，所以它永远不会被使用。像 R 中的许多东西（包括函数和反应块）一样，最后评估的表达式将是返回值（或显式 return(.) 调用中的任何内容，尽管通常不是必需的）。在您的情况下，最后评估 if 语句。如果条件为真，那么它会尝试运行filter(!is.na(Period_1))，但它没有数据（它没有明确在管道中）；如果条件为假，由于没有else 块，它返回NULL（不可见）。

尝试将该块更改为：

summed_data <- reactive({
  dataExpand() %>%
    group_by(!!sym(input$grouping)) %>%
    select("ColA","ColB") %>%
    summarise(across(everything(), sum, na.rm = TRUE)) %>%
    filter(input$grouping != "Period_1" | !is.na(Period_1))
})