From e72d5559108809e506405553bc368ddcf61246a0 Mon Sep 17 00:00:00 2001 From: Brett Taylor Date: Tue, 30 Jan 2018 04:33:06 +0000 Subject: [PATCH 1/3] Added in the extension to dashboardPage to support the "light" skin color themes that is supported by AdminLTE. --- R/dashboardPage.R | 9 +- man/dashboardPage.Rd | 11 +- tests-manual/bigDashLIghtcolor.R | 311 +++++++++++++++++++++++++++++++ 3 files changed, 324 insertions(+), 7 deletions(-) create mode 100644 tests-manual/bigDashLIghtcolor.R diff --git a/R/dashboardPage.R b/R/dashboardPage.R index e35c9eca..fee145c2 100644 --- a/R/dashboardPage.R +++ b/R/dashboardPage.R @@ -7,8 +7,10 @@ #' @param body A body created by \code{dashboardBody}. #' @param title A title to display in the browser's title bar. If no value is #' provided, it will try to extract the title from the \code{dashboardHeader}. -#' @param skin A color theme. One of \code{"blue"}, \code{"black"}, -#' \code{"purple"}, \code{"green"}, \code{"red"}, or \code{"yellow"}. +#' @param skin A color theme. One of \code{"blue"}, \code{"blue-light"}, +#' \code{"black"}, \code{"black-light"}, \code{"purple"}, \code{"purple-light"}, +#' \code{"green"}, \code{"green-light"} , \code{"red"}, \code{"red-light"}, +#' \code{"yellow"}, or \code{"yellow-light"}. #' #' @seealso \code{\link{dashboardHeader}}, \code{\link{dashboardSidebar}}, #' \code{\link{dashboardBody}}. @@ -29,7 +31,8 @@ #' } #' @export dashboardPage <- function(header, sidebar, body, title = NULL, - skin = c("blue", "black", "purple", "green", "red", "yellow")) { + skin = c("blue", "blue-light","black","black-light", "purple","purple-light", "green","green-light", + "red","red-light", "yellow","yellow-light")) { tagAssert(header, type = "header", class = "main-header") tagAssert(sidebar, type = "aside", class = "main-sidebar") diff --git a/man/dashboardPage.Rd b/man/dashboardPage.Rd index 2e29f3e0..10ca2b64 100644 --- a/man/dashboardPage.Rd +++ b/man/dashboardPage.Rd @@ -4,8 +4,9 @@ \alias{dashboardPage} \title{Dashboard page} \usage{ -dashboardPage(header, sidebar, body, title = NULL, skin = c("blue", "black", - "purple", "green", "red", "yellow")) +dashboardPage(header, sidebar, body, title = NULL, skin = c("blue", + "blue-light", "black", "black-light", "purple", "purple-light", "green", + "green-light", "red", "red-light", "yellow", "yellow-light")) } \arguments{ \item{header}{A header created by \code{dashboardHeader}.} @@ -17,8 +18,10 @@ dashboardPage(header, sidebar, body, title = NULL, skin = c("blue", "black", \item{title}{A title to display in the browser's title bar. If no value is provided, it will try to extract the title from the \code{dashboardHeader}.} -\item{skin}{A color theme. One of \code{"blue"}, \code{"black"}, -\code{"purple"}, \code{"green"}, \code{"red"}, or \code{"yellow"}.} +\item{skin}{A color theme. One of \code{"blue"}, \code{"blue-light"}, + \code{"black"}, \code{"black-light"}, \code{"purple"}, \code{"purple-light"}, +\code{"green"}, \code{"green-light"} , \code{"red"}, \code{"red-light"}, + \code{"yellow"}, or \code{"yellow-light"}.} } \description{ This creates a dashboard page for use in a Shiny app. diff --git a/tests-manual/bigDashLIghtcolor.R b/tests-manual/bigDashLIghtcolor.R new file mode 100644 index 00000000..42aeca24 --- /dev/null +++ b/tests-manual/bigDashLIghtcolor.R @@ -0,0 +1,311 @@ +## This tries to render a dashboard with many different components, incl. sidebar, dropdown menus etc. + +library(shiny) +library(shinydashboard) + +header <- dashboardHeader( + title = "Dashboard Light", + + # Dropdown menu for messages + dropdownMenu( + type = "messages", + badgeStatus = "success", + messageItem("Support Team", + "This is the content of a message.", + time = "5 mins"), + messageItem("Support Team", + "This is the content of another message.", + time = "2 hours"), + messageItem("New User", + "Can I get some help?", + time = "Today") + ), + + # Dropdown menu for notifications + dropdownMenu( + type = "notifications", + badgeStatus = "warning", + notificationItem( + icon = icon("users"), + status = "info", + "5 new members joined today" + ), + notificationItem( + icon = icon("warning"), + status = "danger", + "Resource usage near limit." + ), + notificationItem( + icon = icon("shopping-cart", lib = "glyphicon"), + status = "success", + "25 sales made" + ), + notificationItem( + icon = icon("user", lib = "glyphicon"), + status = "danger", + "You changed your username" + ) + ), + + # Dropdown menu for tasks, with progress bar + dropdownMenu( + type = "tasks", + badgeStatus = "danger", + taskItem(value = 20, color = "aqua", + "Refactor code"), + taskItem(value = 40, color = "green", + "Design new layout"), + taskItem(value = 60, color = "yellow", + "Another task"), + taskItem(value = 80, color = "red", + "Write documentation") + ) +) +sidebar <- dashboardSidebar( + sidebarUserPanel( + "User Name", + subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"), + # Image file should be in www/ subdir + image = "userimage.png" + ), + sidebarSearchForm(label = "Enter a number", "searchText", "searchButton"), + sidebarMenu( + # Setting id makes input$tabs give the tabName of currently-selected tab + id = "tabs", + menuItem( + "Dashboard", + tabName = "dashboard", + icon = icon("dashboard") + ), + menuItem( + "Widgets", + icon = icon("th"), + tabName = "widgets", + badgeLabel = "new", + badgeColor = "green" + ), + menuItem( + "Charts", + icon = icon("bar-chart-o"), + menuSubItem("Sub-item 1", tabName = "subitem1"), + menuSubItem("Sub-item 2", tabName = "subitem2") + ) + ), + sidebarMenuOutput("menu") +) + +body <- dashboardBody(tabItems( + tabItem("dashboard", + div(p( + "Dashboard tab content" + ))), + tabItem("widgets", + "Widgets tab content"), + tabItem("subitem1", + "Sub-item 1 tab content"), + tabItem("subitem2", + "Sub-item 2 tab content")), + + # Boxes need to be put in a row (or column) + fluidRow(box(plotOutput("plot1", height = 250)), + box( + title = "Controls", + sliderInput("slider", "Number of observations:", 1, 100, 50) + )), + + # infoBoxes + fluidRow( + infoBox( + "Orders", + uiOutput("orderNum2"), + "Subtitle", + icon = icon("credit-card") + ), + infoBox( + "Approval Rating", + "60%", + icon = icon("line-chart"), + color = "green", + fill = TRUE + ), + infoBox( + "Progress", + uiOutput("progress2"), + icon = icon("users"), + color = "purple" + ) + ), + + # valueBoxes + fluidRow( + valueBox( + uiOutput("orderNum"), + "New Orders", + icon = icon("credit-card"), + href = "http://google.com" + ), + valueBox( + tagList("60", tags$sup(style = "font-size: 20px", "%")), + "Approval Rating", + icon = icon("line-chart"), + color = "green" + ), + valueBox( + htmlOutput("progress"), + "Progress", + icon = icon("users"), + color = "purple" + ) + ), + + # Boxes + fluidRow( + box( + status = "primary", + sliderInput( + "orders", + "Orders", + min = 1, + max = 2000, + value = 650 + ), + selectInput( + "progress", + "Progress", + choices = c( + "0%" = 0, + "20%" = 20, + "40%" = 40, + "60%" = 60, + "80%" = 80, + "100%" = 100 + ) + ) + ), + box( + title = "Histogram box title", + status = "warning", + solidHeader = TRUE, + collapsible = TRUE, + plotOutput("plot", height = 250) + ) + ), + + # Boxes with solid color, using `background` + fluidRow( + # Box with textOutput + box( + title = "Status summary", + background = "green", + width = 4, + textOutput("status") + ), + + # Box with HTML output, when finer control over appearance is needed + box( + title = "Status summary 2", + width = 4, + background = "red", + uiOutput("status2") + ), + + box( + width = 4, + background = "light-blue", + p("This is content. The background color is set to light-blue") + ) + ), + + 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") + ) + ) + +) + +server <- function(input, output) { + set.seed(122) + histdata <- rnorm(500) + + output$menu <- renderMenu({ + sidebarMenu(menuItem("Menu item", icon = icon("calendar"))) + }) + + output$plot1 <- renderPlot({ + data <- histdata[seq_len(input$slider)] + hist(data) + }) + + output$orderNum <- renderText({ + prettyNum(input$orders, big.mark = ",") + }) + + output$orderNum2 <- renderText({ + prettyNum(input$orders, big.mark = ",") + }) + + output$progress <- renderUI({ + tagList(input$progress, tags$sup(style = "font-size: 20px", "%")) + }) + + output$progress2 <- renderUI({ + paste0(input$progress, "%") + }) + + output$status <- renderText({ + paste0( + "There are ", + input$orders, + " orders, and so the current progress is ", + input$progress, + "%." + ) + }) + + output$status2 <- renderUI({ + iconName <- switch(input$progress, + "100" = "ok", + "0" = "remove", + "road") + p("Current status is: ", icon(iconName, lib = "glyphicon")) + }) + + + output$plot <- renderPlot({ + hist(rnorm(input$orders)) + }) + + # The currently selected tab from the first box + output$tabset1Selected <- renderText({ + input$tabset1 + }) +} + +ui <- dashboardPage(header, + sidebar, + body,skin = "green-light") + +shinyApp(ui, server) From de3ca842ffa3005d144f7a160ca3caf09eb9f1e7 Mon Sep 17 00:00:00 2001 From: Brett Taylor Date: Tue, 30 Jan 2018 21:44:04 +0000 Subject: [PATCH 2/3] Extended capabilities to support light skins with dark color in the sidebar. --- inst/shinydashboard.css | 53 ++++++++++++++++++++++++++++++-- tests-manual/bigDash.R | 4 ++- tests-manual/bigDashLIghtcolor.R | 5 ++- 3 files changed, 57 insertions(+), 5 deletions(-) diff --git a/inst/shinydashboard.css b/inst/shinydashboard.css index 1bee0459..123a958f 100644 --- a/inst/shinydashboard.css +++ b/inst/shinydashboard.css @@ -50,9 +50,56 @@ div.box-body .shiny-input-container { width: auto; } -/* Sidebar is dark, so make text light by default. */ -.sidebar { - color: #fff; +/* When the sidebar is dark, make text light (#fff), and when it is light, make it dark (#2F4F4F). */ + +.skin-blue .sidebar { + color: #fff; +} + +.skin-blue-light .sidebar { + color: #2F4F4F; + +} +.skin-black .sidebar { + color: #fff; +} + +.skin-black-light .sidebar { + color: #2F4F4F; + +} + +.skin-purple .sidebar { + color: #fff; +} + +.skin-purple-light .sidebar { + color: #2F4F4F; + +} +.skin-green .sidebar { + color: #fff; +} + +.skin-green-light .sidebar { + color: #2F4F4F; + +} +.skin-red .sidebar { + color: #fff; +} + +.skin-green-red .sidebar { + color: #2F4F4F; + +} +.skin-yellow .sidebar { + color: #fff; +} + +.skin-yellow-light .sidebar { + color: #2F4F4F; + } /* Slider min and max in sidebar. */ .sidebar .irs-min, .sidebar .irs-max { diff --git a/tests-manual/bigDash.R b/tests-manual/bigDash.R index 1fd4a3ee..f6f0f3fd 100644 --- a/tests-manual/bigDash.R +++ b/tests-manual/bigDash.R @@ -62,6 +62,8 @@ header <- dashboardHeader( ) ) sidebar <- dashboardSidebar( + headerPanel("Hello ") , + sidebarUserPanel( "User Name", subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"), @@ -91,7 +93,7 @@ sidebar <- dashboardSidebar( menuSubItem("Sub-item 2", tabName = "subitem2") ) ), - sidebarMenuOutput("menu") + sidebarMenuOutput("menu") ) body <- dashboardBody(tabItems( diff --git a/tests-manual/bigDashLIghtcolor.R b/tests-manual/bigDashLIghtcolor.R index 42aeca24..3770f423 100644 --- a/tests-manual/bigDashLIghtcolor.R +++ b/tests-manual/bigDashLIghtcolor.R @@ -62,6 +62,8 @@ header <- dashboardHeader( ) ) sidebar <- dashboardSidebar( + headerPanel("Hello ") , + sidebarUserPanel( "User Name", subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"), @@ -92,6 +94,7 @@ sidebar <- dashboardSidebar( ) ), sidebarMenuOutput("menu") + ) body <- dashboardBody(tabItems( @@ -306,6 +309,6 @@ server <- function(input, output) { ui <- dashboardPage(header, sidebar, - body,skin = "green-light") + body,skin = "blue-light") shinyApp(ui, server) From a2bd05e75f6a26fe1589bd1b775828b388711476 Mon Sep 17 00:00:00 2001 From: Brett Taylor Date: Tue, 30 Jan 2018 21:48:14 +0000 Subject: [PATCH 3/3] renamed test-manual for skin light color --- tests-manual/{bigDashLIghtcolor.R => bigDashSkinLightcolor.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests-manual/{bigDashLIghtcolor.R => bigDashSkinLightcolor.R} (100%) diff --git a/tests-manual/bigDashLIghtcolor.R b/tests-manual/bigDashSkinLightcolor.R similarity index 100% rename from tests-manual/bigDashLIghtcolor.R rename to tests-manual/bigDashSkinLightcolor.R