How can I reactively update the active menuItem in a Shiny app using `renderUI`?

Question

I am building a shiny app that dynamically creates reactive bs4Box elements from a data frame. I want to make those boxes clickable by the user so that automatic redirection to a different menuItem occurs. I have read and followed similar previous SO questions like this one or this issue without success. A JavaScript solution like this one could also work?

Here's my attempt so far using the updatebs4ControlbarMenu function:

library(shiny)
#> Warning: package 'shiny' was built under R version 3.6.3
library(shinyWidgets)
#> Warning: package 'shinyWidgets' was built under R version 3.6.3
library(bs4Dash)
#> 
#> Attaching package: 'bs4Dash'
#> The following objects are masked from 'package:shiny':
#> 
#>     column, tabPanel, tabsetPanel, updateTabsetPanel
#> The following object is masked from 'package:graphics':
#> 
#>     box
library(tidyverse)
#> Warning: package 'ggplot2' was built under R version 3.6.3
#> Warning: package 'tibble' was built under R version 3.6.3
#> Warning: package 'tidyr' was built under R version 3.6.3
#> Warning: package 'readr' was built under R version 3.6.3
#> Warning: package 'purrr' was built under R version 3.6.3
#> Warning: package 'dplyr' was built under R version 3.6.3

shinyApp(
  ui = bs4DashPage(
    sidebar_collapsed = FALSE,
    controlbar_collapsed = TRUE,
    enable_preloader = FALSE,
    navbar = bs4DashNavbar(skin = "dark"),
    sidebar = bs4DashSidebar(
      inputId = "sidebarState",
      bs4SidebarMenu(
        id = "sidebr",
        bs4SidebarMenuItem(
          "Tab 1",
          tabName = "tab1"
        ),
        bs4SidebarMenuItem(
          "Tab 2",
          tabName = "tab2"
        )
      )
    ),
    
    bs4DashBody(
      bs4TabItems(
        bs4TabItem(
          tabName = "tab1",
          h1("Welcome!"),
          fluidRow(
            pickerInput(
              inputId = "car",
              label = "Car", 
              choices = row.names(mtcars),
              selected = head(row.names(mtcars), 3),
              multiple = TRUE,
              options = list(
                `actions-box` = TRUE)
            ),
            pickerInput(
              inputId = "gear",
              label = "Gear", 
              choices = unique(mtcars$gear),
              selected = unique(mtcars$gear),
              multiple = TRUE,
              options = list(
                `actions-box` = TRUE)
            )
          ),
          
          fluidRow(
            column(6,
                   uiOutput("uiboxes")
            )
          )
        ),
        
        bs4TabItem(
          tabName = "tab2",
          h4("Yuhuuu! You've been directed automatically in Tab 2!")
        )
      )
    )
  ),
  server = function(input, output, session) {
    
    submtcars <- reactive({
      req(input$car, input$gear)
      mtcars %>% 
        mutate(
          carnames = rownames(mtcars)) %>% 
        filter(
          carnames %in% input$car &
            gear %in% input$gear
        )
    })
    
    
    observeEvent( submtcars(), {
      
      output$uiboxes <- renderUI({
        n_ex <- nrow(submtcars())
        lapply(1:n_ex, FUN = function(j) {
          print(paste("j is ", j))
          bs4Box(
            title = submtcars()$carnames[j],
            width = 12,
            str_c("Number of gears:", submtcars()$gear[j]),
            
            btnID <- paste0("btnID", j),
            
            print(btnID),
            fluidRow(
              column(
                2,
                actionBttn(
                  inputId = btnID,
                  icon("search-plus")
                )
              )
            )
          )
        })
      })
    })
    
    observeEvent( input$btnID , {
      updatebs4ControlbarMenu(
        session,
        inputId = "sidebr",
        selected = "tab2"
      )
      
    })
  }
)
#> 
#> Listening on http://127.0.0.1:5851
#> [1] "j is  1"
#> [1] "btnID1"
#> [1] "j is  2"
#> [1] "btnID2"
#> [1] "j is  3"
#> [1] "btnID3"

^{Created on 2020-12-10 by the reprex package (v0.3.0)}

Answer 1

Your problem is how you set up the observeEvent. You only register one observer that listens to input$btnID. However, btnID is only a variable in which you define the different IDs for the action buttons (in your case "btnID1" to "btnID3". Therefore, you must register observeEvents with these IDs. For this, you can use lapply again as in my solution below.

library(shiny)
library(shinyWidgets)
library(bs4Dash)
library(tidyverse)

shinyApp(
  ui = bs4DashPage(
    sidebar_collapsed = FALSE,
    controlbar_collapsed = TRUE,
    enable_preloader = FALSE,
    navbar = bs4DashNavbar(skin = "dark"),
    sidebar = bs4DashSidebar(
      inputId = "sidebarState",
      bs4SidebarMenu(
        id = "sidebr",
        bs4SidebarMenuItem(
          "Tab 1",
          tabName = "tab1"
        ),
        bs4SidebarMenuItem(
          "Tab 2",
          tabName = "tab2"
        )
      )
    ),
    
    bs4DashBody(
      bs4TabItems(
        bs4TabItem(
          tabName = "tab1",
          h1("Welcome!"),
          fluidRow(
            pickerInput(
              inputId = "car",
              label = "Car", 
              choices = row.names(mtcars),
              selected = head(row.names(mtcars), 3),
              multiple = TRUE,
              options = list(
                `actions-box` = TRUE)
            ),
            pickerInput(
              inputId = "gear",
              label = "Gear", 
              choices = unique(mtcars$gear),
              selected = unique(mtcars$gear),
              multiple = TRUE,
              options = list(
                `actions-box` = TRUE)
            )
          ),
          
          fluidRow(
            column(6,
                   uiOutput("uiboxes")
            )
          )
        ),
        
        bs4TabItem(
          tabName = "tab2",
          h4("Yuhuuu! You've been directed automatically in Tab 2!")
        )
      )
    )
  ),
  server = function(input, output, session) {
    
    submtcars <- reactive({
      req(input$car, input$gear)
      mtcars %>% 
        mutate(
          carnames = rownames(mtcars)) %>% 
        filter(
          carnames %in% input$car &
            gear %in% input$gear
        )
    })
    
    
    observeEvent( submtcars(), {
      n_ex <- nrow(submtcars())
      output$uiboxes <- renderUI({
        
        lapply(1:n_ex, FUN = function(j) {
          print(paste("j is ", j))
          bs4Box(
            title = submtcars()$carnames[j],
            width = 12,
            str_c("Number of gears:", submtcars()$gear[j]),
            
            btnID <- paste0("btnID", j),
            
            print(btnID),
            fluidRow(
              column(
                2,
                actionBttn(
                  inputId = btnID,
                  icon("search-plus")
                )
              )
            )
          )
        })
      })
      
      lapply(1:n_ex, function(j) {
        btnID <- paste0("btnID", j)
        observeEvent(input[[btnID]] , {
          updatebs4ControlbarMenu(
            session,
            inputId = "sidebr",
            selected = "tab2"
          )
        })
      })
    })
    
  }
)

However, I think that approaches with lapply and renderUI are not very good, as all the boxes get rendered anew if one of your inputs change, while maybe some boxes would stay the same. Therefore, I recommend an approach with insertUI/removeUI. Have a look at some of my older answers, e.g. https://stackoverflow.com/a/63758952/12647315