r - 在 shinydashboard tabBox 中更改所选选项卡的颜色

Question

有没有办法更改指示 shinydashboard tabBox 的事件选项卡的颜色？我已将仪表板的“皮肤”更改为“红色”。虽然这会影响侧边栏突出显示的事件选项卡，但它似乎对 tabBox 中的选定选项卡没有影响。

我只找到了更改所选选项卡的实际背景颜色的解决方案(例如 Shinydashboard - Change background based on selected tab )，但是，我找不到任何关于 tabBox 中所选选项卡顶部的小线的信息。在我的示例中，选定的选项卡(Tab1、Tab3、Tab1)应该有一个红色指示器，而不是现在的蓝色指示器。

    library(shiny)
    library(shinydashboard)
#> 
#> Attaching package: 'shinydashboard'
#> The following object is masked from 'package:graphics':
#> 
#>     box

    body <- dashboardBody(
        fluidRow(
            tabBox(
                title = "First tabBox",
                # The id lets us use input$tabset1 on the server to find the current tab
                id = "tabset1", height = "250px",
                tabPanel("Tab1", "First tab content"),
                tabPanel("Tab2", "Tab content 2")
            ),
            tabBox(
                side = "right", height = "250px",
                selected = "Tab3",
                tabPanel("Tab1", "Tab content 1"),
                tabPanel("Tab2", "Tab content 2"),
                tabPanel("Tab3", "Note that when side=right, the tab order is reversed.")
            )
        ),
        fluidRow(
            tabBox(
                # Title can include an icon
                title = tagList(shiny::icon("gear"), "tabBox status"),
                tabPanel("Tab1",
                         "Currently selected tab from first box:",
                         verbatimTextOutput("tabset1Selected")
                ),
                tabPanel("Tab2", "Tab content 2")
            )
        )
    )

    shinyApp(
        ui = dashboardPage(dashboardHeader(title = "tabBoxes"), skin = "red", dashboardSidebar(), body),
        server = function(input, output) {
            # The currently selected tab from the first box
            output$tabset1Selected <- renderText({
                input$tabset1
            })
        }
    )
#> 
#> Listening on http://127.0.0.1:7512

^{由 reprex package 创建于 2019-10-18 (v0.3.0)}

