1

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:

  1. Very short MWE code that illustrates the flashing issue, contributed by ismirsehregal
  2. 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 renderUI for conditional panels in the sidebar panels like in #3 below which resolves this although it introduces other problems not explained in this post).
  3. Adaptation of #2 above where renderUI is 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)
4
  • 2
    Why do you always post bulky apps? A minimal app is enough to show the flashing issue. Commented Sep 13, 2021 at 16:55
  • 1
    That's a tough one. I'm able to reproduce this behaviour and did some tests. Besides using hidden from library(shinyjs) I don't have a UI based solution so far. I made a MWE and posted it here. If you like copy it to SO to reduce the effort for other to look into the problem. Commented Sep 14, 2021 at 7:37
  • 1
    By now I got some feedback on GitHub. Stéphane Laurent and Joe cheng provided some CSS based solutions. Also see my answer below. Commented Sep 20, 2021 at 7:12
  • I was a beginner, I have since learned to cut code back to bare-bones minimum when posting for help Commented Dec 17, 2022 at 6:58

2 Answers 2

2

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.

library(shiny)

ui <- fluidPage(
  radioButtons("yourChoice", "Display button?", choices = c("Yes", "No"), selected = "No",),
  conditionalPanel("input.yourChoice == 'Yes'", style = "display: none;", actionButton("test", "test"))
)

server <- function(input, output, session) {}

shinyApp(ui, server)

applied to @CuriousJorge-user9788072's code:

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")),
        style = "display: none;"
      ), # 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)
1

Rather use an observeEvent within the server than conditionalPanel in the ui as below (see #Added Code). I also needed to add an id to the h4() and started out with all the second tab sidebar buttons hidden upfront. Lastly I added ignoreInit = TRUE to the observeEvent as it's unnecessary initially:

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"))),
            
            h4(id = 'select', "Select:", ),
            
            hidden(sliderInput('periods','',min=1,max=120,value=60)),
            hidden(matrix1Input("base_input")),
            hidden(actionButton('showVectorBtn','Show')), 
            hidden(actionButton('hideVectorBtn','Hide')),
            hidden(actionButton('resetVectorBtn','Reset')),
            hidden(uiOutput("Vectors"))
            
            
        ), # 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


    # Added Code
    observeEvent(input$tabselected, {
        if (input$tabselected == 1) {
            show('select')
            hide('periods')
            hide("base_input")
            hide('showVectorBtn') 
            hide('hideVectorBtn')
            hide('resetVectorBtn')
        } else {
            hide('select')
            show('periods')
            show("base_input")
            show('showVectorBtn') 
            show('hideVectorBtn')
            show('resetVectorBtn')
        }
    }, ignoreInit = TRUE)
    
    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)
5
  • Eli that took quite a bit of time and diligence on your part to resolve. Sorry the code is so convoluted! Your solution works well in the scenarios I tested, so thank you! Commented Sep 15, 2021 at 8:14
  • Jorge, no problem. It actually wasn't too bad. I work with shiny quite a lot and have seen these kinds of examples before. I managed to isolate the code you were asking about quite easily. Anyway, glad to help. I do agree with Stéphane Laurent that you should simplify your code for questions in future though.
    – Eli Berkow
    Commented Sep 15, 2021 at 13:59
  • Note that this works fine in this example of only 2 tabs. However, when an App has multiple tabs this solution becomes very cumbersome with a long list of shows/hides in the "observeEvent(input$tabselected..." section. Commented Sep 17, 2021 at 9:25
  • What you could do is create a div that contains all the buttons/inputs per tab which would make it slightly better. You use its id to show or hide all.
    – Eli Berkow
    Commented Sep 19, 2021 at 14:15
  • Actually your best option is to have a tabsetPanel upfront and then each tabPanel has its own pageWithSidebar within it. Kind of the reverse of what you have. This would automatically keep each sidebar to its respective tabPanel with no extra code necessary.
    – Eli Berkow
    Commented Sep 19, 2021 at 14:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.