New to modular programming r Shiny

shiny
1

A shiny app which I am building is growing in terms of lines and I am trying to understand how to use modules. This is how my code looks like below. What I am trying to do is add a couple of dropdowns. The first drop-down class_level is a straightforward value. But the second one selected_product depends upon what the user selects in the first dropdown. As of now, everything renders for me except for the second drop down. I want to know if what I am doing is the right way of doing things in terms of R shiny modules and what is wrong in my code that the second dropdown doesn't show up. Thank you.

EDIT: Modified the code for a reproducible code.

library(shiny)
library(shinydashboard)
library(shinyWidgets)

dropDownUI <- function(id, div_width = "col-xs-12 col-md-8") {

  ns <- NS(id)

  div(column(3, uiOutput(ns("class_level"))),
      column(
        width = 3,
        pickerInput(
          inputId = ns("selected_product"),
          label = h4("Product Family"),
          choices <- c("22","33","44"),
          width = "100%"
        )
      ))
}

dropDown <- function(input, output, session) {

  ns <- session$ns

  output$class_level <- renderUI({
    selectInput(
      ns("selected_class"),
      label = h4("Classification Level"),
      choices = list(
        "apple " = "apple",
        "orange " = "orange"),
      selected = "orange"
    )})

  observeEvent(input$class_level, {
    ns <- session$ns

    if (input$selected_class == "apple") {
      choices <- c("foo","zoo","boo")
    } else if (input$selected_class == "orange") {
      choices <- c("22","33","44")
    } else {
      choices <- c("aa","bb","cc")
    }
    updateSelectInput(session,
                      inputId = ns("selected_product"),
                      label = h4("Product Family"),
                      choices = choices)
  })
}

sidebar <- dashboardSidebar(sidebarMenu(
      menuItem("aaa",tabName = "aaa"),
      menuItem("bbb", tabName = "bbb"),
      menuItem("ccc", tabName = "ccc")
    ))

    body <-   ## Body content
      dashboardBody(tabItems(
        tabItem(tabName = "aaa",
                fluidRow(dropDownUI(id = "dropdown")),
                fluidRow(chartTableBoxUI(id = "ATC_Topline"))) # render the tabBox inside a fluidRow

      ))

    # Put them together into a dashboardPage
    ui <-   dashboardPage(
      dashboardHeader(title = "Loyalty Monthly Scorecard"),
      sidebar,
      body
    )

  server = {
    shinyServer(function(input, output, session) {

      MyData <- read.csv(file="ldb_data.csv", header=TRUE, sep=",")

      callModule(chartTableBox, id = "ATC_Topline", data = MyData)
      callModule(dropDown, id = "dropdown")

    })
  }

shinyApp(ui = ui, server = server)
2

What does your ui and server code look like when you call the modules? I see that you are using an updatePickerInput call in your your dropDown server module, but I am not seeing where you actually define the pickerInput in the first place. I am not familiar with shinyWidgets but assuming they work the same as normal shiny ui elements, you will need to actually define the ui element before you use an update*Input function on it.

3

This is how the server and ui code looks like

