add wrench to boxes

Author: dmpe

R/boxes.R

@@ -17,8 +17,7 @@
 #'
 #' @export
 valueBox <- function(value, subtitle, icon = NULL, color = "aqua", width = 4,
-  href = NULL)
-{
+  href = NULL) {
   validateColor(color)
   if (!is.null(icon)) tagAssert(icon, type = "i")
 
@@ -120,6 +119,7 @@ infoBox <- function(title, value = NULL, subtitle = NULL,
 #' @param collapsed If TRUE, start collapsed. This must be used with
 #'   \code{collapsible=TRUE}.
 #' @param ... Contents of the box.
+#' @param wrench adds a dropdown menu
 #'
 #' @family boxes
 #'
@@ -250,7 +250,7 @@ infoBox <- function(title, value = NULL, subtitle = NULL,
 #' @export
 box <- function(..., title = NULL, footer = NULL, status = NULL,
                 solidHeader = FALSE, background = NULL, width = 6,
-                height = NULL, collapsible = FALSE, collapsed = FALSE) {
+                height = NULL, collapsible = FALSE, collapsed = FALSE, wrench = FALSE) {
 
   boxClass <- "box"
   if (solidHeader || !is.null(background)) {
@@ -263,6 +263,7 @@ box <- function(..., title = NULL, footer = NULL, status = NULL,
   if (collapsible && collapsed) {
     boxClass <- paste(boxClass, "collapsed-box")
   }
+
   if (!is.null(background)) {
     validateColor(background)
     boxClass <- paste0(boxClass, " bg-", background)
@@ -279,24 +280,35 @@ box <- function(..., title = NULL, footer = NULL, status = NULL,
   }
 
   collapseTag <- NULL
-  if (collapsible) {
+  wrenchTag <- NULL
+  boxToolsTag <- NULL
+
+  if (collapsible == TRUE && wrench == TRUE) {
     buttonStatus <- status %OR% "default"
 
     collapseIcon <- if (collapsed) "plus" else "minus"
 
-    collapseTag <- div(class = "box-tools pull-right",
-      tags$button(class = paste0("btn btn-box-tool"),
-        `data-widget` = "collapse",
-        shiny::icon(collapseIcon)
-      )
+    collapseTag <- tags$button(class = paste0("btn btn-box-tool"), `data-widget` = "collapse", shiny::icon(collapseIcon))
+    wrenchTag <- div(class = paste0("btn-group"),
+                     tags$button(class = "btn btn-box-tool dropdown-toggle", `type` = "button", `data-toggle` = "dropdown", shiny::icon("wrench")),
+                     tags$ul(class = "dropdown-menu", `role` = "menu")
+                     ## todo vymyslet jak zaridit abych to pouzivatelne z UI
+    )
+
+    boxToolsTag <- div(class = "box-tools pull-right",
+                       collapseTag,
+                       wrenchTag
     )
   }
 
+
+
+
   headerTag <- NULL
   if (!is.null(titleTag) || !is.null(collapseTag)) {
     headerTag <- div(class = "box-header",
       titleTag,
-      collapseTag
+      boxToolsTag
     )
   }
 
@@ -368,8 +380,8 @@ box <- function(..., title = NULL, footer = NULL, status = NULL,
 #' }
 #' @export
 tabBox <- function(..., id = NULL, selected = NULL, title = NULL,
-                   width = 6, height = NULL, side = c("left", "right"))
-{
+                   width = 6, height = NULL, side = c("left", "right")) {
+
   side <- match.arg(side)
 
   # The content is basically a tabsetPanel with some custom modifications

man/box.Rd

@@ -42,7 +42,7 @@ body <- dashboardBody(
         )
     ),
     box(title = "Histogram box title",
-        status = "warning", solidHeader = TRUE, collapsible = TRUE,
+        status = "warning", solidHeader = TRUE, collapsible = F, wrench = TRUE,
         plotOutput("plot", height = 250)
     )
   ),

tests-manual/box.R

@@ -1,8 +1,12 @@
-## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110
+## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 and 94
+
 library(shiny)
 library(shinydashboard)
 
-header <- dashboardHeader(title = "Dashboard Demo")
+header <- dashboardHeader(
+  ##title = "Dashboard Demo"
+  title = span(tagList(icon("diamond",class='fa-lg'), 'Icon not showing'))
+  )
 
 body <- dashboardBody()
 

tests-manual/repro_issues_110.R renamed to tests-manual/repro_issues_110_94.R

@@ -1,13 +1,5 @@
-<<<<<<< 7e2d8ee5ec2d42bdf67b396a36e9fce3ce73d0fb
-<<<<<<< 31102cf44a0361cb470aaa716f30397a926fddb3
 ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/17
 
-=======
->>>>>>> e4c3bc1ef3418879040e39f52363c8e601b609cd
-=======
-if(interactive()){
-## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/17
->>>>>>> 228ee6faa3c1f4d6827a35be79a240b9027de4bd
 library(shiny)
 library(shinydashboard)
 
@@ -31,4 +23,3 @@ shinyApp(
   ),
   server = server
 )
-}

tests-manual/repro_issues_17.R

@@ -1,13 +1,5 @@
-<<<<<<< 7e2d8ee5ec2d42bdf67b396a36e9fce3ce73d0fb
-<<<<<<< 31102cf44a0361cb470aaa716f30397a926fddb3
 ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/42
 
-=======
->>>>>>> e4c3bc1ef3418879040e39f52363c8e601b609cd
-=======
-if(interactive()) {
-## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/42
->>>>>>> 228ee6faa3c1f4d6827a35be79a240b9027de4bd
 library(shiny)
 library(shinydashboard)
 
@@ -49,4 +41,3 @@ server <-  function(input, output) {
 }
 
 shinyApp(ui, server)
-}

tests-manual/repro_issues_42.R

@@ -1,12 +1,4 @@
-<<<<<<< 31102cf44a0361cb470aaa716f30397a926fddb3
 ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/54
-=======
-# Working example
-<<<<<<< 7e2d8ee5ec2d42bdf67b396a36e9fce3ce73d0fb
->>>>>>> e4c3bc1ef3418879040e39f52363c8e601b609cd
-=======
-## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/54
->>>>>>> 228ee6faa3c1f4d6827a35be79a240b9027de4bd
 
 # library(shiny)
 # library(shinydashboard)