Adding all remaining apps for the shiny dev center gallery

027-absolutely-positioned-panels/DESCRIPTION

@@ -0,0 +1,7 @@
+Title: Absolutely-positioned panels
+Type: Shiny
+Author: Joe Cheng <[email protected]>
+AuthorUrl: http://www.rstudio.com/
+Tags: absolutePanel css markdown
+License: MIT
+DisplayMode: Showcase

027-absolutely-positioned-panels/server.R

@@ -0,0 +1,12 @@
+shinyServer(function(input, output, session) {
+  output$plot <- renderPlot({
+    mtscaled <- as.matrix(scale(mtcars))
+    heatmap(mtscaled,
+      col = topo.colors(200, alpha=0.5),
+      Colv=F, scale="none")
+  })
+
+  output$plot2 <- renderPlot({
+    plot(head(cars, input$n), main="Foo")
+  }, bg = "#F5F5F5")
+})

027-absolutely-positioned-panels/ui.R

@@ -0,0 +1,37 @@
+library(markdown)
+
+shinyUI(fluidPage(style="padding-top: 80px;",
+  h1("Absolutely-positioned panels"),
+  absolutePanel(
+    bottom = 20, right = 20, width = 300,
+    draggable = TRUE,
+    wellPanel(
+      HTML(markdownToHTML(fragment.only=TRUE, text=c(
+"This is an absolutePanel that uses `bottom` and `right` attributes.
+
+It also has `draggable = TRUE`, so you can drag it to move it around the page.
+
+The slight transparency is due to `style = 'opacity: 0.92'`.
+
+You can put anything in absolutePanel, including inputs and outputs:"
+      ))),
+      sliderInput("n", "", min=3, max=20, value=5),
+      plotOutput("plot2", height="200px")
+    ),
+    style = "opacity: 0.92"
+  ),
+  absolutePanel(
+    top = 0, left = 0, right = 0,
+    fixed = TRUE,
+    div(
+      style="padding: 8px; border-bottom: 1px solid #CCC; background: #FFFFEE;",
+      HTML(markdownToHTML(fragment.only=TRUE, text=c(
+"This absolutePanel is docked to the top of the screen
+using `top`, `left`, and `right` attributes.
+
+Because `fixed=TRUE`, it won't scroll with the page."
+      )))
+    )
+  ),
+  plotOutput("plot", height = "800px")
+))

028-actionbutton-demo/DESCRIPTION

@@ -0,0 +1,7 @@
+Type: Shiny
+Title: actionButton demo
+License: MIT
+Author: Winston Chang <[email protected]>
+AuthorUrl: http://www.rstudio.com/
+Tags: actionbutton
+DisplayMode: Showcase

028-actionbutton-demo/server.r

@@ -0,0 +1,9 @@
+shinyServer(function(input, output) {
+  output$nText <- renderText({
+    # Take a dependency on input$goButton
+    input$goButton
+
+    # Use isolate() to avoid dependency on input$n
+    isolate(input$n)
+  })
+})

028-actionbutton-demo/ui.r

@@ -0,0 +1,12 @@
+shinyUI(pageWithSidebar(
+  headerPanel("actionButton test"),
+  sidebarPanel(
+    numericInput("n", "N:", min = 0, max = 100, value = 50),
+    br(),
+    actionButton("goButton", "Go!"),
+    p("Click the button to update the value displayed in the main panel.")
+  ),
+  mainPanel(
+    verbatimTextOutput("nText")
+  )
+))

029-authentication-and-database/server.R

