Skip to content

Instantly share code, notes, and snippets.

@bayesball
Created Dec 5, 2021
Embed
What would you like to do?
Shiny app to display in-play and hit rate data over Retrosheet field locations
library(shiny)
library(ggplot2)
library(dplyr)
library(readr)
# read in Retrosheet data for two seasons
d <- read_csv("retro_2seasons_ip.csv")
# main drawing function
draw_retro_diagram <- function(new_data,
title = "",
subtitle = ""){
x <- c(0, 232, 60, -60, -232, 0)
y <- c(0, 212, 415, 415, 212, 0)
x1 <- c(0, -60); y1 <- c(0, 415)
x2 <- c(0, 60); y2 <- c(0, 415)
x3 <- c(0, -135); y3 <- c(0, 324)
x4 <- c(0, -188); y4 <- c(0, 262)
d <- data.frame(x = x, y = y)
d1 <- data.frame(x1 = x1, y1 = y1)
d2 <- data.frame(x2 = x2, y2 = y2)
d3 <- data.frame(x3 = x3, y3 = y3)
d4 <- data.frame(x4 = x4, y4 = y4)
d5 <- data.frame(x5 = - x3, y5 = y3)
d6 <- data.frame(x6 = - x4, y6 = y4)
d0 <- 50
x0 <- 90 / sqrt(2)
labels <- c("78XD", "8XD", "89XD",
"7LD", "7D", "78D", "8D", "89D", "9D", "9LD",
"7L", "7", "78", "8", "89", "9", "9L",
"7LS", "7S", "78S", "8S", "89S", "9S", "9LS",
"5D", "56D", "6D", "6MD", "4MD", "4D", "34D",
"3D",
"5", "56", "6", "6M", "4M", "4", "34", "3")
xl0 <- c(-70, 0, 70,
-200, -140, -80, 0, 80, 140, 200,
-180, -130, -70, 0, 70, 130, 180,
-150, -110, -70, 0, 70, 110, 150,
-120, -90, -50, -15, 15, 50, 90, 120,
-90, -65, -42, -12, 12, 42, 65, 90)
yl0 <- c(370, 380, 370,
250, 280, 320, 330, 320, 280, 250,
220, 240, 270, 280, 270, 240, 220,
180, 200, 220, 225, 220, 200, 180,
133, 150, 170, 180, 180, 170, 150, 133,
100, 110, 128, 135, 135, 128, 110, 100)
dl <- data.frame(xl0, yl0, labels)
draw_circle_segment <- function(radius,
theta1, theta2){
theta <- seq(theta1, theta2, length.out = 50)
df <- data.frame(x = radius * cos(theta),
y = radius * sin(theta))
geom_line(data = df, aes(x, y),
color = "red")
}
plot1 <- ggplot(d, aes(x, y)) +
geom_path(lwd = 0.5, linetype = 2,
color = "red") +
geom_path(data = data.frame(
x = c(0, x0, 0, -x0, 0),
y = c(0, x0, 2 * x0, x0, 0)), aes(x, y),
color = "red") +
geom_line(data = d1, aes(x1, y1),
color = "red") +
geom_line(data = d2, aes(x2, y2),
color = "red") +
geom_line(data = d3, aes(x3, y3),
color = "red") +
geom_line(data = d4, aes(x4, y4),
color = "red") +
geom_line(data = d5, aes(x5, y5),
color = "red") +
geom_line(data = d6, aes(x6, y6),
color = "red") +
coord_fixed() +
draw_circle_segment(405 - d0, pi / 2 * .75,
pi / 2 * 1.25) +
draw_circle_segment(405 - 2 * d0, pi / 2 * .47,
pi / 2 * 1.53) +
draw_circle_segment(405 - 3 * d0, pi / 2 * .47,
pi / 2 * 1.53) +
draw_circle_segment(405 - 4 * d0, pi / 2 * .47,
pi / 2 * 1.53) +
draw_circle_segment(405 - 5 * d0, pi / 2 * .47,
pi / 2 * 1.53) +
theme_bw() +
xlab("") + ylab("") +
theme(axis.text = element_blank(),
axis.ticks = element_blank(),
panel.border = element_blank(),
panel.grid.major = element_blank()) +
labs(title = title, subtitle = subtitle) +
theme(plot.title = element_text(colour = "blue",
size = 16,
hjust = 0.5, vjust = 0.8, angle = 0),
plot.subtitle = element_text(colour = "blue",
size = 16,
hjust = 0.5, vjust = 0.8, angle = 0))
if(is.null(new_data) == FALSE){
out2 <- inner_join(new_data, dl,
by = c("BATTEDBALL_LOC_TX" =
"labels"))
plot1 <- plot1 +
geom_text(data = out2, aes(xl0, yl0,
label = P),
fontface = "bold",
color = "blue")} else {
plot1 <- plot1 +
geom_text(data = dl, aes(xl0, yl0,
label = labels),
fontface = "bold",
color = "blue")
}
plot1
}
# Shiny application
ui <- fluidPage(
theme = bslib::bs_theme(version = 4,
bootswatch = "superhero"),
h2("Retrosheet Batted Ball Rates"),
fluidRow(
column(3, wellPanel(
radioButtons("season", "Season:",
c("2020", "2021"),
"2020", inline = TRUE),
radioButtons("stand", "Batter Side:",
c("L", "R"),
"L", inline = TRUE),
radioButtons("bbtype", "Batted Ball Type:",
c("G", "L", "F", "P"),
"G", inline = TRUE),
radioButtons("type", "Measure:",
c("In-Play", "Hits",
"Batted Ball Rate", "In-Play AVG"),
"Batted Ball Rate", inline = TRUE),
downloadButton("downloadData", "Download Data")
)),
column(9,
tabsetPanel(type = "tabs",
tabPanel("Rates",
plotOutput("plot1",
height = "650px")
),
tabPanel("Codes",
plotOutput("plot2",
height = "650px")
)
)
)
)
)
server <- function(input, output, session) {
output$plot1 <- renderPlot({
d %>%
filter(Season == input$season,
BAT_EVENT_FL == TRUE,
BATTEDBALL_CD == input$bbtype,
BAT_HAND_CD == input$stand) -> d2
N <- nrow(d2)
d2 %>%
group_by(BATTEDBALL_LOC_TX) %>%
summarize(
IP = n(),
H = sum(H_FL > 0),
BB_Rate = round(100 * IP / N, 1),
AVG = round(H / IP, 3)
) -> S
if(input$type == "Batted Ball Rate"){
S$P <- S$BB_Rate
}
if(input$type == "In-Play AVG"){
S$P <- substr(S$AVG, 2, 5)
S$P <- ifelse((S$H == S$IP) & (S$IP > 0),
"1.000", S$P)
S$P <- ifelse((S$H == 0) & (S$IP > 0),
".000", S$P)
}
if(input$type == "In-Play"){
S$P <- S$IP
}
if(input$type == "Hits"){
S$P <- S$H
}
mytitle <- paste("Season: ", input$season,
", Batter Side: ", input$stand,
sep = "")
mysubtitle <- paste("Batted Ball Type: ",
input$bbtype,
", Measure: ", input$type,
sep = "")
if(input$type == "Batted Ball"){
mysubtitle <- paste(mysubtitle, "(%)")
}
draw_retro_diagram(S, title = mytitle,
subtitle = mysubtitle)
}, res = 96)
output$plot2 <- renderPlot({
draw_retro_diagram(NULL,
title = "Retrosheet Field Codes")
}, res = 96)
output$downloadData <- downloadHandler(
filename = "field_output.csv",
content = function(file) {
d %>%
filter(Season == input$season,
BAT_EVENT_FL == TRUE,
BATTEDBALL_CD == input$bbtype,
BAT_HAND_CD == input$stand) -> d2
N <- nrow(d2)
d2 %>%
group_by(BATTEDBALL_LOC_TX) %>%
summarize(
IP = n(),
H = sum(H_FL > 0),
BB_Rate = round(100 * IP / N, 1),
AVG = round(H / IP, 3)
) -> S
S %>%
mutate(N = N,
Season = input$season) -> S
write.csv(S, file, row.names = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment