Modify a single output with different modules

[bretauv]

I am making a Shiny app in which there is a unique table and a lot of inputs to modify this table. Since almost all of these inputs are independent and I can classify them into categories, I created several modules, each containing several inputs.

However, since I have a single table to render (i.e only one tableOutput) and since I would like this table to be affected by all modules, I didn't put it in a particular UI module, but I have put one renderTable per server module.

This is a small example reproducing my situation:

library(shiny)

mod_select_ui <- function(id){
  ns <- NS(id)
  tagList(
    selectInput(ns("test_select"), "choose among mtcars", names(mtcars))
  )
}

mod_select_server <- function(input, output, session){
  output$test_mtcars <- renderTable({
    mtcars[[input$test_select]]
  }) 
}

mod_checkbox_ui <- function(id){
  ns <- NS(id)
  tagList(
    checkboxInput(ns("test_checkbox"), "only head of data")
  ) 
}

mod_checkbox_server <- function(input, output, session){
  observe({
    if(input$test_checkbox){
      output$test_mtcars <- renderTable({
        head(mtcars)
      })
    }
  })
}

ui <- fluidPage(
  mod_checkbox_ui("1"),
  mod_select_ui("1"),
  tableOutput("test_mtcars")
)

server <- function(input, output, session) {
  
  callModule(mod_select_server, "1")
  callModule(mod_checkbox_server, "1")
  
}

shinyApp(ui, server)

There are several issues in this example. The first one is that nothing is rendered because output$test_mtcars is in server modules and hence, it is expected to have the complementary tableOutput in an UI module. The second one is that I'm not sure that both renderTable will be taken into account.

Is it possible to modify this single tableOutput with several modules? Merging the different UI modules together is not an option (I have separated the inputs in modules precisely because I have a lot of them).

Also asked on StackOverflow

[nirgrahamuk]

here is how I would do it

library(shiny)

mod_select_ui <- function(id) {
  ns <- NS(id)
  tagList(
    selectInput(ns("test_select"), "choose among mtcars", names(mtcars))
  )
}

mod_select_server <- function(input, output, session) {
  mod_select <- reactive({
    req(input$test_select)
    function(x) {
      select(x, sym(input$test_select))
    }
  })
}

mod_checkbox_ui <- function(id) {
  ns <- NS(id)
  tagList(
    checkboxInput(ns("test_checkbox"), "only head of data")
  )
}

mod_checkbox_server <- function(input, output, session) {
  mod_checkbox <- reactive({
    if (input$test_checkbox) {
      function(x) {
        head(x)
      }
    } else {
      function(x) {
        identity(x)
      }
    }
  })
}

ui <- fluidPage(
  mod_checkbox_ui("1"),
  mod_select_ui("1"),
  tableOutput("test_mtcars")
)

server <- function(input, output, session) {
  selmod <- callModule(mod_select_server, "1")
  checkmod <- callModule(mod_checkbox_server, "1")

  output$test_mtcars <- renderTable({
    sm <- req(selmod())
    cm <- req(checkmod())

    mtcars %>%
      sm() %>%
      cm()
  })
}

shinyApp(ui, server)

[bretauv]

Hi @nirgrahamuk, thank you for your answer. Your code works but I can't apply it to my situation. Indeed, the example in my post is made with a dataframe and using a list of different functions on it works well, but my real situation concerns {stargazer} table. I would like to modify a stargazer table (printed in HTML) with different options.

However, your code doesn't work for this because I can't apply several times the stargazer() function in a row. The example below works when there is only one module but adding one more function breaks it (uncomment the line in renderUI to see it).

library(shiny)
library(stargazer)
library(magrittr)

mod_select_ui <- function(id) {
  ns <- NS(id)
  tagList(
    selectInput(ns("test_select"), "", 
                c("American Economic Review" = "aer", 
                  "American Journal of Political Science" = "ajps"))
  )
}

mod_select_server <- function(input, output, session) {
  reactive({
    req(input$test_select)
    function(x){
      stargazer(list(x), type = "html", style = input$test_select)
    }      
  })
}

mod_checkbox_ui <- function(id) {
  ns <- NS(id)
  tagList(
    checkboxInput(ns("test_checkbox"), "only head of data")
  )
}

mod_checkbox_server <- function(input, output, session) {
  mod_checkbox <- reactive({
    function(x){
      stargazer(list(x), type = "html", out.header = input$test_checkbox)
    }   
  })
}

ui <- fluidPage(
  mod_checkbox_ui("1"),
  mod_select_ui("1"),
  uiOutput("test_mtcars")
)

server <- function(input, output, session) {
  
  selmod <- callModule(mod_select_server, "1")
  checkmod <- callModule(mod_checkbox_server, "1")
  
  output$test_mtcars <- renderUI({
    sm <- req(selmod())
    cm <- req(checkmod())
    HTML( 
      test %>% 
        sm() # %>%
        # cm()
    )
  })
}

shinyApp(ui, server)

Again, your answer is good and works with dataframes, it's just I didn't anticipate that this solution wouldn't work with stargazer tables. Do you know how to adapt your answer to this situation?

[bretauv]

I finally found the solution, I just needed to return every input in a reactive expression in each module and use them in server part. I validate @nirgrahamuk's answer since it solves the problem detailed in my first post.

library(shiny)
library(stargazer)
library(magrittr)

test <- lm(drat ~ mpg + cyl, data = mtcars)

mod_select_ui <- function(id) {
  ns <- NS(id)
  tagList(
    selectInput(ns("test_select"), "", 
                c("American Economic Review" = "aer", 
                  "American Journal of Political Science" = "ajps"))
  )
}

mod_select_server <- function(input, output, session) {
  return(
    list(
      test_select = reactive({ input$test_select })
    )
  )
}

mod_checkbox_ui <- function(id) {
  ns <- NS(id)
  tagList(
    checkboxInput(ns("test_checkbox"), "only head of data")
  )
}

mod_checkbox_server <- function(input, output, session) {
  return(
    list(
      test_checkbox = reactive({ input$test_checkbox })
    )
  )
}

ui <- fluidPage(
  mod_select_ui("1"),
  mod_checkbox_ui("1"),
  uiOutput("test_mtcars")
)

server <- function(input, output, session) {
  
  test_modified_1 <- callModule(mod_select_server, "1")
  test_modified_2 <- callModule(mod_checkbox_server, "1")
  
  
  output$test_mtcars <- renderUI({
    HTML( 
      stargazer(test, type = "html", 
                style = test_modified_1$test_select(),
                ci = test_modified_2$test_checkbox()
                )
    )
  })
}

shinyApp(ui, server)