使用 bslib::accordion 替代闪亮的仪表板::sidebarMenu

问题描述 投票：0回答：2

如何使用 

bslib
实现与 
shinydashboard
类似的行为？我特别对带有手风琴的侧边栏感兴趣。当选择一项时，我想选择一个预定义的 
page_fluid
对象。

我尝试定义一个看起来像侧边栏菜单的手风琴。我想出了

ui <- bslib::page_navbar(
    sidebar=bslib::sidebar(
        bslib::accordion(
            shiny::actionButton(inputId = "btn_start", label = "Start"),
            shiny::actionButton(inputId = "btn_overview", label = "Overview"),
            bslib::accordion_panel(
                "Menu Level 1", 
                shiny::actionButton(inputId="btn_lvl1_a", label="Menu Level 1a"),
                shiny::actionButton(inputId="btn_lvl1_b", label="Menu Level 1b")
            ),
            bslib::accordion_panel(
                "Menu Level 2", 
                shiny::actionButton(inputId="btn_lvl2_a", label="Menu Level 2a"),
                shiny::actionButton(inputId="btn_lvl2_b", label="Menu Level 2b"),
                shiny::actionButton(inputId="btn_lvl2_c", label="Menu Level 2c")
            )
        )
    )
)

server <- function(input, output, session) {

}

shiny::shinyApp(ui, server)

并计划

observeEvent
点击
actionButton
，但这似乎不是定义菜单的正确方法。看起来很奇怪。

一个最小的例子将不胜感激。

r shiny bslib
2个回答
15
投票

一个好的方法是在侧边栏上使用 html 列表，并在主区域使用隐藏的 tabsetPanel。

虽然有点长，但我在下面提供的reprex很容易理解，并且它清楚地描述了shiny在定制方面的功能。

Reprex showcase

global.R

library(shiny)


ui.R

