在 Shiny 仪表板中刷新值框时如何避免闪烁

Question

I use shiny modules to update a large number of value boxes. The annoying part is the value boxes donot seem to scale above 10 or 20 as their updating is causing annoying flickers. Even those boxes whose values are not changing on the next invalidation, flicker. Ideally if the value is not changing the box should not refresh.

A representative shiny app using shiny modules is presented to replicate the problem. When the value of N is 4 or 5 the number of boxes are small and the updates happen instantaneously. As you increase N to 10 it gets noticeable and at N = 20 the flicker is unbearable.

### ui.R
## reprex ui.r
suppressPackageStartupMessages(library(shiny))
suppressPackageStartupMessages(library(magrittr))
suppressPackageStartupMessages(library(shinydashboard))
suppressPackageStartupMessages(library(shinydashboardPlus))
suppressPackageStartupMessages(library(lubridate))
suppressPackageStartupMessages(library(shinyjs))

ui <- dashboardPage(
        header = dashboardHeader(title = "Reprex"),
        sidebar = dashboardSidebar(
                sidebarMenu(id = "sidebar",
                            menuItem(text = "Fuel prediction",tabName = "LIVE",icon = icon("tachometer-alt"))
                )
        ), # end of sidebarMenu
        body = dashboardBody(id="body",useShinyjs(),
                             tabItems(
                                     tabItem(tabName = "LIVE",h1("FUEL DISPENSATION"),
                                             fluidRow(id = "parameters",
                                                      column(width = 2,h3("STATION")),
                                                      column(width = 2,h4("TIME UPDT")),
                                                      column(width = 2,h4("TANK LEVEL")),
                                                      column(width = 2,h4("DISPENSED")),
                                                      column(width = 2,h4("REFUELLED"))
                                             ),
                                             uiOutput("st1"),
                                             uiOutput("st2"),
                                             uiOutput("st3"),
                                             uiOutput("st4"),
                                             uiOutput("st5"),
                                             uiOutput("st6"),
                                             uiOutput("st7"),
                                             uiOutput("st8"),
                                             uiOutput("st9"),
                                             uiOutput("st10"),
                                             uiOutput("st11"),
                                             uiOutput("st12"),
                                             uiOutput("st13"),
                                             uiOutput("st14"),
                                             uiOutput("st15"),
                                             uiOutput("st16"),
                                             uiOutput("st17"),
                                             uiOutput("st18"),
                                             uiOutput("st19"),
                                             uiOutput("st20")
                                     )
                             )
        ) # End of body
) # end of dashboard page

And this is the server.R :

## reprex server.R
suppressPackageStartupMessages(library(shiny))
suppressPackageStartupMessages(library(shinydashboard))
suppressPackageStartupMessages(library(data.table))
source("modules.R")

shinyServer(function(input, output,session) {
        seqno <- reactiveVal(5)
        timer <- reactiveTimer(3000)
        observeEvent(timer(),{
                seqno((seqno() + 1))
                for(i in seq_len(N)){ ## the for loop generates all the output assignment statements using shiny module.
                        genrVB(i = i,output = output,s = seqno())
                }
        })
        
        # This is just to stop the app when session ends. Ignore for the purposes of this reprex.
        session$onSessionEnded(function() {
                print("Session ended")
                stopApp()
        })
})

And this is the modules.R

### Shiny module reprex
library(shiny)
library(purrr)
library(maps)
# take N cities and N data.tables randomly generated to serve our input data for the shiny app
N <- 4
cities <-  world.cities %>% as.data.table() %>% .$name %>% sample(N)

### Generate N simulated data.tables for the N cities.
### Notice the values of the column 2,3,4 donot change every minute.
simdata <- purrr::map(seq_len(N),
                      ~data.table(ts = seq.POSIXt(Sys.time(),by = 60,length.out = 100),
                                  fuel = rep(c(5000:5004),each = 2),
                                  out =  rep(c(100,110),each = 25),
                                  fill = rep(c(100,200),each = 10)
                                  ))

