shiny & pitchRx: an MLB PITCHf/x visualization app for the layman.

server.R

library(shiny)
library(animation)
library(Cairo)
library(pitchRx)
library(shinyRGL)
library(rgl)


valid <- function(input, default) { 
  if (is.null(input)) return(FALSE)
  if (input == default) return (FALSE)
  return(TRUE)
} #used for repeated checking of whether "valid" input exists


shinyServer(function(input, output) {
  
  getSample <- reactive(function() {
    data(pitches, package = "pitchRx")
    get('pitches')
  })
  
  getLocal <- reactive(function() {
    if (!is.null(input$file)) {
      path <- input$file$datapath 
      read.csv(path)
    } else NULL
  })
  
  getData <- reactive(function() {
    if (input$dataSource == "local") {
      data <- getLocal()
    } else {
      data <- getSample()
    }
  })
  
  getNames <- reactive(function() {
    data <- getData()
    vars <- names(data)
    names(vars) <- vars
  })
  
  output$pointColor <- reactiveUI(function() {
    n <- getNames()
    selectInput("pointColor", "Choose a 'color' variable:", 
                choices=c("pitch_types"="pitch_types", "None"="None", n))
  })
  
  output$denVar1 <- reactiveUI(function() {
    if (input$geom %in% c("hex", "tile", "bin")){
      n <- getNames()
      selectInput("denVar1", "Choose a variable:", choices=c("None"="None", n))
    } else NULL
  })
  
  output$denVar2 <- reactiveUI(function() {
    if (input$geom %in% c("hex", "tile", "bin")){
      n <- getNames()
      selectInput("denVar2", "Choose a variable:", choices=c("None"="None", n))
    } else NULL
  })
  
  output$vals1 <- reactiveUI(function() {
    if (!is.null(input$denVar1)) {
      if (input$denVar1 != "None") {
        data <- getData()
        vals <- sort(unique(data[,input$denVar1]))
        checkboxGroupInput("vals1", "Select value(s) of this variable:", 
                           choices  = vals, selected = vals[[1]])
      } else NULL
    } else NULL
  })
  
  output$vals2 <- reactiveUI(function() {
    if (!is.null(input$denVar1)) {
      if (input$denVar2 != "None") {
        data <- getData()
        vals <- sort(unique(data[,input$denVar2]))
        checkboxGroupInput("vals2", "Select value(s) of this variable:", 
                           choices  = vals, selected = vals[[1]])
      } else NULL
    } else NULL
  })
  
  output$myWebGL <- renderWebGL({
    points3d(1:10, 1:10, 1:10)
    axes3d()
    #interactiveFX(data, interval=input$interval, color=input$pointColor, alpha=input$point_alpha)
    #browseURL(paste("file://", writeWebGL(dir=file.path(tempdir(), "webGL"), width=500, height=500),sep=""))
  })

  
  plotFX <- reactive(function() {
    data <- getData()
    #Build facetting call
    facet1 <- input$facet1
    facet2 <- input$facet2
    if (facet1 == "Enter my own") facet1 <- input$facet1custom
    if (facet2 == "Enter my own") facet2 <- input$facet2custom
    if (facet1 == "No facet" & facet2 == "No facet") 
      facet_layer <- list()
    if (facet1 != "No facet" & facet2 == "No facet") {
      facet_layer <- call("facet_grid", paste(".~", facet1, sep=""))
    }
    if (facet1 == "No facet" & facet2 != "No facet") {  
      facet_layer <- call("facet_grid", paste(facet2, "~.", sep=""))
    }
    if (facet1 != "No facet" & facet2 != "No facet") {
      facet_layer <- call("facet_grid", paste(facet2, "~", facet1, sep=""))
    }
    if (input$coord.equal) {
      coord_equal <- coord_equal()
    } else coord_equal <- NULL

    if (input$tabs == "animate") {
      oopt <- ani.options(interval = 0.01, ani.dev = CairoPNG, 
                          title = "My pitchRx Animation", 
                          description = "Generated from <a href='http://cpsievert.github.com/home.html'>Carson Sievert</a>'s PITCHf/x <a href='https://gist.github.com/4440099'>visualization tool</a>")
      ani.start()
      print(animateFX(data, point.size=input$point_size, 
                      point.alpha=input$point_alpha, 
                      layer=list(facet_layer, coord_equal), parent=TRUE))
      ani.stop()
      ani.options(oopt)
    }
    #Set binwidths for hex and bins
    #contours require special handling within each geometry
    binwidths <- NULL
    if (input$geom == "hex") {
      binwidths <- c(input$hex_xbin, input$hex_ybin)
      contours <- input$hex_contour
      a <- input$hex_adjust
    }
    if (input$geom == "bin") {
      binwidths <- c(input$bin_xbin, input$bin_ybin)
      contours <- input$bin_contour
      a <- input$bin_adjust
    }
    if (input$geom == "point") {
      contours <- input$point_contour
      a <- input$point_adjust
    }
    if (input$geom == "tile") {
      contours <- input$tile_contour
      a <- input$tile_adjust
    }
    if (input$tabs == "2D Scatterplot") {
      den1 <- list()
      den2 <- list()
      if (valid(input$denVar1, "None") && !is.null(input$vals1)) {
        den1 <- list(input$vals1)
        names(den1) <- input$denVar1
      }
      if (valid(input$denVar2, "None") && !is.null(input$vals1)) {
        den2 <- list(input$vals2)
        names(den2) <- input$denVar2
      }
      if (!is.null(input$pointColor)) {
        pointColor <- input$pointColor
      } else pointColor <- "pitch_types"
      print(strikeFX(data, geom=input$geom, point.size=input$point_size, 
                     point.alpha=input$point_alpha, color=pointColor, density1=den1,
                     density2=den2, layer=list(facet_layer, coord_equal), contour=contours, 
                     adjust=a, limitz=c(input$xmin, input$xmax, input$ymin, input$ymax),
                     binwidth=binwidths, parent=TRUE))
    }
  })
  
  output$staticPlot <- reactivePlot(function() {
    print(plotFX())
  })
  
  output$downloadPlot <- downloadHandler(
    filename <- function() {
      pre <- paste("pitchRx", as.POSIXct(Sys.Date()), sep="-")
      paste(pre, ".png", sep="")
    },
    content <- function(file) {
      png(file) 
      print(plotFX())
      dev.off()
    },
    contentType = 'image/png'
  )
  
})