ui <- tags$html(
  lang = "en",
  `data-bs-theme` = "auto",
  tags$head(
    tags$meta(charset = "utf-8"),
    tags$meta(name = "viewport", content = "width=device-width, initial-scale=1"),
    tags$title("Sidebar Demo"),
    # bootstrap css:
    tags$link(
      href = "https://cdn.jsdelivr.net/npm/[email protected]/dist/css/bootstrap.min.css",
      rel = "stylesheet",
      integrity = "sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM",
      crossorigin = "anonymous"
    ),
    # styles.css:
    tags$link(
      href = "styles.css",
      rel = "stylesheet"
    ),
    # google fonts:
    tags$link(rel = "preconnect", href = "https://fonts.googleapis.com"),
    tags$link(rel = "preconnect", href = "https://fonts.gstatic.com", crossorigin = NA),
    tags$link(
      href = "https://fonts.googleapis.com/css2?family=Quicksand:wght@300;400;500;600;700&display=swap",
      rel = "stylesheet"
    )
  ),
  tags$body(
    class = "bg-light",
    bootstrapLib(theme = bslib::bs_theme(version = 5)),
    suppressDependencies("bootstrap"),
    tags$div(
      class = "d-flex vh-100",
      # sidebar
      tags$div(
        class = "flex-shrink-0 p-3 bg-white border-end shadow-sm",
        style = "width: 280px;",
        tags$a(
          href = "https://shiny.posit.co/",
          class = paste(
            "d-flex align-items-center pb-3 mb-3 link-body-emphasis",
            "text-decoration-none border-bottom"
          ),
          tags$img(
            src = "shiny-solo.png",
            alt = "Shiny Logo",
            width = 50,
            height = 25
          ),
          tags$span(
            class = "fs-5 fw-semibold ps-2",
            "Sidebar Showcase"
          )
        ),
        tags$ul(
          class = "list-unstyled ps-0",
          tags$li(
            class = "mb-1",
            create_sidebar_menu_header(
              title = "Home",
              data_bs_target = "#home-collapse",
              aria_expanded = "true"
            ),
            tags$div(
              class = "collapse show",
              id = "home-collapse",
              tags$ul(
                class = "btn-toggle-nav list-unstyled fw-normal pb-1 small",
                create_sidebar_link(id = "overview", label = "Overview", active = TRUE),
                create_sidebar_link(id = "updates", label = "Updates"),
                create_sidebar_link(id = "reports", label = "Reports")
              )
            )
          ),
          tags$li(
            class = "mb-1",
            create_sidebar_menu_header(
              title = "Dashboard",
              data_bs_target = "#dashboard_collapse"
            ),
            tags$div(
              class = "collapse",
              id = "dashboard_collapse",
              tags$ul(
                class = "btn-toggle-nav list-unstyled fw-normal pb-1 small",
                create_sidebar_link(id = "weekly", label = "Weekly"),
                create_sidebar_link(id = "monthly", label = "Monthly"),
                create_sidebar_link(id = "annually", label = "Annually")
              )
            )
          ),
          tags$li(
            class = "mb-1",
            create_sidebar_menu_header(
              title = "Orders",
              data_bs_target = "#orders_collapse"
            ),
            tags$div(
              class = "collapse",
              id = "orders_collapse",
              tags$ul(
                class = "btn-toggle-nav list-unstyled fw-normal pb-1 small",
                create_sidebar_link(id = "new_orders", label = "New"),
                create_sidebar_link(id = "processed_orders", label = "Processed"),
                create_sidebar_link(id = "shipped_orders", label = "Shipped"),
                create_sidebar_link(id = "returned_orders", label = "Returned")
              )
            )
          ),
          tags$li(class = "border-top my-3"),
          tags$li(
            class = "mb-1",
            create_sidebar_menu_header(
              title = "Account",
              data_bs_target = "#account_collapse"
            ),
            tags$div(
              class = "collapse",
              id = "account_collapse",
              tags$ul(
                class = "btn-toggle-nav list-unstyled fw-normal pb-1 small",
                create_sidebar_link(id = "new_account", label = "New..."),
                create_sidebar_link(id = "profile", label = "Profile"),
                create_sidebar_link(id = "account_settings", label = "Settings"),
                create_sidebar_link(id = "sign_out", label = "Sign Out")
              )
            )
          ),
        )
      ),
      # main
      tags$div(
        class = "p-3",
        tabsetPanel(
          id = "tabs",
          type = "hidden",
          tabPanelBody(
            value = "overview",
            tags$h3("Overview")
          ),
          tabPanelBody(
            value = "updates",
            tags$h3("Updates")
          ),
          tabPanelBody(
            value = "reports",
            tags$h3("Reports")
          ),
          tabPanelBody(
            value = "weekly",
            tags$h3("Weekly Dashboard")
          ),
          tabPanelBody(
            value = "monthly",
            tags$h3("Monthly Dashboard Summary")
          ),
          tabPanelBody(
            value = "annually",
            tags$h3("Annual Dashboard Analytics")
          ),
          tabPanelBody(
            value = "new_orders",
            tags$h3("New Orders")
          ),
          tabPanelBody(
            value = "processed_orders",
            tags$h3("Processed Orders")
          ),
          tabPanelBody(
            value = "shipped_orders",
            tags$h3("Here are the shipped orders")
          ),
          tabPanelBody(
            value = "returned_orders",
            tags$h3("Returned orders here")
          ),
          tabPanelBody(
            value = "new_account",
            tags$h3("Create New Account")
          ),
          tabPanelBody(
            value = "profile",
            tags$h3("View your profile")
          ),
          tabPanelBody(
            value = "account_settings",
            tags$h3("Your account settings")
          ),
          tabPanelBody(
            value = "sign_out",
            tags$h3("You're now signed out")
          )
        )
      )
    ),
    # bootstrap js:
    tags$script(
      src = "https://cdn.jsdelivr.net/npm/[email protected]/dist/js/bootstrap.bundle.min.js",
      integrity = "sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz",
      crossorigin = "anonymous"
    ),
    # script.js:
    tags$script(src = "script.js")
  )
)


server.R

server <- function(input, output, session) {
  sidebar_link_ids <- c(
    "overview", "updates", "reports",
    "weekly", "monthly", "annually",
    "new_orders", "processed_orders", "shipped_orders", "returned_orders",
    "new_account", "profile", "account_settings", "sign_out"
  )
  # add observers to switch to the clicked link's tab:
  lapply(sidebar_link_ids, \(id) {
    observeEvent(input[[id]], {
      freezeReactiveValue(input, "tabs")
      updateTabsetPanel(session = session, inputId = "tabs", selected = id)
    })
  })
}


R/create_sidebar_link.R

#' Create sidebar link
#' 
#' @param id input id for the link
#' @param label Label
#' @param class Bootstrap classes to apply to the link
#' @param active Whether this should be the active link
#' @return tagList with a tags$li
create_sidebar_link <- \(
  id,
  label,
  class = "link-body-emphasis d-inline-flex text-decoration-none rounded w-100",
  active = FALSE
) {
  if (active) {
    class <- paste(class, "active")
  }
  
  tagList(
    tags$li(
      actionLink(
        inputId = id,
        label = label,
        class = class
      )
    )
  )
}


R/create_sidebar_menu_header.R

