Update input that is outside of shiny module namespace

I want to be able to click on a polygon to update the dropdown menu. This would update the map, which gets the selected polygon from the dropdown.

Right now, clicking the map doesn't work. The leaflet map is in a module, but the dropdown is outside of it. How would I do this? Thanks.

# libraries ---------------------------------------------------------------

library(shiny)
library(sf)
library(tidyverse)
library(leaflet)

# data --------------------------------------------------------------------

# data in the sf package
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>% 
  select(NAME, AREA, SID74) %>% 
  st_transform(4326)

# names for dropdown
nc_names <- sort(unique(nc$NAME))

# modules -----------------------------------------------------------------

map_ui <- function(id) {
  ns <- NS(id)
  tagList(
    leafletOutput(ns("map"))
  )
}

map_server <- function(id, dropdown){
  moduleServer(id, function(input, output, session){
    
    output$map <- renderLeaflet({
      
      # initial map
      leaflet() %>% 
        addProviderTiles("Stamen.TonerHybrid") %>% 
        
        # base layer
        addPolygons(data = nc, 
                    fillColor =  "grey",
                    fillOpacity = 0.1,
                    weight = 1,
                    stroke = TRUE,
                    color = "black", 
                    opacity = 1,
                    layerId = ~NAME) %>% 
        
        # initial selected layer
        addPolygons(data = nc %>% filter(NAME == "Alamance"), 
                    fillColor =  "blue",
                    fillOpacity = 0.5,
                    weight = 1,
                    stroke = TRUE,
                    color = "black", 
                    opacity = 1,
                    layerId = ~NAME)
        
    })
    
    # new polygon
    new_poly <- reactive({nc %>%
        filter(NAME == dropdown())})

    # update polygon for new map
    observe({

      leafletProxy("map") %>%
        clearShapes() %>%
        # base layer
        addPolygons(data = nc, 
                    fillColor =  "grey",
                    fillOpacity = 0.1,
                    weight = 1,
                    stroke = TRUE,
                    color = "black", 
                    opacity = 1,
                    layerId = ~NAME) %>% 
        # highlighted
        addPolygons(data = new_poly(),
                    weight = 3,
                    stroke = TRUE,
                    opacity = 1,
                    fillOpacity = 0,
                    layerId = ~NAME
        )
    })
    
    # update dropdown based on clicked map (thus updating map)
    observe({
      event <- input$map_shape_click
      
      updateSelectInput(session,
                           "name", # this is not in the module
                           selected = event$id)
      
    })
    
  })
    
}

# app ---------------------------------------------------------------------

# Define UI for application that draws a histogram
ui <- fluidPage(    

  sidebarLayout(      
    sidebarPanel(
      selectInput("name",
                  label = "Name",
                  selected = nc_names[1],
                  choices = nc_names)
    ),
    
    mainPanel(
      map_ui("map")
    )
  )
)

server <- function(input, output) {
  
  # map from server
  map_server("map", dropdown = drop_val)
  
  # reactive values
  drop_val <- reactive(input$name)
  
}

shinyApp(ui, server)

Hi,
I found a way.
But it may be more look like a trick than a documented official way.
It seems session within module is of class 'session_proxy'
And if you look for 'session_proxy' in shiny github you can see that

Having this in your module works for me

    observe({
      event <- input$map_shape_click
      
      updateSelectizeInput(session = .subset2(session, "parent"),
                           "name", # this is not in the module
                           selected = event$id)
      
    })

So far, I did not use modules so I wondering if it is normal behaviour or not that session can not be passed directly as the way you did in update* function inside a module or if it is a matter of security or something alike

1 Like

I think best practice would be to have your map_server module return input$map$click as a reactive value that gets assigned to an object in your app server code. Then in your app server code the dropdown can be updated based on the returned click value.

1 Like

Thanks for the response. How would I do this though? Here is the updated code.

The click gets captured. The problem is in the return in the server.

The error on the call module is

Warning: Error in module: unused argument (childScope)

# libraries ---------------------------------------------------------------

library(shiny)
library(sf)
library(tidyverse)
library(leaflet)

# data --------------------------------------------------------------------

# data in the sf package
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>% 
    select(NAME, AREA, SID74) %>% 
    st_transform(4326)

# names for dropdown
nc_names <- sort(unique(nc$NAME))

# modules -----------------------------------------------------------------

map_ui <- function(id) {
    ns <- NS(id)
    tagList(
        leafletOutput(ns("map"))
    )
}

