【问题标题】：Combining Rintrojs with shinydashboard将 Rintrojs 与 Shinydashboard 相结合
【发布时间】：2019-12-02 16:05:57
【问题描述】：

我刚刚开始使用rintrojs 包，我想将它与shinydashboard 包混合使用。特别是我想迈出一步：

侧边栏，
标题（图中蓝色）
允许关闭和打开侧边栏的按钮（我在图片中用红色包围）

我尝试从他们 github 页面上的示例开始，并在侧边栏添加第六步，但它返回了一个错误

library(rintrojs)
library(shiny)
library(shinydashboard)

# Define UI for application that draws a histogram
ui <- shinyUI(
  dashboardPage(
    dashboardHeader(title = "Basic dashboard"),
    introBox(dashboardSidebar(

    ),data.step = 6,
    data.intro = 'This is the sidebar'),
    dashboardBody(
      fluidPage(
        introjsUI(),

        # Application title
        introBox(
          titlePanel("Old Faithful Geyser Data"),
          data.step = 1,
          data.intro = "This is the title panel"
        ),

        # Sidebar with a slider input for number of bins
        sidebarLayout(sidebarPanel(
          introBox(
            introBox(
              sliderInput(
                "bins",
                "Number of bins:",
                min = 1,
                max = 50,
                value = 30
              ),
              data.step = 3,
              data.intro = "This is a slider",
              data.hint = "You can slide me"
            ),
            introBox(
              actionButton("help", "Press for instructions"),
              data.step = 4,
              data.intro = "This is a button",
              data.hint = "You can press me"
            ),
            data.step = 2,
            data.intro = "This is the sidebar. Look how intro elements can nest"
          )
        ),

        # Show a plot of the generated distribution
        mainPanel(
          introBox(
            plotOutput("distPlot"),
            data.step = 5,
            data.intro = "This is the main plot"
          )
        ))
      )
    )
  )
)

# Define server logic required to draw a histogram
server <- shinyServer(function(input, output, session) {
  # initiate hints on startup with custom button and event
  hintjs(session, options = list("hintButtonLabel"="Hope this hint was helpful"),
         events = list("onhintclose"=I('alert("Wasn\'t that hint helpful")')))

  output$distPlot <- renderPlot({
    # generate bins based on input$bins from ui.R
    x    <- faithful[, 2]
    bins <- seq(min(x), max(x), length.out = input$bins + 1)

    # draw the histogram with the specified number of bins
    hist(x,
         breaks = bins,
         col = 'darkgray',
         border = 'white')
  })

  # start introjs when button is pressed with custom options and events
  observeEvent(input$help,
               introjs(session, options = list("nextLabel"="Onwards and Upwards",
                                               "prevLabel"="Did you forget something?",
                                               "skipLabel"="Don't be a quitter"),
                       events = list("oncomplete"=I('alert("Glad that is over")')))
  )
})

# Run the application
shinyApp(ui = ui, server = server)

tagAssert(sidebar, type = "aside", class= "main-sidebar") 中的错误：预期标签的类型放在一边

第二个问题：是否可以在一个独特的 rintrojs 演示文稿中在侧边栏的不同菜单项之间导航？

【问题讨论】：

标签： r shiny shinydashboard intro.js

【解决方案1】：

对你来说可能为时已晚，但对于像我一样绕过这个问题的其他人来说可能不是。

第一个技巧是在服务器端实现介绍逻辑。第二个技巧是用它们的 class 指向元素，而不是它们的 id。它可能有副作用，但在你的简单情况下，它就像一个魅力。

library(rintrojs)
library(shiny)
library(shinydashboard)

ui <- shinyUI(
    dashboardPage(
        dashboardHeader(title = "Basic dashboard"),
        dashboardSidebar(
            introjsUI(),
            sidebarMenu(
                menuItem("Item1", tabName="item1", icon=icon("dashboard")),
                menuItem("Item2", tabName="item2", icon=icon("thumbs-up"))
            )
        ),
        dashboardBody(
            fluidPage(
                titlePanel("Old Faithful Geyser Data"),
                sidebarLayout(
                    sidebarPanel(
                        sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30),
                        actionButton("help", "Press for instructions"),
                    ),
                    mainPanel(
                        plotOutput("distPlot"),
                    )
                )
            )
        )
    )
)

