added plotFielding, MAJOR speed up to fielding model

Author: beanumber

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: openWAR
 Type: Package
 Title: Machinery for analyzing baseball data and computing WAR
-Version: 0.2.2.9000
+Version: 0.2.2.9001
 Date: 2013-07-31
 Authors@R: c(
     person("Ben", "Baumer", email = "[email protected]", role = c("aut", "cre")), 

NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2 (4.1.1): do not edit by hand
 
+S3method(getModelFieldingCollective,GameDayPlays)
+S3method(getModelFieldingCollective,default)
 S3method(getModelRunExpectancy,GameDayPlays)
 S3method(getModelRunExpectancy,default)
 S3method(getModels,GameDayPlays)
@@ -16,6 +18,12 @@ S3method(plot,GameDayPlays)
 S3method(plot,do.openWARPlayers)
 S3method(plot,gameday)
 S3method(plot,openWARPlayers)
+S3method(plotFielding,bkde2D)
+S3method(plotFielding,default)
+S3method(plotFielding,formula)
+S3method(plotFielding,glm)
+S3method(plotFielding,lm)
+S3method(predict,bkde2D)
 S3method(shakeWAR,GameDayPlays)
 S3method(shakeWAR,list)
 S3method(shakeWAR,openWARPlays)
@@ -43,7 +51,9 @@ export(makeWAR)
 export(makeWARBaserunning)
 export(makeWARre24)
 export(panel.baseball)
+export(panel.fielding)
 export(panel.war)
+export(plotFielding)
 export(readData.gameday)
 export(shakeWAR)
 export(tabulate)

R/getModels.R

@@ -1,17 +1,16 @@
 #' @title getModels
-#' @aliases getModels.GameDayPlays
 #' 
-#' @description Retrieve various models trained on GameDayPlays data
+#' @description Retrieve various models trained on \code{\link{GameDayPlays}} data
 #' 
 #' @details This function will retrieve various models based on the MLBAM data 
 #' set and the openWAR framework. Currently this only returns the Run Expectancy Model.
 #' 
-#' @param data a GameDayPlays dataset
+#' @param data a \code{\link{GameDayPlays}} dataset
 #' @param ... currently ignored
 #' 
-#' @return A list of model objects
+#' @return A \code{\link{list}} of model objects
 #' 
-#' @export getModels
+#' @export
 #' @examples
 #' 
 #' data(May)
@@ -35,13 +34,12 @@ getModels.GameDayPlays = function(data, ...) {
 }
 
 #' @title getModelRunExpectancy
-#' @aliases getModelRunExpectancy
 #' 
 #' @description Build the Run Expectancy Model
 #' 
-#' @details This function will build the Run Expectancy Model used in \code{openWAR}.
+#' @details This function will build the Run Expectancy Model used in \code{\link{openWAR}}.
 #' 
-#' @param data a GameDayPlays dataset
+#' @param data a \code{\link{GameDayPlays}} dataset
 #' @param mod.re an existing Run Expectancy Model
 #' @param verbose print messages to screen during operation?
 #' @param drop.incomplete a LOGICAL indicating whether incomplete innings (e.g. walk-off innings)
@@ -197,7 +195,7 @@ getModelFieldingRF = function(data) {
 #' @details Computes a 2D kernel smoothed estimate of the probability that *any* of the 9 fielders
 #' will make a play on a ball in play
 #' 
-#' @param data An MLBAM data.frame 
+#' @param data A \code{\link{GameDayPlays}} object
 #' 
 #' @return a vector representing the probability that each ball in play will be fielded
 #' 
@@ -206,36 +204,56 @@ getModelFieldingRF = function(data) {
 #' @importFrom KernSmooth bkde2D
 #' @importFrom Hmisc whichClosest
 #' 
+#' @examples 
+#' 
+#' fmod <- getModelFieldingCollective(May)
+#' plotFielding(fmod)
 #' 
 
-getModelFieldingCollective = function(data) {
+getModelFieldingCollective = function(data) { UseMethod("getModelFieldingCollective"); }
+
+#' @export
+#' @rdname getModelFieldingCollective
+#' @method getModelFieldingCollective GameDayPlays
+
+getModelFieldingCollective.GameDayPlays = function(data) {
+  getModelFieldingCollective(filter_(data, ~isBIP == TRUE))
+}
+
+#' @export
+#' @rdname getModelFieldingCollective
+#' @method getModelFieldingCollective default
+#' 
+getModelFieldingCollective.default = function(data) {
     message("....Computing the collective fielding model...")
     data = dplyr::mutate_(data, wasFielded = ~!is.na(fielderId))
     outs = dplyr::select_(dplyr::filter_(data, ~wasFielded == TRUE), ~our.x, ~our.y)
     hits = dplyr::select_(dplyr::filter_(data, ~wasFielded == FALSE), ~our.x, ~our.y)
     # Find 2D kernel density estimates for hits and outs Make sure to specify the range, so that they over estimated over the
     # same grid
     grid = list(range(data$our.x, na.rm = TRUE), range(data$our.y, na.rm = TRUE))
-    fit.out <- KernSmooth::bkde2D(outs, bandwidth = c(10, 10), range.x = grid)
-    fit.hit <- KernSmooth::bkde2D(hits, bandwidth = c(10, 10), range.x = grid)
-    
-    field.smooth = data.frame(cbind(expand.grid(fit.out$x1, fit.out$x2), isOut = as.vector(fit.out$fhat)), isHit = as.vector(fit.hit$fhat))
-    names(field.smooth)[1:2] = c("x", "y")
-    # Plot the surfaces wireframe(isOut ~ x + y, data=field.smooth, scales = list(arrows = FALSE), drape = TRUE, colorkey =
-    # TRUE) wireframe(isHit ~ x + y, data=field.smooth, scales = list(arrows = FALSE), drape = TRUE, colorkey = TRUE)
+    fit.out <- KernSmooth::bkde2D(as.matrix(outs), bandwidth = c(10, 10), range.x = grid)
+    fit.hit <- KernSmooth::bkde2D(as.matrix(hits), bandwidth = c(10, 10), range.x = grid)
+    class(fit.out) <- union("bkde2D", class(fit.out))
+    class(fit.hit) <- union("bkde2D", class(fit.hit))
 
-    # Make sure to add a small amount to avoid division by zero
-    field.smooth = dplyr::mutate_(field.smooth, wasFielded = ~(isOut/(isOut + isHit + 1e-08)))
-    # summary(field.smooth) fieldingplot(wasFielded ~ x + y, data=field.smooth, label = 'cum_resp', write.pdf=TRUE)
-    
-    fit.all = function(x, y) {
-        x.idx = Hmisc::whichClosest(field.smooth$x, x)
-        y.idx = Hmisc::whichClosest(field.smooth$y, y)
-        match = dplyr::filter_(field.smooth, ~x == field.smooth$x[x.idx] & y == field.smooth$y[y.idx])
-        return(match$wasFielded)
-    }
-    
-    message("....Applying the collective fielding model...")
-    resp.field = mapply(fit.all, data$our.x, data$our.y)
-    return(resp.field)
-} 
+    fmod <- fit.out
+    fmod$fhat <- fit.out$fhat / (fit.out$fhat + fit.hit$fhat + 1e-08)
+    return(fmod)
+}
+
+#' @export
+
+predict.bkde2D <- function(object, ...) {
+  dots <- list(...)
+  newdata <- dots$newdata
+  if (ncol(newdata) < 2) {
+    stop("newdata must have at least two columns")
+  }
+  # find the indices that match closest
+  x.idx = Hmisc::whichClosest(object$x1, as.numeric(as.data.frame(newdata)[,1]))
+  y.idx = Hmisc::whichClosest(object$x2, as.numeric(as.data.frame(newdata)[,2]))
+  zHat <- apply(data.frame(x.idx, y.idx), MARGIN = 1, function(x) { object$fhat[x[1], x[2]]; })
+  return(zHat)
+}
+

R/makeWAR.R

@@ -233,7 +233,9 @@ makeWARFielding = function(data, ...) {
     message("...Estimating Fielding Runs Above Average...")
 
     # Compute the collective responsibility of all fielders
-    p.hat = getModelFieldingCollective(data[, c("fielderId", "our.x", "our.y")])
+    fmod = getModelFieldingCollective(data[, c("fielderId", "our.x", "our.y")])
+    message("....Applying the collective fielding model...")
+    p.hat <- predict(fmod, newdata = select_(data, ~our.x, ~our.y))
     # Step 2a: Define \delta.field for the defense, collectively
     delta.field = data$delta * p.hat
 

R/fieldingplot.R renamed to R/plotFielding.R

@@ -1,4 +1,4 @@
-#' @title fieldingplot
+#' @title plotFielding
 #' 
 #' @description Creates a plot of the fielding model for an individual player
 #' 
@@ -8,7 +8,8 @@
 #' paper. However, this function is not exported, since it is not really accessible
 #' to end users. We hope to add this functionality in a future release. 
 #' 
-#' @param x a model object, currently \code{\link{lm}} and \code{\link{glm}} are
+#' @param x a model object, currently \code{\link{lm}}, \code{\link{glm}}, and
+#' \code{\link{bkde2D}} are
 #'  supported. For the default method this is an x-coordinate to be passed to
 #'  \code{\link{contourplot}}.
 #' @param y y-coordinate for default method passed to \code{\link{contourplot}}.
@@ -23,6 +24,7 @@
 #' @importFrom RColorBrewer brewer.pal
 #' @importFrom mosaic lhs
 #' 
+#' @export
 #' @return A contourplot object
 #' 
 #' @examples
@@ -31,21 +33,23 @@
 #' library(dplyr)
 #' BIP <- filter(Mayplus, isBIP == TRUE)
 #' \dontrun{
-#' fielding = makeWARFielding(BIP)
+#' fielding <- makeWARFielding(BIP)
 #' }
 #' 
 
-fieldingplot = function(x, data, ...) UseMethod("fieldingplot")
+plotFielding = function(x, ...) UseMethod("plotFielding")
 
-#' @rdname fieldingplot
+#' @export
+#' @rdname plotFielding
 
-fieldingplot.glm = function(x, data, ...) {
-    fieldingplot.lm(x, data, ...)
+plotFielding.glm = function(x, ...) {
+    NextMethod()
 }
 
-#' @rdname fieldingplot
+#' @export
+#' @rdname plotFielding
 
-fieldingplot.lm = function(x, data, ...) {
+plotFielding.lm = function(x, ...) {
     model = x
     # make sure that the model object passed has a predict() method
     if (sum(paste("predict.", class(model), sep = "") %in% methods(predict)) == 0) {
@@ -59,12 +63,13 @@ fieldingplot.lm = function(x, data, ...) {
 
     label = gsub("[^A-Z]", "", paste(lhs(terms(model)), collapse = ""))
 
-    fieldingplot.formula(z.hat ~ our.x + our.y, data = my.grid, label = label, ...)
+    plotFielding.formula(z.hat ~ our.x + our.y, data = my.grid, label = label, ...)
 }
 
-#' @rdname fieldingplot
+#' @export
+#' @rdname plotFielding
 
-fieldingplot.formula = function(x, data, label = "label", write.pdf = FALSE, ...) {
+plotFielding.formula = function(x, label = "label", write.pdf = FALSE, ...) {
 
     if (write.pdf) {
         filename = paste("fielding_", label, ".pdf", sep = "")
@@ -81,13 +86,38 @@ fieldingplot.formula = function(x, data, label = "label", write.pdf = FALSE, ...
     }
 }
 
-#' @rdname fieldingplot
+#' @export
+#' @rdname plotFielding
 
-fieldingplot.default = function(x, y, z, label = "label", write.pdf = FALSE, ...) {
+plotFielding.default = function(x, y, z, label = "label", write.pdf = FALSE, ...) {
     stop("No available methods")
 }
 
-#' @rdname fieldingplot
+
+#' @export
+#' @rdname plotFielding
+#' @method plotFielding bkde2D
+#' 
+#' @examples 
+#' fmod <- getModelFieldingCollective(May)
+#' plotFielding(fmod)
+#' 
+
+plotFielding.bkde2D <- function(x, ...) {
+  contourplot(x = x$fhat, row.values = x$x1, column.values = x$x2,
+              panel = panel.fielding, region = TRUE, alpha.regions = 0.5, 
+              col.regions = colorRampPalette(RColorBrewer::brewer.pal(9, "Blues"))(100), 
+              cuts = 10, contour = TRUE,
+              #        , xlim = c(-350, 350), ylim = c(0, 550)
+              xlab = "Horizontal Distance from Home Plate (ft.)", 
+              ylab = "Vertical Distance from Home Plate (ft.)", 
+              ...
+              )
+}
+
+
+#' @rdname plotFielding
+#' @export
 
 panel.fielding = function(x, y, z, ...) {
   panel.baseball()

man/fieldingplot.Rd

@@ -2,12 +2,18 @@
 % Please edit documentation in R/getModels.R
 \name{getModelFieldingCollective}
 \alias{getModelFieldingCollective}
+\alias{getModelFieldingCollective.GameDayPlays}
+\alias{getModelFieldingCollective.default}
 \title{getModelFieldingCollective}
 \usage{
 getModelFieldingCollective(data)
+
+\method{getModelFieldingCollective}{GameDayPlays}(data)
+
+\method{getModelFieldingCollective}{default}(data)
 }
 \arguments{
-\item{data}{An MLBAM data.frame}
+\item{data}{A \code{\link{GameDayPlays}} object}
 }
 \value{
 a vector representing the probability that each ball in play will be fielded
@@ -21,4 +27,8 @@ Determine the responsibility of the fielders, collectively
 Computes a 2D kernel smoothed estimate of the probability that *any* of the 9 fielders
 will make a play on a ball in play
 }
+\examples{
+fmod <- getModelFieldingCollective(May)
+plotFielding(fmod)
+}