map_server <- function(id, dropdown){
    moduleServer(id, function(input, output, session){
        
        output$map <- renderLeaflet({
            
            # initial map
            leaflet() %>% 
                addProviderTiles("Stamen.TonerHybrid") %>% 
                
                # base layer
                addPolygons(data = nc, 
                            fillColor =  "grey",
                            fillOpacity = 0.1,
                            weight = 1,
                            stroke = TRUE,
                            color = "black", 
                            opacity = 1,
                            layerId = ~NAME) %>% 
                
                # initial selected layer
                addPolygons(data = nc %>% filter(NAME == "Alamance"), 
                            fillColor =  "blue",
                            fillOpacity = 0.5,
                            weight = 1,
                            stroke = TRUE,
                            color = "black", 
                            opacity = 1,
                            layerId = ~NAME)
            
        })
        
        # new polygon
        new_poly <- reactive({nc %>%
                filter(NAME == dropdown())})
        
        # update polygon for new map
        observe({
            
            leafletProxy("map") %>%
                clearShapes() %>%
                # base layer
                addPolygons(data = nc, 
                            fillColor =  "grey",
                            fillOpacity = 0.1,
                            weight = 1,
                            stroke = TRUE,
                            color = "black", 
                            opacity = 1,
                            layerId = ~NAME) %>% 
                # highlighted
                addPolygons(data = new_poly(),
                            weight = 3,
                            stroke = TRUE,
                            opacity = 1,
                            fillOpacity = 0,
                            layerId = ~NAME
                )
        })
        
        # observe click and return it
        observe({
            event <- input$map_shape_click

            # print(event)
            return(reactive(event))

        })
        
    })
    
}

# app ---------------------------------------------------------------------

# Define UI for application that draws a histogram
ui <- fluidPage(    
    
    sidebarLayout(      
        sidebarPanel(
            selectInput("name",
                        label = "Name",
                        selected = nc_names[1],
                        choices = nc_names)
        ),
        
        mainPanel(
            map_ui("map")
        )
    )
)

server <- function(input, output) {
    
    # reactive values
    drop_val <- reactive(input$name)
    
    # map from server
    map_server("map", dropdown = drop_val)
    
    # Calling input module.
    map_return <- callModule(map_server, "map") # Warning: Error in module: unused argument (childScope)

    # update dropdown based on clicked map (thus updating map)
    observe({
        updateSelectInput(session,
                          "name",
                          selected = map_return$id) # then this doesn't work
    })
    
}

shinyApp(ui, server)

Hope this helps you.

# libraries ---------------------------------------------------------------

library(shiny)
library(sf)
library(tidyverse)
library(leaflet)

# data --------------------------------------------------------------------

# data in the sf package
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>% 
  select(NAME, AREA, SID74) %>% 
  st_transform(4326)

# names for dropdown
nc_names <- sort(unique(nc$NAME))

# modules -----------------------------------------------------------------

map_ui <- function(id) {
  ns <- NS(id)
  tagList(
    leafletOutput(ns("map"))
  )
}

map_server <- function(id, dropdown){
  moduleServer(id, function(input, output, session){
    
    output$map <- renderLeaflet({
      
      # initial map
      leaflet() %>% 
        addProviderTiles("Stamen.TonerHybrid") %>% 
        
        # base layer
        addPolygons(data = nc, 
                    fillColor =  "grey",
                    fillOpacity = 0.1,
                    weight = 1,
                    stroke = TRUE,
                    color = "black", 
                    opacity = 1,
                    layerId = ~NAME) %>% 
        
        # initial selected layer
        addPolygons(data = nc %>% filter(NAME == "Alamance"), 
                    fillColor =  "blue",
                    fillOpacity = 0.5,
                    weight = 1,
                    stroke = TRUE,
                    color = "black", 
                    opacity = 1,
                    layerId = ~NAME)
      
    })
    
    # new polygon
    new_poly <- reactive({nc %>%
        filter(NAME == dropdown())})
    
    # update polygon for new map
    observe({
      
      leafletProxy("map") %>%
        clearShapes() %>%
        # base layer
        addPolygons(data = nc, 
                    fillColor =  "grey",
                    fillOpacity = 0.1,
                    weight = 1,
                    stroke = TRUE,
                    color = "black", 
                    opacity = 1,
                    layerId = ~NAME) %>% 
        # highlighted
        addPolygons(data = new_poly(),
                    weight = 3,
                    stroke = TRUE,
                    opacity = 1,
                    fillOpacity = 0,
                    layerId = ~NAME
        )
    })
    
    # update dropdown based on clicked map (thus updating map)
    return(reactive(input$map_shape_click$id))
      
  })
  
}

