1

我使用闪亮的模块来更新大量的值框。烦人的部分是值框似乎没有超过 10 或 20，因为它们的更新会导致烦人的闪烁。即使是那些在下一次失效时其值没有改变的框也会闪烁。理想情况下，如果值未更改，则框不应刷新。

提出了一个使用闪亮模块的有代表性的闪亮应用程序来复制问题。当 N 的值为 4 或 5 时，框的数量很少，并且更新会立即发生。当您将 N 增加到 10 时，它会变得很明显，并且在 N = 20 时，闪烁是无法忍受的。

### 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

这是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()
        })
})

这是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")
}

请在三个文件中加载三个代码段：ui.R、server.R 和 modules.R。

注意：在 modules.R 中，第一行有一行N <- 4。请将其设置为 20 以查看烦人的闪烁。

4

1 回答 1

1

如果您只想在重新计算时停止闪烁，您只需添加

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

到您的 UI - 取自这里。

我仍然鼓励您简化您的应用程序以获得更好的性能。

这是我在评论中提到的方法的示例：

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)
于 2021-11-14T20:11:27.187 回答