Overlaying sidebar using shinydashboard and addSidebar

[svenb78]

Hi,

my problem is not easy to describe but I will do my best.

I use golem for a modularized shiny app, and within app_ui.R I define a sidebar:

 , sidebar = shinydashboardPlus::dashboardSidebar(

        shinydashboard::sidebarMenu(

          id = "mainSidebar", ...)

Now, I would like to integrate a shinydashboard::menuItem() with a leaflet map having its own sidebar. For testing, I used the build-in leaflet.extras2::addSidebar() example which can be found via:

paste0(system.file("examples", package = "leaflet.extras2"),
              "/sidebar_app.R")

In the result, the leaflet sidebar overlays the dashboard sidebar (mainSidebar), even if I use a different id for the leaflet sidebar, e.g. leaflet.extras2::sidebar_tabs(id = ns("mysidebarid"), ...) .

Within the help page of leaflet.extras2::sidebar_pane() I find

Value A shiny.tag with sidebar-specific HTML classes

, and I think, that is the problem. But how can I solve this?

[trafficonese]

Could you maybe come up with a minimal reproducible example? That would make it much easier to debug.

[svenb78]

I tried. The examples takes the leaflet.extras2 example named sidebar_app.R and "frames" it by shinydashboardPlus::dashboardSidebar code. Looks not nice but rare. :-)

library(sf)
library(shiny)
library(leaflet)
library(leaflet.extras2)

data(breweries91, package = "leaflet")

ui <- shinydashboardPlus::dashboardPage(

  header = shinydashboardPlus::dashboardHeader(title = "Test Leaflet"), 

  sidebar = shinydashboardPlus::dashboardSidebar(
    shinydashboard::sidebarMenu(
      shinydashboard::menuItem(
        text = "leaflet Test"
        , tabName = "leaflet_test"
        , icon = icon("angry")
        , badgeLabel = "test"
        , badgeColor = "blue"
      ),
      shinydashboard::menuItem(
        text = "another Tab"
        , tabName = "another_tab"
        , icon = icon("bell")
        , badgeLabel = "tab"
        , badgeColor = "green"
      ), 
      shinydashboard::menuItem(
        text = "a third tab"
        , tabName = "third_tab"
        , icon = icon("address-card")
        , badgeLabel = "tab3"
        , badgeColor = "yellow"
      )
    )
  ), 

  body = shinydashboard::dashboardBody(

    shinydashboard::tabItems(

      shinydashboard::tabItem(
        tabName = "leaflet_test",
  fluidPage(
  tags$head(tags$style(".btn-default {display: block;}")),
  h4("Leaflet Sidebar Plugin"),
  splitLayout(cellWidths = c("20%", "80%"),
              tagList(
                actionButton("open", "Open Sidebar"),
                actionButton("close", "Close Sidebar"),
                actionButton("clear", "Clear Sidebar")
              ),
              tagList(
                sidebar_tabs(id = "mysidebarid",
                             list(icon("car"), icon("user"), icon("envelope")),
                             sidebar_pane(
                               title = "home", id = "home_id", icon = icon("home"),
                               tagList(
                                 sliderInput("obs", "Number of observations:",
                                             min = 1, max = 32, value = 10),
                                 sliderInput("opa", "Point Opacity:",
                                             min = 0, max = 1, value = 0.5),
                                 sliderInput("fillopa", "Fill Opacity:",
                                             min = 0, max = 1, value = 0.2),
                                 dateRangeInput("daterange4", "Date range:",
                                                start = Sys.Date() - 10,
                                                end = Sys.Date() + 10),
                                 verbatimTextOutput("tab1")
                               )
                             ),
                             sidebar_pane(
                               title = "profile", id = "profile_id", icon = icon("wrench"),
                               tagList(
                                 textInput("caption", "Caption", "Data Summary"),
                                 selectInput("label", "Label",
                                             choices = c("brewery", "address",
                                                         "zipcode", "village")),
                                 passwordInput("password", "Password:"),
                                 actionButton("go", "Go"),
                                 verbatimTextOutput("value")
                               )
                             ),
                             sidebar_pane(
                               title = "messages", id = "messages_id",
                               icon = icon("person", verify_fa = FALSE),
                               tagList(
                                 checkboxGroupInput("variable", "Variables to show:",
                                                    c("Cylinders" = "cyl",
                                                      "Transmission" = "am",
                                                      "Gears" = "gear")),
                                 tableOutput("data")
                               )
                             )
                ),
                leafletOutput("map", height = "700px")
              )
            )
          )
        )
      )
    )
  )