ui.R

library(shiny)

# This app assumes one already has PITCHf/x data available to visualize (or wants to use sample data)
shinyUI(pageWithSidebar(
  
  headerPanel("PITCHf/x Visualization App"),
  
  sidebarPanel(  
    helpText(HTML("<h3>Data source</h3>")),
    radioButtons("dataSource", "",
                 c("Use sample dataset" = "sample", "Use local file" = "local", "Collect data from the source" = "source")),
    HTML("<hr />"),
    conditionalPanel(
      condition = "input.dataSource == 'sample'",
      helpText(HTML("<div style=\"text-indent: 25px\">This sample dataset contains every four-seam fastball and cutting fastball thrown by Mariano Rivera and Phil Hughes over the 2011 season.</div>"))
    ),
    conditionalPanel(
      condition = "input.dataSource == 'local'",            
      fileInput(inputId = "file", label="PITCHf/x data stored in csv format:")
    ),
    conditionalPanel(
      condition = "input.dataSource == 'source'",
      helpText(HTML("<div style=\"text-indent: 25px\">See <a href='http://cpsievert.wordpress.com/2013/01/10/easily-obtain-mlb-pitchfx-data-using-r/'>my post</a> on collecting PITCHf/x data from the source using <a href='http://cran.r-project.org/web/packages/pitchRx/'>pitchRx</a>.</div>"))
    ),
    HTML("<hr />"),
#     helpText(HTML("<h3>Visualization Method</h3>")),
#     radioButtons("visMethod", "",
#                  c("Visualize strikezones" = "strike", 
#                    "3D scatterplot" = "rgl")),
#    HTML("<hr />"),
    conditionalPanel(
      condition = "input.tabs == '3D Scatterplot'",
      checkboxInput("avgby", "Average over pitch types", TRUE)
    ),
    #conditionalPanel(
    #  condition = "input.tabs == '2D Scatterplot'",
      helpText(HTML("<h3>Axis Settings</h3>")),
      numericInput("xmin", "x-axis minimum:", -3.5),
      numericInput("xmax", "x-axis maximum:", 3.5),
      numericInput("ymin", "y-axis minimum", 0),
      numericInput("ymax", "y-axis maximum", 7),
      checkboxInput("coord.equal", strong("Preserve Plotting Persepective"), TRUE),
      helpText(HTML("<h3>Facetting</h3>")),
      selectInput("facet1", "Column-wise Split:", 
                  choices = c("stand", "pitch_type", "pitcher_name", "top_inning", "No facet", "Enter my own")),
      conditionalPanel(
        condition = "input.facet1 == 'Enter my own'",
        textInput("facet1custom", "Type variable name here:", " ")
      ),
      selectInput("facet2", "Row-wise Split:", 
                  choices = c("No facet", "pitch_type", "pitcher_name", "top_inning", "Enter my own")),
      conditionalPanel(
        condition = "input.facet2 == 'Enter my own'",
        textInput("facet2custom", "Type variable name here:", " ")
      ),
      HTML("<hr />"),
      helpText(HTML("<h3>Plotting Geometries</h3>")),
      radioButtons("geom", "",
                   c("point" = "point", 
                     "tile" = "tile",
                     "hex" = "hex",
                     "bin" = "bin")),
      wellPanel(
        conditionalPanel(
          condition = "input.geom == 'point'",
          uiOutput("pointColor"),
          sliderInput("point_alpha", "Alpha (transparency):",
                      min = 0, max = 1, value = 0.5, step = 0.1),
          sliderInput("point_size", "Size:",
                      min = 0.5, max = 8, value = 5, step = 0.5),
          checkboxInput("point_contour", strong("Add contour lines"), FALSE),
          conditionalPanel(
            condition = "input.tabs == '2D Scatterplot'",
            checkboxInput("point_adjust", strong("Adjust vertical locations to aggregate strikezone"), TRUE)
          )
        ),
        conditionalPanel(
          condition = "input.tabs == '2D Scatterplot'",
          conditionalPanel(
            condition = "input.geom == 'tile'",
            checkboxInput("tile_contour", strong("Add contour lines"), FALSE),
            checkboxInput("tile_adjust", strong("Adjust vertical locations to aggregate strikezone"), TRUE)
          ),
          conditionalPanel(
            condition = "input.geom == 'hex'",
            checkboxInput("hex_contour", strong("Add contour lines"), FALSE),
            sliderInput("hex_xbin", "Hex Width:",
                        min = 0.1, max = 3, value = 0.25, step = 0.05),
            sliderInput("hex_ybin", "Hex Height:",
                        min = 0.1, max = 3, value = 0.25, step = 0.05),
            checkboxInput("hex_adjust", strong("Adjust vertical locations to aggregate strikezone"), TRUE)
          ),
          conditionalPanel(
            condition = "input.geom == 'bin'",
            checkboxInput("bin_contour", strong("Add contour lines"), FALSE),
            sliderInput("bin_xbin", "Bin Width:",
                        min = 0.1, max = 3, value = 0.25, step = 0.05),
            sliderInput("bin_ybin", "Bin Height:",
                        min = 0.1, max = 3, value = 0.25, step = 0.05),
            checkboxInput("bin_adjust", strong("Adjust vertical locations to aggregate strikezone"), TRUE)
          )
        ),
        #panel for density geometries
        conditionalPanel( 
          condition = "input.geom == 'bin' || input.geom == 'hex' || input.geom == 'tile'",
          helpText(HTML("<h3>Alter Density(ies)</h3>")),
          uiOutput("denVar1"),
          conditionalPanel(
            condition = "input.denVar1 != 'None'",
            uiOutput("vals1")
          ),
          uiOutput("denVar2"),
          conditionalPanel(
            condition = "input.denVar2 != 'None'",
            uiOutput("vals2")
          )
        )
      )
    #)
  ),
  
  #Main panel with static (strikezone) plot and download button
  mainPanel(
    tabsetPanel(id="tabs",
      tabPanel("2D Scatterplot", HTML("<div class=\"span8\">
                                          <a id=\"downloadPlot\" class=\"btn shiny-download-link\" target=\"_blank\">Download Current Plot</a>
                                          <div id=\"staticPlot\" class=\"shiny-plot-output\" style=\"position:fixed ; width: 60% ; height: 80%\">
                                        </div>
                                      </div>")),
      tabPanel("3D Scatterplot", webGLOutput("myWebGL"))
    )
  )

  
  ))

Essential functionality is working. Having trouble with facetting "differenced density estimates". Eventually, animations hopefully won't open a new tab.

All desired functionality currently works. Sometimes plots are produced twice.