@@ -0,0 +1,175 @@
+
+library(shiny)
+library(dplyr)
+library(lubridate)
+
+# Load libraries and functions needed to create SQLite databases.
+library(RSQLite)
+library(RSQLite.extfuns)
+saveSQLite <- function(data, name){
+  path <- dplyr:::db_location(filename=paste0(name, ".sqlite"))
+  if (!file.exists(path)) {
+    message("Caching db at ", path)
+    src <- src_sqlite(path, create = TRUE)
+    copy_to(src, data, name, temporary = FALSE)
+  } else {
+    src <- src_sqlite(path)
+  }
+  return (src)
+}
+
+# Load/create some data and put it in SQLite. In practice, the data you want
+# likely already exists in the databse, so you would just be reading the data
+# in from the database, not uploading it from R.
+
+# Load and upload flights data
+library(hflights)
+hflights_db <- tbl(hflights_sqlite(), "hflights")
+
+# Create a user membership data.frame that maps user names to an airline 
+# company.
+membership <- data.frame(
+  user = c("kim", "sam", "john", "kelly", "ben", "joe"),
+  company = c("", "DL", "AA", "UA", "US", "DL"),
+  role = c("manager", rep("user", 5)))
+membership_db <- tbl(saveSQLite(membership, "membership"), "membership")
+
+airlines <- data.frame(
+  abbrev = c("AA", "DL", "UA", "US"),
+  name = c("American Airlines", "Delta Air Lines", 
+           "United Airlines", "US Airways")
+)
+airline_db <- tbl(saveSQLite(airlines, "airline"), "airline")
+
+
+#' Get the full name of an airline given its abbreviation.
+airlineName <- function(abbr){
+  as.data.frame(select(filter(airline_db, abbrev == abbr), name))[1,1]
+}
+
+shinyServer(function(input, output, session) {
+
+  #' Get the current user's username
+  user <- reactive({
+
+    curUser <- session$user
+
+    # Not logged in. Shiny Server Pro should be configured to prevent this.
+    if (is.null(curUser)){
+      return(NULL)
+    }
+
+    # Look up the user in the database to load all the associated data.
+    user <- as.data.frame(
+      filter(membership_db, user==curUser)      
+    )
+
+    # No user in the database
+    if (nrow(user) < 1){
+      return(NULL)
+    }
+
+    user[1,]    
+  })
+
+  #' Determine whether or not the current user is a manager.
+  isManager <- reactive({
+    if (is.null(user())){
+      return(FALSE)
+    }
+
+    role <- user()$role
+    return(role == "manager")    
+  })
+
+  #' Get the company of which the current user is a member
+  userCompany <- reactive({
+    if (is.null(user())){
+      return(NULL)
+    }
+
+    if (isManager()){
+      # If the user is a manager, then they're allowed to select any company
+      # they want and view its data.
+      if (is.null(input$company)){
+        return(as.data.frame(airline_db)$abbrev[1])
+      }
+      return(input$company)
+    }
+
+    # Otherwise this is just a regular, logged-in user. Look up what company
+    # they're associated with and return that.
+    user()$company
+  })
+
+  #' Get the data the current user has permissions to see
+  #' @return a dplyr tbl
+  companyData <- reactive({
+    # Trim down to only relevant variables
+    delays <- select(hflights_db, Month, DayofMonth, DepDelay, UniqueCarrier)
+
+    # Trim down to only values that we have permissions to see
+    comp <- userCompany()
+    delays <- filter(delays, UniqueCarrier == comp)
+
+    delays
+  })
+
+  #' Of the data a user is allowed to see, further refine it to only include the
+  #' date range selected by the user.
+  filteredData <- reactive({
+    # Get current month and day
+    curMonth <- month(now())
+    curDay <- day(now())
+
+    # Get the previous month and day based on the slider input
+    prevMonth <- month(now()-days(input$days))
+    prevDay <- day(now()-days(input$days))
+
+    # Filter to only include the flights in between the selected dates.
+    data <- filter(companyData(), 
+           (Month > prevMonth | (Month == prevMonth & DayofMonth >= prevDay)) &
+           (Month < curMonth | (Month == curMonth & DayofMonth <= curDay)))
+
+    as.data.frame(data)
+  })
+
+  output$title <- renderText({
+    if(is.null(user())){
+      return("ERROR: This application is designed to be run in Shiny Server Pro and to require authentication.")
+    }
+    paste0("Airline Delays for ", airlineName(userCompany()))
+  })
+
+  output$userPanel <- renderUI({
+    if (isManager()){
+      # The management UI should have a drop-down that allows you to select a 
+      # company.
+      tagList(
+        HTML(paste0("Logged in as <code>", user()$user, 
+                    "</code> who is a <code>", user()$role ,"</code>.")),
+        hr(),
+        p("As a manager, you may select any company's data you wish to view."),
+        selectInput("company", "", as.data.frame(airline_db)$abbrev)
+      )
+    } else{
+      # It's just a regular user. Just tell them who they are.
+      HTML(paste0("Logged in as <code>", user()$user, "</code> with <code>",
+                  airlineName(userCompany()),"</code>."))
+    }
+  })
+
+  #' Print a boxplot of the selected data.
+  output$box <- renderPlot({    
+    boxplot(
+      lapply(
+        split(filteredData(), as.factor(
+          paste0(filteredData()$Month, "/", filteredData()$DayofMonth))), 
+        function(dayData){ 
+          dayData$DepDelay 
+        }
+      ), ylab = "Delay (minutes)"
+    )
+  })
+
+})

