Shiny DT data table with a filter and total row - large data set

[dougfir]

I am working on a Shiny App that should display a table of data.

On the app I must provide a way to show column totals. I'm finding this challenging because I must also provide column filters, so the totals must reflect the total after applying the filters.

The table i a trended metric by date, so I would like the total for each date along the top. I was looking at tibble::add_row() but was unable to get it to do what I wanted. But even if I succeed, I do not know if this total will reflect a new total when a user filters on a column.

Here is an example app using nycflights data:

library(tidyverse)
library(shiny)
library(nycflights13)
library(lubridate)

# Define UI for application that draws a histogram
ui <- fluidPage(
   
   # Application title
   titlePanel("Example Shiny App"),
   
   # Sidebar with a slider input for number of bins 
   sidebarLayout(
      sidebarPanel(
        selectInput(inputId = "group_dims", 
                    label =  "group_dims", 
                    choices = c("carrier", "origin", "dest", "tailnum"),
                    selected = c("carrier"),
                    multiple = T) # There can be only one
      ),
      
      # DT table
      mainPanel(
         DT::dataTableOutput("eg_table")
      )
   )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  
  # initial preprocessing
  my_flights <- flights %>% 
    filter(month == 11 & day >= 14) %>% # just data for 2 weeks
    mutate(date = ymd(paste(year, month, day, sep = "-"))) %>% 
    select(date, carrier, origin, dest, tailnum, distance) %>% 
    mutate(date = ordered(format(date, "%d-%b"), levels = format(sort(unique(date)), "%d-%b")))
  
  
  # recative preprocessing
  my_flights_react <- reactive({
    dims <- input$group_dims
    my_flights %>%
      group_by_at(vars(date, dims)) %>%
      summarise(distance = sum(distance)) %>%
      pivot_wider(names_from = date, values_from = distance) %>%
      replace(is.na(.), 0) %>% 
      ungroup() %>% 
      add_column(Total = rowSums(select(., -dims), na.rm = T), .after = length(dims)) %>% 
      arrange(desc(Total))# %>% 
    #add_row(Total = colSums(select(., -dims), na.rm = T))
  })

  
   output$eg_table <- DT::renderDT({my_flights_react() }, 
                                   filter = 'top', options = list(dom = 'tip',
                                                                  autoWidth = T,
                                                                  scrollX=T,
                                                                  columnDefs = list(list(width = '100px',
                                                                                         targets = 1:length(input$group_dims)))
                                                                  )
                                   )
}

# Run the application 
shinyApp(ui = ui, server = server)

If you run that app, you can see a daily trend of total flight duration. In the screen shot I have filtered on origin EWR.

How can I show a total row across the top, showing the sum of duration for each date and just ignoring the grouping variables selected by the input$group_dims?

[dougfir]

Nudging back to top.
I considered moving the filters off into their own separate non DT place up top and then creating a sum total row in my dplyr chain.
But I'd prefer to be able to use DT filters since they allow the app to load faster.
Is there a way to add a totals row to DT?

[nirgrahamuk]

library(tidyverse)
library(shiny)
library(nycflights13)
library(lubridate)
library(shinycssloaders)
# Define UI for application that draws a histogram
ui <- fluidPage(

  # Application title
  titlePanel("Example Shiny App"),

  # Sidebar with a slider input for number of bins
  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "group_dims",
        label = "group_dims",
        choices = c("carrier", "origin", "dest", "tailnum"),
        selected = c("carrier"),
        multiple = T
      ) # There can be only one
    ),

    # DT table
    mainPanel(
      DT::dataTableOutput("eg_table") %>% shinycssloaders::withSpinner()
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

  # initial preprocessing
  my_flights <- flights %>%
    filter(month == 11 & day >= 14) %>% # just data for 2 weeks
    mutate(date = ymd(paste(year, month, day, sep = "-"))) %>%
    select(date, carrier, origin, dest, tailnum, distance) %>%
    mutate(date = ordered(format(date, "%d-%b"), levels = format(sort(unique(date)), "%d-%b")))


  # recative preprocessing
  my_flights_react <- reactive({
    dims <- input$group_dims

    suppressMessages({my_flights %>%
      group_by_at(vars(date, dims)) %>%
      summarise(distance = sum(distance)) %>%
      pivot_wider(names_from = date, values_from = distance) %>%
     mutate_if(is.numeric, ~ if_else(is.na(.) ,0,.)) %>%
      ungroup() %>%
      add_column(Total = rowSums(select(., -dims), na.rm = T), .after = length(dims)) %>%
      arrange(desc(Total)) -> extable})
   if(length(dims)>0)
   {
    csums <- colSums(select(extable, -dims), na.rm = T)

    table_top <- map_dfc(csums, ~.) %>% mutate(!!sym(head(dims,1)):="Total")
    union_all(table_top, extable) %>% select(names(extable))
   } else 
   {
     extable
   }
  })


  output$eg_table <- DT::renderDT(
    {
      datatable(my_flights_react(),rownames = FALSE,
    filter = "top",
    options = list(
      dom = "tip",
      autoWidth = T,
      scrollX = T,
      columnDefs = list(list(
        width = "100px",
        targets = 1:length(input$group_dims)
      
  
      ))))
})
}
# Run the application
shinyApp(ui = ui, server = server)

[dougfir]

This does appear to work. Thank you!