#' Create a sidebar menu header
#' 
#' When clicked, it collapses it's contents (sidebar menus)
#' 
#' @param title Header title
#' @param title_class Bootstrap classes to apply to the title
#' @param data_bs_target 'data-bs-target' attribute of the menu header
#' @param data_bs_toggle 'data-bs-toggle' attribute of the menu header
#' @param class Bootstrap classes to apply to the menu header
#' @param aria_expanded 'aria-expanded' attribute of the menu header. Whether
#' this sidebar menu is open or closed. Either "true" or "false".
#' @return tagList with a tags$button
create_sidebar_menu_header <- \(
  title,
  title_class = "ps-2",
  data_bs_target,
  data_bs_toggle = "collapse",
  class = "btn btn-toggle d-inline-flex align-items-center rounded border-0 collapsed w-100",
  aria_expanded = "false"
) {
  tagList(
    tags$button(
      class = class,
      `data-bs-toggle` = data_bs_toggle,
      `data-bs-target` = data_bs_target,
      `aria-expanded` = aria_expanded,
      tags$span(
        class = title_class,
        title
      )
    )
  )
}


www/styles.css

body {
  min-height: 100vh;
  min-height: -webkit-fill-available;
  font-family: 'Quicksand', sans-serif;
}

html {
  height: -webkit-fill-available;
}

.btn-toggle {
  padding: .25rem .5rem;
  font-weight: 600;
  color: var(--bs-emphasis-color);
  background-color: transparent;
}
.btn-toggle:hover,
.btn-toggle:focus {
  color: rgba(var(--bs-emphasis-color-rgb), .85);
  background-color: var(--bs-tertiary-bg);
}

.btn-toggle::before {
  width: 1.25rem;
  line-height: 0;
  content: url("data:image/svg+xml,%3csvg xmlns='http://www.w3.org/2000/svg' width='16' height='16' viewBox='0 0 16 16'%3e%3cpath fill='none' stroke='rgba%280,0,0,.5%29' stroke-linecap='round' stroke-linejoin='round' stroke-width='2' d='M5 14l6-6-6-6'/%3e%3c/svg%3e");
  transition: transform .35s ease;
  transform-origin: .5em 50%;
}

[data-bs-theme="dark"] .btn-toggle::before {
  content: url("data:image/svg+xml,%3csvg xmlns='http://www.w3.org/2000/svg' width='16' height='16' viewBox='0 0 16 16'%3e%3cpath fill='none' stroke='rgba%28255,255,255,.5%29' stroke-linecap='round' stroke-linejoin='round' stroke-width='2' d='M5 14l6-6-6-6'/%3e%3c/svg%3e");
}

.btn-toggle[aria-expanded="true"] {
  color: rgba(var(--bs-emphasis-color-rgb), .85);
}
.btn-toggle[aria-expanded="true"]::before {
  transform: rotate(90deg);
}

.btn-toggle-nav a {
  padding: .1875rem .5rem;
  margin-top: .125rem;
  margin-left: 1.25rem;
  max-width: 190px;
}
.btn-toggle-nav a:hover,
.btn-toggle-nav a:focus {
  background-color: var(--bs-tertiary-bg);
}
.btn-toggle-nav a.active {
  background-color: var(--bs-dark);
  color: var(--bs-white) !important;
}


www/script.js

$(document).ready(function() {
  $(".btn-toggle-nav").on("click", "a", function() {
    // remove "active" class from all elements:
    $(".btn-toggle-nav a").removeClass("active");

    // add "active" class to the clicked element:
    $(this).addClass("active");
  });
});


www/shiny-solo.png

shiny-solo.png

0
投票

我想建议将其作为纯 bslib 解决方案来生成闪亮的仪表板外观和感觉：

library(shiny)
library(bslib)

# Define UI
ui <- page_fluid(
  navset_pill_list(
    id = "sidebar_menu",
    widths = c(2, 10),
    nav_item(h1("Bslib shinyDashboard Mimic")),
    nav_panel(
      title = "One", 
      p("First tab content."), plotOutput("distPlot")
    ),
    nav_panel(
      title = "Two", 
      p("Second tab content."), textOutput("textOutput"), tableOutput("tabcars")
    )
  )
)

# Define server logic
server <- function(input, output, session) {
  output$distPlot <- renderPlot({
    hist(rnorm(500))
  })
  output$textOutput <- renderText({
    "Settings content goes here."
  })
  output$tabcars <- renderTable({
    head(mtcars)
  })
}

# Run the application
shinyApp(ui = ui, server = server, options = list(launch.browser = FALSE))

截图：

enter image description here

enter image description here

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.