From b22787f9f6bb793279233f49b2ee6fcdc189b92d Mon Sep 17 00:00:00 2001 From: dmpe Date: Mon, 7 Dec 2015 20:27:57 +0100 Subject: [PATCH 01/13] sq. them --- .Rbuildignore | 1 + R/boxes.R | 25 +++++++++--- man/box.Rd | 4 +- {tests => tests-manual}/bigDash.R | 4 +- {tests => tests-manual}/box.R | 6 +-- {tests => tests-manual}/dashboardHeader.R | 0 {tests => tests-manual}/dashboardSidebar.R | 0 {tests => tests-manual}/renderMenu.R | 0 {tests => tests-manual}/renderMenu2.R | 0 {tests => tests-manual}/renderValueBox.R | 0 {tests => tests-manual}/repro_issues_110.R | 5 ++- tests-manual/repro_issues_17.R | 23 +++++++++++ tests-manual/repro_issues_42.R | 41 ++++++++++++++++++++ tests-manual/repro_issues_54.R | 44 ++++++++++++++++++++++ {tests => tests-manual}/tabBox.R | 0 {tests => tests-manual}/updateTabItems.R | 0 16 files changed, 140 insertions(+), 13 deletions(-) rename {tests => tests-manual}/bigDash.R (95%) rename {tests => tests-manual}/box.R (95%) rename {tests => tests-manual}/dashboardHeader.R (100%) rename {tests => tests-manual}/dashboardSidebar.R (100%) rename {tests => tests-manual}/renderMenu.R (100%) rename {tests => tests-manual}/renderMenu2.R (100%) rename {tests => tests-manual}/renderValueBox.R (100%) rename {tests => tests-manual}/repro_issues_110.R (87%) create mode 100644 tests-manual/repro_issues_17.R create mode 100644 tests-manual/repro_issues_42.R create mode 100644 tests-manual/repro_issues_54.R rename {tests => tests-manual}/tabBox.R (100%) rename {tests => tests-manual}/updateTabItems.R (100%) diff --git a/.Rbuildignore b/.Rbuildignore index 5ef022d0..75af928c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,4 +1,5 @@ ^.*\.Rproj$ ^\.Rproj\.user$ ^tools$ +^tests-manual$ ^\.travis\.yml$ diff --git a/R/boxes.R b/R/boxes.R index 4f287ec9..c1366565 100644 --- a/R/boxes.R +++ b/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) @@ -292,11 +293,23 @@ box <- function(..., title = NULL, footer = NULL, status = NULL, ) } + wrenchTag <- NULL + if (wrench) { + wrenchTag <- div(class = "box-tools pull-right", + div(class = paste0("btn-group"), + tags$button(class = "btn btn-box-tool dropdown-toggle", `data-toggle` = "dropdown", shiny::icon("wrench")), + tags$ul(class = "dropdown-menu", `role` = "menu") + ## todo vymyslet jak zaridit abych to pouzivatelne z UI + ) + ) + } + headerTag <- NULL if (!is.null(titleTag) || !is.null(collapseTag)) { headerTag <- div(class = "box-header", titleTag, - collapseTag + collapseTag, + wrenchTag ) } @@ -368,8 +381,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 diff --git a/man/box.Rd b/man/box.Rd index 9626aaf0..81c4ba9b 100644 --- a/man/box.Rd +++ b/man/box.Rd @@ -6,7 +6,7 @@ \usage{ box(..., title = NULL, footer = NULL, status = NULL, solidHeader = FALSE, background = NULL, width = 6, height = NULL, - collapsible = FALSE, collapsed = FALSE) + collapsible = FALSE, collapsed = FALSE, wrench = FALSE) } \arguments{ \item{...}{Contents of the box.} @@ -38,6 +38,8 @@ the user to collapse the box.} \item{collapsed}{If TRUE, start collapsed. This must be used with \code{collapsible=TRUE}.} + +\item{wrench}{adds a dropdown menu} } \description{ Boxes can be used to hold content in the main body of a dashboard. diff --git a/tests/bigDash.R b/tests-manual/bigDash.R similarity index 95% rename from tests/bigDash.R rename to tests-manual/bigDash.R index f8f2b8bc..1b549ef0 100644 --- a/tests/bigDash.R +++ b/tests-manual/bigDash.R @@ -1,4 +1,4 @@ -if(interactive()) { +#if(interactive()) { library(shiny) library(shinydashboard) @@ -310,4 +310,4 @@ if(interactive()) { body) shinyApp(ui, server) -} +#} diff --git a/tests/box.R b/tests-manual/box.R similarity index 95% rename from tests/box.R rename to tests-manual/box.R index b93d5da7..feb90938 100644 --- a/tests/box.R +++ b/tests-manual/box.R @@ -1,4 +1,4 @@ -if(interactive()) { +#if(interactive()) { library(shiny) # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes @@ -43,7 +43,7 @@ if(interactive()) { ) ), box(title = "Histogram box title", - status = "warning", solidHeader = TRUE, collapsible = TRUE, + status = "warning", solidHeader = TRUE, collapsible = FALSE, wrench = TRUE, plotOutput("plot", height = 250) ) ), @@ -171,4 +171,4 @@ if(interactive()) { ), server = server ) -} +#} diff --git a/tests/dashboardHeader.R b/tests-manual/dashboardHeader.R similarity index 100% rename from tests/dashboardHeader.R rename to tests-manual/dashboardHeader.R diff --git a/tests/dashboardSidebar.R b/tests-manual/dashboardSidebar.R similarity index 100% rename from tests/dashboardSidebar.R rename to tests-manual/dashboardSidebar.R diff --git a/tests/renderMenu.R b/tests-manual/renderMenu.R similarity index 100% rename from tests/renderMenu.R rename to tests-manual/renderMenu.R diff --git a/tests/renderMenu2.R b/tests-manual/renderMenu2.R similarity index 100% rename from tests/renderMenu2.R rename to tests-manual/renderMenu2.R diff --git a/tests/renderValueBox.R b/tests-manual/renderValueBox.R similarity index 100% rename from tests/renderValueBox.R rename to tests-manual/renderValueBox.R diff --git a/tests/repro_issues_110.R b/tests-manual/repro_issues_110.R similarity index 87% rename from tests/repro_issues_110.R rename to tests-manual/repro_issues_110.R index 4ea76ae3..528d13fa 100644 --- a/tests/repro_issues_110.R +++ b/tests-manual/repro_issues_110.R @@ -2,7 +2,10 @@ if(interactive()) { 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')) # Github Issue 94 + ) body <- dashboardBody() diff --git a/tests-manual/repro_issues_17.R b/tests-manual/repro_issues_17.R new file mode 100644 index 00000000..2e400b1b --- /dev/null +++ b/tests-manual/repro_issues_17.R @@ -0,0 +1,23 @@ +library(shiny) +library(shinydashboard) + +body <- dashboardBody( + uiOutput("ui") +) + +server <- function(input, output) { + output$ui <- renderUI({ + box(title = "Collapse me", + status = "warning", solidHeader = TRUE, collapsible = TRUE + ) + }) +} + +shinyApp( + ui = dashboardPage( + dashboardHeader(), + dashboardSidebar(), + body + ), + server = server +) diff --git a/tests-manual/repro_issues_42.R b/tests-manual/repro_issues_42.R new file mode 100644 index 00000000..9ce40238 --- /dev/null +++ b/tests-manual/repro_issues_42.R @@ -0,0 +1,41 @@ +library(shiny) +library(shinydashboard) + +ui <- dashboardPage( + dashboardHeader(), + dashboardSidebar( + sidebarMenu( + menuItem("Inputs", icon = icon("bar-chart-o"), tabName = "tabOne" + ) + ) + ), + dashboardBody( + tabItems( + tabItem("tabOne", + box(title = "Test Box One", + status = "success", + solidHeader = TRUE, + collapsible = TRUE, + collapsed = TRUE, + plotOutput("plot", height = 250), + verbatimTextOutput("boxOneText") + ), + box( + actionButton("go", "Go") + ) + ) + ) + ) +) + +server <- function(input, output) { + output$plot <- renderPlot({ + cat(paste("plotting", input$go, "\n")) + plot(rnorm(1 + input$go), rnorm(1 + input$go)) + }) + output$boxOneText <- renderText({ + paste("Go counter:", input$go) + }) +} + +shinyApp(ui, server) diff --git a/tests-manual/repro_issues_54.R b/tests-manual/repro_issues_54.R new file mode 100644 index 00000000..f15eddad --- /dev/null +++ b/tests-manual/repro_issues_54.R @@ -0,0 +1,44 @@ +# Working example + +# library(shiny) +# library(shinydashboard) +# +# sidebar <- dashboardSidebar( +# sidebarMenu(menuItem("foo", +# menuSubItem("foo_"), tabName = "tabfoo")) +# ) +# +# +# ui <- dashboardPage( +# dashboardHeader(), +# sidebar, +# dashboardBody() +# ) +# +# server <- function(input, output) {} +# +# shinyApp(ui, server) + +# Not working example + +library(shinydashboard) +library(shiny) + +sidebar <- dashboardSidebar( + sidebarMenuOutput("sbMenu") +) + + +ui <- dashboardPage( + dashboardHeader(), + sidebar, + dashboardBody() +) + +server <- function(input, output) { + output$sbMenu <- renderMenu({ + sidebarMenu(menuItem("foo", menuSubItem("foo_"), tabName = "tabfoo")) + }) +} + +shinyApp(ui, server) diff --git a/tests/tabBox.R b/tests-manual/tabBox.R similarity index 100% rename from tests/tabBox.R rename to tests-manual/tabBox.R diff --git a/tests/updateTabItems.R b/tests-manual/updateTabItems.R similarity index 100% rename from tests/updateTabItems.R rename to tests-manual/updateTabItems.R From 934ff246293466357dd542bdc1dc641251252c7d Mon Sep 17 00:00:00 2001 From: dmpe Date: Thu, 29 Oct 2015 23:11:08 +0100 Subject: [PATCH 02/13] roxygenize + update description file --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 026de3ed..fde706f3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,3 +19,4 @@ Imports: htmltools (>= 0.2.6) BugReports: https://github.com/rstudio/shinydashboard RoxygenNote: 5.0.1 + From 4cf4ad541dcefc364aace1951a45eecbb510e418 Mon Sep 17 00:00:00 2001 From: dmpe Date: Sat, 31 Oct 2015 22:18:09 +0100 Subject: [PATCH 03/13] add standalone tests so that one can use them in the tests folder add really big dashboard covering about 70-80% of all elements used or described. update news file as I believe version update to AdminLTE 2.3.2 is fine and not going to break anything. --- tests/bigDash.R | 311 +++++++++++++++++++++++++++++++++++++++ tests/box.R | 171 +++++++++++++++++++++ tests/dashboardHeader.R | 63 ++++++++ tests/dashboardSidebar.R | 53 +++++++ tests/renderMenu.R | 19 +++ tests/renderMenu2.R | 43 ++++++ tests/renderValueBox.R | 32 ++++ tests/tabBox.R | 41 ++++++ tests/updateTabItems.R | 33 +++++ 9 files changed, 766 insertions(+) create mode 100644 tests/bigDash.R create mode 100644 tests/box.R create mode 100644 tests/dashboardHeader.R create mode 100644 tests/dashboardSidebar.R create mode 100644 tests/renderMenu.R create mode 100644 tests/renderMenu2.R create mode 100644 tests/renderValueBox.R create mode 100644 tests/tabBox.R create mode 100644 tests/updateTabItems.R diff --git a/tests/bigDash.R b/tests/bigDash.R new file mode 100644 index 00000000..cee39215 --- /dev/null +++ b/tests/bigDash.R @@ -0,0 +1,311 @@ +library(shiny) +library(shinydashboard) + +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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") + ) +) + + +body <- dashboardBody( + 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 + }) +} + +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") +) + +ui <- dashboardPage(header, + sidebar, + body) + +shinyApp(ui, server) diff --git a/tests/box.R b/tests/box.R new file mode 100644 index 00000000..7beaeb42 --- /dev/null +++ b/tests/box.R @@ -0,0 +1,171 @@ +library(shiny) +# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes +body <- dashboardBody( + + # 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") + ) + ) +) + +server <- function(input, output) { + 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)) + }) +} +# A dashboard header with 3 dropdown menus +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) +) + +shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + body + ), + server = server +) diff --git a/tests/dashboardHeader.R b/tests/dashboardHeader.R new file mode 100644 index 00000000..d5f76671 --- /dev/null +++ b/tests/dashboardHeader.R @@ -0,0 +1,63 @@ +library(shiny) + +# A dashboard header with 3 dropdown menus +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) +) + +shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + dashboardBody() + ), + server = function(input, output) { } +) diff --git a/tests/dashboardSidebar.R b/tests/dashboardSidebar.R new file mode 100644 index 00000000..25106f47 --- /dev/null +++ b/tests/dashboardSidebar.R @@ -0,0 +1,53 @@ +header <- dashboardHeader() + +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") + ) + ) +) + +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") +)) + +shinyApp( + ui = dashboardPage(header, sidebar, body), + server = function(input, output) { + + } +) diff --git a/tests/renderMenu.R b/tests/renderMenu.R new file mode 100644 index 00000000..010cc4f6 --- /dev/null +++ b/tests/renderMenu.R @@ -0,0 +1,19 @@ +library(shiny) +# ========== Dynamic sidebarMenu ========== +ui <- dashboardPage( + dashboardHeader(title = "Dynamic sidebar"), + dashboardSidebar( + sidebarMenuOutput("menu") + ), + dashboardBody() +) + +server <- function(input, output) { + output$menu <- renderMenu({ + sidebarMenu( + menuItem("Menu item", icon = icon("calendar")) + ) + }) +} + +shinyApp(ui, server) diff --git a/tests/renderMenu2.R b/tests/renderMenu2.R new file mode 100644 index 00000000..b5992169 --- /dev/null +++ b/tests/renderMenu2.R @@ -0,0 +1,43 @@ +messageData <- data.frame( + from = c("Admininstrator", "New User", "Support"), + message = c( + "Sales are steady this month.", + "How do I register?", + "The new server is ready." + ), + stringsAsFactors = FALSE +) + +ui <- dashboardPage( + dashboardHeader( + title = "Dynamic menus", + dropdownMenuOutput("messageMenu") + ), + dashboardSidebar(), + dashboardBody( + fluidRow( + box( + title = "Controls", + sliderInput("slider", "Number of observations:", 1, 100, 50) + ) + ) + ) +) + +server <- function(input, output) { + output$messageMenu <- renderMenu({ + # Code to generate each of the messageItems here, in a list. messageData + # is a data frame with two columns, 'from' and 'message'. + # Also add on slider value to the message content, so that messages update. + msgs <- apply(messageData, 1, function(row) { + messageItem( + from = row[["from"]], + message = paste(row[["message"]], input$slider) + ) + }) + + dropdownMenu(type = "messages", .list = msgs) + }) +} + +shinyApp(ui, server) diff --git a/tests/renderValueBox.R b/tests/renderValueBox.R new file mode 100644 index 00000000..30c24ede --- /dev/null +++ b/tests/renderValueBox.R @@ -0,0 +1,32 @@ +library(shiny) + +ui <- dashboardPage( + dashboardHeader(title = "Dynamic boxes"), + dashboardSidebar(), + dashboardBody( + fluidRow( + box(width = 2, actionButton("count", "Count")), + infoBoxOutput("ibox"), + valueBoxOutput("vbox") + ) + ) +) + +server <- function(input, output) { + output$ibox <- renderInfoBox({ + infoBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + output$vbox <- renderValueBox({ + valueBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) +} + +shinyApp(ui, server) diff --git a/tests/tabBox.R b/tests/tabBox.R new file mode 100644 index 00000000..971140c4 --- /dev/null +++ b/tests/tabBox.R @@ -0,0 +1,41 @@ +library(shiny) + +body <- dashboardBody( + 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") + ) + ) +) + +shinyApp( + ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), + server = function(input, output) { + # The currently selected tab from the first box + output$tabset1Selected <- renderText({ + input$tabset1 + }) + } +) diff --git a/tests/updateTabItems.R b/tests/updateTabItems.R new file mode 100644 index 00000000..db53355d --- /dev/null +++ b/tests/updateTabItems.R @@ -0,0 +1,33 @@ +ui <- dashboardPage( + dashboardHeader(title = "Simple tabs"), + dashboardSidebar( + sidebarMenu( + id = "tabs", + menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), + menuItem("Widgets", tabName = "widgets", icon = icon("th")) + ), + actionButton('switchtab', 'Switch tab') + ), + dashboardBody( + tabItems( + tabItem(tabName = "dashboard", + h2("Dashboard tab content") + ), + tabItem(tabName = "widgets", + h2("Widgets tab content") + ) + ) + ) +) + +server <- function(input, output, session) { + observeEvent(input$switchtab, { + newtab <- switch(input$tabs, + "dashboard" = "widgets", + "widgets" = "dashboard" + ) + updateTabItems(session, "tabs", newtab) + }) +} + +shinyApp(ui, server) From 19221ee96e1b07c86fa5e40ced60c7ca298ae06a Mon Sep 17 00:00:00 2001 From: dmpe Date: Sat, 31 Oct 2015 22:25:52 +0100 Subject: [PATCH 04/13] fix tests for travis --- tests/bigDash.R | 540 ++++++++++++++++++++------------------- tests/box.R | 319 +++++++++++------------ tests/dashboardHeader.R | 117 ++++----- tests/dashboardSidebar.R | 95 +++---- tests/renderMenu.R | 37 +-- tests/renderMenu2.R | 73 +++--- tests/renderValueBox.R | 56 ++-- tests/tabBox.R | 3 + tests/updateTabItems.R | 57 +++-- 9 files changed, 661 insertions(+), 636 deletions(-) diff --git a/tests/bigDash.R b/tests/bigDash.R index cee39215..f8f2b8bc 100644 --- a/tests/bigDash.R +++ b/tests/bigDash.R @@ -1,311 +1,313 @@ -library(shiny) -library(shinydashboard) +if(interactive()) { + library(shiny) + library(shinydashboard) -header <- dashboardHeader( - title = "Dashboard Demo", + header <- dashboardHeader( + title = "Dashboard Demo", - # 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." + # 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") ), - notificationItem( - icon = icon("shopping-cart", lib = "glyphicon"), - status = "success", - "25 sales made" + + # 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" + ) ), - 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") + # 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") + ) ) -) -body <- dashboardBody( - 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" - ) - ), + body <- dashboardBody( + 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"), - # 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 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) + )), - # Boxes - fluidRow( - box( - status = "primary", - sliderInput( - "orders", + # infoBoxes + fluidRow( + infoBox( "Orders", - min = 1, - max = 2000, - value = 650 + uiOutput("orderNum2"), + "Subtitle", + icon = icon("credit-card") + ), + infoBox( + "Approval Rating", + "60%", + icon = icon("line-chart"), + color = "green", + fill = TRUE ), - selectInput( - "progress", + infoBox( "Progress", - choices = c( - "0%" = 0, - "20%" = 20, - "40%" = 40, - "60%" = 60, - "80%" = 80, - "100%" = 100 - ) + uiOutput("progress2"), + icon = icon("users"), + color = "purple" ) ), - 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") + # 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" + ) ), - # Box with HTML output, when finer control over appearance is needed - box( - title = "Status summary 2", - width = 4, - background = "red", - uiOutput("status2") + # 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) + ) ), - box( - width = 4, - background = "light-blue", - p("This is content. The background color is set to light-blue") - ) - ), + # 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") + ), - 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") + box( + width = 4, + background = "light-blue", + p("This is content. The background color is set to light-blue") + ) ), - 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") + + 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") ), - 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) + server <- function(input, output) { + set.seed(122) + histdata <- rnorm(500) - output$menu <- renderMenu({ - sidebarMenu(menuItem("Menu item", icon = icon("calendar"))) - }) + output$menu <- renderMenu({ + sidebarMenu(menuItem("Menu item", icon = icon("calendar"))) + }) - output$plot1 <- renderPlot({ - data <- histdata[seq_len(input$slider)] - hist(data) - }) + output$plot1 <- renderPlot({ + data <- histdata[seq_len(input$slider)] + hist(data) + }) - output$orderNum <- renderText({ - prettyNum(input$orders, big.mark = ",") - }) + output$orderNum <- renderText({ + prettyNum(input$orders, big.mark = ",") + }) - output$orderNum2 <- 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$progress <- renderUI({ + tagList(input$progress, tags$sup(style = "font-size: 20px", "%")) + }) - output$progress2 <- renderUI({ - paste0(input$progress, "%") - }) + output$progress2 <- renderUI({ + paste0(input$progress, "%") + }) - output$status <- renderText({ - paste0( - "There are ", - input$orders, - " orders, and so the current progress is ", - 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$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)) - }) + output$plot <- renderPlot({ + hist(rnorm(input$orders)) + }) - # The currently selected tab from the first box - output$tabset1Selected <- renderText({ - input$tabset1 - }) -} + # The currently selected tab from the first box + output$tabset1Selected <- renderText({ + input$tabset1 + }) + } -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") + sidebar <- dashboardSidebar( + sidebarUserPanel( + "User Name", + subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"), + # Image file should be in www/ subdir + image = "userimage.png" ), - menuItem( - "Widgets", - icon = icon("th"), - tabName = "widgets", - badgeLabel = "new", - badgeColor = "green" + 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") + ) ), - menuItem( - "Charts", - icon = icon("bar-chart-o"), - menuSubItem("Sub-item 1", tabName = "subitem1"), - menuSubItem("Sub-item 2", tabName = "subitem2") - ) - ), - sidebarMenuOutput("menu") -) + sidebarMenuOutput("menu") + ) -ui <- dashboardPage(header, - sidebar, - body) + ui <- dashboardPage(header, + sidebar, + body) -shinyApp(ui, server) + shinyApp(ui, server) +} diff --git a/tests/box.R b/tests/box.R index 7beaeb42..b93d5da7 100644 --- a/tests/box.R +++ b/tests/box.R @@ -1,171 +1,174 @@ -library(shiny) -# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes -body <- dashboardBody( - - # infoBoxes - fluidRow( - infoBox( - "Orders", uiOutput("orderNum2"), "Subtitle", icon = icon("credit-card") +if(interactive()) { + + library(shiny) + # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes + body <- dashboardBody( + + # 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" + ) ), - 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" + # 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" + ) ), - 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) - ) + + # 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) + ) ), - 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") + ) ) - ), - - # Boxes with solid color, using `background` - fluidRow( - # Box with textOutput - box( - title = "Status summary", - background = "green", - width = 4, - textOutput("status") + ) + + server <- function(input, output) { + 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)) + }) + } + # A dashboard header with 3 dropdown menus + header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) ), - # Box with HTML output, when finer control over appearance is needed - box( - title = "Status summary 2", - width = 4, - background = "red", - uiOutput("status2") + # 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" + ) ), - box( - width = 4, - background = "light-blue", - p("This is content. The background color is set to light-blue") + # 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" + ) ) ) -) - -server <- function(input, output) { - 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)) - }) -} -# A dashboard header with 3 dropdown menus -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) + shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + body + ), + server = server ) -) - -shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - body - ), - server = server -) +} diff --git a/tests/dashboardHeader.R b/tests/dashboardHeader.R index d5f76671..ace3cec8 100644 --- a/tests/dashboardHeader.R +++ b/tests/dashboardHeader.R @@ -1,63 +1,66 @@ -library(shiny) +if(interactive()) { -# A dashboard header with 3 dropdown menus -header <- dashboardHeader( - title = "Dashboard Demo", + library(shiny) - # 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" - ) - ), + # A dashboard header with 3 dropdown menus + header <- dashboardHeader( + title = "Dashboard Demo", - # 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 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 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" - ) + # 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" + ) + ) ) -) -shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - dashboardBody() - ), - server = function(input, output) { } -) + shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + dashboardBody() + ), + server = function(input, output) { } + ) +} diff --git a/tests/dashboardSidebar.R b/tests/dashboardSidebar.R index 25106f47..87f1f66f 100644 --- a/tests/dashboardSidebar.R +++ b/tests/dashboardSidebar.R @@ -1,53 +1,56 @@ -header <- dashboardHeader() +if(interactive()) { -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" + header <- dashboardHeader() + + sidebar <- dashboardSidebar( + sidebarUserPanel( + "User Name", + subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"), + # Image file should be in www/ subdir + image = "userimage.png" ), - menuItem( - "Charts", - icon = icon("bar-chart-o"), - menuSubItem("Sub-item 1", tabName = "subitem1"), - menuSubItem("Sub-item 2", tabName = "subitem2") + 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") + ) ) ) -) -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") -)) + 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") + )) -shinyApp( - ui = dashboardPage(header, sidebar, body), - server = function(input, output) { + shinyApp( + ui = dashboardPage(header, sidebar, body), + server = function(input, output) { - } -) + } + ) +} diff --git a/tests/renderMenu.R b/tests/renderMenu.R index 010cc4f6..16ba84e7 100644 --- a/tests/renderMenu.R +++ b/tests/renderMenu.R @@ -1,19 +1,22 @@ -library(shiny) -# ========== Dynamic sidebarMenu ========== -ui <- dashboardPage( - dashboardHeader(title = "Dynamic sidebar"), - dashboardSidebar( - sidebarMenuOutput("menu") - ), - dashboardBody() -) +if(interactive()) { -server <- function(input, output) { - output$menu <- renderMenu({ - sidebarMenu( - menuItem("Menu item", icon = icon("calendar")) - ) - }) -} + library(shiny) + # ========== Dynamic sidebarMenu ========== + ui <- dashboardPage( + dashboardHeader(title = "Dynamic sidebar"), + dashboardSidebar( + sidebarMenuOutput("menu") + ), + dashboardBody() + ) + + server <- function(input, output) { + output$menu <- renderMenu({ + sidebarMenu( + menuItem("Menu item", icon = icon("calendar")) + ) + }) + } -shinyApp(ui, server) + shinyApp(ui, server) +} diff --git a/tests/renderMenu2.R b/tests/renderMenu2.R index b5992169..c7b646bb 100644 --- a/tests/renderMenu2.R +++ b/tests/renderMenu2.R @@ -1,43 +1,46 @@ -messageData <- data.frame( - from = c("Admininstrator", "New User", "Support"), - message = c( - "Sales are steady this month.", - "How do I register?", - "The new server is ready." - ), - stringsAsFactors = FALSE -) +if(interactive()) { -ui <- dashboardPage( - dashboardHeader( - title = "Dynamic menus", - dropdownMenuOutput("messageMenu") - ), - dashboardSidebar(), - dashboardBody( - fluidRow( - box( - title = "Controls", - sliderInput("slider", "Number of observations:", 1, 100, 50) + messageData <- data.frame( + from = c("Admininstrator", "New User", "Support"), + message = c( + "Sales are steady this month.", + "How do I register?", + "The new server is ready." + ), + stringsAsFactors = FALSE + ) + + ui <- dashboardPage( + dashboardHeader( + title = "Dynamic menus", + dropdownMenuOutput("messageMenu") + ), + dashboardSidebar(), + dashboardBody( + fluidRow( + box( + title = "Controls", + sliderInput("slider", "Number of observations:", 1, 100, 50) + ) ) ) ) -) -server <- function(input, output) { - output$messageMenu <- renderMenu({ - # Code to generate each of the messageItems here, in a list. messageData - # is a data frame with two columns, 'from' and 'message'. - # Also add on slider value to the message content, so that messages update. - msgs <- apply(messageData, 1, function(row) { - messageItem( - from = row[["from"]], - message = paste(row[["message"]], input$slider) - ) + server <- function(input, output) { + output$messageMenu <- renderMenu({ + # Code to generate each of the messageItems here, in a list. messageData + # is a data frame with two columns, 'from' and 'message'. + # Also add on slider value to the message content, so that messages update. + msgs <- apply(messageData, 1, function(row) { + messageItem( + from = row[["from"]], + message = paste(row[["message"]], input$slider) + ) + }) + + dropdownMenu(type = "messages", .list = msgs) }) + } - dropdownMenu(type = "messages", .list = msgs) - }) + shinyApp(ui, server) } - -shinyApp(ui, server) diff --git a/tests/renderValueBox.R b/tests/renderValueBox.R index 30c24ede..32f51b31 100644 --- a/tests/renderValueBox.R +++ b/tests/renderValueBox.R @@ -1,32 +1,34 @@ -library(shiny) +if(interactive()) { + library(shiny) -ui <- dashboardPage( - dashboardHeader(title = "Dynamic boxes"), - dashboardSidebar(), - dashboardBody( - fluidRow( - box(width = 2, actionButton("count", "Count")), - infoBoxOutput("ibox"), - valueBoxOutput("vbox") + ui <- dashboardPage( + dashboardHeader(title = "Dynamic boxes"), + dashboardSidebar(), + dashboardBody( + fluidRow( + box(width = 2, actionButton("count", "Count")), + infoBoxOutput("ibox"), + valueBoxOutput("vbox") + ) ) ) -) -server <- function(input, output) { - output$ibox <- renderInfoBox({ - infoBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - output$vbox <- renderValueBox({ - valueBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) -} + server <- function(input, output) { + output$ibox <- renderInfoBox({ + infoBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + output$vbox <- renderValueBox({ + valueBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + } -shinyApp(ui, server) + shinyApp(ui, server) +} diff --git a/tests/tabBox.R b/tests/tabBox.R index 971140c4..d9dba699 100644 --- a/tests/tabBox.R +++ b/tests/tabBox.R @@ -1,3 +1,5 @@ +if(interactive()) { + library(shiny) body <- dashboardBody( @@ -39,3 +41,4 @@ shinyApp( }) } ) +} diff --git a/tests/updateTabItems.R b/tests/updateTabItems.R index db53355d..6eb0c615 100644 --- a/tests/updateTabItems.R +++ b/tests/updateTabItems.R @@ -1,33 +1,36 @@ -ui <- dashboardPage( - dashboardHeader(title = "Simple tabs"), - dashboardSidebar( - sidebarMenu( - id = "tabs", - menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), - menuItem("Widgets", tabName = "widgets", icon = icon("th")) - ), - actionButton('switchtab', 'Switch tab') - ), - dashboardBody( - tabItems( - tabItem(tabName = "dashboard", - h2("Dashboard tab content") +if(interactive()) { + + ui <- dashboardPage( + dashboardHeader(title = "Simple tabs"), + dashboardSidebar( + sidebarMenu( + id = "tabs", + menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), + menuItem("Widgets", tabName = "widgets", icon = icon("th")) ), - tabItem(tabName = "widgets", - h2("Widgets tab content") + actionButton('switchtab', 'Switch tab') + ), + dashboardBody( + tabItems( + tabItem(tabName = "dashboard", + h2("Dashboard tab content") + ), + tabItem(tabName = "widgets", + h2("Widgets tab content") + ) ) ) ) -) -server <- function(input, output, session) { - observeEvent(input$switchtab, { - newtab <- switch(input$tabs, - "dashboard" = "widgets", - "widgets" = "dashboard" - ) - updateTabItems(session, "tabs", newtab) - }) -} + server <- function(input, output, session) { + observeEvent(input$switchtab, { + newtab <- switch(input$tabs, + "dashboard" = "widgets", + "widgets" = "dashboard" + ) + updateTabItems(session, "tabs", newtab) + }) + } -shinyApp(ui, server) + shinyApp(ui, server) +} From 016bc373581bd00b16c2c527f620af8a76aa35c0 Mon Sep 17 00:00:00 2001 From: dmpe Date: Sun, 6 Dec 2015 18:19:26 +0100 Subject: [PATCH 05/13] add test to reproduce issue #110. Also upgrade shiny. add news and update descripition. --- tests/repro_issues_110.R | 49 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 tests/repro_issues_110.R diff --git a/tests/repro_issues_110.R b/tests/repro_issues_110.R new file mode 100644 index 00000000..a446b377 --- /dev/null +++ b/tests/repro_issues_110.R @@ -0,0 +1,49 @@ +library(shiny) +library(shinydashboard) + +header <- dashboardHeader(title = "Dashboard Demo") + +body <- dashboardBody() + +server <- function(input, output) { +} + +sidebar <- dashboardSidebar( + 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") + ), + menuItem( + "test stack", + icon = icon("fa fa-user-plus"), + icon("user", "fa-stack-1x"), + icon("ban", "fa-stack-2x"), + span(shiny::icon("fa fa-user-plus")) + ) + ), + sidebarMenuOutput("menu") +) + +ui <- dashboardPage(header, + sidebar, + body) + +shinyApp(ui, server) From 31102cf44a0361cb470aaa716f30397a926fddb3 Mon Sep 17 00:00:00 2001 From: dmpe Date: Sun, 6 Dec 2015 18:20:39 +0100 Subject: [PATCH 06/13] for skipping travis tests --- tests/repro_issues_110.R | 86 ++++++++++++++++++++-------------------- 1 file changed, 44 insertions(+), 42 deletions(-) diff --git a/tests/repro_issues_110.R b/tests/repro_issues_110.R index a446b377..4ea76ae3 100644 --- a/tests/repro_issues_110.R +++ b/tests/repro_issues_110.R @@ -1,49 +1,51 @@ -library(shiny) -library(shinydashboard) +if(interactive()) { + library(shiny) + library(shinydashboard) -header <- dashboardHeader(title = "Dashboard Demo") + header <- dashboardHeader(title = "Dashboard Demo") -body <- dashboardBody() + body <- dashboardBody() -server <- function(input, output) { -} + server <- function(input, output) { + } -sidebar <- dashboardSidebar( - 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" + sidebar <- dashboardSidebar( + 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") + ), + menuItem( + "test stack", + icon = icon("fa fa-user-plus"), + icon("user", "fa-stack-1x"), + icon("ban", "fa-stack-2x"), + span(shiny::icon("fa fa-user-plus")) + ) ), - menuItem( - "Charts", - icon = icon("bar-chart-o"), - menuSubItem("Sub-item 1", tabName = "subitem1"), - menuSubItem("Sub-item 2", tabName = "subitem2") - ), - menuItem( - "test stack", - icon = icon("fa fa-user-plus"), - icon("user", "fa-stack-1x"), - icon("ban", "fa-stack-2x"), - span(shiny::icon("fa fa-user-plus")) - ) - ), - sidebarMenuOutput("menu") -) + sidebarMenuOutput("menu") + ) -ui <- dashboardPage(header, - sidebar, - body) + ui <- dashboardPage(header, + sidebar, + body) -shinyApp(ui, server) + shinyApp(ui, server) +} From 7e2d8ee5ec2d42bdf67b396a36e9fce3ce73d0fb Mon Sep 17 00:00:00 2001 From: dmpe Date: Tue, 8 Dec 2015 14:49:49 +0100 Subject: [PATCH 07/13] merge selective commits from a different branch [skip ci] --- tests-manual/bigDash.R | 624 +++++++++--------- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 311 +++++++++ tests-manual/box.R | 347 +++++----- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 173 +++++ tests-manual/dashboardHeader.R | 130 ++-- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 64 ++ tests-manual/dashboardSidebar.R | 111 ++-- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 55 ++ tests-manual/renderMenu.R | 42 +- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 20 + tests-manual/renderMenu2.R | 92 +-- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 46 ++ tests-manual/renderValueBox.R | 68 +- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 34 + tests-manual/repro_issues_110.R | 87 +-- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 50 ++ tests-manual/repro_issues_17.R | 3 + tests-manual/repro_issues_42.R | 3 + tests-manual/repro_issues_54.R | 4 + tests-manual/tabBox.R | 87 +-- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 87 ++- tests-manual/updateTabItems.R | 72 +- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 72 +- tests/bigDash.R | 313 --------- tests/box.R | 174 ----- tests/dashboardHeader.R | 66 -- tests/dashboardSidebar.R | 56 -- tests/renderMenu.R | 22 - tests/renderMenu2.R | 46 -- tests/renderValueBox.R | 34 - tests/repro_issues_110.R | 51 -- 31 files changed, 1677 insertions(+), 1667 deletions(-) create mode 100644 tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 create mode 100644 tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 rename tests/tabBox.R => tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 (92%) rename tests/updateTabItems.R => tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 (85%) delete mode 100644 tests/bigDash.R delete mode 100644 tests/box.R delete mode 100644 tests/dashboardHeader.R delete mode 100644 tests/dashboardSidebar.R delete mode 100644 tests/renderMenu.R delete mode 100644 tests/renderMenu2.R delete mode 100644 tests/renderValueBox.R delete mode 100644 tests/repro_issues_110.R diff --git a/tests-manual/bigDash.R b/tests-manual/bigDash.R index 1fd4a3ee..f8f2b8bc 100644 --- a/tests-manual/bigDash.R +++ b/tests-manual/bigDash.R @@ -1,311 +1,313 @@ -## This tries to render a dashboard with many different components, incl. sidebar, dropdown menus etc. - -library(shiny) -library(shinydashboard) - -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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) - -shinyApp(ui, server) +if(interactive()) { + library(shiny) + library(shinydashboard) + + header <- dashboardHeader( + title = "Dashboard Demo", + + # 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") + ) + ) + + + body <- dashboardBody( + 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 + }) + } + + 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") + ) + + ui <- dashboardPage(header, + sidebar, + body) + + shinyApp(ui, server) +} diff --git a/tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..1fd4a3ee --- /dev/null +++ b/tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -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 Demo", + + # 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) + +shinyApp(ui, server) diff --git a/tests-manual/box.R b/tests-manual/box.R index 53934085..b93d5da7 100644 --- a/tests-manual/box.R +++ b/tests-manual/box.R @@ -1,173 +1,174 @@ -# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of other boxes - -library(shiny) -body <- dashboardBody( - - # 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") - ) - ) -) - -server <- function(input, output) { - 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)) - }) -} -# A dashboard header with 3 dropdown menus -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) -) - -shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - body - ), - server = server -) - +if(interactive()) { + + library(shiny) + # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes + body <- dashboardBody( + + # 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") + ) + ) + ) + + server <- function(input, output) { + 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)) + }) + } + # A dashboard header with 3 dropdown menus + header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) + ) + + shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + body + ), + server = server + ) +} diff --git a/tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..53934085 --- /dev/null +++ b/tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,173 @@ +# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of other boxes + +library(shiny) +body <- dashboardBody( + + # 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") + ) + ) +) + +server <- function(input, output) { + 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)) + }) +} +# A dashboard header with 3 dropdown menus +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) +) + +shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + body + ), + server = server +) + diff --git a/tests-manual/dashboardHeader.R b/tests-manual/dashboardHeader.R index b40354d8..ace3cec8 100644 --- a/tests-manual/dashboardHeader.R +++ b/tests-manual/dashboardHeader.R @@ -1,64 +1,66 @@ -# A dashboard header with 3 dropdown menus: messages, notifications and tasks - -library(shiny) - -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) -) - -shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - dashboardBody() - ), - server = function(input, output) { } -) +if(interactive()) { + + library(shiny) + + # A dashboard header with 3 dropdown menus + header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) + ) + + shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + dashboardBody() + ), + server = function(input, output) { } + ) +} diff --git a/tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..b40354d8 --- /dev/null +++ b/tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,64 @@ +# A dashboard header with 3 dropdown menus: messages, notifications and tasks + +library(shiny) + +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) +) + +shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + dashboardBody() + ), + server = function(input, output) { } +) diff --git a/tests-manual/dashboardSidebar.R b/tests-manual/dashboardSidebar.R index e8bcf179..87f1f66f 100644 --- a/tests-manual/dashboardSidebar.R +++ b/tests-manual/dashboardSidebar.R @@ -1,55 +1,56 @@ -## This creates 4 tabs (dashboard, widget and 2 charts) on the sidebar allowing to switch the content of each tab. - -header <- dashboardHeader() - -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") - ) - ) -) - -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") -)) - -shinyApp( - ui = dashboardPage(header, sidebar, body), - server = function(input, output) { - } -) - +if(interactive()) { + + header <- dashboardHeader() + + 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") + ) + ) + ) + + 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") + )) + + shinyApp( + ui = dashboardPage(header, sidebar, body), + server = function(input, output) { + + } + ) +} diff --git a/tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..e8bcf179 --- /dev/null +++ b/tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,55 @@ +## This creates 4 tabs (dashboard, widget and 2 charts) on the sidebar allowing to switch the content of each tab. + +header <- dashboardHeader() + +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") + ) + ) +) + +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") +)) + +shinyApp( + ui = dashboardPage(header, sidebar, body), + server = function(input, output) { + } +) + diff --git a/tests-manual/renderMenu.R b/tests-manual/renderMenu.R index 5bc5b227..16ba84e7 100644 --- a/tests-manual/renderMenu.R +++ b/tests-manual/renderMenu.R @@ -1,20 +1,22 @@ -# ========== Dynamic sidebarMenu ========== - -library(shiny) -ui <- dashboardPage( - dashboardHeader(title = "Dynamic sidebar"), - dashboardSidebar( - sidebarMenuOutput("menu") - ), - dashboardBody() -) - -server <- function(input, output) { - output$menu <- renderMenu({ - sidebarMenu( - menuItem("Menu item", icon = icon("calendar")) - ) - }) -} - -shinyApp(ui, server) +if(interactive()) { + + library(shiny) + # ========== Dynamic sidebarMenu ========== + ui <- dashboardPage( + dashboardHeader(title = "Dynamic sidebar"), + dashboardSidebar( + sidebarMenuOutput("menu") + ), + dashboardBody() + ) + + server <- function(input, output) { + output$menu <- renderMenu({ + sidebarMenu( + menuItem("Menu item", icon = icon("calendar")) + ) + }) + } + + shinyApp(ui, server) +} diff --git a/tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..5bc5b227 --- /dev/null +++ b/tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,20 @@ +# ========== Dynamic sidebarMenu ========== + +library(shiny) +ui <- dashboardPage( + dashboardHeader(title = "Dynamic sidebar"), + dashboardSidebar( + sidebarMenuOutput("menu") + ), + dashboardBody() +) + +server <- function(input, output) { + output$menu <- renderMenu({ + sidebarMenu( + menuItem("Menu item", icon = icon("calendar")) + ) + }) +} + +shinyApp(ui, server) diff --git a/tests-manual/renderMenu2.R b/tests-manual/renderMenu2.R index a2afcf6d..c7b646bb 100644 --- a/tests-manual/renderMenu2.R +++ b/tests-manual/renderMenu2.R @@ -1,46 +1,46 @@ -## Creates a slider though which (dropdown) notifications are updated - -library(shiny) -messageData <- data.frame( - from = c("Admininstrator", "New User", "Support"), - message = c( - "Sales are steady this month.", - "How do I register?", - "The new server is ready." - ), - stringsAsFactors = FALSE -) - -ui <- dashboardPage( - dashboardHeader( - title = "Dynamic menus", - dropdownMenuOutput("messageMenu") - ), - dashboardSidebar(), - dashboardBody( - fluidRow( - box( - title = "Controls", - sliderInput("slider", "Number of observations:", 1, 100, 50) - ) - ) - ) -) - -server <- function(input, output) { - output$messageMenu <- renderMenu({ - # Code to generate each of the messageItems here, in a list. messageData - # is a data frame with two columns, 'from' and 'message'. - # Also add on slider value to the message content, so that messages update. - msgs <- apply(messageData, 1, function(row) { - messageItem( - from = row[["from"]], - message = paste(row[["message"]], input$slider) - ) - }) - - dropdownMenu(type = "messages", .list = msgs) - }) -} - -shinyApp(ui, server) +if(interactive()) { + + messageData <- data.frame( + from = c("Admininstrator", "New User", "Support"), + message = c( + "Sales are steady this month.", + "How do I register?", + "The new server is ready." + ), + stringsAsFactors = FALSE + ) + + ui <- dashboardPage( + dashboardHeader( + title = "Dynamic menus", + dropdownMenuOutput("messageMenu") + ), + dashboardSidebar(), + dashboardBody( + fluidRow( + box( + title = "Controls", + sliderInput("slider", "Number of observations:", 1, 100, 50) + ) + ) + ) + ) + + server <- function(input, output) { + output$messageMenu <- renderMenu({ + # Code to generate each of the messageItems here, in a list. messageData + # is a data frame with two columns, 'from' and 'message'. + # Also add on slider value to the message content, so that messages update. + msgs <- apply(messageData, 1, function(row) { + messageItem( + from = row[["from"]], + message = paste(row[["message"]], input$slider) + ) + }) + + dropdownMenu(type = "messages", .list = msgs) + }) + } + + shinyApp(ui, server) +} diff --git a/tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..a2afcf6d --- /dev/null +++ b/tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,46 @@ +## Creates a slider though which (dropdown) notifications are updated + +library(shiny) +messageData <- data.frame( + from = c("Admininstrator", "New User", "Support"), + message = c( + "Sales are steady this month.", + "How do I register?", + "The new server is ready." + ), + stringsAsFactors = FALSE +) + +ui <- dashboardPage( + dashboardHeader( + title = "Dynamic menus", + dropdownMenuOutput("messageMenu") + ), + dashboardSidebar(), + dashboardBody( + fluidRow( + box( + title = "Controls", + sliderInput("slider", "Number of observations:", 1, 100, 50) + ) + ) + ) +) + +server <- function(input, output) { + output$messageMenu <- renderMenu({ + # Code to generate each of the messageItems here, in a list. messageData + # is a data frame with two columns, 'from' and 'message'. + # Also add on slider value to the message content, so that messages update. + msgs <- apply(messageData, 1, function(row) { + messageItem( + from = row[["from"]], + message = paste(row[["message"]], input$slider) + ) + }) + + dropdownMenu(type = "messages", .list = msgs) + }) +} + +shinyApp(ui, server) diff --git a/tests-manual/renderValueBox.R b/tests-manual/renderValueBox.R index 70328ee2..32f51b31 100644 --- a/tests-manual/renderValueBox.R +++ b/tests-manual/renderValueBox.R @@ -1,34 +1,34 @@ -## Display count button with two boxes which show the incremented value -library(shiny) - -ui <- dashboardPage( - dashboardHeader(title = "Dynamic boxes"), - dashboardSidebar(), - dashboardBody( - fluidRow( - box(width = 2, actionButton("count", "Count")), - infoBoxOutput("ibox"), - valueBoxOutput("vbox") - ) - ) -) - -server <- function(input, output) { - output$ibox <- renderInfoBox({ - infoBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - output$vbox <- renderValueBox({ - valueBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) -} - -shinyApp(ui, server) - +if(interactive()) { + library(shiny) + + ui <- dashboardPage( + dashboardHeader(title = "Dynamic boxes"), + dashboardSidebar(), + dashboardBody( + fluidRow( + box(width = 2, actionButton("count", "Count")), + infoBoxOutput("ibox"), + valueBoxOutput("vbox") + ) + ) + ) + + server <- function(input, output) { + output$ibox <- renderInfoBox({ + infoBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + output$vbox <- renderValueBox({ + valueBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + } + + shinyApp(ui, server) +} diff --git a/tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..70328ee2 --- /dev/null +++ b/tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,34 @@ +## Display count button with two boxes which show the incremented value +library(shiny) + +ui <- dashboardPage( + dashboardHeader(title = "Dynamic boxes"), + dashboardSidebar(), + dashboardBody( + fluidRow( + box(width = 2, actionButton("count", "Count")), + infoBoxOutput("ibox"), + valueBoxOutput("vbox") + ) + ) +) + +server <- function(input, output) { + output$ibox <- renderInfoBox({ + infoBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + output$vbox <- renderValueBox({ + valueBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) +} + +shinyApp(ui, server) + diff --git a/tests-manual/repro_issues_110.R b/tests-manual/repro_issues_110.R index a2703df4..4ea76ae3 100644 --- a/tests-manual/repro_issues_110.R +++ b/tests-manual/repro_issues_110.R @@ -1,50 +1,51 @@ -## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 -library(shiny) -library(shinydashboard) +if(interactive()) { + library(shiny) + library(shinydashboard) -header <- dashboardHeader(title = "Dashboard Demo") + header <- dashboardHeader(title = "Dashboard Demo") -body <- dashboardBody() + body <- dashboardBody() -server <- function(input, output) { -} + server <- function(input, output) { + } -sidebar <- dashboardSidebar( - 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" + sidebar <- dashboardSidebar( + 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") + ), + menuItem( + "test stack", + icon = icon("fa fa-user-plus"), + icon("user", "fa-stack-1x"), + icon("ban", "fa-stack-2x"), + span(shiny::icon("fa fa-user-plus")) + ) ), - menuItem( - "Charts", - icon = icon("bar-chart-o"), - menuSubItem("Sub-item 1", tabName = "subitem1"), - menuSubItem("Sub-item 2", tabName = "subitem2") - ), - menuItem( - "test stack", - icon = icon("fa fa-user-plus"), - icon("user", "fa-stack-1x"), - icon("ban", "fa-stack-2x"), - span(shiny::icon("fa fa-user-plus")) - ) - ), - sidebarMenuOutput("menu") -) + sidebarMenuOutput("menu") + ) -ui <- dashboardPage(header, - sidebar, - body) + ui <- dashboardPage(header, + sidebar, + body) -shinyApp(ui, server) + shinyApp(ui, server) +} diff --git a/tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 new file mode 100644 index 00000000..a2703df4 --- /dev/null +++ b/tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -0,0 +1,50 @@ +## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 +library(shiny) +library(shinydashboard) + +header <- dashboardHeader(title = "Dashboard Demo") + +body <- dashboardBody() + +server <- function(input, output) { +} + +sidebar <- dashboardSidebar( + 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") + ), + menuItem( + "test stack", + icon = icon("fa fa-user-plus"), + icon("user", "fa-stack-1x"), + icon("ban", "fa-stack-2x"), + span(shiny::icon("fa fa-user-plus")) + ) + ), + sidebarMenuOutput("menu") +) + +ui <- dashboardPage(header, + sidebar, + body) + +shinyApp(ui, server) diff --git a/tests-manual/repro_issues_17.R b/tests-manual/repro_issues_17.R index f7de3e8f..66757fc7 100644 --- a/tests-manual/repro_issues_17.R +++ b/tests-manual/repro_issues_17.R @@ -1,5 +1,8 @@ +<<<<<<< 31102cf44a0361cb470aaa716f30397a926fddb3 ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/17 +======= +>>>>>>> e4c3bc1ef3418879040e39f52363c8e601b609cd library(shiny) library(shinydashboard) diff --git a/tests-manual/repro_issues_42.R b/tests-manual/repro_issues_42.R index 7763edf1..4195cad1 100644 --- a/tests-manual/repro_issues_42.R +++ b/tests-manual/repro_issues_42.R @@ -1,5 +1,8 @@ +<<<<<<< 31102cf44a0361cb470aaa716f30397a926fddb3 ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/42 +======= +>>>>>>> e4c3bc1ef3418879040e39f52363c8e601b609cd library(shiny) library(shinydashboard) diff --git a/tests-manual/repro_issues_54.R b/tests-manual/repro_issues_54.R index 6e7343b2..1741f604 100644 --- a/tests-manual/repro_issues_54.R +++ b/tests-manual/repro_issues_54.R @@ -1,4 +1,8 @@ +<<<<<<< 31102cf44a0361cb470aaa716f30397a926fddb3 ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/54 +======= +# Working example +>>>>>>> e4c3bc1ef3418879040e39f52363c8e601b609cd # library(shiny) # library(shinydashboard) diff --git a/tests-manual/tabBox.R b/tests-manual/tabBox.R index a0d8934c..d9dba699 100644 --- a/tests-manual/tabBox.R +++ b/tests-manual/tabBox.R @@ -1,43 +1,44 @@ -## This dashboard shows 3 different boxes, which have n tabs to switch content inside of them. - -library(shiny) - -body <- dashboardBody( - 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") - ) - ) -) - -shinyApp( - ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), - server = function(input, output) { - # The currently selected tab from the first box - output$tabset1Selected <- renderText({ - input$tabset1 - }) - } -) +if(interactive()) { + +library(shiny) + +body <- dashboardBody( + 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") + ) + ) +) + +shinyApp( + ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), + server = function(input, output) { + # The currently selected tab from the first box + output$tabset1Selected <- renderText({ + input$tabset1 + }) + } +) +} diff --git a/tests/tabBox.R b/tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 similarity index 92% rename from tests/tabBox.R rename to tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 index d9dba699..a0d8934c 100644 --- a/tests/tabBox.R +++ b/tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -1,44 +1,43 @@ -if(interactive()) { - -library(shiny) - -body <- dashboardBody( - 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") - ) - ) -) - -shinyApp( - ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), - server = function(input, output) { - # The currently selected tab from the first box - output$tabset1Selected <- renderText({ - input$tabset1 - }) - } -) -} +## This dashboard shows 3 different boxes, which have n tabs to switch content inside of them. + +library(shiny) + +body <- dashboardBody( + 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") + ) + ) +) + +shinyApp( + ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), + server = function(input, output) { + # The currently selected tab from the first box + output$tabset1Selected <- renderText({ + input$tabset1 + }) + } +) diff --git a/tests-manual/updateTabItems.R b/tests-manual/updateTabItems.R index f7e03dde..6eb0c615 100644 --- a/tests-manual/updateTabItems.R +++ b/tests-manual/updateTabItems.R @@ -1,36 +1,36 @@ -## This creates dashboard with a sidebar. The sidebar has a button which allows to switch between different -## panels (tabs) within the same dashboard - - ui <- dashboardPage( - dashboardHeader(title = "Simple tabs"), - dashboardSidebar( - sidebarMenu( - id = "tabs", - menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), - menuItem("Widgets", tabName = "widgets", icon = icon("th")) - ), - actionButton('switchtab', 'Switch tab') - ), - dashboardBody( - tabItems( - tabItem(tabName = "dashboard", - h2("Dashboard tab content") - ), - tabItem(tabName = "widgets", - h2("Widgets tab content") - ) - ) - ) - ) - - server <- function(input, output, session) { - observeEvent(input$switchtab, { - newtab <- switch(input$tabs, - "dashboard" = "widgets", - "widgets" = "dashboard" - ) - updateTabItems(session, "tabs", newtab) - }) - } - - shinyApp(ui, server) +if(interactive()) { + + ui <- dashboardPage( + dashboardHeader(title = "Simple tabs"), + dashboardSidebar( + sidebarMenu( + id = "tabs", + menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), + menuItem("Widgets", tabName = "widgets", icon = icon("th")) + ), + actionButton('switchtab', 'Switch tab') + ), + dashboardBody( + tabItems( + tabItem(tabName = "dashboard", + h2("Dashboard tab content") + ), + tabItem(tabName = "widgets", + h2("Widgets tab content") + ) + ) + ) + ) + + server <- function(input, output, session) { + observeEvent(input$switchtab, { + newtab <- switch(input$tabs, + "dashboard" = "widgets", + "widgets" = "dashboard" + ) + updateTabItems(session, "tabs", newtab) + }) + } + + shinyApp(ui, server) +} diff --git a/tests/updateTabItems.R b/tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 similarity index 85% rename from tests/updateTabItems.R rename to tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 index 6eb0c615..f7e03dde 100644 --- a/tests/updateTabItems.R +++ b/tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 @@ -1,36 +1,36 @@ -if(interactive()) { - - ui <- dashboardPage( - dashboardHeader(title = "Simple tabs"), - dashboardSidebar( - sidebarMenu( - id = "tabs", - menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), - menuItem("Widgets", tabName = "widgets", icon = icon("th")) - ), - actionButton('switchtab', 'Switch tab') - ), - dashboardBody( - tabItems( - tabItem(tabName = "dashboard", - h2("Dashboard tab content") - ), - tabItem(tabName = "widgets", - h2("Widgets tab content") - ) - ) - ) - ) - - server <- function(input, output, session) { - observeEvent(input$switchtab, { - newtab <- switch(input$tabs, - "dashboard" = "widgets", - "widgets" = "dashboard" - ) - updateTabItems(session, "tabs", newtab) - }) - } - - shinyApp(ui, server) -} +## This creates dashboard with a sidebar. The sidebar has a button which allows to switch between different +## panels (tabs) within the same dashboard + + ui <- dashboardPage( + dashboardHeader(title = "Simple tabs"), + dashboardSidebar( + sidebarMenu( + id = "tabs", + menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), + menuItem("Widgets", tabName = "widgets", icon = icon("th")) + ), + actionButton('switchtab', 'Switch tab') + ), + dashboardBody( + tabItems( + tabItem(tabName = "dashboard", + h2("Dashboard tab content") + ), + tabItem(tabName = "widgets", + h2("Widgets tab content") + ) + ) + ) + ) + + server <- function(input, output, session) { + observeEvent(input$switchtab, { + newtab <- switch(input$tabs, + "dashboard" = "widgets", + "widgets" = "dashboard" + ) + updateTabItems(session, "tabs", newtab) + }) + } + + shinyApp(ui, server) diff --git a/tests/bigDash.R b/tests/bigDash.R deleted file mode 100644 index f8f2b8bc..00000000 --- a/tests/bigDash.R +++ /dev/null @@ -1,313 +0,0 @@ -if(interactive()) { - library(shiny) - library(shinydashboard) - - header <- dashboardHeader( - title = "Dashboard Demo", - - # 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") - ) - ) - - - body <- dashboardBody( - 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 - }) - } - - 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") - ) - - ui <- dashboardPage(header, - sidebar, - body) - - shinyApp(ui, server) -} diff --git a/tests/box.R b/tests/box.R deleted file mode 100644 index b93d5da7..00000000 --- a/tests/box.R +++ /dev/null @@ -1,174 +0,0 @@ -if(interactive()) { - - library(shiny) - # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes - body <- dashboardBody( - - # 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") - ) - ) - ) - - server <- function(input, output) { - 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)) - }) - } - # A dashboard header with 3 dropdown menus - header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) - ) - - shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - body - ), - server = server - ) -} diff --git a/tests/dashboardHeader.R b/tests/dashboardHeader.R deleted file mode 100644 index ace3cec8..00000000 --- a/tests/dashboardHeader.R +++ /dev/null @@ -1,66 +0,0 @@ -if(interactive()) { - - library(shiny) - - # A dashboard header with 3 dropdown menus - header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) - ) - - shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - dashboardBody() - ), - server = function(input, output) { } - ) -} diff --git a/tests/dashboardSidebar.R b/tests/dashboardSidebar.R deleted file mode 100644 index 87f1f66f..00000000 --- a/tests/dashboardSidebar.R +++ /dev/null @@ -1,56 +0,0 @@ -if(interactive()) { - - header <- dashboardHeader() - - 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") - ) - ) - ) - - 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") - )) - - shinyApp( - ui = dashboardPage(header, sidebar, body), - server = function(input, output) { - - } - ) -} diff --git a/tests/renderMenu.R b/tests/renderMenu.R deleted file mode 100644 index 16ba84e7..00000000 --- a/tests/renderMenu.R +++ /dev/null @@ -1,22 +0,0 @@ -if(interactive()) { - - library(shiny) - # ========== Dynamic sidebarMenu ========== - ui <- dashboardPage( - dashboardHeader(title = "Dynamic sidebar"), - dashboardSidebar( - sidebarMenuOutput("menu") - ), - dashboardBody() - ) - - server <- function(input, output) { - output$menu <- renderMenu({ - sidebarMenu( - menuItem("Menu item", icon = icon("calendar")) - ) - }) - } - - shinyApp(ui, server) -} diff --git a/tests/renderMenu2.R b/tests/renderMenu2.R deleted file mode 100644 index c7b646bb..00000000 --- a/tests/renderMenu2.R +++ /dev/null @@ -1,46 +0,0 @@ -if(interactive()) { - - messageData <- data.frame( - from = c("Admininstrator", "New User", "Support"), - message = c( - "Sales are steady this month.", - "How do I register?", - "The new server is ready." - ), - stringsAsFactors = FALSE - ) - - ui <- dashboardPage( - dashboardHeader( - title = "Dynamic menus", - dropdownMenuOutput("messageMenu") - ), - dashboardSidebar(), - dashboardBody( - fluidRow( - box( - title = "Controls", - sliderInput("slider", "Number of observations:", 1, 100, 50) - ) - ) - ) - ) - - server <- function(input, output) { - output$messageMenu <- renderMenu({ - # Code to generate each of the messageItems here, in a list. messageData - # is a data frame with two columns, 'from' and 'message'. - # Also add on slider value to the message content, so that messages update. - msgs <- apply(messageData, 1, function(row) { - messageItem( - from = row[["from"]], - message = paste(row[["message"]], input$slider) - ) - }) - - dropdownMenu(type = "messages", .list = msgs) - }) - } - - shinyApp(ui, server) -} diff --git a/tests/renderValueBox.R b/tests/renderValueBox.R deleted file mode 100644 index 32f51b31..00000000 --- a/tests/renderValueBox.R +++ /dev/null @@ -1,34 +0,0 @@ -if(interactive()) { - library(shiny) - - ui <- dashboardPage( - dashboardHeader(title = "Dynamic boxes"), - dashboardSidebar(), - dashboardBody( - fluidRow( - box(width = 2, actionButton("count", "Count")), - infoBoxOutput("ibox"), - valueBoxOutput("vbox") - ) - ) - ) - - server <- function(input, output) { - output$ibox <- renderInfoBox({ - infoBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - output$vbox <- renderValueBox({ - valueBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - } - - shinyApp(ui, server) -} diff --git a/tests/repro_issues_110.R b/tests/repro_issues_110.R deleted file mode 100644 index 4ea76ae3..00000000 --- a/tests/repro_issues_110.R +++ /dev/null @@ -1,51 +0,0 @@ -if(interactive()) { - library(shiny) - library(shinydashboard) - - header <- dashboardHeader(title = "Dashboard Demo") - - body <- dashboardBody() - - server <- function(input, output) { - } - - sidebar <- dashboardSidebar( - 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") - ), - menuItem( - "test stack", - icon = icon("fa fa-user-plus"), - icon("user", "fa-stack-1x"), - icon("ban", "fa-stack-2x"), - span(shiny::icon("fa fa-user-plus")) - ) - ), - sidebarMenuOutput("menu") - ) - - ui <- dashboardPage(header, - sidebar, - body) - - shinyApp(ui, server) -} From 98c0c3de1040bb0b7b7d8c377129b2107e6e7b41 Mon Sep 17 00:00:00 2001 From: dmpe Date: Tue, 26 Jan 2016 17:05:59 +0100 Subject: [PATCH 08/13] add #117 delete `interactive()` because tests are in Rignore add comments fix tabItems issue comment repro issues fix version, bump both package further ahead and make sure that #42 is not repro on my pc --- DESCRIPTION | 4 +- tests-manual/bigDash.R | 623 ++++++++++++++++---------------- tests-manual/box.R | 346 +++++++++--------- tests-manual/dashboardHeader.R | 129 ++++--- tests-manual/dashboardSidebar.R | 109 +++--- tests-manual/renderMenu.R | 41 +-- tests-manual/renderMenu2.R | 89 +++-- tests-manual/renderValueBox.R | 67 ++-- tests-manual/repro_issues_110.R | 1 + tests-manual/repro_issues_117.R | 190 ++++++++++ tests-manual/repro_issues_17.R | 6 + tests-manual/repro_issues_42.R | 6 + tests-manual/repro_issues_54.R | 4 + tests-manual/tabBox.R | 85 +++-- tests-manual/updateTabItems.R | 72 ++-- 15 files changed, 979 insertions(+), 793 deletions(-) create mode 100644 tests-manual/repro_issues_117.R diff --git a/DESCRIPTION b/DESCRIPTION index fde706f3..e5d9fa94 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,8 +15,8 @@ Depends: License: GPL-2 | file LICENSE Imports: utils, - shiny (>= 0.12.1), - htmltools (>= 0.2.6) + shiny (>= 0.13.0), + htmltools (>= 0.3) BugReports: https://github.com/rstudio/shinydashboard RoxygenNote: 5.0.1 diff --git a/tests-manual/bigDash.R b/tests-manual/bigDash.R index f8f2b8bc..b62712a1 100644 --- a/tests-manual/bigDash.R +++ b/tests-manual/bigDash.R @@ -1,313 +1,310 @@ -if(interactive()) { - library(shiny) - library(shinydashboard) - - header <- dashboardHeader( - title = "Dashboard Demo", - - # 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") - ) - ) - - - body <- dashboardBody( - 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 - }) - } - - 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") - ) - - ui <- dashboardPage(header, - sidebar, - body) - - shinyApp(ui, server) -} +## This tries to render a dashboard with many different components +library(shiny) +library(shinydashboard) + +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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) + +shinyApp(ui, server) diff --git a/tests-manual/box.R b/tests-manual/box.R index b93d5da7..67545743 100644 --- a/tests-manual/box.R +++ b/tests-manual/box.R @@ -1,174 +1,172 @@ -if(interactive()) { - - library(shiny) - # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes - body <- dashboardBody( - - # 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") - ) - ) - ) - - server <- function(input, output) { - 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)) - }) - } - # A dashboard header with 3 dropdown menus - header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) - ) - - shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - body - ), - server = server - ) -} +# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes +library(shiny) +body <- dashboardBody( + + # 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") + ) + ) +) + +server <- function(input, output) { + 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)) + }) +} +# A dashboard header with 3 dropdown menus +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) +) + +shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + body + ), + server = server +) + diff --git a/tests-manual/dashboardHeader.R b/tests-manual/dashboardHeader.R index ace3cec8..5fbe509c 100644 --- a/tests-manual/dashboardHeader.R +++ b/tests-manual/dashboardHeader.R @@ -1,66 +1,63 @@ -if(interactive()) { - - library(shiny) - - # A dashboard header with 3 dropdown menus - header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) - ) - - shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - dashboardBody() - ), - server = function(input, output) { } - ) -} +# A dashboard header with 3 dropdown menus +library(shiny) + +header <- dashboardHeader( + title = "Dashboard Demo", + + # 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" + ) + ) +) + +shinyApp( + ui = dashboardPage( + header, + dashboardSidebar(), + dashboardBody() + ), + server = function(input, output) { } +) diff --git a/tests-manual/dashboardSidebar.R b/tests-manual/dashboardSidebar.R index 87f1f66f..5ba84302 100644 --- a/tests-manual/dashboardSidebar.R +++ b/tests-manual/dashboardSidebar.R @@ -1,56 +1,53 @@ -if(interactive()) { - - header <- dashboardHeader() - - 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") - ) - ) - ) - - 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") - )) - - shinyApp( - ui = dashboardPage(header, sidebar, body), - server = function(input, output) { - - } - ) -} +header <- dashboardHeader() + +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") + ) + ) +) + +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") +)) + +shinyApp( + ui = dashboardPage(header, sidebar, body), + server = function(input, output) { + } +) + diff --git a/tests-manual/renderMenu.R b/tests-manual/renderMenu.R index 16ba84e7..8db026a3 100644 --- a/tests-manual/renderMenu.R +++ b/tests-manual/renderMenu.R @@ -1,22 +1,19 @@ -if(interactive()) { - - library(shiny) - # ========== Dynamic sidebarMenu ========== - ui <- dashboardPage( - dashboardHeader(title = "Dynamic sidebar"), - dashboardSidebar( - sidebarMenuOutput("menu") - ), - dashboardBody() - ) - - server <- function(input, output) { - output$menu <- renderMenu({ - sidebarMenu( - menuItem("Menu item", icon = icon("calendar")) - ) - }) - } - - shinyApp(ui, server) -} +library(shiny) +# ========== Dynamic sidebarMenu ========== +ui <- dashboardPage( + dashboardHeader(title = "Dynamic sidebar"), + dashboardSidebar( + sidebarMenuOutput("menu") + ), + dashboardBody() +) + +server <- function(input, output) { + output$menu <- renderMenu({ + sidebarMenu( + menuItem("Menu item", icon = icon("calendar")) + ) + }) +} + +shinyApp(ui, server) diff --git a/tests-manual/renderMenu2.R b/tests-manual/renderMenu2.R index c7b646bb..16ddf600 100644 --- a/tests-manual/renderMenu2.R +++ b/tests-manual/renderMenu2.R @@ -1,46 +1,43 @@ -if(interactive()) { - - messageData <- data.frame( - from = c("Admininstrator", "New User", "Support"), - message = c( - "Sales are steady this month.", - "How do I register?", - "The new server is ready." - ), - stringsAsFactors = FALSE - ) - - ui <- dashboardPage( - dashboardHeader( - title = "Dynamic menus", - dropdownMenuOutput("messageMenu") - ), - dashboardSidebar(), - dashboardBody( - fluidRow( - box( - title = "Controls", - sliderInput("slider", "Number of observations:", 1, 100, 50) - ) - ) - ) - ) - - server <- function(input, output) { - output$messageMenu <- renderMenu({ - # Code to generate each of the messageItems here, in a list. messageData - # is a data frame with two columns, 'from' and 'message'. - # Also add on slider value to the message content, so that messages update. - msgs <- apply(messageData, 1, function(row) { - messageItem( - from = row[["from"]], - message = paste(row[["message"]], input$slider) - ) - }) - - dropdownMenu(type = "messages", .list = msgs) - }) - } - - shinyApp(ui, server) -} +messageData <- data.frame( + from = c("Admininstrator", "New User", "Support"), + message = c( + "Sales are steady this month.", + "How do I register?", + "The new server is ready." + ), + stringsAsFactors = FALSE +) + +ui <- dashboardPage( + dashboardHeader( + title = "Dynamic menus", + dropdownMenuOutput("messageMenu") + ), + dashboardSidebar(), + dashboardBody( + fluidRow( + box( + title = "Controls", + sliderInput("slider", "Number of observations:", 1, 100, 50) + ) + ) + ) +) + +server <- function(input, output) { + output$messageMenu <- renderMenu({ + # Code to generate each of the messageItems here, in a list. messageData + # is a data frame with two columns, 'from' and 'message'. + # Also add on slider value to the message content, so that messages update. + msgs <- apply(messageData, 1, function(row) { + messageItem( + from = row[["from"]], + message = paste(row[["message"]], input$slider) + ) + }) + + dropdownMenu(type = "messages", .list = msgs) + }) +} + +shinyApp(ui, server) diff --git a/tests-manual/renderValueBox.R b/tests-manual/renderValueBox.R index 32f51b31..bc3914b6 100644 --- a/tests-manual/renderValueBox.R +++ b/tests-manual/renderValueBox.R @@ -1,34 +1,33 @@ -if(interactive()) { - library(shiny) - - ui <- dashboardPage( - dashboardHeader(title = "Dynamic boxes"), - dashboardSidebar(), - dashboardBody( - fluidRow( - box(width = 2, actionButton("count", "Count")), - infoBoxOutput("ibox"), - valueBoxOutput("vbox") - ) - ) - ) - - server <- function(input, output) { - output$ibox <- renderInfoBox({ - infoBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - output$vbox <- renderValueBox({ - valueBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - } - - shinyApp(ui, server) -} +library(shiny) + +ui <- dashboardPage( + dashboardHeader(title = "Dynamic boxes"), + dashboardSidebar(), + dashboardBody( + fluidRow( + box(width = 2, actionButton("count", "Count")), + infoBoxOutput("ibox"), + valueBoxOutput("vbox") + ) + ) +) + +server <- function(input, output) { + output$ibox <- renderInfoBox({ + infoBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) + output$vbox <- renderValueBox({ + valueBox( + "Title", + input$count, + icon = icon("credit-card") + ) + }) +} + +shinyApp(ui, server) + diff --git a/tests-manual/repro_issues_110.R b/tests-manual/repro_issues_110.R index 4ea76ae3..944ce244 100644 --- a/tests-manual/repro_issues_110.R +++ b/tests-manual/repro_issues_110.R @@ -1,4 +1,5 @@ if(interactive()) { + ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 library(shiny) library(shinydashboard) diff --git a/tests-manual/repro_issues_117.R b/tests-manual/repro_issues_117.R new file mode 100644 index 00000000..6d9dd308 --- /dev/null +++ b/tests-manual/repro_issues_117.R @@ -0,0 +1,190 @@ +library(shiny) +library(shinydashboard) +library(shinythemes) + +header <- dashboardHeader( + title = "Upload Data", + titleWidth = 1000, + + #tags$head( + # tags$link( HTML( 'Data Upload>') + # ) + #) + dropdownMenu(type = "messages", + messageItem(from = "Dept", + message = "Under construction")) + +) + +#Sidebar Panel +sidebar <- dashboardSidebar(width = 200, + sidebarMenu(menuItem( + "Upload Data", tabName = "filetable", icon = icon("upload") + ))) + +#Dashboard Body +body <- dashboardBody( + tags$head(tags$style( + HTML( + ' + .main-header .logo { + font-family: "Georgia", Times, "Times New Roman", serif; + font-weight: bold; + font-size: 34px; + }' + ) + )), + tags$head( + tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"), + tags$style( + HTML( + ' + .main-header .logo { + font-family: "Georgia", Times, "Times New Roman", serif; + font-weight: bold; + font-size: 34px; + }' + ) + ) + ), + tabItems(tabItem(tabName = "filetable", + fluidRow( + box( + title = "Data Input", + status = "primary", + solidHeader = TRUE, + collapsible = TRUE, + radioButtons( + "dataInput", + "", + choices = list( + "Load sample data" = 1, + "Upload file" = 2, + "Paste data" = 3 + ), + selected = 1 + ), + conditionalPanel(condition = "input.dataInput=='1'", + h5("Selected Data Input")), + conditionalPanel( + condition = "input.dataInput=='2'", + h5("Upload delimited text file: "), + fileInput("upload", "", multiple = FALSE), + radioButtons( + "fileSepDF", + "Delimiter:", + list( + "Comma" = 1, + "Tab" = 2, + "Semicolon" = 3 + ) + ), selected = NULL + ), + conditionalPanel( + condition = "input.dataInput=='3'", + h5("Paste data below:"), + tags$textarea(id = "myData", rows = 10, cols = + 100, ""), + br(), + actionButton('clearText_button', 'Clear data'), + radioButtons( + "fileSepP", + "Separator:", + list( + "Comma" = 1, + "Tab" = 2, + "Semicolon" = 3 + ) + ) + ), + width = 12 + ), + box( + title = "Data", + status = "primary", + solidHeader = TRUE, + collapsible = TRUE, + verbatimTextOutput("filetable"), + width = 12 + ) + )))) + +ui <- dashboardPage(header, + Sidebar, + body, + skin = "blue") + + +server <- function(input, output, session) { + dataM <- reactive({ + if (input$dataInput == 1) { + data <- read.table("Sample.csv", + sep = ",", + header = TRUE, + fill = TRUE) + + } + else if (input$dataInput == 2) { + inFile <- input$upload + # Avoid error message while file is not uploaded yet + if (is.null(input$upload)) { + return(NULL) + } + # Get the separator + mySep <- + switch( + input$fileSepDF, + '1' = ",", + '2' = "\t", + '3' = ";", + '4' = "" + ) #list("Comma"=1,"Tab"=2,"Semicolon"=3) + if (file.info(inFile$datapath)$size <= 10485800) { + data <- read.table( + inFile$datapath, + sep = mySep, + header = TRUE, + fill = TRUE + ) + } + else + print("File is more than 10MB size will not be uploaded.") + } + else { + if (is.null(input$myData)) { + return(NULL) + } + tmp <- matrix(strsplit(input$myData, "\n")[[1]]) + mySep <- switch(input$fileSepP, + '1' = ",", + '2' = "\t", + '3' = ";") + myColnames <- strsplit(tmp[1], mySep)[[1]] + data <- matrix(0, length(tmp) - 1, length(myColnames)) + colnames(data) <- myColnames + for (i in 2:length(tmp)) { + myRow <- + as.numeric(strsplit(paste(tmp[i], mySep, mySep, sep = ""), mySep)[[1]]) + data[i - 1, ] <- myRow[-length(myRow)] + } + data <- data.frame(data) + + } + return(data) + }) + + output$filetable <- renderTable({ + print(nrow(dataM())) + if (nrow(dataM()) < 500) { + return(dataM()) + } + else { + return(dataM()[1:100, ]) + } + #dataM() + + }) + +} + +shinyApp(ui, server) diff --git a/tests-manual/repro_issues_17.R b/tests-manual/repro_issues_17.R index 66757fc7..eef8f3c8 100644 --- a/tests-manual/repro_issues_17.R +++ b/tests-manual/repro_issues_17.R @@ -1,8 +1,13 @@ +<<<<<<< 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) @@ -26,3 +31,4 @@ shinyApp( ), server = server ) +} diff --git a/tests-manual/repro_issues_42.R b/tests-manual/repro_issues_42.R index 4195cad1..1711a2b7 100644 --- a/tests-manual/repro_issues_42.R +++ b/tests-manual/repro_issues_42.R @@ -1,8 +1,13 @@ +<<<<<<< 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) @@ -44,3 +49,4 @@ server <- function(input, output) { } shinyApp(ui, server) +} diff --git a/tests-manual/repro_issues_54.R b/tests-manual/repro_issues_54.R index 1741f604..9785bfbd 100644 --- a/tests-manual/repro_issues_54.R +++ b/tests-manual/repro_issues_54.R @@ -2,7 +2,11 @@ ## 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) diff --git a/tests-manual/tabBox.R b/tests-manual/tabBox.R index d9dba699..0801880b 100644 --- a/tests-manual/tabBox.R +++ b/tests-manual/tabBox.R @@ -1,44 +1,41 @@ -if(interactive()) { - -library(shiny) - -body <- dashboardBody( - 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") - ) - ) -) - -shinyApp( - ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), - server = function(input, output) { - # The currently selected tab from the first box - output$tabset1Selected <- renderText({ - input$tabset1 - }) - } -) -} +library(shiny) + +body <- dashboardBody( + 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") + ) + ) +) + +shinyApp( + ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), + server = function(input, output) { + # The currently selected tab from the first box + output$tabset1Selected <- renderText({ + input$tabset1 + }) + } +) diff --git a/tests-manual/updateTabItems.R b/tests-manual/updateTabItems.R index 6eb0c615..fc158d3f 100644 --- a/tests-manual/updateTabItems.R +++ b/tests-manual/updateTabItems.R @@ -1,36 +1,36 @@ -if(interactive()) { - - ui <- dashboardPage( - dashboardHeader(title = "Simple tabs"), - dashboardSidebar( - sidebarMenu( - id = "tabs", - menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), - menuItem("Widgets", tabName = "widgets", icon = icon("th")) - ), - actionButton('switchtab', 'Switch tab') - ), - dashboardBody( - tabItems( - tabItem(tabName = "dashboard", - h2("Dashboard tab content") - ), - tabItem(tabName = "widgets", - h2("Widgets tab content") - ) - ) - ) - ) - - server <- function(input, output, session) { - observeEvent(input$switchtab, { - newtab <- switch(input$tabs, - "dashboard" = "widgets", - "widgets" = "dashboard" - ) - updateTabItems(session, "tabs", newtab) - }) - } - - shinyApp(ui, server) -} +## This creates dashboard with a sidebar. The sidebar has a button which allows to switch between different +## panels within the same dashboard + + ui <- dashboardPage( + dashboardHeader(title = "Simple tabs"), + dashboardSidebar( + sidebarMenu( + id = "tabs", + menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), + menuItem("Widgets", tabName = "widgets", icon = icon("th")) + ), + actionButton('switchtab', 'Switch tab') + ), + dashboardBody( + tabItems( + tabItem(tabName = "dashboard", + h2("Dashboard tab content") + ), + tabItem(tabName = "widgets", + h2("Widgets tab content") + ) + ) + ) + ) + + server <- function(input, output, session) { + observeEvent(input$switchtab, { + newtab <- switch(input$tabs, + "dashboard" = "widgets", + "widgets" = "dashboard" + ) + updateTabItems(session, "tabs", newtab) + }) + } + + shinyApp(ui, server) From aa7f09716306a84c6d7a6ab82c336727c7848060 Mon Sep 17 00:00:00 2001 From: dmpe <cincenko@seznam.cz> Date: Wed, 27 Jan 2016 19:38:30 +0100 Subject: [PATCH 09/13] improve description file, and also add more comments for manual tests. and delete 117 test. --- DESCRIPTION | 4 +- tests-manual/bigDash.R | 3 +- tests-manual/box.R | 3 +- tests-manual/dashboardHeader.R | 3 +- tests-manual/dashboardSidebar.R | 2 + tests-manual/renderMenu.R | 3 +- tests-manual/renderMenu2.R | 3 + tests-manual/renderValueBox.R | 1 + tests-manual/repro_issues_110.R | 88 ++++++++------- tests-manual/repro_issues_117.R | 190 -------------------------------- tests-manual/tabBox.R | 2 + tests-manual/updateTabItems.R | 2 +- 12 files changed, 62 insertions(+), 242 deletions(-) delete mode 100644 tests-manual/repro_issues_117.R diff --git a/DESCRIPTION b/DESCRIPTION index e5d9fa94..fde706f3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,8 +15,8 @@ Depends: License: GPL-2 | file LICENSE Imports: utils, - shiny (>= 0.13.0), - htmltools (>= 0.3) + shiny (>= 0.12.1), + htmltools (>= 0.2.6) BugReports: https://github.com/rstudio/shinydashboard RoxygenNote: 5.0.1 diff --git a/tests-manual/bigDash.R b/tests-manual/bigDash.R index b62712a1..1fd4a3ee 100644 --- a/tests-manual/bigDash.R +++ b/tests-manual/bigDash.R @@ -1,4 +1,5 @@ -## This tries to render a dashboard with many different components +## This tries to render a dashboard with many different components, incl. sidebar, dropdown menus etc. + library(shiny) library(shinydashboard) diff --git a/tests-manual/box.R b/tests-manual/box.R index 67545743..53934085 100644 --- a/tests-manual/box.R +++ b/tests-manual/box.R @@ -1,4 +1,5 @@ -# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes +# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of other boxes + library(shiny) body <- dashboardBody( diff --git a/tests-manual/dashboardHeader.R b/tests-manual/dashboardHeader.R index 5fbe509c..b40354d8 100644 --- a/tests-manual/dashboardHeader.R +++ b/tests-manual/dashboardHeader.R @@ -1,4 +1,5 @@ -# A dashboard header with 3 dropdown menus +# A dashboard header with 3 dropdown menus: messages, notifications and tasks + library(shiny) header <- dashboardHeader( diff --git a/tests-manual/dashboardSidebar.R b/tests-manual/dashboardSidebar.R index 5ba84302..e8bcf179 100644 --- a/tests-manual/dashboardSidebar.R +++ b/tests-manual/dashboardSidebar.R @@ -1,3 +1,5 @@ +## This creates 4 tabs (dashboard, widget and 2 charts) on the sidebar allowing to switch the content of each tab. + header <- dashboardHeader() sidebar <- dashboardSidebar( diff --git a/tests-manual/renderMenu.R b/tests-manual/renderMenu.R index 8db026a3..5bc5b227 100644 --- a/tests-manual/renderMenu.R +++ b/tests-manual/renderMenu.R @@ -1,5 +1,6 @@ -library(shiny) # ========== Dynamic sidebarMenu ========== + +library(shiny) ui <- dashboardPage( dashboardHeader(title = "Dynamic sidebar"), dashboardSidebar( diff --git a/tests-manual/renderMenu2.R b/tests-manual/renderMenu2.R index 16ddf600..a2afcf6d 100644 --- a/tests-manual/renderMenu2.R +++ b/tests-manual/renderMenu2.R @@ -1,3 +1,6 @@ +## Creates a slider though which (dropdown) notifications are updated + +library(shiny) messageData <- data.frame( from = c("Admininstrator", "New User", "Support"), message = c( diff --git a/tests-manual/renderValueBox.R b/tests-manual/renderValueBox.R index bc3914b6..70328ee2 100644 --- a/tests-manual/renderValueBox.R +++ b/tests-manual/renderValueBox.R @@ -1,3 +1,4 @@ +## Display count button with two boxes which show the incremented value library(shiny) ui <- dashboardPage( diff --git a/tests-manual/repro_issues_110.R b/tests-manual/repro_issues_110.R index 944ce244..a2703df4 100644 --- a/tests-manual/repro_issues_110.R +++ b/tests-manual/repro_issues_110.R @@ -1,52 +1,50 @@ -if(interactive()) { - ## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 - library(shiny) - library(shinydashboard) +## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 +library(shiny) +library(shinydashboard) - header <- dashboardHeader(title = "Dashboard Demo") +header <- dashboardHeader(title = "Dashboard Demo") - body <- dashboardBody() +body <- dashboardBody() - server <- function(input, output) { - } +server <- function(input, output) { +} - sidebar <- dashboardSidebar( - 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") - ), - menuItem( - "test stack", - icon = icon("fa fa-user-plus"), - icon("user", "fa-stack-1x"), - icon("ban", "fa-stack-2x"), - span(shiny::icon("fa fa-user-plus")) - ) +sidebar <- dashboardSidebar( + 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" ), - sidebarMenuOutput("menu") - ) + menuItem( + "Charts", + icon = icon("bar-chart-o"), + menuSubItem("Sub-item 1", tabName = "subitem1"), + menuSubItem("Sub-item 2", tabName = "subitem2") + ), + menuItem( + "test stack", + icon = icon("fa fa-user-plus"), + icon("user", "fa-stack-1x"), + icon("ban", "fa-stack-2x"), + span(shiny::icon("fa fa-user-plus")) + ) + ), + sidebarMenuOutput("menu") +) - ui <- dashboardPage(header, - sidebar, - body) +ui <- dashboardPage(header, + sidebar, + body) - shinyApp(ui, server) -} +shinyApp(ui, server) diff --git a/tests-manual/repro_issues_117.R b/tests-manual/repro_issues_117.R deleted file mode 100644 index 6d9dd308..00000000 --- a/tests-manual/repro_issues_117.R +++ /dev/null @@ -1,190 +0,0 @@ -library(shiny) -library(shinydashboard) -library(shinythemes) - -header <- dashboardHeader( - title = "Upload Data", - titleWidth = 1000, - - #tags$head( - # tags$link( HTML( '<title>Data Upload>') - # ) - #) - dropdownMenu(type = "messages", - messageItem(from = "Dept", - message = "Under construction")) - -) - -#Sidebar Panel -sidebar <- dashboardSidebar(width = 200, - sidebarMenu(menuItem( - "Upload Data", tabName = "filetable", icon = icon("upload") - ))) - -#Dashboard Body -body <- dashboardBody( - tags$head(tags$style( - HTML( - ' - .main-header .logo { - font-family: "Georgia", Times, "Times New Roman", serif; - font-weight: bold; - font-size: 34px; - }' - ) - )), - tags$head( - tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"), - tags$style( - HTML( - ' - .main-header .logo { - font-family: "Georgia", Times, "Times New Roman", serif; - font-weight: bold; - font-size: 34px; - }' - ) - ) - ), - tabItems(tabItem(tabName = "filetable", - fluidRow( - box( - title = "Data Input", - status = "primary", - solidHeader = TRUE, - collapsible = TRUE, - radioButtons( - "dataInput", - "", - choices = list( - "Load sample data" = 1, - "Upload file" = 2, - "Paste data" = 3 - ), - selected = 1 - ), - conditionalPanel(condition = "input.dataInput=='1'", - h5("Selected Data Input")), - conditionalPanel( - condition = "input.dataInput=='2'", - h5("Upload delimited text file: "), - fileInput("upload", "", multiple = FALSE), - radioButtons( - "fileSepDF", - "Delimiter:", - list( - "Comma" = 1, - "Tab" = 2, - "Semicolon" = 3 - ) - ), selected = NULL - ), - conditionalPanel( - condition = "input.dataInput=='3'", - h5("Paste data below:"), - tags$textarea(id = "myData", rows = 10, cols = - 100, ""), - br(), - actionButton('clearText_button', 'Clear data'), - radioButtons( - "fileSepP", - "Separator:", - list( - "Comma" = 1, - "Tab" = 2, - "Semicolon" = 3 - ) - ) - ), - width = 12 - ), - box( - title = "Data", - status = "primary", - solidHeader = TRUE, - collapsible = TRUE, - verbatimTextOutput("filetable"), - width = 12 - ) - )))) - -ui <- dashboardPage(header, - Sidebar, - body, - skin = "blue") - - -server <- function(input, output, session) { - dataM <- reactive({ - if (input$dataInput == 1) { - data <- read.table("Sample.csv", - sep = ",", - header = TRUE, - fill = TRUE) - - } - else if (input$dataInput == 2) { - inFile <- input$upload - # Avoid error message while file is not uploaded yet - if (is.null(input$upload)) { - return(NULL) - } - # Get the separator - mySep <- - switch( - input$fileSepDF, - '1' = ",", - '2' = "\t", - '3' = ";", - '4' = "" - ) #list("Comma"=1,"Tab"=2,"Semicolon"=3) - if (file.info(inFile$datapath)$size <= 10485800) { - data <- read.table( - inFile$datapath, - sep = mySep, - header = TRUE, - fill = TRUE - ) - } - else - print("File is more than 10MB size will not be uploaded.") - } - else { - if (is.null(input$myData)) { - return(NULL) - } - tmp <- matrix(strsplit(input$myData, "\n")[[1]]) - mySep <- switch(input$fileSepP, - '1' = ",", - '2' = "\t", - '3' = ";") - myColnames <- strsplit(tmp[1], mySep)[[1]] - data <- matrix(0, length(tmp) - 1, length(myColnames)) - colnames(data) <- myColnames - for (i in 2:length(tmp)) { - myRow <- - as.numeric(strsplit(paste(tmp[i], mySep, mySep, sep = ""), mySep)[[1]]) - data[i - 1, ] <- myRow[-length(myRow)] - } - data <- data.frame(data) - - } - return(data) - }) - - output$filetable <- renderTable({ - print(nrow(dataM())) - if (nrow(dataM()) < 500) { - return(dataM()) - } - else { - return(dataM()[1:100, ]) - } - #dataM() - - }) - -} - -shinyApp(ui, server) diff --git a/tests-manual/tabBox.R b/tests-manual/tabBox.R index 0801880b..a0d8934c 100644 --- a/tests-manual/tabBox.R +++ b/tests-manual/tabBox.R @@ -1,3 +1,5 @@ +## This dashboard shows 3 different boxes, which have n tabs to switch content inside of them. + library(shiny) body <- dashboardBody( diff --git a/tests-manual/updateTabItems.R b/tests-manual/updateTabItems.R index fc158d3f..f7e03dde 100644 --- a/tests-manual/updateTabItems.R +++ b/tests-manual/updateTabItems.R @@ -1,5 +1,5 @@ ## This creates dashboard with a sidebar. The sidebar has a button which allows to switch between different -## panels within the same dashboard +## panels (tabs) within the same dashboard ui <- dashboardPage( dashboardHeader(title = "Simple tabs"), From 4eff21fd4e634b740427cc4a19716b454d73da57 Mon Sep 17 00:00:00 2001 From: dmpe <cincenko@seznam.cz> Date: Thu, 28 Jan 2016 20:38:38 +0100 Subject: [PATCH 10/13] bump minor shiny version delete Rcpp from travis add 2 new repro cases for new issues --- .travis.yml | 3 --- DESCRIPTION | 2 +- tests-manual/repro_issues_112.R | 23 +++++++++++++++++++++++ tests-manual/repro_issues_113.R | 21 +++++++++++++++++++++ 4 files changed, 45 insertions(+), 4 deletions(-) create mode 100644 tests-manual/repro_issues_112.R create mode 100644 tests-manual/repro_issues_113.R diff --git a/.travis.yml b/.travis.yml index 0e853645..ab55dc25 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,9 +3,6 @@ language: r warnings_are_errors: true -r_binary_packages: - - Rcpp - notifications: email: on_success: change diff --git a/DESCRIPTION b/DESCRIPTION index fde706f3..d8710e9f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ Depends: License: GPL-2 | file LICENSE Imports: utils, - shiny (>= 0.12.1), + shiny (>= 0.12.2), htmltools (>= 0.2.6) BugReports: https://github.com/rstudio/shinydashboard RoxygenNote: 5.0.1 diff --git a/tests-manual/repro_issues_112.R b/tests-manual/repro_issues_112.R new file mode 100644 index 00000000..67c6cdb4 --- /dev/null +++ b/tests-manual/repro_issues_112.R @@ -0,0 +1,23 @@ +ui <- dashboardPage( + dashboardHeader( + title = "Sidebar spill" + + ), + dashboardSidebar( + sidebarMenu( + menuItem(text = "sfsdf sfaosh oas fwue wi aseiu wehw wuer woeur owuer ") + ) + ), + dashboardBody( + fluidRow( + + ) + ) +) + +server <- function(input, output) { + +} + +shinyApp(ui, server) + diff --git a/tests-manual/repro_issues_113.R b/tests-manual/repro_issues_113.R new file mode 100644 index 00000000..db7191bf --- /dev/null +++ b/tests-manual/repro_issues_113.R @@ -0,0 +1,21 @@ +library(shiny) +library(shinydashboard) + +ui = shinyUI(dashboardPage( + dashboardHeader(), + dashboardSidebar(disable = TRUE), + dashboardBody( + box(title = "Report", width = 12, + verbatimTextOutput("protocol") + ) + + ) +)) + +server = shinyServer(function(input, output, session) { + output$protocol <- renderPrint({ + print(numeric(10e3)) + }) +}) + +shinyApp(ui, server) From 97a15818facc2659cc20ffa99896984c79d81377 Mon Sep 17 00:00:00 2001 From: dmpe <cincenko@seznam.cz> Date: Thu, 28 Jan 2016 20:56:18 +0100 Subject: [PATCH 11/13] add --- tests-manual/repro_issues_112.R | 8 ++------ tests-manual/repro_issues_113.R | 3 +-- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/tests-manual/repro_issues_112.R b/tests-manual/repro_issues_112.R index 67c6cdb4..2bd40412 100644 --- a/tests-manual/repro_issues_112.R +++ b/tests-manual/repro_issues_112.R @@ -1,22 +1,18 @@ ui <- dashboardPage( dashboardHeader( title = "Sidebar spill" - ), dashboardSidebar( sidebarMenu( - menuItem(text = "sfsdf sfaosh oas fwue wi aseiu wehw wuer woeur owuer ") + menuItem(text = "sfsdf sfaosh oas fwue wi aseiu wehw wuer woeur owuer") ) ), dashboardBody( - fluidRow( - - ) + fluidRow() ) ) server <- function(input, output) { - } shinyApp(ui, server) diff --git a/tests-manual/repro_issues_113.R b/tests-manual/repro_issues_113.R index db7191bf..627ebba7 100644 --- a/tests-manual/repro_issues_113.R +++ b/tests-manual/repro_issues_113.R @@ -5,8 +5,7 @@ ui = shinyUI(dashboardPage( dashboardHeader(), dashboardSidebar(disable = TRUE), dashboardBody( - box(title = "Report", width = 12, - verbatimTextOutput("protocol") + box(title = "Report", width = 12, verbatimTextOutput("protocol") ) ) From fc9413f19e4fd6c76be70e86a7b16597847b6685 Mon Sep 17 00:00:00 2001 From: dmpe <cincenko@seznam.cz> Date: Sun, 31 Jan 2016 14:55:13 +0100 Subject: [PATCH 12/13] delete them --- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 311 ------------------ ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 173 ---------- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 64 ---- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 55 ---- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 20 -- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 46 --- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 34 -- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 50 --- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 43 --- ...R~31102cf44a0361cb470aaa716f30397a926fddb3 | 36 -- 10 files changed, 832 deletions(-) delete mode 100644 tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 delete mode 100644 tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 diff --git a/tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index 1fd4a3ee..00000000 --- a/tests-manual/bigDash.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,311 +0,0 @@ -## This tries to render a dashboard with many different components, incl. sidebar, dropdown menus etc. - -library(shiny) -library(shinydashboard) - -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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) - -shinyApp(ui, server) diff --git a/tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index 53934085..00000000 --- a/tests-manual/box.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,173 +0,0 @@ -# A dashboard body with a row of infoBoxes and valueBoxes, and two rows of other boxes - -library(shiny) -body <- dashboardBody( - - # 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") - ) - ) -) - -server <- function(input, output) { - 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)) - }) -} -# A dashboard header with 3 dropdown menus -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) -) - -shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - body - ), - server = server -) - diff --git a/tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index b40354d8..00000000 --- a/tests-manual/dashboardHeader.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,64 +0,0 @@ -# A dashboard header with 3 dropdown menus: messages, notifications and tasks - -library(shiny) - -header <- dashboardHeader( - title = "Dashboard Demo", - - # 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" - ) - ) -) - -shinyApp( - ui = dashboardPage( - header, - dashboardSidebar(), - dashboardBody() - ), - server = function(input, output) { } -) diff --git a/tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index e8bcf179..00000000 --- a/tests-manual/dashboardSidebar.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,55 +0,0 @@ -## This creates 4 tabs (dashboard, widget and 2 charts) on the sidebar allowing to switch the content of each tab. - -header <- dashboardHeader() - -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") - ) - ) -) - -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") -)) - -shinyApp( - ui = dashboardPage(header, sidebar, body), - server = function(input, output) { - } -) - diff --git a/tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index 5bc5b227..00000000 --- a/tests-manual/renderMenu.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,20 +0,0 @@ -# ========== Dynamic sidebarMenu ========== - -library(shiny) -ui <- dashboardPage( - dashboardHeader(title = "Dynamic sidebar"), - dashboardSidebar( - sidebarMenuOutput("menu") - ), - dashboardBody() -) - -server <- function(input, output) { - output$menu <- renderMenu({ - sidebarMenu( - menuItem("Menu item", icon = icon("calendar")) - ) - }) -} - -shinyApp(ui, server) diff --git a/tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index a2afcf6d..00000000 --- a/tests-manual/renderMenu2.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,46 +0,0 @@ -## Creates a slider though which (dropdown) notifications are updated - -library(shiny) -messageData <- data.frame( - from = c("Admininstrator", "New User", "Support"), - message = c( - "Sales are steady this month.", - "How do I register?", - "The new server is ready." - ), - stringsAsFactors = FALSE -) - -ui <- dashboardPage( - dashboardHeader( - title = "Dynamic menus", - dropdownMenuOutput("messageMenu") - ), - dashboardSidebar(), - dashboardBody( - fluidRow( - box( - title = "Controls", - sliderInput("slider", "Number of observations:", 1, 100, 50) - ) - ) - ) -) - -server <- function(input, output) { - output$messageMenu <- renderMenu({ - # Code to generate each of the messageItems here, in a list. messageData - # is a data frame with two columns, 'from' and 'message'. - # Also add on slider value to the message content, so that messages update. - msgs <- apply(messageData, 1, function(row) { - messageItem( - from = row[["from"]], - message = paste(row[["message"]], input$slider) - ) - }) - - dropdownMenu(type = "messages", .list = msgs) - }) -} - -shinyApp(ui, server) diff --git a/tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index 70328ee2..00000000 --- a/tests-manual/renderValueBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,34 +0,0 @@ -## Display count button with two boxes which show the incremented value -library(shiny) - -ui <- dashboardPage( - dashboardHeader(title = "Dynamic boxes"), - dashboardSidebar(), - dashboardBody( - fluidRow( - box(width = 2, actionButton("count", "Count")), - infoBoxOutput("ibox"), - valueBoxOutput("vbox") - ) - ) -) - -server <- function(input, output) { - output$ibox <- renderInfoBox({ - infoBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) - output$vbox <- renderValueBox({ - valueBox( - "Title", - input$count, - icon = icon("credit-card") - ) - }) -} - -shinyApp(ui, server) - diff --git a/tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index a2703df4..00000000 --- a/tests-manual/repro_issues_110.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,50 +0,0 @@ -## Tries to reproduce Github Issue: https://github.com/rstudio/shinydashboard/issues/110 -library(shiny) -library(shinydashboard) - -header <- dashboardHeader(title = "Dashboard Demo") - -body <- dashboardBody() - -server <- function(input, output) { -} - -sidebar <- dashboardSidebar( - 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") - ), - menuItem( - "test stack", - icon = icon("fa fa-user-plus"), - icon("user", "fa-stack-1x"), - icon("ban", "fa-stack-2x"), - span(shiny::icon("fa fa-user-plus")) - ) - ), - sidebarMenuOutput("menu") -) - -ui <- dashboardPage(header, - sidebar, - body) - -shinyApp(ui, server) diff --git a/tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index a0d8934c..00000000 --- a/tests-manual/tabBox.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,43 +0,0 @@ -## This dashboard shows 3 different boxes, which have n tabs to switch content inside of them. - -library(shiny) - -body <- dashboardBody( - 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") - ) - ) -) - -shinyApp( - ui = dashboardPage(dashboardHeader(title = "tabBoxes"), dashboardSidebar(), body), - server = function(input, output) { - # The currently selected tab from the first box - output$tabset1Selected <- renderText({ - input$tabset1 - }) - } -) diff --git a/tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 b/tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 deleted file mode 100644 index f7e03dde..00000000 --- a/tests-manual/updateTabItems.R~31102cf44a0361cb470aaa716f30397a926fddb3 +++ /dev/null @@ -1,36 +0,0 @@ -## This creates dashboard with a sidebar. The sidebar has a button which allows to switch between different -## panels (tabs) within the same dashboard - - ui <- dashboardPage( - dashboardHeader(title = "Simple tabs"), - dashboardSidebar( - sidebarMenu( - id = "tabs", - menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")), - menuItem("Widgets", tabName = "widgets", icon = icon("th")) - ), - actionButton('switchtab', 'Switch tab') - ), - dashboardBody( - tabItems( - tabItem(tabName = "dashboard", - h2("Dashboard tab content") - ), - tabItem(tabName = "widgets", - h2("Widgets tab content") - ) - ) - ) - ) - - server <- function(input, output, session) { - observeEvent(input$switchtab, { - newtab <- switch(input$tabs, - "dashboard" = "widgets", - "widgets" = "dashboard" - ) - updateTabItems(session, "tabs", newtab) - }) - } - - shinyApp(ui, server) From 7e7f2a1830d5216ddb2888eac9feb06fe0e13358 Mon Sep 17 00:00:00 2001 From: dmpe <cincenko@seznam.cz> Date: Sun, 31 Jan 2016 16:01:59 +0100 Subject: [PATCH 13/13] Fourth attempt. --- DESCRIPTION | 3 +- NAMESPACE | 2 + NEWS | 2 + R/boxes.R | 65 +++++++++++++++++++-------------- R/deps.R | 2 +- R/menuOutput.R | 39 ++++++++++++++------ man/box.Rd | 11 ++++-- man/boxMenuOutput.Rd | 24 ++++++++++++ man/dropdownMenuOutput.Rd | 6 +-- man/menuItemOutput.Rd | 3 +- man/menuOutput.Rd | 3 +- man/renderMenu.Rd | 3 +- man/sidebarMenuOutput.Rd | 3 +- tests-manual/box.R | 43 ++++++++++++++++++++-- tests-manual/repro_issues_112.R | 19 ---------- tests-manual/repro_issues_113.R | 20 ---------- 16 files changed, 153 insertions(+), 95 deletions(-) create mode 100644 man/boxMenuOutput.Rd delete mode 100644 tests-manual/repro_issues_112.R delete mode 100644 tests-manual/repro_issues_113.R diff --git a/DESCRIPTION b/DESCRIPTION index d8710e9f..026de3ed 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,8 +15,7 @@ Depends: License: GPL-2 | file LICENSE Imports: utils, - shiny (>= 0.12.2), + shiny (>= 0.12.1), htmltools (>= 0.2.6) BugReports: https://github.com/rstudio/shinydashboard RoxygenNote: 5.0.1 - diff --git a/NAMESPACE b/NAMESPACE index d3773d32..0b7b5e7c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,8 @@ # Generated by roxygen2: do not edit by hand export(box) +export(boxItem) +export(boxMenuOutput) export(dashboardBody) export(dashboardHeader) export(dashboardPage) diff --git a/NEWS b/NEWS index d26178f8..c4b23a19 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ shinydashboard 0.5.1.9000 -------------------------------------------------------------------------------- * Updated to AdminLTE 2.3.2 (1ee281b). +* Add wrench icon to the box-header (and a log more by using dropdown box-menu) + shinydashboard 0.5.1 -------------------------------------------------------------------------------- diff --git a/R/boxes.R b/R/boxes.R index 184f4dde..e3ded371 100644 --- a/R/boxes.R +++ b/R/boxes.R @@ -17,7 +17,8 @@ #' #' @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") @@ -118,8 +119,8 @@ infoBox <- function(title, value = NULL, subtitle = NULL, #' the user to collapse the box. #' @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 +#' @param ... Contents of the box/boxItem. +#' @param boxMenu Adds a box menu consisting of \link{boxItem}. #' #' @family boxes #' @@ -250,7 +251,8 @@ 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, wrench = FALSE) { + height = NULL, collapsible = FALSE, collapsed = FALSE, + boxMenu = NULL) { boxClass <- "box" if (solidHeader || !is.null(background)) { @@ -263,7 +265,6 @@ 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,36 +280,26 @@ box <- function(..., title = NULL, footer = NULL, status = NULL, titleTag <- h3(class = "box-title", title) } + boxTools <- NULL collapseTag <- NULL - wrenchTag <- NULL - boxToolsTag <- NULL - - if (collapsible == TRUE && wrench == TRUE) { - buttonStatus <- status %OR% "default" + if (collapsible) { collapseIcon <- if (collapsed) "plus" else "minus" - 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 - ) + collapseTag <- tags$button(class = "btn btn-box-tool", + `data-widget` = "collapse", + shiny::icon(collapseIcon)) } - - + if (!is.null(collapseTag) || !is.null(boxMenu)) { + boxTools <- div(class = "box-tools pull-right", collapseTag, boxMenu) + } headerTag <- NULL - if (!is.null(titleTag) || !is.null(collapseTag)) { + if (!is.null(titleTag) || !is.null(boxTools)) { headerTag <- div(class = "box-header", titleTag, - boxToolsTag + boxTools ) } @@ -322,6 +313,26 @@ box <- function(..., title = NULL, footer = NULL, status = NULL, ) } +#' @inheritParams box +#' @param icon Default icon (if boxMenu is used) is wrench +#' @rdname box +#' @export +boxItem <- function(..., icon = shiny::icon("wrench")) { + listOfValues <- list(...) + # include each arg into <li> </li> tags + listOfLi <- lapply(listOfValues, tags$li) + + tags$div(class = "btn-group", + tags$button(class = "btn btn-box-tool dropdown-toggle", + `type` = "button", + `data-toggle` = "dropdown", + icon), + tags$ul(class = "dropdown-menu", + `role` = "menu", + listOfLi) + ) +} + #' Create a tabbed box #' #' @inheritParams shiny::tabsetPanel @@ -380,8 +391,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 diff --git a/R/deps.R b/R/deps.R index c5276df4..5d0758a4 100644 --- a/R/deps.R +++ b/R/deps.R @@ -20,7 +20,7 @@ addDeps <- function(x) { } dashboardDeps <- list( - htmlDependency("AdminLTE", "2.0.6", + htmlDependency("AdminLTE", "2.3.2", c(file = system.file("AdminLTE", package = "shinydashboard")), script = adminLTE_js, stylesheet = adminLTE_css diff --git a/R/menuOutput.R b/R/menuOutput.R index acc073d4..4c08254a 100644 --- a/R/menuOutput.R +++ b/R/menuOutput.R @@ -19,6 +19,21 @@ menuOutput <- function(outputId, tag = tags$li) { } +#' Create a sidebar menu item output (client side) +#' +#' This is the UI-side function for creating a dynamic sidebar menu item. +#' +#' @inheritParams menuOutput +#' @family menu outputs +#' @seealso \code{\link{renderMenu}} for the corresponding server-side function +#' and examples, and \code{\link{menuItem}} for the corresponding function +#' for generating static sidebar menus. +#' @export +menuItemOutput <- function(outputId) { + menuOutput(outputId = outputId, tag = tags$li) +} + + #' Create a dropdown menu output (client side) #' #' This is the UI-side function for creating a dynamic dropdown menu. @@ -34,35 +49,35 @@ dropdownMenuOutput <- function(outputId) { } -#' Create a sidebar menu output (client side) +#' Create a dropdown box-menu output (client side) #' -#' This is the UI-side function for creating a dynamic sidebar menu. +#' This is the UI-side function for creating a dynamic dropdown box-menu. #' #' @inheritParams menuOutput #' @family menu outputs #' @seealso \code{\link{renderMenu}} for the corresponding server-side function -#' and examples, and \code{\link{sidebarMenu}} for the corresponding function -#' for generating static sidebar menus. +#' and examples, and \code{\link{dropdownMenu}} for the corresponding function +#' for generating static menus. #' @export -sidebarMenuOutput <- function(outputId) { - menuOutput(outputId = outputId, tag = tags$ul) +boxMenuOutput <- function(outputId) { + menuOutput(outputId = outputId, tag = tags$div) } -#' Create a sidebar menu item output (client side) + +#' Create a sidebar menu output (client side) #' -#' This is the UI-side function for creating a dynamic sidebar menu item. +#' This is the UI-side function for creating a dynamic sidebar menu. #' #' @inheritParams menuOutput #' @family menu outputs #' @seealso \code{\link{renderMenu}} for the corresponding server-side function -#' and examples, and \code{\link{menuItem}} for the corresponding function +#' and examples, and \code{\link{sidebarMenu}} for the corresponding function #' for generating static sidebar menus. #' @export -menuItemOutput <- function(outputId) { - menuOutput(outputId = outputId, tag = tags$li) +sidebarMenuOutput <- function(outputId) { + menuOutput(outputId = outputId, tag = tags$ul) } - #' Create dynamic menu output (server side) #' #' @inheritParams shiny::renderUI diff --git a/man/box.Rd b/man/box.Rd index 81c4ba9b..91f92c17 100644 --- a/man/box.Rd +++ b/man/box.Rd @@ -2,14 +2,17 @@ % Please edit documentation in R/boxes.R \name{box} \alias{box} +\alias{boxItem} \title{Create a box for the main body of a dashboard} \usage{ box(..., title = NULL, footer = NULL, status = NULL, solidHeader = FALSE, background = NULL, width = 6, height = NULL, - collapsible = FALSE, collapsed = FALSE, wrench = FALSE) + collapsible = FALSE, collapsed = FALSE, boxMenu = NULL) + +boxItem(..., icon = shiny::icon("wrench")) } \arguments{ -\item{...}{Contents of the box.} +\item{...}{Contents of the box/boxItem.} \item{title}{Optional title.} @@ -39,7 +42,9 @@ the user to collapse the box.} \item{collapsed}{If TRUE, start collapsed. This must be used with \code{collapsible=TRUE}.} -\item{wrench}{adds a dropdown menu} +\item{boxMenu}{Adds a box menu consisting of \link{boxItem}.} + +\item{icon}{Default icon (if boxMenu is used) is wrench} } \description{ Boxes can be used to hold content in the main body of a dashboard. diff --git a/man/boxMenuOutput.Rd b/man/boxMenuOutput.Rd new file mode 100644 index 00000000..df85cb46 --- /dev/null +++ b/man/boxMenuOutput.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/menuOutput.R +\name{boxMenuOutput} +\alias{boxMenuOutput} +\title{Create a dropdown box-menu output (client side)} +\usage{ +boxMenuOutput(outputId) +} +\arguments{ +\item{outputId}{Output variable name.} +} +\description{ +This is the UI-side function for creating a dynamic dropdown box-menu. +} +\seealso{ +\code{\link{renderMenu}} for the corresponding server-side function + and examples, and \code{\link{dropdownMenu}} for the corresponding function + for generating static menus. + +Other menu outputs: \code{\link{dropdownMenuOutput}}, + \code{\link{menuItemOutput}}, \code{\link{menuOutput}}, + \code{\link{renderMenu}}, \code{\link{sidebarMenuOutput}} +} + diff --git a/man/dropdownMenuOutput.Rd b/man/dropdownMenuOutput.Rd index dfe460a9..960b5026 100644 --- a/man/dropdownMenuOutput.Rd +++ b/man/dropdownMenuOutput.Rd @@ -17,8 +17,8 @@ This is the UI-side function for creating a dynamic dropdown menu. and examples, and \code{\link{dropdownMenu}} for the corresponding function for generating static menus. -Other menu outputs: \code{\link{menuItemOutput}}, - \code{\link{menuOutput}}, \code{\link{renderMenu}}, - \code{\link{sidebarMenuOutput}} +Other menu outputs: \code{\link{boxMenuOutput}}, + \code{\link{menuItemOutput}}, \code{\link{menuOutput}}, + \code{\link{renderMenu}}, \code{\link{sidebarMenuOutput}} } diff --git a/man/menuItemOutput.Rd b/man/menuItemOutput.Rd index b2bf5776..aa27db7e 100644 --- a/man/menuItemOutput.Rd +++ b/man/menuItemOutput.Rd @@ -17,7 +17,8 @@ This is the UI-side function for creating a dynamic sidebar menu item. and examples, and \code{\link{menuItem}} for the corresponding function for generating static sidebar menus. -Other menu outputs: \code{\link{dropdownMenuOutput}}, +Other menu outputs: \code{\link{boxMenuOutput}}, + \code{\link{dropdownMenuOutput}}, \code{\link{menuOutput}}, \code{\link{renderMenu}}, \code{\link{sidebarMenuOutput}} } diff --git a/man/menuOutput.Rd b/man/menuOutput.Rd index ab37fa3e..e632dba6 100644 --- a/man/menuOutput.Rd +++ b/man/menuOutput.Rd @@ -24,7 +24,8 @@ present; for example, \code{\link{dropdownMenuOutput}} and \code{\link{renderMenu}} for the corresponding server side function and examples. -Other menu outputs: \code{\link{dropdownMenuOutput}}, +Other menu outputs: \code{\link{boxMenuOutput}}, + \code{\link{dropdownMenuOutput}}, \code{\link{menuItemOutput}}, \code{\link{renderMenu}}, \code{\link{sidebarMenuOutput}} } diff --git a/man/renderMenu.Rd b/man/renderMenu.Rd index a7192167..949dddaf 100644 --- a/man/renderMenu.Rd +++ b/man/renderMenu.Rd @@ -96,7 +96,8 @@ shinyApp(ui, server) \code{\link{menuOutput}} for the corresponding client side function and examples. -Other menu outputs: \code{\link{dropdownMenuOutput}}, +Other menu outputs: \code{\link{boxMenuOutput}}, + \code{\link{dropdownMenuOutput}}, \code{\link{menuItemOutput}}, \code{\link{menuOutput}}, \code{\link{sidebarMenuOutput}} } diff --git a/man/sidebarMenuOutput.Rd b/man/sidebarMenuOutput.Rd index 5bee9719..af9afec1 100644 --- a/man/sidebarMenuOutput.Rd +++ b/man/sidebarMenuOutput.Rd @@ -17,7 +17,8 @@ This is the UI-side function for creating a dynamic sidebar menu. and examples, and \code{\link{sidebarMenu}} for the corresponding function for generating static sidebar menus. -Other menu outputs: \code{\link{dropdownMenuOutput}}, +Other menu outputs: \code{\link{boxMenuOutput}}, + \code{\link{dropdownMenuOutput}}, \code{\link{menuItemOutput}}, \code{\link{menuOutput}}, \code{\link{renderMenu}} } diff --git a/tests-manual/box.R b/tests-manual/box.R index f47b107a..4b325e86 100644 --- a/tests-manual/box.R +++ b/tests-manual/box.R @@ -1,6 +1,8 @@ # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of other boxes library(shiny) +library(shinydashboard) + body <- dashboardBody( # infoBoxes @@ -39,10 +41,15 @@ body <- dashboardBody( selectInput("progress", "Progress", choices = c("0%" = 0, "20%" = 20, "40%" = 40, "60%" = 60, "80%" = 80, "100%" = 100) - ) + ), + boxMenu = boxItem(a(href="https://www.bing.com", "bing it!", + style = "color: yellow", target = "_blank"), + downloadButton("svgdown", "download svg")), + collapsible = FALSE, collapsed = FALSE ), box(title = "Histogram box title", - status = "warning", solidHeader = TRUE, collapsible = F, wrench = TRUE, + status = "info", solidHeader = TRUE, collapsible = T, + boxMenu = boxMenuOutput("menuWrench"), plotOutput("plot", height = 250) ) ), @@ -74,6 +81,25 @@ body <- dashboardBody( ) server <- function(input, output) { + output$menuWrench <- renderMenu({ + boxItem(p("some text", style="color: red"), + a(href="https://google.cz", "google czech", style = "color: red", target = "_blank"), + a(href="https://www.polygon.com", "polygon!", style = "color: yellow", target = "_blank")) + }) + + select_plot2 = function() { + hist(rnorm(input$orders)) + } + + output$svgdown <- downloadHandler( + filename <- "plot.svg", + content = function(file) { + svg(file) + select_plot2() + dev.off() + } + ) + output$orderNum <- renderText({ prettyNum(input$orders, big.mark=",") }) @@ -104,10 +130,10 @@ server <- function(input, output) { p("Current status is: ", icon(iconName, lib = "glyphicon")) }) - output$plot <- renderPlot({ hist(rnorm(input$orders)) }) + } # A dashboard header with 3 dropdown menus header <- dashboardHeader( @@ -160,12 +186,21 @@ header <- dashboardHeader( "Write documentation" ) ) + +) + +sidebar <- dashboardSidebar( + sidebarUserPanel( + "User Name", + subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"), + image = "https://almsaeedstudio.com/themes/AdminLTE/dist/img/user2-160x160.jpg" + ) ) shinyApp( ui = dashboardPage( header, - dashboardSidebar(), + sidebar, body ), server = server diff --git a/tests-manual/repro_issues_112.R b/tests-manual/repro_issues_112.R deleted file mode 100644 index 2bd40412..00000000 --- a/tests-manual/repro_issues_112.R +++ /dev/null @@ -1,19 +0,0 @@ -ui <- dashboardPage( - dashboardHeader( - title = "Sidebar spill" - ), - dashboardSidebar( - sidebarMenu( - menuItem(text = "sfsdf sfaosh oas fwue wi aseiu wehw wuer woeur owuer") - ) - ), - dashboardBody( - fluidRow() - ) -) - -server <- function(input, output) { -} - -shinyApp(ui, server) - diff --git a/tests-manual/repro_issues_113.R b/tests-manual/repro_issues_113.R deleted file mode 100644 index 627ebba7..00000000 --- a/tests-manual/repro_issues_113.R +++ /dev/null @@ -1,20 +0,0 @@ -library(shiny) -library(shinydashboard) - -ui = shinyUI(dashboardPage( - dashboardHeader(), - dashboardSidebar(disable = TRUE), - dashboardBody( - box(title = "Report", width = 12, verbatimTextOutput("protocol") - ) - - ) -)) - -server = shinyServer(function(input, output, session) { - output$protocol <- renderPrint({ - print(numeric(10e3)) - }) -}) - -shinyApp(ui, server)