在R Shiny的sidebar panel指定区域绘制边框并设置填充色

你只需要给需要高亮的区块套一个带自定义样式的div容器即可，div会自动根据内部内容高度自适应，同时支持自定义边框和背景填充色，修改后的完整代码如下：

library(shiny)
library(shinyjs)

f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions       <- c("show", "reset")
tbl           <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("2nd input", "3rd input")

firstInput <- function(inputId){
  matrixInput(inputId, 
              value = matrix(c(5), 1, 1, dimnames = list(c("1st input"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

secondInput <- function(inputId,x){
  matrixInput(inputId, 
              value = matrix(c(x), 1, 1, dimnames = list(c("2nd input"),NULL)),
              rows =  list(extend = FALSE, names = TRUE),
              cols =  list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      "td .checkbox {margin-top: 0; margin-bottom: 0;}
       td .form-group {margin-bottom: 0;}
       /* 自定义高亮区块样式 */
       .highlight-block {
          border: 3px solid #d9534f; /* 边框：粗细 样式 颜色，可自行修改 */
          background-color: #fff5f5; /* 背景填充色，可自行修改 */
          padding: 12px; /* 内边距，避免内容贴边框 */
          border-radius: 4px; /* 圆角，不需要可以删掉这行 */
          margin: 8px 0; /* 上下外边距，和其他内容拉开距离 */
       }"
    ))
  ),
  br(),
  sidebarLayout(
    sidebarPanel(
      uiOutput("panel"),
    ),
    mainPanel(plotOutput("plot1"))
  )
)

server <- function(input, output){
  
  input1      <- reactive(input$input1)
  input2      <- reactive(input$input2)
  
  output$panel <- renderUI({
    tagList(
      useShinyjs(),
      strong(helpText("SLIDER INPUT HERE...")),
      div(style = "margin-top: 15px"),
      # 把需要高亮的内容全部包裹在这个div里
      div(class = "highlight-block",
        firstInput("input1"),
        strong(helpText("Generate curves (Y|X):")),
        tableOutput("checkboxes"),
        hidden(uiOutput("secondInput"))
      ),
      strong(helpText("ADDITIONAL SCENARIOS...")),
    )
  })
  
  output[["checkboxes"]] <- 
    renderTable({tbl}, 
      rownames = TRUE, align = "c",
      sanitize.text.function = function(x) x
    )

  observeEvent(input[["show1"]], {
    if(input[["show1"]]){
      shinyjs::show("secondInput")
    } else {
      shinyjs::hide("secondInput")
    }
  })
  
  output$secondInput <- renderUI({
    req(input1())
    secondInput("input2",input$input1[1,1])
  })
  
  outputOptions(output,"secondInput",suspendWhenHidden = FALSE) 
  
  output$plot1 <-renderPlot({
    req(input2())
    plot(rep(input2(),times=5))
  })
}

shinyApp(ui, server)

自定义调整说明 #

• 修改.highlight-block里的border参数可以调整边框的粗细、颜色、样式，比如改成2px dashed #337ab7就是蓝色虚线边框
• 修改background-color参数可以调整背景填充色，支持十六进制色值、rgb色值或者标准颜色名
• 不需要其中某一种效果直接删掉对应的CSS行即可，比如删掉background-color行就只保留边框效果

内容的提问来源于stack exchange，提问作者Curious Jorge - user9788072