# app ---------------------------------------------------------------------

# Define UI for application that draws a histogram
ui <- fluidPage(    
  
  sidebarLayout(      
    sidebarPanel(
      selectInput("name",
                  label = "Name",
                  selected = nc_names[1],
                  choices = nc_names)
    ),
    
    mainPanel(
      map_ui("map")
    )
  )
)

server <- function(input, output,session) {
  
  # map from server
  ms_click <- map_server("map", dropdown = drop_val)
  
  # reactive values
  drop_val <- reactive(input$name)
  
  observeEvent(ms_click(),
               {
                 msc <- ms_click()
                 if(isTruthy(msc)){
                 updateSelectInput(session=session,
                                  inputId = "name",
                                  selected = msc)}})
  
}

shinyApp(ui, server)
1 Like

Great. Thanks for your help @nirgrahamuk and @gitdemont as well.

You're welcome :slight_smile:
By the way I've just looked at the reactiveValuesToList(input)
And "map_shape_click" can be accessed from server() if you append module's name (i.e. "map-map_shape_click"
As a result, you can also do it thanks to:

server <- function(input, output, session) {
  
  # reactive values
  drop_val <- reactive(input$name)
  
  # map from server
  map_server("map", dropdown = drop_val)
  
  # update dropdown based on clicked map (thus updating map)
  observe({
    updateSelectInput(session = session,
                      inputId = "name",
                      selected = input[["map-map_shape_click"]]$id)
  })
}
1 Like

Thanks. That is really useful. It also saves the need to return a value from inside the module.

# libraries ---------------------------------------------------------------

library(shiny)
library(sf)
library(tidyverse)
library(leaflet)

# data --------------------------------------------------------------------

# data in the sf package
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>% 
    select(NAME, AREA, SID74) %>% 
    st_transform(4326)

# names for dropdown
nc_names <- sort(unique(nc$NAME))

# modules -----------------------------------------------------------------

map_ui <- function(id) {
    ns <- NS(id)
    tagList(
        leafletOutput(ns("map"))
    )
}

map_server <- function(id, dropdown){
    moduleServer(id, function(input, output, session){
        
        output$map <- renderLeaflet({
            
            # initial map
            leaflet() %>% 
                addProviderTiles("Stamen.TonerHybrid") %>% 
                
                # base layer
                addPolygons(data = nc, 
                            fillColor =  "grey",
                            fillOpacity = 0.1,
                            weight = 1,
                            stroke = TRUE,
                            color = "black", 
                            opacity = 1,
                            layerId = ~NAME) %>% 
                
                # initial selected layer
                addPolygons(data = nc %>% filter(NAME == "Alamance"), 
                            fillColor =  "blue",
                            fillOpacity = 0.5,
                            weight = 1,
                            stroke = TRUE,
                            color = "black", 
                            opacity = 1,
                            layerId = ~NAME)
            
        })
        
        # new polygon
        new_poly <- reactive({nc %>%
                filter(NAME == dropdown())})
        
        # update polygon for new map
        observe({
            
            leafletProxy("map") %>%
                clearShapes() %>%
                # base layer
                addPolygons(data = nc, 
                            fillColor =  "grey",
                            fillOpacity = 0.1,
                            weight = 1,
                            stroke = TRUE,
                            color = "black", 
                            opacity = 1,
                            layerId = ~NAME) %>% 
                # highlighted
                addPolygons(data = new_poly(),
                            weight = 3,
                            stroke = TRUE,
                            opacity = 1,
                            fillOpacity = 0,
                            layerId = ~NAME
                )
        })
        
        
    })
    
}

# app ---------------------------------------------------------------------

# Define UI for application that draws a histogram
ui <- fluidPage(    
    
    sidebarLayout(      
        sidebarPanel(
            selectInput("name",
                        label = "Name",
                        selected = nc_names[1],
                        choices = nc_names)
        ),
        
        mainPanel(
            map_ui("map")
        )
    )
)

server <- function(input, output, session) {
    
    # map from server
    map_server("map", dropdown = drop_val)
    
    # reactive values
    drop_val <- reactive(input$name)
    
    # update dropdown based on clicked map (thus updating map)
    observe({
        updateSelectInput(session = session,
                          inputId = "name",
                          selected = input[["map-map_shape_click"]]$id)
    })
    
}

shinyApp(ui, server)

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.