server <- function(input, output, session) {
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%
      addSidebar(
        id = "mysidebarid",
        options = list(position = "left")
      )
  })
  observe({
    req(input$obs)
    df <- breweries91[sample.int(nrow(breweries91), input$obs), ]
    bbox <- suppressWarnings(st_bbox(df))
    leafletProxy("map", session) %>%
      clearGroup("pts") %>%
      addCircleMarkers(data = df,
                       label = df[[input$label]],
                       opacity = input$opa,
                       fillOpacity = input$fillopa,
                       group = "pts") %>%
      fitBounds(bbox[[1]], bbox[[2]], bbox[[3]], bbox[[4]])
  })

  output$tab1 <- renderText({
    input$obs
  })
  output$value <- renderText({
    req(input$go)
    isolate(input$password)
  })
  output$data <- renderTable(rownames = FALSE, {
    mtcars[, c("mpg", input$variable), drop = FALSE]
  })

  observeEvent(input$open, {
    leafletProxy("map", session) %>%
      openSidebar(sample(c("home_id","profile_id","messages_id"), 1))
  })
  observeEvent(input$close, {
    leafletProxy("map", session) %>%
      closeSidebar()
  })
  observeEvent(input$clear, {
    leafletProxy("map", session) %>%
      removeSidebar()
  })
}
shinyApp(ui, server)

[trafficonese]

I just pushed a commit to the sidebar branch, where I changed the CSS-classes.

Can you try if that fixes your problem?

remotes::install_github("trafficonese/leaflet.extras2@sidebar")

[svenb78]

It looks like. :-) The above example works, and -- at a first glance -- also the more complex golem app. Tank you!

Annotation: After using remotes::install_github() and running the app on a Ubuntu server, I got an error message lazy-load database '/[PATH_TO_R_LIBRARIES]/leaflet.extras2.rdb' is corrupt. The error disappeared after re-installing leaflet.extras2 and again remotes::install_github(). The error did not come up on a Windows machine with a local RStudio version.

[trafficonese]

Awesome, I'll check it a bit more and then merge it to the main branch

[svenb78]

I still have a problem. The code (golem module):

#' leaflet_test UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#' 
#' @import leaflet leaflet.extras2 sf
#'
#' @importFrom shiny NS tagList 
mod_leaflet_test_ui <- function(id){
  ns <- NS(id)
  tagList(

    fluidPage(

      leaflet.extras2::sidebar_tabs(
        id = ns("mySide")
        , iconList = list(icon("car"))
        , leaflet.extras2::sidebar_pane(
          title = "home"
          , id = ns("home_id")
          , icon = icon("home")
          , sliderInput(
            inputId = "slider_1"
            , label = "Input"
            , min = 1
            , max = 10 
            , value = 5
          )
        )
      )
      , leaflet::leafletOutput(outputId = ns("map"))

    )

    , sliderInput(
      inputId = "slider_2"
      , label = "Input"
      , min = 1
      , max = 10 
      , value = 5
    )

  )
}

#' leaflet_test Server Functions
#'
#' @noRd 
mod_leaflet_test_server <- function(id){
  moduleServer( id, function(input, output, session){
    ns <- session$ns

    output$map <- renderLeaflet({
      leaflet() %>%
        leaflet::setView(lng = 7.943808, lat = 50.491119, zoom = 10) %>% 
        leaflet::addProviderTiles(leaflet::providers$OpenStreetMap, group = "Open Street Map") %>% 
        leaflet.extras2::addSidebar(
          id = "mySide",
          options = list(position = "left")
        ) %>%
        leaflet.extras2::openSidebar(id = "mySide")
    })

  })
}

## To be copied in the UI
# mod_leaflet_test_ui("leaflet_test_ui_1")

## To be copied in the server
# mod_leaflet_test_server("leaflet_test_ui_1")

The result:

The rendering is no longer weird, but the leaflet sidebar does not appear. Where is my mistake?

[trafficonese]