server <- shinyServer(function(input, output, session) {
    steps <- reactive(
        data.frame(
            element=c(".sidebar-menu", ".main-header", ".sidebar-toggle", ".active", "#help"),
            intro=c(
                "This is a sidebar. Note that we access it with '.' instead of '#', because we track its class and not its id.",
                "This is a header.",
                "This is a button that allows to close and open the sidebar.",
                "This is the active element of the sidebar.",
                "This is a button that I added just to show the normal way to point to elements: with their id."
            ),
            position=c("right", "bottom", "bottom", "right", "top")
        )
    )
    observeEvent(input$help,
        introjs(session,
            options = list(steps=steps(),
                "nextLabel"="Next",
                "prevLabel"="Previous",
                "skipLabel"="Skip"
            ),
            events = list("oncomplete"=I('alert("Done")'))
        )
    )

    output$distPlot <- renderPlot({
        x <- faithful[, 2]
        bins <- seq(min(x), max(x), length.out = input$bins + 1)
        hist(x, breaks = bins, col = 'darkgray', border = 'white')
    })
})

shinyApp(ui = ui, server = server)

至于你的第二个问题，据我所知，你不能。

【讨论】：

【解决方案2】：

回答你的第二个问题：

正如@Vongo（我认为是正确的）指出的那样，这是不可能直接实现的。

话虽如此，我找到了一种可以让您处理不同部分的 hacky 方法。如前所述，诀窍是通过 class 而不是 id 来处理元素，查看menuItem() 的输出，我们看到最高元素 (li)没有上课...

shinydashboard::menuItem("Menu 1", tabName = "menu_1")
#> <li>
#>   <a href="#shiny-tab-menu_1" data-toggle="tab" data-value="menu_1">
#>     <span>Menu 1</span>
#>  </a>
#> </li>

我们可以做的是重载menuItem函数来分配一个类。

警告，这只是经过轻微测试，可能会破坏应用程序的某些部分，尤其是如果您按位置而不是按名称传递选项（即，menuItem("Menu 1", "menu_1") 比 menuItem(text = "Menu 1", tabName = "menu1") 危险得多）。

menuItem <- function(text, tabName, ...) {
  r <- shinydashboard::menuItem(text, ...)
  r$attribs <- append(r$attribs, list(class = tabName))
  r
}

menuItem("Menu 1", tabName = "menu_1")
#> <li class="menu_1">
#>   <a href="#">
#>     <span>Menu 1</span>
#>   </a>
#> </li>

通过这个覆盖，我们可以将第一个菜单寻址为.menu_1。

有关更详尽的示例，请参阅以下示例：

library(shinydashboard)
library(rintrojs)

menuItem <- function(text, tabName, ...) {
  r <- shinydashboard::menuItem(text, ...)
  r$attribs <- append(r$attribs, list(class = tabName))
  r
}

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    sidebarMenu(
      menuItem("Menu 1", tabName = "menu_1"),
      menuItem("Menu 2", tabName = "menu_2"),
      actionButton("btn_info", "Help")
    )
  ),
  dashboardBody(
    introjsUI()
  )
)

steps_general <- tibble::tribble(
  ~element, ~intro,
  NA, "First Empty State",
  ".menu_1", "First Item",
  ".menu_2", "Second Item"
)
server <- function(input, output, session) {
  observeEvent(input$btn_info, introjs(session, options = list(steps = steps_general)))
}
shinyApp(ui, server)

编辑

一种侵入性较小但劳动强度更大的解决方法是：

# adds a class to a shiny element
add_class <- function(x, class) {
  x$attribs <- append(x$attribs, list(class = class))
  x
}

然后可以在 UI 代码中使用

#...
sidebarMenu(
  menuItem("Menu 1", tabName = "view_1") %>% add_class("view_1")
)

# alternatively without the pipe:
sidebarMenu(
  add_class(menuItem("Menu 1", tabName = "view_1"), "view_1")
)


# ...
actionButton("btn_info", "Help") %>% add_class("btn_info")

# ...
plotOutput("plot1") %>% add_class("plot1")

# etc

可以在in this gist找到一个完整的例子。

【讨论】：