0

I am facing an issue in updating the data selected using SelectInput and modules in Shiny. In a few words, when I select the data to be loaded into the selectInput panel, it updates it on the first selection, but if I then want to go from dataset 1 to dataset 2, the data does not update. Below you cand find the code to reproduce the specific problem.

# Libraries

pacman::p_load(shiny, shinydashboard,
              tidyverse, data.table, DT, stringr,
              ggplot2, plotly,
              survival, survminer, GGally, scales,
              shinycssloaders)

version <- 0.1

# GENERAL PARAMETERS

box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12

# Data

men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(50, mean = 1))
men1_2.pois <<- as.numeric(rpois(50, lambda = 2))

# ui modules

LoadDataUI <- function(id, 
                      label = "Select the data:", 
                      sel = "Data 1", 
                      choic = c('Data 1','Data 2')){
 ns <- NS(id)
 selectInput(ns("data.sel"),
             label = label,
             choices = choic,
             selected = sel)
}

PlotUI <- function(id){
 ns <- NS(id)
 plotOutput(ns("plot"))
}

# ui

ui <- dashboardPage(
 dashboardHeader(title = paste('My Dashboard',version,sep='')),
 dashboardSidebar(
   sidebarMenu(
     id = "sbMenu",
     #Tabs for different data displays
     menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
   )
 ),
 dashboardBody(
   tabItems(
     tabItem(tabName = 'men1',
             h2(strong('tab 1')),
             fluidRow(
               ### !!!! TO REMOVE ERROR MESSAGES !!!!
               # tags$style(type="text/css",
               #            ".shiny-output-error { visibility: hidden; }",
               #            ".shiny-output-error:before { visibility: hidden; }"
               #,
               box(title='Select data to load:', height= select.box.height, width = select.box.width,
                   LoadDataUI("data1")
               ),
               box(title='Normal', height=box.height,
                   PlotUI("hist_norm1")
               ),
               box(title='Poisson', height=box.height,
                   PlotUI("hist_pois1")
               )
             )
         
     )
   )
 )
)


# server modules

Panel <- function(id){
 moduleServer(
   id,
   function(input, output, session) {
     return(
       list(
         data = reactive({input$data.sel})
       )
     )
   }
 )
}

LoadDataServer <- function(id, menu, data_selected
){
 moduleServer(
   id,
   function(input, output, session){
     dt <- reactive(data_selected)
     data <- reactiveValues(norm = NULL,
                            pois = NULL)
     data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
     data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
     return(
       data
     )
   }
 )
}


PlotServer <- function(id,data = NULL){
 moduleServer(
   id,
   function(input, output, session) {
     x <- reactive(as.numeric(data))
     output$plot <- renderPlot({
       hist(x(), col = 'darkgray', border = 'white')
     })
     # output$plot <- renderPlot({
     #   if(is.null(data)){return(NULL)}else{
     #       hist(data, col = 'darkgray', border = 'white')}
     # })
   }
 )
}


# server

server <- function(input, output, session){
 data1 <- Panel("data1")
 observeEvent(data1$data(), {
   updateSelectInput(session, 'data.sel', selected = input$data.sel)
 })
 pnl1 <- reactive(
   switch(data1$data(),
          "Data 1" = "1",
          "Data 2" = "2")
 )
 d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = pnl1())

 # Plot

 # menu1
 output$plot <- PlotServer("hist_norm1", data = d1$norm())
 output$plot <- PlotServer("hist_pois1", data = d1$pois())
}

shinyApp(ui, server)

Thanks!

giulia
  • 63
  • 1
  • 6

2 Answers2

1

Try this

version <- 0.1

# GENERAL PARAMETERS

box.height <<- 500
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12

# Data

men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(150, mean = 1))
men1_2.pois <<- as.numeric(rpois(150, lambda = 2))
# ui modules

LoadDataUI <- function(id, 
                       label = "Select the data:", 
                       sel = "Data 1", 
                       choic = c('Data 1','Data 2')){
  ns <- NS(id)
  selectInput(ns("data.sel"),
              label = label,
              choices = choic,
              selected = sel)
}

PlotUI <- function(id){
  ns <- NS(id)
  tagList(
    plotOutput(ns("plot"))
  )
  
  
}

# ui

ui <- dashboardPage(
  dashboardHeader(title = paste('My Dashboard',version,sep='')),
  dashboardSidebar(
    sidebarMenu(
      id = "sbMenu",
      #Tabs for different data displays
      menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
    )
  ),
  dashboardBody(
    tabItems(
      tabItem(tabName = 'men1',
              h2(strong('tab 1')),
              fluidRow(
                ### !!!! TO REMOVE ERROR MESSAGES !!!!
                # tags$style(type="text/css",
                #            ".shiny-output-error { visibility: hidden; }",
                #            ".shiny-output-error:before { visibility: hidden; }"
                #,
                box(title='Select data to load:', height= select.box.height, width = select.box.width,
                    LoadDataUI("data1")
                ),
                box(title='Normal', height=box.height,
                    PlotUI("hist_norm1")
                ),
                box(title='Poisson', height=box.height,
                    PlotUI("hist_pois1")
                )
              )
              
      )
    )
  )
)


# server modules

Panel <- function(id){
  moduleServer(
    id,
    function(input, output, session) {
      return(
        list(
          data = reactive({input$data.sel})
        )
      )
    }
  )
}

