This is follows up on my June 30 post where I eliminated conditionalPanel flashing in the sidebarPanel when invoking the App. The solution was to move those sidebar conditional panels into renderUI, eliminating flashing. However, I later found out that using renderUI in this manner results in other limitations. Is there any way to eliminate invocation flashing without using renderUI?
I include below 3 sets of code:
- Very short MWE code that illustrates the flashing issue, contributed by ismirsehregal
- Long, convoluted code that very clearly illustrates how all conditional panels flash by in sidepanel upon invocation, when sidebar conditional panels are rendered in UI (there is no
renderUIfor conditional panels in the sidebar panels like in #3 below which resolves this although it introduces other problems not explained in this post). - Adaptation of #2 above where
renderUIis used and there is no invocation flashing.
I didn't want to completely strip down the code in items 2 and 3, so that the sidebar panels are large enough which makes the invocation flashing more obvious. Also I when I did some stripping down of this code I did lose some functionality like "Reset", which isn't relevant to the problem at hand in any case.
Though the code in #2 and #3 may be torturously long and involved, the moving of the conditional panel into renderUI is straightforward.
No. 1 short MWE code:
library(shiny)
ui <- fluidPage(
radioButtons("yourChoice", "Display button?", choices = c("Yes", "No"), selected = "No",),
conditionalPanel("input.yourChoice == 'Yes'", actionButton("test", "test"))
# not working: ------------------------------------------------------------
# conditionalPanel("typeof input.yourChoice !== 'undefined' && input.yourChoice == 'Yes'", actionButton("test", "test"))
# conditionalPanel("typeof input !== 'undefined' && input.yourChoice == 'Yes'", actionButton("test", "test"))
)
server <- function(input, output, session) {}
shinyApp(ui, server)
No. 2 Long code without renderUI, and with sidebar invocation flashing:
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))
), # close conditional panel
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
No. 3 Long code resloving #2 with renderUI, and with no sidebar invocation flashing (leaving out custom functions since they are same as in above code):
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
uiOutput("Panels")
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
output$Panels <- renderUI({
tagList(
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))
), # close conditional panel
) # close tag list
}) # close renderUI
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
By now I got some feedback on GitHub.
The flashing can be avoided by setting
style = "display: none;".Solving this in the UI instead of using server based workarounds (@EliBerkow's answer) results in faster loading of the UI.
applied to @CuriousJorge-user9788072's code: