working on collapsePanels

NAMESPACE

@@ -1,5 +1,8 @@
 # Generated by roxygen2 (4.1.0): do not edit by hand
 
 export(bsAlert)
+export(bsCollapse)
+export(bsCollapsePanel)
 export(closeAlert)
 export(createAlert)
+export(updateCollapse)

R/bsAlert.R

@@ -8,7 +8,7 @@
 #' @param alertId A unique ID that identifies the specific alert being created.
 #' @param title An optional title for the alert. This will appear at the top of the alert in larger font.
 #' @param content The main body of the alert. HTML tags are allowed.
-#' @param style The Bootstrap style to apply (\code{danger}, \code{warning}, \code{info}, or \code{success}.
+#' @param style A Bootstrap style to apply (\code{danger}, \code{warning}, \code{info}, or \code{success}.
 #' @param dismiss \code{logical} indicating whether the alert should be user dismissable.
 #' @param append \code{logical} indicating whether the alert should be appended to the anchor, below any existing alerts.
 #' @inheritParams shiny::updateTextInput

R/bsCollapse.R

@@ -0,0 +1,119 @@
+#' Collapse Panels
+#' 
+#' Collapse panels allow you to reduce clutter in your Shiny app by making 
+#' panels of information that open and close with a user's click. Any type of
+#' content can go in a collapse panel. Standard Bootstrap styling options are
+#' available.
+#' 
+#'@section Components:
+#' \describe{
+#'  \item{\code{\link{bsCollapse}}}{A container for holder the individual panels created by \code{\link{bsCollapsePanel}}.}
+#'  \item{\code{\link{bsCollapsePanel}}}{Creates an individual Collapse Panel that resides within a \code{\link{bsCollapse}}.}
+#'  \item{\code{\link{updateCollapse}}}{Used within your server logic to open/close collapse panels or change their style.}
+#'} 
+#'@family Collapses
+#'@name Collapses
+#'@template group_footer
+NULL
+
+#' bsCollapse
+#'
+#' Create a collapse that contains \code{\link{bsCollapsePanel}} elements. 
+#' See \code{\link{Collapses}}
+#' 
+#'@param id If provided, you can use input$id in your server script to open or
+#' close \code{bsCollapsePanels} within the \code{bsCollapse}. 
+#'@param multiple \code{logical} indication whether multiple \code{bsCollapsePanels}
+#' within this \code{bsCollapse} can be open at once.
+#'@param open The \code{value} (or, if none was supplied, the title) of the 
+#' \code{bsCollapsePanel} that should be open. If \code{multiple = TRUE}, then
+#' this can be a vector of \code{value}s or \code{title}s.
+#'@param \dots \code{\link{bsCollapsePanel}} elements to include in the \code{bsCollapse}.
+#'@family Collapses
+#'@template footer
+#'@export
+bsCollapse <- function(..., id = NULL, multiple = FALSE, open = NULL) {
+  if(is.null(id)) id = paste0("collapse", sprintf("%07i", as.integer(stats::runif(1, 1, 1000000))))
+
+  if(!multiple & length(open) > 1) {
+    open <- open[1]
+  }
+
+  panels <- list(...)
+  panels <<- panels
+  for(i in seq(length(panels))) {
+    if(getAttribs(panels[[i]])$value %in% open) {
+      panels[[i]]$children[[2]] <- addClass(panels[[i]]$children[[2]], "in")
+    }
+    if(!multiple) {
+      panels[[i]]$children[[1]]$children[[1]]$children[[1]] <- addAttribs(panels[[i]]$children[[1]]$children[[1]]$children[[1]], 'data-parent' = paste0("#", id))
+    }
+  }
+
+  bsTag <- tags$div(class = "panel-group sbs-panel-group", id=id, role = "tablist", panels)
+  htmltools::attachDependencies(bsTag, shinyBSDep)
+
+}
+
+#' bsCollapsePanel
+#' 
+#' Create a collapse panel that can be included within a \code{\link{bsCollapse}}
+#' See \code{\link{Collapses}}
+#' 
+#'@param title The title to display at the top of the \code{bsCollapsePanel}
+#'@param value The value that should be returned to the server when this 
+#' \code{bsCollapsePanel} is open.
+#'@param \dots UI elements to include within the collapse panel
+#'@inheritParams Alerts
+#'@family Collapses
+#'@template footer
+#'@export
+bsCollapsePanel <- function(title, ..., value = title, style = NULL) {
+
+  content <- list(...)
+
+  id <- paste0("cpanel", sprintf("%07i", as.integer(stats::runif(1, 1, 1000000))))
+  if(is.null(value)) {
+    value = title
+  }
+  if(is.null(style)) {
+    style = "default"
+  }
+
+  bsTag <- tags$div(class = paste0("panel panel-", style), value = value,
+    tags$div(class = "panel-heading", role = "tab", id = paste0("heading_", id),
+      tags$h4(class = "panel-title",
+        tags$a("data-toggle" = "collapse", href = paste0("#", id), title)
+      )
+    ),
+    tags$div(id = id, class = "panel-collapse collapse", role = "tabpanel",
+      tags$div(class = "panel-body", content)         
+    )
+  )
+
+  htmltools::attachDependencies(bsTag, shinyBSDep)
+
+}
+
+#' updateCollapse
+#' 
+#' Open or close collapse panels or change their styles. See \code{\link{Collapses}}
+#' 
+#'@param id The id of the \code{\link{bsCollapse}} object you want to change.
+#'@param open A vector of \code{value} (or \code{title} if no \code{value} was provided)
+#'of the \code{\link{bsCollapsePanel}} elements you want to open.
+#'@param close A vector of \code{value} (or \code{title} if no \code{value} was provided)
+#'of the \code{\link{bsCollapsePanel}} elements you want to close.
+#'@param style A named list of Bootstrap styles (danger, info, warning, success, default).
+#'The names should correspond the the \code{value} of the \code{\link{bsCollapsePanel}} you
+#'want to change.
+#'@inheritParams Alerts
+#'@family Collapses
+#'@template footer
+#'@export
+updateCollapse <- function(session, id, open = NULL, close = NULL, style = NULL) {
+
+  data <- dropNulls(list(open = open, close = close, style = style))
+  session$sendInputMessage(id, data)
+
+}