I dont really know anything about golem, but if you can make a reproducile example with shiny modules I'm glad to help.

[svenb78]

I created a modularized mini example without golem, and that worked fine. Your solution also works within a mini app made with golem. So, I think, in my case might emerge some undesired interactions with other modules or configs which seems not to be an issue of your package. Good for you, bad for me. :-)

[svenb78]

Hi,

I found out, that the issue might be namespacing. Within my golem app, I use multiple leaflets on different menu items. Inspecting the HTML code, I saw that my leaflet sidebar contents are assigned to a wrong leaflet, indeed a leaflet at a totally different menu item. So, I extended my mini examples by another leaflet, and see: The same problem. I came across with https://stackoverflow.com/questions/70532084/reference-to-a-leaflet-map-from-a-golem-module-to-another, what does not describe exactly my problem, because I don't want to reference to another module. But it seems to be connected, for what reason I experimented with ns() and the id-extension (see second paragraph of the answer in the link), but it did not work. A second issue might be some interference between shinydashboard::menuItem and leaflet.extras2::menuItem.

Next you find a mini example with two leaflets. Switch between the corresponding menu items and you will see the problem.

library(sf)
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(leaflet)
library(leaflet.extras2)

counterButton <- function(id, label = "Counter") {
  ns <- NS(id)
  tagList(
    actionButton(ns("button"), label = label),
    verbatimTextOutput(ns("out"))
  )
}

counterServer <- function(id) {
  moduleServer(
    id,
    function(input, output, session) {
      count <- reactiveVal(0)
      observeEvent(input$button, {
        count(count() + 1)
      })
      output$out <- renderText({
        count()
      })
      count
    }
  )
}

mod_leaflet_test_ui <- function(id){
  ns <- NS(id)
  tagList(

    fluidPage(
      tags$head(tags$style(".btn-default {display: block;}")),
      h4("Leaflet Sidebar Plugin"),
      splitLayout(cellWidths = c("20%", "80%"),
                  tagList(
                    actionButton(ns("open"), "Open Sidebar"),
                    actionButton(ns("close"), "Close Sidebar"),
                  ),
                  tagList(
                    sidebar_tabs(id = ns("mysidebarid"),
                                 list(icon("car"), icon("user"), icon("envelope")),
                                 sidebar_pane(
                                   title = "home", id = ns("home_id"), icon = icon("home"),
                                   tagList(
                                     sliderInput(ns("obs"), "Number of observations:",
                                                 min = 1, max = 32, value = 10),
                                     sliderInput(ns("opa"), "Point Opacity:",
                                                 min = 0, max = 1, value = 0.5),
                                     sliderInput(ns("fillopa"), "Fill Opacity:",
                                                 min = 0, max = 1, value = 0.2),
                                     dateRangeInput(ns("daterange4"), "Date range:",
                                                    start = Sys.Date() - 10,
                                                    end = Sys.Date() + 10),
                                     verbatimTextOutput(ns("tab1"))
                                   )
                                 ),
                                 sidebar_pane(
                                   title = "profile", id = ns("profile_id"), icon = icon("wrench"),
                                   tagList(
                                     textInput(ns("caption"), "Caption", "Data Summary"),
                                     selectInput(ns("label"), "Label",
                                                 choices = c("brewery", "address",
                                                             "zipcode", "village")),
                                     passwordInput(ns("password"), "Password:"),
                                     actionButton(ns("go"), "Go"),
                                     verbatimTextOutput(ns("value"))
                                   )
                                 ),
                                 sidebar_pane(
                                   title = "messages", ns(id = "messages_id"),
                                   icon = icon("person", verify_fa = FALSE),
                                   tagList(
                                     checkboxGroupInput(ns("variable"), "Variables to show:",
                                                        c("Cylinders" = "cyl",
                                                          "Transmission" = "am",
                                                          "Gears" = "gear")),
                                     tableOutput(ns("data"))
                                   )
                                 )
                    ),
                    leafletOutput(ns("map"), height = "700px")
                  )
      )
    )

  )
}

