In R Shiny, how too draw a box around a specified section of a sidebar panel?

Viewed 267

I'm working on a sidebar panel for a Shiny App, you can see simplified version in MWE code below. The sidebar will mainly have user inputs and action buttons (triggering modal dialog) to explain the inputs to the user. In order to better guide users through the input process of what will be a complex model, it would be helpful to better format the sidebar panel with a highlighting box as shown in the images at the bottom. I drew in those heavy-line boxes so you can see what I'm trying to get. Also the ability to change the color shade within that box would be very helpful. Any ideas on how to do both of these (box + shading)? I´ll take any suggestions for either one if both are not possible!

I've been fooling with fluidRow(column...)) with no luck yet.

Note that the sidebar panel may extend if user clicks on "Show" checkbox and I'd like the highlighting box to extend to accommodate the expanded size as shown in the 2nd image.

MWE code:

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;}"
    ))
  ),
  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"),
      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)

enter image description here

enter image description here

1 Answers

Maybe with wellPanel:

  output$panel <- renderUI({
    tagList(
      useShinyjs(),
      strong(helpText("SLIDER INPUT HERE...")),
      div(style = "margin-top: 15px"),
      wellPanel(
        firstInput("input1"),
        strong(helpText("Generate curves (Y|X):")),
        tableOutput("checkboxes"),
        hidden(uiOutput("secondInput"))
      ),
      strong(helpText("ADDITIONAL SCENARIOS..."))
    )
  })

I have not tried, but I think you can change the background color with an inline style:

  wellPanel(
    style = "background-color: cyan;",
    firstInput("input1"),
    strong(helpText("Generate curves (Y|X):")),
    tableOutput("checkboxes"),
    hidden(uiOutput("secondInput"))
  ),
  strong(helpText("ADDITIONAL SCENARIOS..."))
  
Related