Why does this dplyr filter not work in shiny, but works fine when run without shiny?

The below code, run without Shiny, works fine for grouping data by 2 different methods of measuring time horizons (by calendar month ("Period_1") and by months elapsed since element origination ("Period_2")), and for expanding the data frame to true-up periods when grouping by 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))

Results (which are correct when running the above code):

> 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

However, when I throw the above into Shiny where the user can click on the radio button to select grouping by either Period_1 or Period_2, the App crashes. The problem appears to lie in the line if(input$grouping == 'Period_1'... because when I comment it out the App runs (but without removing the Period_1's that are NA like this line is suppose to do). How can this be fixed?

   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)

Is this closer to what you need?

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)

Your summed_data block doesn't return anything.

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

In fact should be failing with an error.

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

One way to fix that would be

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

Done there:

wrapped in braces { ... };
used the special . in the call to filter, so that it actually has data to operate on; and
added an else that returns all data otherwise.

Another method:

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

Notes:

Note that I inverted the logic. That is, your logic is to filter only if grouping is Period_1; here, input$grouping != "Period_1" returns TRUE when it is not Period_1, which means nothing in cyl == 4 will matter, all will be true; if it is Period_1, then that will return false, and then cyl == 4 will have an impact.

The other problem with your code is that you process the pipe data_Expand() %>% ... summarize(.) but because you do not capture that expression into a variable, it is never used. Like many things in R (including functions and reactive blocks), the last expression evaluated will be the return value (or whatever is in the explicit return(.) call, though often not required). In your case, the if statement is evaluated last. If the condition is true, then it tries to run filter(!is.na(Period_1)), but that has no data (it is not expressly in the pipe); if the condition is false, since there is no else block, it returns NULL (invisibly).

Try changing that block to:

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

Why does this dplyr filter not work in shiny, but works fine when run without shiny?

Related

Recent Posts