mod_leaflet_test_server <- function(id){
  moduleServer( id, function(input, output, session){
    ns <- session$ns

    output$map <- renderLeaflet({
      leaflet() %>%
        addTiles() %>%
        addSidebar(
          id = "mysidebarid",
          options = list(position = "left")
        )
    })
    observe({
      req(input$obs)
      tmp_df <- leaflet::breweries91
      df <- tmp_df[sample.int(nrow(tmp_df), input$obs), ]
      bbox <- suppressWarnings(st_bbox(df))
      leafletProxy("map", session) %>%
        clearGroup("pts") %>%
        addCircleMarkers(data = df,
                         label = df[[input$label]],
                         opacity = input$opa,
                         fillOpacity = input$fillopa,
                         group = "pts") %>%
        fitBounds(bbox[[1]], bbox[[2]], bbox[[3]], bbox[[4]])
    })

    output$tab1 <- renderText({
      input$obs
    })
    output$value <- renderText({
      req(input$go)
      isolate(input$password)
    })
    output$data <- renderTable(rownames = FALSE, {
      mtcars[, c("mpg", input$variable), drop = FALSE]
    })

    observeEvent(input$open, {
      leafletProxy("map", session) %>%
        openSidebar(sample(c("home_id","profile_id","messages_id"), 1))
    })
    observeEvent(input$close, {
      leafletProxy("map", session) %>%
        closeSidebar()
    })

  })
}

mod_another_leaflet_ui <- function(id){
  ns <- NS(id)
  tagList(

    fluidPage(

      leaflet::leafletOutput(outputId = ns("another_leaf"))

    )

  )
}

mod_another_leaflet_server <- function(id){
  moduleServer( id, function(input, output, session){
    ns <- session$ns

    output$another_leaf <- leaflet::renderLeaflet({

      m <- leaflet::leaflet() %>%
        leaflet::addTiles() %>%  # Add default OpenStreetMap map tiles
        leaflet::addMarkers(lng=174.768, lat=-36.852, popup="The birthplace of R")

      m

    })

  })
}

##########   MAIN UI   ##########
ui <- fluidPage(

  shinydashboardPlus::dashboardPage(
    header = shinydashboardPlus::dashboardHeader(title = "Leaflet Testing")

    , sidebar = shinydashboardPlus::dashboardSidebar(

      id = "mainSidebar"

      , shinydashboard::sidebarMenu(
        shinydashboard::menuItem(
          text = "Menu 1"
          , tabName = "menu1"
        )
      )
      , shinydashboard::sidebarMenu(
        shinydashboard::menuItem(
          text = "Menu 2"
          , tabName = "menu2"
        )
      )
      , shinydashboard::sidebarMenu(
        shinydashboard::menuItem(
          text = "Menu 3"
          , tabName = "menu3"
        )
      )

    )

    , body = shinydashboard::dashboardBody(
      shinydashboard::tabItems(

        shinydashboard::tabItem(
          tabName = "menu1"
          , counterButton("counter1", "Counter #1")
        )
        , shinydashboard::tabItem(
          tabName = "menu2"
          , mod_another_leaflet_ui("mod_another_leaflet_ui_1")
        )

        , shinydashboard::tabItem(
          tabName = "menu3"
          , mod_leaflet_test_ui("mod_leaflet_test_ui_1")
        )

      )
    )

    , controlbar = shinydashboardPlus::dashboardControlbar(
      skin = "dark"
      , width = 300
      , collapsed = FALSE
    )

  )

)

##########   MAIN SERVER   ##########
server <- function(input, output, session) {
  counterServer("counter1")

  mod_leaflet_test_server("mod_leaflet_test_ui_1")

  mod_another_leaflet_server("mod_another_leaflet_ui_1")
}

shinyApp(ui, server)

[trafficonese]

Indeed there seem to be some bugs in my code. I am not appending the leaflet map correctly and I'm also not sure about the module namespacing, thats probably wrong too.

Also interesting, whenever I start your example with a fresh session, the app crashes with this error:

Warning: Error in [: object of type 'S4' is not subsettable
  48: <Anonymous>

When I restart it agin, the app runs normally. Not sure where that error comes from..

[svenb78]

In I fresh session, I get the same message at first run. Forgot to mention it. Sorry.

[trafficonese]

The sidebar branch has a new commit 70e2b17 which should fix problems related with modules and has some CSS-fixes too.

[svenb78]

At a first glance: seems to work. :-) THANK YOU!