fuelrowUI <- function(id,label = "Site X",n = 1){
        ns <- NS(id)
        fluidRow(id = ns("siteid"),
                 column(2,h3(cities[n])),
                 valueBoxOutput(ns("upd"),width = 2),
                 valueBoxOutput(ns("tank"),width = 2),
                 valueBoxOutput(ns("out"),width = 2),
                 valueBoxOutput(ns("fill"),width = 2)
        )
}

fuelrowServer <- function(id,datarow=1,n = 1){
        moduleServer(id,
                     function(input,output,session){
                             output$upd <- renderValueBox(vbtime(n,k = datarow))
                             output$tank <- renderValueBox(vblevel(n,k = datarow))
                             output$out <- renderValueBox(vbout(n,k = datarow))
                             output$fill <- renderValueBox(vbin(n,k = datarow))
                     })
}

# Function to loop through the output$.. in server.R using the two shiny modules
genrVB <- function(i,s,output = output){
        stn <- paste0("st",i)
        output[[stn]] <- renderUI(fuelrowUI(stn,label = "DUMMY",n = i))
        fuelrowServer(stn,datarow = s,n = i)
}


##### Value box helper functions ##########
vblevel <- function(n = 1,k=1){
        val <- simdata[[n]][k,round(fuel,0)]
        valueBox(value = paste(val,"L"), 
                 subtitle = tags$h4(cities[n]),
                 color = case_when(
                         val < 1000 ~ "red",
                         val >= 1000 ~ "green"
                 ))
}

vbout <- function(n = 1,k=1){
        val = simdata[[n]][k,out]
        valueBox(value = paste(val,"L"), 
                 subtitle = tags$h4(cities[n]),
                 color = case_when(
                         val < 100 ~ "aqua",
                         val >= 100 ~ "purple"
                 ))
}

vbin <- function(n = 1,k=1){
        val = simdata[[n]][k,fill]
        valueBox(value = paste(val,"L"), 
                 subtitle = tags$h4(cities[n]),
                 color = case_when(
                         val < 100 ~ "teal",
                         val >= 100 ~ "olive"
                 ))
}

# Time Value box
vbtime <- function(n = 1,k = 1){
        time <-simdata[[n]][k,ts]
        timestr <- format(time,"%H:%M")
        valueBox(value = timestr,
                 subtitle = "Last Updated",color = "aqua")
}

Please load the three code sections in three files: ui.R, server.R and modules.R.

Note: In the modules.R the first line has a line N <- 4 . Please set it to 20 to see the annoying flicker.

Answer 1

If you only want to stop the flashing while recalculating all you'll have to do is adding

tags$style(".recalculating { opacity: inherit !important; }")

to your UI - taken from here .

Still I'd encourage you to simplify your app for better performance.

Here is an example for the approach I mentioned in the comments:

library(shiny)
library(shinydashboard)
library(data.table)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    tags$style(".recalculating { opacity: inherit !important; }"),
    fluidPage(
      sliderInput(
        inputId = "nBoxesRows",
        label = "rows of Boxes",
        min = 1L,
        max = 100L,
        value = 20L
      ),
      uiOutput("myValueBoxes")
      )
  )
)

server <- function(input, output, session) {
  DT <- reactive({
    invalidateLater(1000)
    data.table(replicate(4, round(runif(input$nBoxesRows), digits = 2)))
  })
  
  output$myValueBoxes <- renderUI({
    longDT <- melt(DT(), measure.vars = names(DT()))
    longDT[, subtitle := paste0(variable, "_", seq_len(.N)), by = variable]
    tagList(mapply(valueBox, subtitle = longDT$subtitle, value = longDT$value, MoreArgs = list(width = 3), SIMPLIFY = FALSE))
  })
}

shinyApp(ui, server)