CODEWITHSUNDEEP
rshiny
Curious Jorge - user9788072
Curious Jorge - user9788072

Reputation: 2710

How to set a single observeEvent to trigger multiple plots in r shiny?

The MWE code below works as intended, except that I would like the default output to be of 2 plots, "graph1" and "graph2", graph1 stacked on top of graph2. As coded below, only graph1 is shown by default. How would I change this so both plots are shown by default when the App is invoked, vertically stacked?

If possible I would like to do this without additional packages, keeping things in native R/Shiny. For now plots will be simple.

In the full App, there will be 5 plots to show, all vertically stacked.

As you can see below in the Server section, observeEvent(input$showVectorPlotBtn,...) successfully and reactively triggers graph1. In the line immediately below that, commented out because it does nothing, is my attempt to also have that same observeEvent trigger graph2. Further above that, see my line of code: output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector1_input()))), which also does nothing though I was hoping it and the preceding would generate the 2 plots simultaneously.

Please, any advice?

MWE code:

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)

matrix1.input <- function(x){
  matrixInput(x, 
              value = matrix(c(0.2), 2, 1, dimnames = list(c("A","B"),NULL)),
              rows = list(extend = FALSE,  names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

matrix2.input <- 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")}  

matrix.validate <- 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)}

vector.base <- function(x,y){
  a <- rep(y,x) 
  b <- seq(1:x) 
  c <- data.frame(x = b, y = a) 
  return(c)}

vector.multi <- 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)}

vector.multiFinal <- function(x,y){
  vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}

matrix.link <- 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"))))})}

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(
      uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 actionButton('showVectorPlotBtn','Vector plots'),
                 actionButton('showVectorValueBtn','Vector values'),
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  periods       <- reactive(input$periods)
  base_input    <- reactive(input$base_input)
  vector_input  <- reactive(input$vector_input)
  vector1_input <- reactive(input$vector1_input)
  yld           <- reactiveValues()
  
  vectorVariable <- function(x,y){
    if(input$showVectorBtn == 0) vector.base(input$periods,x)
    else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show'), 
        actionButton('hideVectorBtn','Hide'),
        actionButton('resetVectorBtn','Reset'),
        hidden(uiOutput("Vectors"))
      ) # close conditional panel
    ) # close tagList
  }) # close renderUI
  
  renderUI({
    matrix.link("vector_input",input$base_input[1,1])
    matrix.link("vector1_input",input$base_input[2,1])
    })
  
  output$Vectors <- renderUI({input$resetVectorBtn
    tagList(
      matrix2.input("vector_input",input$periods,input$base_input[1,1]),
      matrix2.input("vector1_input",input$periods,input$base_input[2,1])
      )
    })
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector_input())))
  output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector1_input())))
  
  output$table1 <- renderDT({vectorsAll()})
  
  observeEvent(input$showVectorPlotBtn,{yld$showme <- plotOutput("graph1")},ignoreNULL = FALSE)
  # observeEvent(input$showVectorPlotBtn,{yld$showme <- plotOutput("graph2")},ignoreNULL = FALSE)
  observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})
  
  output$vectorTable <- renderUI({yld$showme})
  
  vectorsAll <- reactive({
    cbind(1:periods(),
          vectorVariable(input$base_input[1,1],vector_input())[,2],
          vectorVariable(input$base_input[2,1],vector1_input())[,2]
    ) # close cbind
  }) # close reactive
}) # close server

shinyApp(ui, server)

Upvotes: 0

Views: 472

Answers (1)

ismirsehregal
ismirsehregal

Reputation: 33407

You can use tagList to pass multiple UI outputs to renderUI.

Please check the following:

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)

matrix1.input <- function(x){
  matrixInput(x, 
              value = matrix(c(0.2), 2, 1, dimnames = list(c("A","B"),NULL)),
              rows = list(extend = FALSE,  names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

matrix2.input <- 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")}  

matrix.validate <- 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)}

vector.base <- function(x,y){
  a <- rep(y,x) 
  b <- seq(1:x) 
  c <- data.frame(x = b, y = a) 
  return(c)}

vector.multi <- 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)}

vector.multiFinal <- function(x,y){
  vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}

matrix.link <- 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"))))})}

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(
      uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 actionButton('showVectorPlotBtn','Vector plots'),
                 actionButton('showVectorValueBtn','Vector values'),
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  periods       <- reactive(input$periods)
  base_input    <- reactive(input$base_input)
  vector_input  <- reactive(input$vector_input)
  vector1_input <- reactive(input$vector1_input)
  yld           <- reactiveValues()
  
  vectorVariable <- function(x,y){
    if(input$showVectorBtn == 0) vector.base(input$periods,x)
    else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show'), 
        actionButton('hideVectorBtn','Hide'),
        actionButton('resetVectorBtn','Reset'),
        hidden(uiOutput("Vectors"))
      ) # close conditional panel
    ) # close tagList
  }) # close renderUI
  
  renderUI({
    matrix.link("vector_input",input$base_input[1,1])
    matrix.link("vector1_input",input$base_input[2,1])
  })
  
  output$Vectors <- renderUI({input$resetVectorBtn
    tagList(
      matrix2.input("vector_input",input$periods,input$base_input[1,1]),
      matrix2.input("vector1_input",input$periods,input$base_input[2,1])
    )
  })
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector_input())))
  output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector1_input())))
  
  output$table1 <- renderDT({vectorsAll()})
  
  observeEvent(input$showVectorPlotBtn,{yld$showme <- tagList(plotOutput("graph1"), plotOutput("graph2"))},ignoreNULL = FALSE)
  observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})
  
  output$vectorTable <- renderUI({yld$showme})
  
  vectorsAll <- reactive({
    cbind(1:periods(),
          vectorVariable(input$base_input[1,1],vector_input())[,2],
          vectorVariable(input$base_input[2,1],vector1_input())[,2]
    ) # close cbind
  }) # close reactive
}) # close server

shinyApp(ui, server)

Upvotes: 1

Related Questions