在使用shinythemes库的Shiny应用中实现预期样式的box组件

我在使用shinythemes库的Shiny应用里添加shinydashboard的box组件，引入了shiny、DT、shinythemes、shinydashboard库，但显示效果不符合预期，想要达到类似目标图的样式，试过titlePanel也没用。

原代码 #

library(shiny)
library(DT)
library(shinythemes)
library(shinydashboard)

ui <- fluidPage(
  theme = shinytheme("lumen"),
  navbarPage("test theme",
             tabPanel("tab1",
                      mainPanel(width = 12,
                                fluidRow(
                                  box(width=6,title = "title",status = "navy", solidHeader = TRUE,            
                                       dataTableOutput(outputId = "tab"))))
             ))
)

Server <- function(input, output,session){
  
  output$tab = renderDataTable(mtcars)
  
}

shinyApp(ui, server)

效果对比 #

实际效果 #

预期效果 #

解决方案 #

问题核心是shinythemes的CSS样式与shinydashboard组件的CSS存在冲突——fluidPage是Shiny基础布局，而box是shinydashboard专属组件，两者样式体系不兼容。提供两种可行方案：

方案1：改用shinydashboard完整布局 #

直接使用dashboardPage替代fluidPage，彻底避免样式冲突，同时可自定义CSS匹配lumen主题风格：

library(shiny)
library(DT)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "test theme"),
  dashboardSidebar(disable = TRUE), # 不需要侧边栏可禁用
  dashboardBody(
    # 自定义CSS匹配lumen主题色调
    tags$head(tags$style(HTML("
      .skin-blue .main-header .navbar {
        background-color: #3c8dbc;
      }
      .skin-blue .main-header .logo {
        background-color: #367fa9;
      }
      .box.box-solid.box-navy>.box-header {
        background: #3c8dbc;
      }
    "))),
    tabItems(
      tabItem(tabName = "tab1",
              fluidRow(
                box(width=6,title = "title",status = "navy", solidHeader = TRUE,            
                    dataTableOutput(outputId = "tab"))
              )
      )
    )
  )
)

server <- function(input, output,session){
  output$tab = renderDataTable(mtcars)
}

shinyApp(ui, server)

方案2：保留fluidPage，替换box组件 #

如果坚持使用fluidPage和shinythemes，可以放弃shinydashboard的box，用以下两种方式实现类似效果：

方法A：使用shinyBS的bsPanel

先安装依赖包：

install.packages("shinyBS")

修改代码：

library(shiny)
library(DT)
library(shinythemes)
library(shinyBS)

ui <- fluidPage(
  theme = shinytheme("lumen"),
  navbarPage("test theme",
             tabPanel("tab1",
                      mainPanel(width = 12,
                                fluidRow(
                                  column(width=6,
                                         bsPanel(title = "title", style = "primary",
                                                 dataTableOutput(outputId = "tab")))
                                )
                      )
             ))
)

server <- function(input, output,session){
  output$tab = renderDataTable(mtcars)
}

shinyApp(ui, server)

方法B：自定义CSS实现box样式

无需额外包，直接编写CSS模拟box效果：

library(shiny)
library(DT)
library(shinythemes)

ui <- fluidPage(
  theme = shinytheme("lumen"),
  tags$head(tags$style(HTML("
    .custom-box {
      border: 1px solid #3c8dbc;
      border-radius: 4px;
      margin-bottom: 20px;
      box-shadow: 0 1px 1px rgba(0,0,0,0.1);
    }
    .custom-box-header {
      background-color: #3c8dbc;
      color: white;
      padding: 10px 15px;
      border-bottom: 1px solid #3c8dbc;
      border-top-left-radius: 3px;
      border-top-right-radius: 3px;
      font-size: 16px;
      font-weight: bold;
    }
    .custom-box-body {
      padding: 15px;
    }
  "))),
  navbarPage("test theme",
             tabPanel("tab1",
                      mainPanel(width = 12,
                                fluidRow(
                                  column(width=6,
                                         div(class="custom-box",
                                             div(class="custom-box-header", "title"),
                                             div(class="custom-box-body",
                                                 dataTableOutput(outputId = "tab")))
                                  )
                                )
                      )
             ))
)

server <- function(input, output,session){
  output$tab = renderDataTable(mtcars)
}

shinyApp(ui, server)

内容的提问来源于stack exchange，提问作者Haribo