闪亮的仪表板标题修改下拉菜单答案

【问题标题】：Shiny dashboard header modify dropdown闪亮的仪表板标题修改下拉菜单
【发布时间】：2017-04-12 14:35:41
【问题描述】：

在带有消息或通知项的标题中包含下拉菜单时，单击时会自动显示“您有 1 条消息”这句话。如何只显示消息而不显示“您有 1 条消息”这句话？

下面重现的例子：

    ui <- dashboardPage(
  dashboardHeader(dropdownMenu(type = "messages",
                               messageItem(
                                 from = "Sales Dept",
                                 message = "Sales are steady this month."
                               ))),
  dashboardSidebar(),
  dashboardBody()
)

server <- function(input, output) { }

shinyApp(ui, server)

【问题讨论】：

标签： r shiny shinydashboard

【解决方案1】：

这句话似乎在dropdownMenu 函数中被硬编码：

function (..., type = c("messages", "notifications", "tasks"), 
          badgeStatus = "primary", icon = NULL, .list = NULL) 
{
    type <- match.arg(type)
    if (!is.null(badgeStatus)) validateStatus(badgeStatus)
    items <- c(list(...), .list)
    lapply(items, tagAssert, type = "li")
    dropdownClass <- paste0("dropdown ", type, "-menu")
    if (is.null(icon)) {
        icon <- switch(type, messages = shiny::icon("envelope"), 
        notifications = shiny::icon("warning"), tasks = shiny::icon("tasks"))
    }
    numItems <- length(items)
    if (is.null(badgeStatus)) {
        badge <- NULL
    }
    else {
        badge <- span(class = paste0("label label-", badgeStatus), 
                      numItems)
    }
    tags$li(
        class = dropdownClass, 
        a(
            href = "#", 
            class = "dropdown-toggle", 
            `data-toggle` = "dropdown", 
            icon, 
            badge
        ), 
        tags$ul(
            class = "dropdown-menu", 
            tags$li(
                class = "header", 
                paste("You have", numItems, type)
            ), 
            tags$li(
                tags$ul(class = "menu", items)
            )
        )
    )
}

我们看到句子是用paste("You have", numItems, type) 构建的。改变这种情况的一种方法是编写一个新函数，该函数采用您想要的句子的新参数：

customSentence <- function(numItems, type) {
  paste("This is a custom message")
}

# Function to call in place of dropdownMenu
dropdownMenuCustom <-     function (..., type = c("messages", "notifications", "tasks"), 
                                    badgeStatus = "primary", icon = NULL, .list = NULL, customSentence = customSentence) 
{
  type <- match.arg(type)
  if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus)
  items <- c(list(...), .list)
  lapply(items, shinydashboard:::tagAssert, type = "li")
  dropdownClass <- paste0("dropdown ", type, "-menu")
  if (is.null(icon)) {
    icon <- switch(type, messages = shiny::icon("envelope"), 
                   notifications = shiny::icon("warning"), tasks = shiny::icon("tasks"))
  }
  numItems <- length(items)
  if (is.null(badgeStatus)) {
    badge <- NULL
  }
  else {
    badge <- span(class = paste0("label label-", badgeStatus), 
                  numItems)
  }
  tags$li(
    class = dropdownClass, 
    a(
      href = "#", 
      class = "dropdown-toggle", 
      `data-toggle` = "dropdown", 
      icon, 
      badge
    ), 
    tags$ul(
      class = "dropdown-menu", 
      tags$li(
        class = "header", 
        customSentence(numItems, type)
      ), 
      tags$li(
        tags$ul(class = "menu", items)
      )
    )
  )
}

一个最小的例子：

ui <- dashboardPage(
  dashboardHeader(dropdownMenuCustom(type = "messages",
                                     customSentence = customSentence,
                               messageItem(
                                 from = "Sales Dept",
                                 message = "Sales are steady this month."
                               ))),
  dashboardSidebar(),
  dashboardBody()
)

server <- function(input, output) { }

shinyApp(ui, server)

【讨论】：

所以要删除句子，用空格完全覆盖 - 还是有捷径？
这给出了错误：错误：找不到对象'tagAssert' - 有什么想法吗？
函数validateStatus 和tagAssert 都不是从shinydashboard 导出的。您仍然可以使用shinydashboard:::validateStatus 和shinydashboard:::tagAssert 给他们打电话。我更新了我的回复，所以它应该可以工作。