shinyServer(function(input, output,session) {
    MyData <- read.csv(file="ldb_data.csv", header=TRUE, sep=",")
    callModule(chartTableBox, id = "ATC_Topline", data = MyData)
  callModule(dropDown, id = "dropdown")
})```

ui.R

sidebar <- dashboardSidebar(sidebarMenu(id = "tab",
                                        menuItem("1", tabName = "1"),
                                        menuItem("2", tabName = "2"),
                                        menuItem("3", tabName = "3"),
                                        menuItem("4", tabName = "4")
                                        
))

body <-   ## Body content
  dashboardBody(tabItems(
    tabItem(tabName = "atc_topline",
            fluidRow(dropDownUI(id = "Select")),
            fluidRow(chartTableBoxUI(id = "ATC Topline")),
            fluidRow(TableBoxUI(id = "Topline"))) # render the tabBox inside a fluidRow
   )
   )
# Put them together into a dashboardPage
dashboardPage(
  dashboardHeader(title = " Scorecard"),
  sidebar,
  body
)
4

So it doesn't look like your selected_product pickerInput is defined anywhere. So it is not showing up and subsequently being updated because you never define it in the first place. If you change updatePickerInput to pickerInput then that may solve the issue.

5

So I did add an output for product (modified the module code in the original post). But now when I select a value in my first dropdown it wont update the values in the second dropdown accordingly.

6

That might have something to do with you not having defined ns in your observeEvent. Try changing it to this:

observeEvent(input$class_level, {
      ns <- session$ns
      if (input$selected_class == "apple") {
        choices <- c(
          "foo",
          "zoo",
          "boo"
        )
      } else if (input$selected_class == "orange") {
        choices <- c(
          "22",
          "33",
          "44"
        )
      } else {
        choices <- c(
          "aa",
          "bb",
          "cc"
        )
      }
      updatePickerInput(session,
                        inputId = ns("selected_product"),
                        label = h4("Product Family"),
                        choices = choices)
    })
7

I did try adding the ns and it still didnt work. Would it be something do with the id's class_level and selected_product

8

so I am not sure if updatePickerInput is meant to work with selectInput but I think you should change it from updatePickerInput to updateSelectInput. This might be the cause.

If that doesn't work, you could try moving the initial creation of the selected_product from a renderUI statement to just directly into the UI code of the module. Having both the renderUI and updateSelectInput in the server code may be causing some problems with the server just always rerendering the initial choices in the renderUI call. OR you could just get rid of the observeEvent all together and just move the logic for what choices is equal to into your initial renderUI call for selected_product.

To answer your question: no, your naming should have nothing to do with the issue unless you are naming an object one thing and then mistyping the name when you try to call the object somewhere else (which does not seem to be the case here)

9

I modified the code in the question and got it all into one app.r This is how it looks like. Got it updated to selectinput.

library(shiny)
library(shinydashboard)
library(shinyWidgets)

dropDownUI <- function(id, div_width = "col-xs-12 col-md-8") {

  ns <- NS(id)

  div(column(3, uiOutput(ns("class_level"))),
      column(
        width = 3,
        selectInput(
          inputId = ns("selected_product"),
          label = h4("Product Family"),
          choices <- c("22","33","44"),
          width = "100%"
        )
      ))
}

dropDown <- function(input, output, session) {

  ns <- session$ns

  output$class_level <- renderUI({
    selectInput(
      ns("selected_class"),
      label = h4("Classification Level"),
      choices = list(
        "apple " = "apple",
        "orange " = "orange"),
      selected = "orange"
    )})

  observeEvent(input$class_level, {
    ns <- session$ns

    if (input$selected_class == "apple") {
      choices <- c("foo","zoo","boo")
    } else if (input$selected_class == "orange") {
      choices <- c("22","33","44")
    } else {
      choices <- c("aa","bb","cc")
    }
    updateSelectInput(session,
                      inputId = ns("selected_product"),
                      label = h4("Product Family"),
                      choices = choices)
  })
}

sidebar <- dashboardSidebar(sidebarMenu(
      menuItem("aaa",tabName = "aaa"),
      menuItem("bbb", tabName = "bbb"),
      menuItem("ccc", tabName = "ccc")
    ))

    body <-   ## Body content
      dashboardBody(tabItems(
        tabItem(tabName = "aaa",
                fluidRow(dropDownUI(id = "dropdown")),
                fluidRow(chartTableBoxUI(id = "ATC_Topline"))) # render the tabBox inside a fluidRow

      ))

    # Put them together into a dashboardPage
    ui <-   dashboardPage(
      dashboardHeader(title = "Loyalty Monthly Scorecard"),
      sidebar,
      body
    )

  server = {
    shinyServer(function(input, output, session) {

      MyData <- read.csv(file="ldb_data.csv", header=TRUE, sep=",")

      callModule(chartTableBox, id = "ATC_Topline", data = MyData)
      callModule(dropDown, id = "dropdown")

    })
  }

shinyApp(ui = ui, server = server)
10

Does your updated code work?

11

It doesn't work :frowning: I have tried to render UI for second dropdown in both UI as well as server part but still doesn't get updated .

12

Well now you switched updatePickerInput to updateSelectInput as I suggested, but you changed your selectInput (initial creation of the ui element) to pickerInput. This may be causing your problem

13

Modified above and still not working

14

I made a few changes. Mainly, as suggested above, I changed the updateSelectInput inside of the observeEvent call into a selectInput in a renderUI call with the logic for what the choices should be in it. I also added a Sys.sleep(0.2) call because an error message was appearing if the renderUI call was rendering to quickly. This app appears, to me, to do what you want.

As a side note, I commented out the second module because it was not relevant to this problem and I do not have access to the csv that you are loading.

library(shiny)
library(shinydashboard)
library(shinyWidgets)

dropDownUI <- function(id, div_width = "col-xs-12 col-md-8") {
  
  ns <- NS(id)
  
  div(column(3, uiOutput(ns("class_level"))),
      column(
        width = 3,
        # selectInput(
        #   inputId = ns("selected_product"),
        #   label = h4("Product Family"),
        #   choices <- c("22","33","44"),
        #   width = "100%"
        # )
        uiOutput(ns("selected_product_ui"))
      ))
}

dropDown <- function(input, output, session) {
  
  ns <- session$ns
  
  output$class_level <- renderUI({
    selectInput(
      ns("selected_class"),
      label = h4("Classification Level"),
      choices = list(
        "apple " = "apple",
        "orange " = "orange"),
      selected = "orange"
    )})
  
  output$selected_product_ui <- renderUI({
    req(input$selected_class)
    Sys.sleep(0.2)
    ns <- session$ns
    
    if (input$selected_class == "apple") {
      my_choices <- c("foo","zoo","boo")
    } else if (input$selected_class == "orange") {
      my_choices <- c("22","33","44")
    } else {
      my_choices <- c("aa","bb","cc")
    }
    
    selectInput(inputId = ns("selected_product"),
                      label = h4("Product Family"),
                      choices = my_choices)
  })
  
}

sidebar <- dashboardSidebar(sidebarMenu(
  menuItem("aaa",tabName = "aaa"),
  menuItem("bbb", tabName = "bbb"),
  menuItem("ccc", tabName = "ccc")
))

body <-   ## Body content
  dashboardBody(tabItems(
    tabItem(tabName = "aaa",
            fluidRow(dropDownUI(id = "dropdown"))
            # fluidRow(chartTableBoxUI(id = "ATC_Topline"))) # render the tabBox inside a fluidRow
    
  )))

# Put them together into a dashboardPage
ui <-   dashboardPage(
  dashboardHeader(title = "Loyalty Monthly Scorecard"),
  sidebar,
  body
)

server = {
  shinyServer(function(input, output, session) {
    
    # MyData <- read.csv(file="ldb_data.csv", header=TRUE, sep=",")
    
    # callModule(chartTableBox, id = "ATC_Topline", data = MyData)
    callModule(dropDown, id = "dropdown")
    
  })
}

shinyApp(ui = ui, server = server)
1 Like
15

Thanks a lot @tbradley . Apart from the intro to R shiny modules on the rstudio blog is their any examples you know which I can use to understand how to modularize R shiny apps.

16

There are not a ton of resources on them, but here are a few:

3 Likes
17

Thank you @tbradley. I have one more question if that is fine. So I am trying to use selected_class into another function. But when it wont print that value in render text.

chartTableBox <- function(input, output, session, data) {
  output$selected_var <- renderText({
    ns <- session$ns
    paste("You have selected",ns(input$selected_class) )
  })
}
18

You don't need the ns around input$selected_class here. That may be causing the issue.

1 Like