029-authentication-and-database/ui.R

@@ -0,0 +1,23 @@
+
+library(shiny)
+
+shinyUI(
+  fluidPage(
+    # Setup the page title
+    tagList(tags$head(tags$title("Airline Delays")), h1(textOutput("title"))),    
+
+    sidebarLayout(
+      sidebarPanel(
+        uiOutput("userPanel"),
+        hr(),
+        sliderInput("days", "Prior days to include:", 1, 30, 7, 1),
+        hr(),        
+        helpText("The graph on the right shows a boxplot of the departure " ,
+                 "delays for the airline(s) your username is allowed to view.")
+      ),
+      mainPanel(
+        plotOutput("box")
+      )
+    )
+  )
+)

030-basic-datatable/DESCRIPTION

@@ -0,0 +1,7 @@
+Title: Basic DataTable
+Author: Jeff Allen <[email protected]>
+AuthorUrl: http://www.rstudio.com/
+License: MIT
+DisplayMode: Showcase
+Tags: mtcars selectinput datatables
+Type: Shiny

030-basic-datatable/server.R

@@ -0,0 +1,25 @@
+library(shiny)
+
+# Load the ggplot2 package which provides
+# the 'mpg' dataset.
+library(ggplot2)
+
+# Define a server for the Shiny app
+shinyServer(function(input, output) {
+
+  # Filter data based on selections
+  output$table <- renderDataTable({
+    data <- mpg
+    if (input$man != "All"){
+      data <- data[data$manufacturer == input$man,]
+    }
+    if (input$cyl != "All"){
+      data <- data[data$cyl == input$cyl,]
+    }
+    if (input$trans != "All"){
+      data <- data[data$trans == input$trans,]
+    }
+    data
+  })
+
+})

030-basic-datatable/ui.R

@@ -0,0 +1,38 @@
+library(shiny)
+
+# Load the ggplot2 package which provides
+# the 'mpg' dataset.
+library(ggplot2)
+
+# Define the overall UI
+shinyUI(
+  fluidPage(
+    titlePanel("Basic DataTable"),
+
+    # Create a new Row in the UI for selectInputs
+    fluidRow(
+      column(4, 
+          selectInput("man", 
+                      "Manufacturer:", 
+                      c("All", 
+                        unique(as.character(mpg$manufacturer))))
+      ),
+      column(4, 
+          selectInput("trans", 
+                      "Transmission:", 
+                      c("All", 
+                        unique(as.character(mpg$trans))))
+      ),
+      column(4, 
+          selectInput("cyl", 
+                      "Cylinders:", 
+                      c("All", 
+                        unique(as.character(mpg$cyl))))
+      )        
+    ),
+    # Create a new row for the table.
+    fluidRow(
+      dataTableOutput(outputId="table")
+    )    
+  )  
+)

031-chat-room/LICENSE

@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2014 Jeff Allen
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

031-chat-room/README.md

@@ -0,0 +1,6 @@
+ShinyChat
+=========
+
+Live demo [here](http://spark.rstudio.com/trestletech/ShinyChat/).
+
+Chat client built in Shiny.