R/misc.R

@@ -0,0 +1,84 @@
+.onAttach <- function(...) {
+
+  # Create link to javascript and css files for package
+  shiny::addResourcePath("sbs", system.file("www", package="shinyBS"))
+
+}
+
+shinyBSDep <- htmltools::htmlDependency("shinyBS", packageVersion("shinyBS"), src = c("href" = "sbs"), script = "shinyBS.js", stylesheet = "shinyBS.css")
+
+# Wrapper to add the appropriate singletons to the head of the shiny app
+sbsHead <- function(...) {
+
+  tagList(singleton(tags$head(tags$script(src = "sbs/shinyBS.js"),
+                              tags$link(rel = "stylesheet", type = "text/css", href = "sbs/shinyBS.css"))),
+          ...
+          )
+}
+
+# Copy of dropNulls function for shiny to avoid using shiny:::dropNulls
+dropNulls <- function(x) {
+    x[!vapply(x, is.null, FUN.VALUE = logical(1))]
+}
+
+# Takes a tag and removes any classes in the remove argument
+removeClass <- function(tag, remove) {
+
+  if(length(remove) == 1) remove <- strsplit(remove, " ", fixed = TRUE)[[1]]
+  class <- strsplit(tag$attribs$class, " ", fixed = TRUE)[[1]]
+  class <- class[!(class %in% remove)]
+  tag$attribs$class <- paste(class, collapse = " ")
+
+  return(tag)
+
+}
+
+addClass <- function(tag, add) {
+  tag$attribs$class <- paste(tag$attribs$class, add)
+  return(tag)
+}
+
+addAttribs <- function(tag, ...) {
+  a <- list(...)
+  for(i in seq(length(a))) {
+    tag$attribs[names(a)[i]] = a[[i]]
+  }
+  return(tag)
+}
+
+removeAttribs <- function(tag, ...) {
+  a <- list(...)
+  for(i in seq(length(a))) {
+    tags$attribs[a[[i]]] = NULL
+  }
+  return(tag)
+}
+
+getAttribs <- function(tag) {
+  tag$attribs
+}
+
+inputCheck <- function(..., valid, stop.func = FALSE) {
+
+  v <- list(...)[1]
+
+  if(!(v %in% valid)) {
+
+    n <- names(list(...))[1]
+    caller <- deparse(sys.call(-1)[1])
+    msg <- paste0("Invalid '", n, "' argument in ", caller, ": ", v)
+    if(stop.func) {
+      stop(msg, call. = FALSE)
+    } else {
+      warning(msg, call. = FALSE)
+    }
+
+    return(FALSE)
+
+  } else {
+
+    return(TRUE)
+
+  }
+
+}

inst/bsDemo/server.R

@@ -21,5 +21,26 @@ shinyServer(function(input, output, session) {
     eval(parse(text = svr))
 
   })
