将 Rintrojs 与 shinydashboard 相结合

Question

我刚刚开始使用 rintrojs 包，我想将其与 shinydashboard 包混合使用。特别是我想有一个步骤：

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

我试图从他们 github 页面上的示例开始，并在边栏上添加第六步，但 returns 我出错了

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)

Error in tagAssert(sidebar, type = "aside", class = "main-sidebar") : Expected tag to be of type aside

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

Answer 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)

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

Answer 2

回答你的第二个问题：

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

话虽如此，我发现了一种允许您处理不同部分的 hacky 方法。如前所述，技巧是通过 class 而不是 id 来寻址元素，查看 menuItem() 的输出, 我们看到最高元素 (li) 没有得到 class...

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函数来赋值一个class.

警告，这仅经过轻微测试，可能会破坏应用程序的某些部分，特别是如果您按位置而不是按名称传递选项（即 menuItem("Menu 1", "menu_1") 比 [=19 危险得多=]).

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。

将 Rintrojs 与 shinydashboard 相结合

Combining Rintrojs with shinydashboard

r

shiny

intro.js

shinydashboard

编辑