r - 将通知链接到 shinydashboard 中的选项卡

Question

我想将通知链接到(内部)标签。

为此我遇到了这个:How to use href in shiny notificationItem?

这似乎在加载应用程序后立即起作用，但在侧边栏中进行一些导航后，链接不再起作用。

ui.R

library(shiny)
library(shinydashboard)

notification <- notificationItem(icon = icon("exclamation-triangle"), status = "danger", paste0("noti"))
notification$children[[1]] <- a(href="#shiny-tab-dashboard","data-toggle"="tab", "data-value"="dashboard",list(notification$children[[1]]$children))

header <- dashboardHeader(dropdownMenu(notification), title = "Dashboard")

sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Test",
             menuSubItem("test1", tabName = "test1", href = NULL, newtab = TRUE,
                         icon = shiny::icon("angle-double-right"), selected = F),
             menuSubItem("test2", tabName = "test2", href = NULL, newtab = TRUE,
                         icon = shiny::icon("angle-double-right"), selected = T)
    )
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "dashboard",
            h2("Dashboard tab content")
    ),

    tabItem(tabName = "test1",
            h2("Widgets tab1 content")
    ),

    tabItem(tabName = "test2",
            h2("Widgets tab2 content")
    )
  )
)

dashboardPage(
  header,
  sidebar,
  body
)

服务器.R

function(input, output) {

}

Answer 1

和之前的坏黑客变体一样)

想法

1)添加onclick

2) 从js到 Shiny

 tags$script(HTML("function clickFunction(link){ 
                       Shiny.onInputChange('linkClicked',link);
    }"))

3) observeEvent + 重新渲染菜单

4) 如果不想重新渲染完整菜单，您可以将菜单用作

output$dropdown=renderMenu({dropdownMenu(type = "tasks", badgeStatus = "danger",.list = d$tasks_now)})

其中 d=reactiveValues({tasks_now=get_noti()}) 并在 observeEvent 更新 d$tasks_now

服务器

library(shiny)

get_noti=function(){
  notification <- notificationItem(icon = icon("exclamation-triangle"), status = "danger", paste0("noti"))
  notification$children[[1]] <- a(href="#shiny-tab-dashboard","onclick"=paste0("clickFunction('",paste0(substr(as.character(runif(1, 0, 1)),1,6),"noti"),"'); return false;"),list(notification$children[[1]]$children))
  return(notification)
}

shinyServer(function(input, output, session) {
  output$dropdown=renderMenu({dropdownMenu(get_noti())})
  observeEvent(input$linkClicked,{
    print(input$linkClicked)
    updateTabItems(session,"sidemenu",selected = "dashboard")
    output$dropdown=renderMenu({dropdownMenu(get_noti())})
  })
  })

界面

library(shiny)
library(shinydashboard)
header <- dashboardHeader(dropdownMenuOutput('dropdown'), title = "Dashboard")
 sidebar <- dashboardSidebar(
  sidebarMenu(id="sidemenu",
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Test",
             menuSubItem("test1", tabName = "test1", href = NULL, newtab = TRUE,
                         icon = shiny::icon("angle-double-right"), selected = F),
             menuSubItem("test2", tabName = "test2", href = NULL, newtab = TRUE,
                         icon = shiny::icon("angle-double-right"), selected = T)
    )))
body <- dashboardBody(
  tags$script(HTML("function clickFunction(link){ 
                       Shiny.onInputChange('linkClicked',link);
    }")),
  tabItems(
    tabItem(tabName = "dashboard",
            h2("Dashboard tab content")
    ),

    tabItem(tabName = "test1",
            h2("Widgets tab1 content")
    ),

    tabItem(tabName = "test2",
            h2("Widgets tab2 content")
    )
  )
)
dashboardPage(
  header,
  sidebar,
  body
)