devtools::session_info()
#> - Session info ----------------------------------------------------------
#>  setting  value                       
#>  version  R version 3.6.1 (2019-07-05)
#>  os       Windows 10 x64              
#>  system   x86_64, mingw32             
#>  ui       RTerm                       
#>  language (EN)                        
#>  collate  German_Germany.1252         
#>  ctype    German_Germany.1252         
#>  tz       Europe/Berlin               
#>  date     2019-10-18                  
#> 
#> - Packages --------------------------------------------------------------
#>  package        * version date       lib source        
#>  assertthat       0.2.1   2019-03-21 [1] CRAN (R 3.5.3)
#>  backports        1.1.4   2019-04-10 [1] CRAN (R 3.5.3)
#>  callr            3.3.2   2019-09-22 [1] CRAN (R 3.5.3)
#>  cli              1.1.0   2019-03-19 [1] CRAN (R 3.5.3)
#>  crayon           1.3.4   2017-09-16 [1] CRAN (R 3.4.2)
#>  curl             4.1     2019-09-16 [1] CRAN (R 3.5.3)
#>  desc             1.2.0   2018-05-01 [1] CRAN (R 3.5.1)
#>  devtools         2.2.1   2019-09-24 [1] CRAN (R 3.5.1)
#>  digest           0.6.21  2019-09-20 [1] CRAN (R 3.5.3)
#>  ellipsis         0.3.0   2019-09-20 [1] CRAN (R 3.5.3)
#>  evaluate         0.14    2019-05-28 [1] CRAN (R 3.5.3)
#>  fs               1.3.1   2019-05-06 [1] CRAN (R 3.5.3)
#>  glue             1.3.1   2019-03-12 [1] CRAN (R 3.5.3)
#>  highr            0.8     2019-03-20 [1] CRAN (R 3.5.3)
#>  htmltools        0.3.6   2017-04-28 [1] CRAN (R 3.5.1)
#>  httpuv           1.5.2   2019-09-11 [1] CRAN (R 3.5.3)
#>  httr             1.4.1   2019-08-05 [1] CRAN (R 3.5.3)
#>  jsonlite         1.6     2018-12-07 [1] CRAN (R 3.5.2)
#>  knitr            1.25    2019-09-18 [1] CRAN (R 3.5.3)
#>  later            0.8.0   2019-02-11 [1] CRAN (R 3.5.3)
#>  magrittr         1.5     2014-11-22 [1] CRAN (R 3.4.1)
#>  memoise          1.1.0   2017-04-21 [1] CRAN (R 3.4.1)
#>  mime             0.7     2019-06-11 [1] CRAN (R 3.5.3)
#>  pkgbuild         1.0.5   2019-08-26 [1] CRAN (R 3.5.3)
#>  pkgload          1.0.2   2018-10-29 [1] CRAN (R 3.5.1)
#>  prettyunits      1.0.2   2015-07-13 [1] CRAN (R 3.5.1)
#>  processx         3.4.1   2019-07-18 [1] CRAN (R 3.5.3)
#>  promises         1.0.1   2018-04-13 [1] CRAN (R 3.5.1)
#>  ps               1.3.0   2018-12-21 [1] CRAN (R 3.5.2)
#>  R6               2.4.0   2019-02-14 [1] CRAN (R 3.5.3)
#>  Rcpp             1.0.2   2019-07-25 [1] CRAN (R 3.5.3)
#>  remotes          2.1.0   2019-06-24 [1] CRAN (R 3.5.3)
#>  rlang            0.4.0   2019-06-25 [1] CRAN (R 3.5.3)
#>  rmarkdown        1.15    2019-08-21 [1] CRAN (R 3.5.3)
#>  rprojroot        1.3-2   2018-01-03 [1] CRAN (R 3.5.1)
#>  sessioninfo      1.1.1   2018-11-05 [1] CRAN (R 3.5.3)
#>  shiny          * 1.3.2   2019-04-22 [1] CRAN (R 3.5.3)
#>  shinydashboard * 0.7.1   2018-10-17 [1] CRAN (R 3.5.2)
#>  stringi          1.4.3   2019-03-12 [1] CRAN (R 3.5.3)
#>  stringr          1.4.0   2019-02-10 [1] CRAN (R 3.5.2)
#>  testthat         2.2.1   2019-07-25 [1] CRAN (R 3.5.3)
#>  usethis          1.5.1   2019-07-04 [1] CRAN (R 3.5.3)
#>  webshot          0.5.1   2018-09-28 [1] CRAN (R 3.5.1)
#>  withr            2.1.2   2018-03-15 [1] CRAN (R 3.5.1)
#>  xfun             0.9     2019-08-21 [1] CRAN (R 3.5.3)
#>  xml2             1.2.2   2019-08-09 [1] CRAN (R 3.5.3)
#>  xtable           1.8-4   2019-04-21 [1] CRAN (R 3.5.3)
#>  yaml             2.2.0   2018-07-25 [1] CRAN (R 3.5.1)
#> 
#> [1] E:/R_LIBS_USER
#> [2] E:/R-3.6.1/library

Answer 1

您可以应用自定义 css 这个。 skin = "red" 中使用的红色是 #d73925

library(shiny)
library(shinydashboard)

js <- '.nav-tabs-custom .nav-tabs li.active {
    border-top-color: #d73925;
}"'

body <- dashboardBody(
  tags$style(js),
  fluidRow(
    tabBox(
      title = "First tabBox",
      # The id lets us use input$tabset1 on the server to find the current tab
      id = "tabset1", height = "250px",
      tabPanel("Tab1", "First tab content"),
      tabPanel("Tab2", "Tab content 2")
    ),
    tabBox(
      side = "right", height = "250px",
      selected = "Tab3",
      tabPanel("Tab1", "Tab content 1"),
      tabPanel("Tab2", "Tab content 2"),
      tabPanel("Tab3", "Note that when side=right, the tab order is reversed.")
    )
  ),
  fluidRow(
    tabBox(
      # Title can include an icon
      title = tagList(shiny::icon("gear"), "tabBox status"),
      tabPanel("Tab1",
               "Currently selected tab from first box:",
               verbatimTextOutput("tabset1Selected")
      ),
      tabPanel("Tab2", "Tab content 2")
    )
  )
)

shinyApp(
  ui = dashboardPage(dashboardHeader(title = "tabBoxes"), skin = "red", dashboardSidebar(), body),
  server = function(input, output) {
    # The currently selected tab from the first box
    output$tabset1Selected <- renderText({
      input$tabset1
    })
  }
)