how to avoid flickering while refreshing valueboxes in Shiny dashboard

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.

You should avoid using so many `renderUI` calls. Put all those valueBoxes in a `tagList` and use `renderUI` once on that list. For more details you might want to [profile](https://shiny.rstudio.com/articles/profiling.html) your app. — ismirsehregal, Nov 13 '21 at 00:00
Thanks the tagList idea looks good. WIll it work with shiny modules? and will it allow dynamic shiny tags? — Lazarus Thurston, Nov 13 '21 at 04:06
A small example on how to replace the looped renderUI with a tagList would be highly appreciated. — Lazarus Thurston, Nov 13 '21 at 04:15
How do I introduce the server component inside a tagList? Refer to my this function.`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) }` — Lazarus Thurston, Nov 13 '21 at 06:32
TBH my motivation to look into your code is quite low as your example is far away from being minimal. In my eyes the problem is, that you are using a server side valueBox (`renderValueBox`) and on top you keep re-rendering it via `renderUI`. I'd try to re-render as little as possible otherwise you'll run into performance problems. — ismirsehregal, Nov 13 '21 at 18:02
I understand the code is not short enough although I tried to retain only the minimum part. Let me see if I can further reduce it. The question I have is how do I reduce a set of server side processes into one tagList and one renderUI. — Lazarus Thurston, Nov 14 '21 at 10:42

ismirsehregal · Accepted Answer · 2021-11-14T20:21:53.160

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)

This was a brilliant hack. The boxes update invisibly now. That's exactly what I wanted. But you have rightly said that I have to make the app more efficient (render once only rather than 30 times). At the moment you @ismir have spoilt me with this hack :-).. Let me try to understand your tagList solution too. — Lazarus Thurston, Nov 15 '21 at 08:34

how to avoid flickering while refreshing valueboxes in Shiny dashboard

1 Answers1