+
+  Collapses <- observe({
+
+    ui <- '
+bsCollapse(id = "collapseExample", multiple = TRUE, open = c("Text", "Shiny Outputs"),
+  bsCollapsePanel("Text", 
+                  HTML("You may want more explanation or instructions for your Shiny app than is reasonable to display at all times. Wrap this text in a <code>bsCollapse</code> and the user can hide it when they are done with it and easily bring it back if they need to reference it again.</p>")
+                 ),
+  bsCollapsePanel("Shiny Outputs", 
+                  tagList(tags$span("You can embed Shiny outputs into your collapses."), 
+                          plotOutput("collapsePlot"))
+                 )
+)
+'
+    session$sendCustomMessage('displayCode', list(id = "Collapses_ui", content = ui))
+
+  })
+
+  output$collapsePlot <- renderPlot({
+    plot(rnorm(100))
+  })
 
 })

inst/bsDemo/ui.R

@@ -6,19 +6,33 @@ demoPanel <- function(title, intro, controls, example) {
     fluidRow(style = 'padding-top: 10px;',
       column(8, 
         fluidRow(
-          column(12, class = "intro", HTML(intro))
+          column(12, class = "intro", 
+            bsCollapse(id = paste(gsub(" ", "_", title, fixed = TRUE), "intro", sep = "_"), open = "Introduction",
+              bsCollapsePanel("Introduction", HTML(intro))
+            )
+          )
         ),
         fluidRow(
-          column(4, wellPanel(controls)),
-          column(8, example)
+          column(4, 
+            bsCollapse(id = paste(gsub(" ", "_", title, fixed = TRUE), "controls", sep = "_"), open = "Controls",
+              bsCollapsePanel("Controls", controls)
+            )
+          ),
+          column(8, 
+             bsCollapse(id = paste(gsub(" ", "_", title, fixed = TRUE), "example", sep = "_"), open = "Example",
+                        bsCollapsePanel("Example", example)
+             )
+          )
         )
       ),
       column(4,
         fluidRow(
-          column(12, "ui.R", tags$div(id = paste(gsub(" ", "_", title, fixed = TRUE), "ui", sep = "_"), class = "r code shiny-text-output", ""))
-        ),
-        fluidRow(
-          column(12, "server.R", tags$div(id = paste(gsub(" ", "_", title, fixed = TRUE), "server", sep = "_"), class = "r code shiny-text-output", ""))
+          column(12, 
+            bsCollapse(id = paste(gsub(" ", "_", title, fixed = TRUE), "code", sep = "_"), open = c("UI", "Server"), multiple = TRUE,
+              bsCollapsePanel("UI", tags$pre(tags$div(id = paste(gsub(" ", "_", title, fixed = TRUE), "ui", sep = "_"), class = "r code shiny-text-output", ""))),
+              bsCollapsePanel("Server", tags$pre(tags$div(id = paste(gsub(" ", "_", title, fixed = TRUE), "server", sep = "_"), class = "r code shiny-text-output", "")))
+            )
+          )
         )
       )   
     )
@@ -45,6 +59,16 @@ fluidPage(style = "padding-top: 20px;",
                                  actionButton("bsAlertCreate", "Create Alert")),
               example = bsAlert("bsAlertDemo")
     ),
+    demoPanel("Collapses",
+              intro = "<p>Collapses are a way to reduce clutter in your Shiny app by allowing users to decide which elements they want visible at any given time. This demo makes extensive use of collapses. Each section is wrapped in a collapse element so that it can be hidden or shown with a click.</p>",
+              controls = tagList(checkboxInput("bsCollapseMultiple", "Multiple", value = TRUE),
+                                 selectInput("bsCollapseTextStyle", "'Text' Style", choices = c("default", "warning", "danger", "info", "success"), selected = "default"),
+                                 selectInput("bsCollapseOutputStyle", "'Shiny Outputs' Style", choices = c("default", "warning", "danger", "info", "success"), selected = "default")),
+              example = bsCollapse(id = "collapseExample", multiple = TRUE, open = c("Text", "Shiny Outputs"),
+                          bsCollapsePanel("Text", HTML("You may want more explanation or instructions for your Shiny app than is reasonable to display at all times. Wrap this text in a <code>bsCollapse</code> and the user can hide it when they are done with it and easily bring it back if they need to reference it again.</p>")),
+                          bsCollapsePanel("Shiny Outputs", tagList(tags$span("You can embed Shiny outputs into your collapses."), plotOutput("collapsePlot")))
+                        )
+    ),                          
     tabPanel("Tab 2",
       fluidRow(
         column(12,

inst/bsDemo/www/demo.css

@@ -6,8 +6,6 @@ div.code {
  font-family: monospace;
  width: 100%;
  min-height: 200px;
- border: solid 1px #CCC;
- border-radius: 4px;
  margin-bottom: 10px;
  padding: 10px;
  text-indent: -20px;