r - 使用 R Shiny 仪表板直接链接到 tabItem

Question

我正在使用 Shiny 的仪表板模板来生成我的 Web UI。

我想在计算完成时动态生成一个信息框，链接指向 dashboardBody 中的 tabItems 之一。 .

例如，
我可以把这个放在我的 tabItem1输出，

renderInfoBox({
  infoBox("Completed", 
    a("Computation Completed", href="#tabItem2"), 
  icon = icon("thumbs-o-up"), color = "green"
  )
})

但问题是当我点击链接时，它什么也不做。我想跳转到 tabItem2 .当我将鼠标悬停在它上面时，链接 href 似乎有效。

谢谢!

更新:
除了使用Javascripts，看起来像使用 actionLink和 updateTabItems shinydashboard 中的函数包也可以工作。

Answer 1

对于冗长的代码示例，我深表歉意，但我不得不用 tabItems 复制一个示例从 Shinydashboard 主页。

你的方法只有几个问题。首先，如果您要检查 menuItems ，您会看到实际选项卡的 ID 不是 tabItem2 ，但是 shiny-tab-tabItem2 .这，加上额外的属性 data-toggle="tab"内a标签足以打开所需的选项卡。片段:

a("Computation Completed", href="#shiny-tab-tabItem2", "data-toggle" = "tab") 

但是，这有其局限性。首先也是最明显的， menuItem 的状态在侧边栏中未设置为 active .这看起来很奇怪，人们可能不相信，一个已移至另一个选项卡。

其次，不太明显，如果您监听选项卡更改(在服务器端)，您将无法获得有关此选项卡切换的信息。这些是由 menuItem 触发的被点击，并且选项卡本身不会报告它是可见的还是隐藏的。

所以，我的方法是模拟相应的 menuItem被点击，到此，以上问题都迎刃而解了。

代码示例:

library(shiny)
library(shinydashboard)

ui <- shinyUI(
  dashboardPage(
    dashboardHeader(title = "Some Header"),
    dashboardSidebar(
      sidebarMenu(
        menuItem("Computations", tabName = "tabItem1", icon = icon("dashboard")),
        menuItem("Results", tabName = "tabItem2", icon = icon("th"))
      )
    ),

    dashboardBody(
      tags$script(HTML("
        var openTab = function(tabName){
          $('a', $('.sidebar')).each(function() {
            if(this.getAttribute('data-value') == tabName) {
              this.click()
            };
          });
        }
      ")),
      tabItems(
        tabItem(tabName = "tabItem1",
          fluidRow(
            box(plotOutput("plot1", height = 250)),

            box(
              title = "Controls",
              sliderInput("slider", "Number of observations:", 1, 100, 50)
            )
          ),
          infoBoxOutput("out1")
        ),

        tabItem(tabName = "tabItem2",
          h2("Widgets tab content")
        )
      )
    )
  )
)

server <- function(input, output){
  histdata <- rnorm(500)

  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider)]
    hist(data)
  })

  output$out1 <- renderInfoBox({
    infoBox("Completed",  
      a("Computation Completed", onclick = "openTab('tabItem2')", href="#"),
      icon = icon("thumbs-o-up"), color = "green"
    )
  })
}

shinyApp(ui, server)

请注意，唯一重要的是 onclick属性，而不是 href .这意味着，每个 div或其他元素可用于创建此链接。您甚至可以通过此 onclick 获得竖起大拇指的图像命令。

如果您有更多问题，请发表评论。

最好的祝福

编辑:整个信息框可点击。

这是对 OmaymaS 评论的回答。重点是让 infoBox 成为一个可点击的容器。为了实现这一点，我们可以定义一个新函数来创建一个稍微不同的 infoBox。自定义框如下:

customInfoBox <- function (title, tab = NULL, value = NULL, subtitle = NULL, icon = shiny::icon("bar-chart"), color = "aqua", width = 4, href = NULL, fill = FALSE) {
    validateColor(color)
    tagAssert(icon, type = "i")
    colorClass <- paste0("bg-", color)
    boxContent <- div(class = "info-box", class = if (fill) colorClass, 
        onclick = if(!is.null(tab)) paste0("$('.sidebar a')).filter(function() { return ($(this).attr('data-value') == ", tab, ")}).click()"),
        span(class = "info-box-icon", class = if (!fill) colorClass, icon),  
        div(class = "info-box-content", 
            span(class = "info-box-text", title), 
            if (!is.null(value)) span(class = "info-box-number", value), 
            if (!is.null(subtitle)) p(subtitle)
        )
    )
    if (!is.null(href)) boxContent <- a(href = href, boxContent)
    div(class = if (!is.null(width)) paste0("col-sm-", width), boxContent)
}

此代码复制自原 infoBox函数定义和唯一的行 onclick是新的。我还添加了 openTab函数(有一些抽搐)就在容器内，这样您就不必担心将此函数放在 View 中的何处。我觉得可能有点重载。
这个自定义信息框可以像默认的一样使用，如果你传递额外的 tab参数，添加到侧边栏的链接。

编辑:字幕漏洞

正如 Alex Dometrius 提到的，使用 subtitle使此功能崩溃。这是因为意外插入的脚本标签被用作 subtitle参数以便与框一起呈现。为了腾出这个位置，我在顶部编辑了主要示例，使脚本标签位于 dashboardBody 的顶层。 (实际上用户界面中的任何地方都可以)。

(为了避免混淆:在版本 1 中， tags$script 被提供在 infobox 内部，它被解释为 subtitle 参数。)