LoadDataServer <- function(id, menu, data_selected
){
  moduleServer(
    id,
    function(input, output, session){
      dt <- reactive(
        switch(data_selected(),
               "Data 1" = "1",
               "Data 2" = "2")
      )
      observe({print(dt())})
      data <- reactiveValues(norm = NULL,
                             pois = NULL)
      data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
      data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
      return(
        data
      )
    }
  )
}


PlotServer <- function(id,data){
  moduleServer(
    id,
    function(input, output, session) {
      #x <- reactive(as.numeric(data))
      
      output$plot <- renderPlot({
        x <- as.numeric(data())
        hist(x, col = 'darkgray', border = 'white')
      })
      # output$plot <- renderPlot({
      #   if(is.null(data)){return(NULL)}else{
      #       hist(data, col = 'darkgray', border = 'white')}
      # })
    }
  )
}


# server

server <- function(input, output, session){
  data1 <- Panel("data1")
  # observeEvent(data1$data(), {
  #   updateSelectInput(session, 'data.sel', selected = input$data.sel)
  # })
  
  # pnl1 <- reactive(
  #   switch(data1$data(),
  #          "Data 1" = "1",
  #          "Data 2" = "2")
  # )
  d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = data1$data )
  
  # Plot
  
  # menu1
  PlotServer("hist_norm1", data = reactive(d1$norm()) )
  PlotServer("hist_pois1", data = reactive(d1$pois()) )
}

shinyApp(ui, server)
YBS
  • 19,324
  • 2
  • 9
  • 27
0

The problem arises because the data you pass to the PlotServer is not reactive. I've made the additional changes:

  • stored the data in the beginning in a list to avoid using get; it's easier and safer to directly work with a data object
  • removed the data_selected argument from the LoadDataServer as this information is determined by the input$data.sel variable, however this is only accessible from within the module and not the the main app server. For the initialisation, you need this information only in the UI part of the module (which you already have implemented). This allows me to remove observeEvent code in your main app server as this is handled by the module.
# Libraries

# pacman::p_load(shiny, shinydashboard,
#                tidyverse, data.table, DT, stringr,
#                ggplot2, plotly,
#                survival, survminer, GGally, scales,
#                shinycssloaders)

library(shiny)
library(shinydashboard)
library(ggplot2)

version <- 0.1

# GENERAL PARAMETERS

box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12

# Data

data_object <- list(
  men1_1 = list(
    norm = as.numeric(rnorm(50)),
    pois = as.numeric(rpois(50, lambda = 1))
  ),
  men1_2 = list(
    norm = as.numeric(rnorm(50, mean = 1)),
    pois = as.numeric(rpois(50, lambda = 2))
  )
)

# ui modules

LoadDataUI <- function(id, 
                       label = "Select the data:", 
                       sel = "Data 1", 
                       choic = c('Data 1' = "1",'Data 2'  = "2")){
  ns <- NS(id)
  selectInput(ns("data.sel"),
              label = label,
              choices = choic,
              selected = sel)
}

PlotUI <- function(id){
  ns <- NS(id)
  plotOutput(ns("plot"))
}

# ui

ui <- dashboardPage(
  dashboardHeader(title = paste('My Dashboard',version,sep='')),
  dashboardSidebar(
    sidebarMenu(
      id = "sbMenu",
      #Tabs for different data displays
      menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
    )
  ),
  dashboardBody(
    tabItems(
      tabItem(tabName = 'men1',
              h2(strong('tab 1')),
              fluidRow(
                ### !!!! TO REMOVE ERROR MESSAGES !!!!
                # tags$style(type="text/css",
                #            ".shiny-output-error { visibility: hidden; }",
                #            ".shiny-output-error:before { visibility: hidden; }"
                #,
                box(title='Select data to load:', height= select.box.height, width = select.box.width,
                    LoadDataUI("data1")
                ),
                box(title='Normal', height=box.height,
                    PlotUI("hist_norm1")
                ),
                box(title='Poisson', height=box.height,
                    PlotUI("hist_pois1")
                )
              )
              
      )
    )
  )
)


# server modules

Panel <- function(id){
  moduleServer(
    id,
    function(input, output, session) {
      return(
        list(
          data = reactive({input$data.sel})
        )
      )
    }
  )
}

LoadDataServer <- function(id, menu
){
  moduleServer(
    id,
    function(input, output, session){
      
      data <- reactiveValues(norm = NULL,
                             pois = NULL)
      observeEvent(input$data.sel, {
        data$norm <- data_object[[paste0(menu(), "_", input$data.sel)]][["norm"]]
        data$pois <- data_object[[paste0(menu(), "_", input$data.sel)]][["pois"]]
      }) 
      
      return(
        data
      )
    }
  )
}


PlotServer <- function(id,data = NULL){
  moduleServer(
    id,
    function(input, output, session) {
      output$plot <- renderPlot({
        hist(data(), col = 'darkgray', border = 'white')
      })
    }
  )
}


# server

server <- function(input, output, session){
  
  d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}))
  
  # Plot
  
  # menu1
  output$plot <- PlotServer("hist_norm1", data = reactive({d1$norm}))
  output$plot <- PlotServer("hist_pois1", data = reactive({d1$pois}))
}

shinyApp(ui, server)

If you pass the complete d1 object to the PlotServer, you could remove the reactive({}) you currently need to pass the norm or pois data.

I recommend to read into how to pass data between modules and module capsulation, you can start with mastering shiny or my introduction to modules.

starja
  • 9,887
  • 1
  • 13
  • 28