Analytical Endeavors

Create a Twitter bot for your local animal shelter using rtweet

Thu, 03 May 2018 00:00:00 +0000

A month or so ago, I came across a cool article about a civic group in Bloomington, IN called BMGhack that coded a Twitter bot in Python for their local animal services department. I’d been reading articles about the earlier twitteR and newer rtweet packages for awhile and thought this was something I could tackle in R. The one I created is for Louisville Metro Animal Services (LMAS), but petfinder.com hosts pet profiles from many organizations. So you should have no problem finding one in your area. To start, let’s go ahead a create the app and get a token.

Create an app and a token

For the most part, everything is explained in Kearney’s tutorial, so I won’t rehash it here. Although, currently there’s a problem with the token that create_token makes. It’s a read-only token, and we need a read and write token in order to tweet using post_tweet.

The good news is that I have a temporary fix until the issue is resolved. After making the token with create_token, you’ll need to regenerate your token at the apps.twitter.com site. Now, you’ll have a read and write token. Then, you replace the old token and secret values with the new token and secret values. Write your new token object to a .rds file in your home directory and Bob’s your uncle.

library(tidyverse)
library(rtweet)



appname <- "<app name>"

key <- "<key>"

secret <- "<secret>"

# create (read-only) token
twitter_token <- create_token(
      app = appname,
      consumer_key = key,
      consumer_secret = secret
)

# Shows Home Directory path
home_directory <- path.expand("~/")

# replace with read and write token and secret values
twitter_token$credentials$oauth_token <- "<new token>"
twitter_token$credentials$oauth_token_secret <- "<new token secret>"

write_rds(twitter_token, "<home directory path>twitter_token.rds")


file_name <- file.path(home_directory, "twitter_token.rds")

# create environment variable so rtweet doesnt need token loaded explicitly in order to work.
cat(paste0("TWITTER_PAT=", file_name),
    file = file.path(home_directory, ".Renviron"),
    append = TRUE,
    fill = TRUE)

GET some pet data

There are two options for getting the information we need: scrape the animal services’ site or use the petfinder.com API. There are pros and cons for each but I’m going to use the API. To access the API, you’ll need a key and to get that key you’ll need to follow the link to the documentation above and create an account.

Once we have our key we need to figure out the shelter ID. The location argument can take a ZIP code or city/state input, and there’s also a XML or JSON option for the response format. On the LMAS website, the phone number and addresses are listed, so I’m going to use the zip codes to narrow the field. We’re left with three entries and from here, we see our shelter ID is “KY102”. So, now we can use the shelter.getPets method to download our pet data. I’ll go into a little more detail about the code later in the post.

library(jsonlite)
library(httr)

URL <- "http://api.petfinder.com/shelter.find"
args <- list(key = "<key>", location = "Louisville, KY", format = "json", count = "200")
api_json <- GET(url = URL, query = args)

# lets you know if any errors occurred in the GET request
stop_for_status(api_json)

# creates character vector that's needed for fromJSON
content_json <- content(api_json, as = "text", encoding = "UTF-8")

# creates list of nested data.frames
obj_json <- fromJSON(content_json)

# Find shelter, 
flatten(obj_json$petfinder$shelters$shelter) %>% 
      rename_at(vars(ends_with(".$t")), ~str_replace(., "\\.\\$t", "")) %>% 
      filter(zip == "40205" | zip == "40218") %>% 
      select(name, email, id)

                              name                                   email    id
1         Pit Bulls of St. Francis           adopt@pitbullsofstfrancis.org KY507
2 Louisville Metro Animal Services AnimalServicesAdoption@louisvilleky.gov KY102
3       Kentucky Great Dane Rescue       KentuckyGreatDaneRescue@Yahoo.com KY404

Next, we use our shelter id to pull some pet data, but you’ll notice I’m only pulling 2 records. This is for EDA purposes. In the final script, I recommend you go to your shelter’s website to get an estimate of how many pets they have for adoption. After you have an estimate, you can set the count argument to a number greater than the records available for your shelter and it won’t be an issue. LMAS has profiles for around 120 pets, so I ended up setting my count equal to 200.

URL <- "http://api.petfinder.com/shelter.getPets"
args <- list(key = "<key>", id = "KY102", format = "json", output = "full", count = "2")
api_json <- GET(url = URL, query = args)

# lets you know if any errors occurred in the GET request
stop_for_status(api_json)

# creates character vector that's needed for fromJSON
content_json <- content(api_json, as = "text", encoding = "UTF-8")

The data I’ll be using for this post are available at my github: content_json_eda and content_json. prettify lets us investigate the nested structure of the JSON we pulled from the API. I’m only showing the top part as these structures can be quite large and complex. Here we can see the meat of the data, with which we want to work, starts three levels down, petfinder –> pets –> pet.

# example data; character vector
content_json_eda <- read_rds("vector_json.rds") # 2 records
content_json <- read_rds("vector_json2.rds") # 200 records


# Get a sense of the nested structure.
content_json_eda %>% prettify

{
    "@encoding": "iso-8859-1",
    "@version": "1.0",
    "petfinder": {
        "@xmlns:xsi": "http://www.w3.org/2001/XMLSchema-instance",
        "lastOffset": {
            "$t": "2"
        },
        "pets": {
            "pet": [
                {
                    "options": {
                        "option": {
                            "$t": "altered"
                        }
                    },
                    "status": {
                        "$t": "A"
                    },
                    "contact": {
                          ...

Formulate the tweet

I haven’t experienced any problems with the Petfinder.com API but if errors do occur, they should be captured by the stop_for_status function earlier. If not, you can check obj_json$header$status$message for answers. Definitions for the status messages can be found in the API documentation.

After applying fromJSON and flatten, we now have a dataframe that we can manipulate by familiar data cleaning methods. Most of the cleaning isn’t noteworthy, but I will mention the weights variable that I created. It’s an attempt to give pets that have had longer stays in the shelter a greater opportunity to be noticed by potential adopters. The greater the weight the more likely that pet is to be selected. It’s based on the lastUpdate variable which isn’t defined in the API documentation. I’m assuming it’s the last time the shelter updated the pet’s information, but it could be the last time Petfinder updated their information (or something else entirely). If it’s the former and judging by the lack of variation in the status column, it might provide some measure of length of stay. If it’s the latter, the effort could be a complete whiff.

# creates list of nested data.frames
obj_json <- fromJSON(content_json)


# api_message <- obj_json$header$status$message


# flatten creates a df; some cols have ".$t" in their names; more heavily weights pets that have been in shelter longer so those pets get more greater opportunity to be seen
pet_df <- flatten(obj_json$petfinder$pets$pet) %>%
      rename_at(vars(ends_with(".$t")), ~str_replace(., "\\.\\$t", "")) %>%
      mutate(lastUpdate = as.POSIXct(lastUpdate),
             link = paste0("https://www.petfinder.com/petdetail/", id),
             sex = recode(sex, "F" = "Female", "M" = "Male"),
             size = recode(size, "L" = "Large", "S" = "Small",
                           "M" = "Medium", "XL" = "Extra Large"),
             status = recode(status, "A" = "Adoptable", "H" = "Hold",
                             "P" = "Pending", "X" = "Adopted/Removed"),
             name = lettercase::str_title_case(tolower(name)),
             elapsedTime = round(Sys.time() - lastUpdate, 0),
             rank = rank(elapsedTime)
      ) %>%  
      mutate(weights = portfolio::weight(., in.var = "rank", type = "linear", sides = "long", size = "all")) %>% 
      sample_n(size = 1, weight = weights)


glimpse(pet_df)

## Observations: 1
## Variables: 26
## $ options.option     <chr> "altered"
## $ status             <chr> "Adoptable"
## $ contact.phone      <chr> "(502) 473-7387"
## $ contact.state      <chr> "KY"
## $ contact.address2   <chr> "3705 Manslick Road Intake Facility"
## $ contact.email      <chr> "AnimalServicesAdoption@louisvilleky.gov"
## $ contact.city       <chr> "Louisville"
## $ contact.zip        <chr> "40218"
## $ contact.address1   <chr> "3516 Newburg Road Adoption Center"
## $ age                <chr> "Senior"
## $ size               <chr> "Medium"
## $ media.photos.photo <list> [<c("pnt", "fpm", "x", "pn", "t"), c("http...
## $ id                 <chr> "41246124"
## $ shelterPetId       <chr> "A637255"
## $ breeds.breed       <list> [["Beagle"]]
## $ name               <chr> "Willy"
## $ sex                <chr> "Male"
## $ description        <chr> NA
## $ mix                <chr> "no"
## $ shelterId          <chr> "KY102"
## $ lastUpdate         <dttm> 2018-03-23
## $ animal             <chr> "Dog"
## $ link               <chr> "https://www.petfinder.com/petdetail/41246124"
## $ elapsedTime        <time> 45 days
## $ rank               <dbl> 99.5
## $ weights            <dbl> 0.01230349

Looking at the columns in pet_df, you can see some of the classes are lists and potentially need unnesting. options.option can have values that give information about whether the pet has been neutered (“altered”), housebroken, good with other animals, etc.. breeds.breed can have multiple values if the animal is mixed breed.

Since unnesting these columns can result in different numbers of rows, the unnesting needs to occur in different code chunks. Also, the column names depend upon whether the column is a nested list or not. For example, if breeds.breed is nested, there will be a $t appended to column name. As long as these columns are non-NA, they’re added to bot_df which will be the primary dataframe we’ll use to create the tweet.

# Dataframe to add columns to
bot_df <- pet_df %>% 
      select(`pet type` = animal, age, sex, size, link)

# Different colnames depending on nrows unnested

if(!is.na(pet_df$options.option)) {
      pet_options <- pet_df %>% 
            select(options.option) %>% 
            unnest %>% 
            rename_at(vars(matches("\\$t")), ~str_replace(., "\\$t", "options")) %>%
            rename_at(vars(matches("options.option")), ~str_replace(., "options.option", "options")) %>% 
            summarize(misc = glue::collapse(options, sep = ", "))
      
      bot_df <- bot_df %>% 
            bind_cols(pet_options) %>% 
            select(`pet type`, misc, everything())
}

if(!is.na(pet_df$breeds.breed)) {
      pet_breeds <- pet_df %>% 
            select(breeds.breed) %>% 
            unnest %>% 
            rename_at(vars(matches("\\$t")), ~str_replace(., "\\$t", "breeds")) %>%
            rename_at(vars(matches("breeds.breed")), ~str_replace(., "breeds.breed", "breeds")) %>% 
            summarize(`breed(s)` = glue::collapse(breeds, sep = ", "))
      
      bot_df <- bot_df %>% 
            bind_cols(pet_breeds) %>% 
            select(`pet type`, `breed(s)`, everything())
}

glimpse(bot_df)

## Observations: 1
## Variables: 7
## $ `pet type` <chr> "Dog"
## $ `breed(s)` <chr> "Beagle"
## $ misc       <chr> "altered"
## $ age        <chr> "Senior"
## $ sex        <chr> "Male"
## $ size       <chr> "Medium"
## $ link       <chr> "https://www.petfinder.com/petdetail/41246124"

select_if keeps columns without values out of our message template, so the tweet doesn’t display a “NA” when a column is vacant. On a side note, I have really started to love these special-case dplyr functions (-if, -at, -all). They’ve become such mental energy savers for me. I recommend you have Suzan Baert’s indispensable dplyr tutorial series bookmarked because there are some syntax quirks when using these functions that I don’t find completely intuitive.

I had never worked with glue before this project, but wow, what a cool package. Here, I’ve layered two different templates by collapsing the first template, adding another column, and using glue_data again to create my final message. If you’re unfamiliar with the package, there are two similar functions, glue and glue_data. The only difference being that glue_data looks for variables in its first argument instead of the calling environment. So for example, glue_data won’t pay attention to any name variable defined outside of my pipeline, because bot_df is its first argument.

Also, you should be aware that Petfinder.com requires including “Powered by Petfinder.com” in your app. It’s a small price to pay in order to help some pets find good homes.

message <- bot_df %>% 
      select_if(~!is.na(.)) %>% 
      gather %>% 
      mutate(spec = glue::glue_data(., "
                                    {key}: {value}
                                    ")) %>% 
      summarize(spec = glue::collapse(spec, sep = "\n")) %>% 
      add_column(name = pet_df$name) %>% 
      mutate(message = glue::glue_data(., "
                                  {name} is:
                                  {spec}
                                  #adoptdontshop #rescue #adoptme #shelterpets
                                  Powered by Petfinder.com
                                  ")) %>% 
      select(message)

head(message)

##                                                                                                                                                                                                                       message
## 1 Willy is:\npet type: Dog\nbreed(s): Beagle\nmisc: altered\nage: Senior\nsex: Male\nsize: Medium\nlink: https://www.petfinder.com/petdetail/41246124\n#adoptdontshop #rescue #adoptme #shelterpets\nPowered by Petfinder.com

You can’t have a pet app and not have an oversized image that unleashes all the cuteness. Gotta tug on those heart strings. Unfortunately, Twitter doesn’t display images from an image link, so we’re going to have to jump through some hoops. Twitter does permit image files to be uploaded, and one of our columns has links to pictures with varying resolutions. We pull the image into our environment from the URL and write it to a temporary file on our disk that will be fed to post_tweet later.

# Some images are blurry on Twitter, but row 3 seems to work alright

if(is.null(pet_df$media.photos.photo[[1]])) {
      # Default photo if no photo is provided
      img_url <- "http://www.dogsinpictures.com/images/dog-cat-bunny-bird-love.jpg"
      image_obj <- magick::image_read(img_url)
      tmp <- tempfile(fileext=".jpg")
      magick::image_write(image_obj, path = tmp, format = "jpg")
}else{
      img_df <- pet_df %>%
            select(media.photos.photo) %>%
            unnest %>%
            slice(3)
      img_url <- img_df$`$t`[[1]]
      
      image_obj <- magick::image_read(img_url)
      tmp <- tempfile(fileext=".jpg")
      magick::image_write(image_obj, path = tmp, format = "jpg")
}

Tweet and automate

We’re set to tweet!

post_tweet(message[[1]], media = tmp)

Louise is:
pet type: Dog
breed(s): Pit Bull Terrier
misc: altered
age: Adult
sex: Female
size: Medium
link: https://t.co/4h99GrVaMJ #adoptdontshop #rescue #adoptme #shelterpets
Powered by https://t.co/T0HSpQ8toe pic.twitter.com/ojgz1JwK42
— Eric (@erbo_exp_bot) April 30, 2018

To be a bot though, it needs to be automated. One way to accomplish this is to set up Windows Task Scheduler. You can create the task through the program itself. In that case, I recommend you check out the bottom of McCann’s post on RPubs. I used the taskscheduleR package which I preferred because of the log file it creates. Task Scheduler has a history tab and a log but it doesn’t show you any useful information if an error is thrown. If you do use taskscheduleR and its add-in, make sure the date format matches your computer’s.

Once your task is initiated. I recommend setting a few options in Task Scheduler. In your task’s general tab, you want to make sure the “run with highest privileges” box is ticked. Otherwise, the UAC box pops-up everytime the task runs. Also, tick “Run whether user is logged on or not” and (if necessary) “do not store password…”. Ticking those boxes will make it so the task runs in the background and doesn’t open a window. There are some other settings worth considering, so you should do some investigating on your own. Also, make sure Rscript.exe has high enough permissions. I gave mine “full control”, but it may not need to be that high.

Lastly, you have to read-in the token and point to it explicitly in post_tweet. Otherwise, for some reason, when the script is executed, lines get written to your .Renviron and bogus copies of your token file are created.

twitter_token <- read_rds("<home directory>twitter_token.rds")

post_tweet(message[[1]], media = tmp, token = twitter_token)

file.remove(tmp)

Session info

Session info --------------------------------------------------------------------------------------------------------
 setting  value                       
 version  R version 3.5.0 (2018-04-23)
 system   i386, mingw32               
 ui       RStudio (1.1.423)           
 language (EN)                        
 collate  English_United States.1252  
 tz       America/New_York            
 date     2018-05-03                  

Packages ------------------------------------------------------------------------------------------------------------
 package    * version date       source        
 assertthat   0.2.0   2017-04-11 CRAN (R 3.5.0)
 base       * 3.5.0   2018-04-23 local         
 bindr        0.1.1   2018-03-13 CRAN (R 3.5.0)
 bindrcpp   * 0.2.2   2018-03-29 CRAN (R 3.5.0)
 broom        0.4.4   2018-03-29 CRAN (R 3.5.0)
 cellranger   1.1.0   2016-07-27 CRAN (R 3.5.0)
 cli          1.0.0   2017-11-05 CRAN (R 3.5.0)
 colorspace   1.3-2   2016-12-14 CRAN (R 3.5.0)
 compiler     3.5.0   2018-04-23 local         
 crayon       1.3.4   2017-09-16 CRAN (R 3.5.0)
 curl         3.2     2018-03-28 CRAN (R 3.5.0)
 datasets   * 3.5.0   2018-04-23 local         
 devtools     1.13.5  2018-02-18 CRAN (R 3.5.0)
 digest       0.6.15  2018-01-28 CRAN (R 3.5.0)
 dplyr      * 0.7.4   2017-09-28 CRAN (R 3.5.0)
 forcats    * 0.3.0   2018-02-19 CRAN (R 3.5.0)
 foreign      0.8-70  2017-11-28 CRAN (R 3.5.0)
 ggplot2    * 2.2.1   2016-12-30 CRAN (R 3.5.0)
 glue         1.2.0   2017-10-29 CRAN (R 3.5.0)
 graphics   * 3.5.0   2018-04-23 local         
 grDevices  * 3.5.0   2018-04-23 local         
 grid         3.5.0   2018-04-23 local         
 gtable       0.2.0   2016-02-26 CRAN (R 3.5.0)
 haven        1.1.1   2018-01-18 CRAN (R 3.5.0)
 hms          0.4.2   2018-03-10 CRAN (R 3.5.0)
 httr       * 1.3.1   2017-08-20 CRAN (R 3.5.0)
 jsonlite   * 1.5     2017-06-01 CRAN (R 3.5.0)
 knitr        1.20    2018-02-20 CRAN (R 3.5.0)
 lattice      0.20-35 2017-03-25 CRAN (R 3.5.0)
 lazyeval     0.2.1   2017-10-29 CRAN (R 3.5.0)
 lettercase   0.13.1  2016-03-03 CRAN (R 3.5.0)
 lubridate    1.7.4   2018-04-11 CRAN (R 3.5.0)
 magick       1.8     2018-03-19 CRAN (R 3.5.0)
 magrittr     1.5     2014-11-22 CRAN (R 3.5.0)
 memoise      1.1.0   2017-04-21 CRAN (R 3.5.0)
 methods    * 3.5.0   2018-04-23 local         
 mime         0.5     2016-07-07 CRAN (R 3.5.0)
 mnormt       1.5-5   2016-10-15 CRAN (R 3.5.0)
 modelr       0.1.1   2017-07-24 CRAN (R 3.5.0)
 munsell      0.4.3   2016-02-13 CRAN (R 3.5.0)
 nlme         3.1-137 2018-04-07 CRAN (R 3.5.0)
 openssl      1.0.1   2018-03-03 CRAN (R 3.5.0)
 parallel     3.5.0   2018-04-23 local         
 pillar       1.2.1   2018-02-27 CRAN (R 3.5.0)
 pkgconfig    2.0.1   2017-03-21 CRAN (R 3.5.0)
 plyr         1.8.4   2016-06-08 CRAN (R 3.5.0)
 portfolio    0.4-7   2015-01-29 CRAN (R 3.5.0)
 psych        1.8.3.3 2018-03-30 CRAN (R 3.5.0)
 purrr      * 0.2.4   2017-10-18 CRAN (R 3.5.0)
 R6           2.2.2   2017-06-17 CRAN (R 3.5.0)
 Rcpp         0.12.16 2018-03-13 CRAN (R 3.5.0)
 readr      * 1.1.1   2017-05-16 CRAN (R 3.5.0)
 readxl       1.1.0   2018-04-20 CRAN (R 3.5.0)
 reshape2     1.4.3   2017-12-11 CRAN (R 3.5.0)
 rlang        0.2.0   2018-02-20 CRAN (R 3.5.0)
 rstudioapi   0.7     2017-09-07 CRAN (R 3.5.0)
 rtweet     * 0.6.0   2017-11-16 CRAN (R 3.5.0)
 rvest        0.3.2   2016-06-17 CRAN (R 3.5.0)
 scales       0.5.0   2017-08-24 CRAN (R 3.5.0)
 stats      * 3.5.0   2018-04-23 local         
 stringi      1.1.7   2018-03-12 CRAN (R 3.5.0)
 stringr    * 1.3.0   2018-02-19 CRAN (R 3.5.0)
 tibble     * 1.4.2   2018-01-22 CRAN (R 3.5.0)
 tidyr      * 0.8.0   2018-01-29 CRAN (R 3.5.0)
 tidyselect   0.2.4   2018-02-26 CRAN (R 3.5.0)
 tidyverse  * 1.2.1   2017-11-14 CRAN (R 3.5.0)
 tools        3.5.0   2018-04-23 local         
 utils      * 3.5.0   2018-04-23 local         
 withr        2.1.2   2018-03-15 CRAN (R 3.5.0)
 xml2         1.2.0   2018-01-24 CRAN (R 3.5.0)
 yaml         2.1.18  2018-03-08 CRAN (R 3.5.0)

Next Steps

This method should work fine if you’re hosting on a local machine, but for cloud-based hosting, the parts where we write/read the image and token to/from disk may have to be changed so these things are stored in memory. With the current rtweet package, I don’t think the solution is straight-forward. I haven’t delved into it too deeply, but one problem is the image input for post_tweet is limited to a “path”. I did do a cursory examination of the post_tweet function and I think it can modified without too much trouble to accept an image object that’s stored in memory.

As for the token portion of issue, I haven’t looked into it at all. The twitteR package is scheduled for a “leisurely deprecation”, and from my memory of a few articles that used that package, I think there might be some code in there could help. It’s just a hunch though. If anyone finds a solution, I’d be very interested.

Acknowledgements

Thanks to Steve Charlesworth for taking the time to answer some questions regarding his bot.

Thanks to Matthew Gotth-Olsen for liaising with Louisville Metro Animal Services

Special Thanks to

Louisville RStats

References

[1] C. Boettiger. knitcitations: Citations for ‘Knitr’ Markdown Files. R package version 1.0.8. 2017. URL: https://CRAN.R-project.org/package=knitcitations.

[2] C. Brown. lettercase: Utilities for Formatting Strings with Consistent Capitalization, Word Breaks and White Space. R package version 0.13.1. 2016. URL: https://CRAN.R-project.org/package=lettercase.

[3] c, e. =. “jwijffels@bnosac.be";), person and person)). taskscheduleR: Schedule R Scripts and Processes with the Windows Task Scheduler. R package version 1.1. 2017. URL: https://CRAN.R-project.org/package=taskscheduleR.

[4] J. Hester. glue: Interpreted String Literals. R package version 1.2.0. 2017. URL: https://CRAN.R-project.org/package=glue.

[5] M. W. Kearney. rtweet: Collecting Twitter Data. R package version 0.6.0. 2017. URL: https://cran.r-project.org/package=rtweet.

[6] J. Ooms. magick: Advanced Graphics and Image-Processing in R. R package version 1.8. 2018. URL: https://CRAN.R-project.org/package=magick.

[7] J. Ooms. “The jsonlite Package: A Practical and Consistent Mapping Between JSON Data and R Objects”. In: arXiv:1403.2805 [stat.CO] (2014). URL: https://arxiv.org/abs/1403.2805.

[8] H. Wickham. httr: Tools for Working with URLs and HTTP. R package version 1.3.1. 2017. URL: https://CRAN.R-project.org/package=httr.

[9] H. Wickham. tidyverse: Easily Install and Load the ‘Tidyverse’. R package version 1.2.1. 2017. URL: https://CRAN.R-project.org/package=tidyverse.

A Baseball Dashboard in Time for Opening Weekend (part three)

Fri, 23 Mar 2018 00:00:00 +0000

@ctrent I’ve always thought that it’d be fun to debate the @Reds HOF like the real one. Set a high , but debatable, bar. Bring on the JAWS
— Craig Wales (@C_Dubs1) August 22, 2017

it would be interesting, I don't have the math or computer skills to do so https://t.co/p5n9O5NjGT
— C. Trent Rosecrans (@ctrent) August 22, 2017

In part one, we collected the data and performed a little EDA. In part two, we did some calculations and prepared the data to be visualized. Now, we get to see the fruits of our labor. You’ll need these objects from part two: display_table, jaws_group, war_group, and war_combo_avg.

DataTable

RStudio and DataTable have excellent documentation on the various features, so I won’t explain every option I’ve enabled here. I will bring to your attention to a few things though.

If you decide to include CSV and PDF buttons, I recommend you also include the “Show entries” feature. It’s activated by default but I’ve turned it off here with lengthChange = FALSE. When a user downloads data using either of these buttons, only the data that is displayed is downloaded, so allowing the user to be able to choose how many rows are displayed is a good option. The problem is the default position (“lfrtip”) is in the header which now is crowded with buttons and the search window. The dom option allows you to configure the location of control elements by specifying the element order. “l” represents the “entries” feature. This order places it in the bottom left corner of the table. In my opinion this is the most display-friendly location.

I also consider the horizontal scrolling option a necessity. There’s an extension Responsive that’s supposed to make your table mobile-friendly but I’ve found it to be buggy. It sometimes creates edge effects that make your columns unreadable. The stable option is to enable horizontal scrolling by setting scrollX = TRUE (capital X).

You’ll also notice the javascript at the bottom. This allows you to change the background and text color of the header. If you want to match the colors of the visuals to a particular team, teamcolorcodes.com or codeofcolors.com provides color codes to all MLB teams and other sports teams as well.

library(DT)

dt <- datatable(data = display_table,
          rownames = FALSE,
          extensions = c("FixedColumns","Buttons"),
          options = list(language = list(sSearch = "Filter:"),
                         search = list(regex = TRUE),
                         buttons = c("colvis", "csv", "pdf"),
                         scrollX = TRUE,
                         pageLength = 3,
                         lengthChange = FALSE,
                         fixedColumns = list(leftColumns = 1),
                         dom = "Bfrtlip",
                         initComplete = JS(
                               "function(settings, json) {",
                               "$(this.api().table().header()).css({'background-color': '#C6011F', 'color': '#FFF'});",
                               "}"
                         ))
)

Cleveland Dot Plots

Dot plots are the old-new hotness as an alternative to bar charts according to my twitter feed, so I thought I’d give them a look. I used this article from University of Cincinnati Stats (coincidence or destiny?) site to guide me.

There will be two dot plots for the dashboard, but I’m only showing one here. The main issues I had were the legend placement and the value labels. If you have (or don’t have) large spreads between some players and the “typical HOF’er”, you’ll want to play with the limits in scale_x_continuous. If the legend gives you problems, I’d look at legend.position and maybe legend.direction.

library(tidyverse)

head(war_group, 3)

## # A tibble: 3 x 4
##   Name         Group Stat  Value
##   <chr>        <chr> <chr> <dbl>
## 1 Aaron Boone  3B    WAR    11.6
## 2 Adam Dunn    LF    WAR    16.4
## 3 Barry Larkin SS    WAR    70.2

war_dot <- war_group %>% 
      filter(Name == "Adam Dunn")


war_right_label <- war_dot %>% 
      group_by(Group) %>% 
      arrange(desc(Value)) %>% 
      top_n(1)

war_left_label <- war_dot %>% 
      group_by(Group) %>% 
      arrange(desc(Value)) %>% 
      slice(2)

ggplot(war_dot, aes(x = Value, y = Group)) +
      geom_line(aes(group = Group)) +
      geom_point(aes(color = Stat), size = 3) +
      geom_text(data = war_right_label, aes(color = Stat, label = round(Value, 1)), size = 5, hjust = -0.5) +
      geom_text(data = war_left_label, aes(color = Stat, label = round(Value, 1)), size = 5, hjust = 1.5) +
      scale_x_continuous(limits = c(min(war_dot$Value)-30, max(war_dot$Value)+28)) + 
      scale_color_manual(labels = c("Typical HOFer (weighted)", "Player"), values = c("#000000", "#C6011F")) +
      labs(title = "WARtenure") +
      theme_minimal() +
      theme(axis.title = element_blank(),
            panel.grid.major.x = element_blank(),
            panel.grid.minor = element_blank(),
            legend.title = element_blank(),
            legend.justification = c(0,1),
            legend.position = c(.1, 1),
            legend.background = element_blank(),
            legend.direction = "vertical",
            plot.title = element_text(size = 20, margin = margin(b = 10))
      )

Interactive Line Chart

The line chart shows the player’s WAR for every season he was a Red. Hovering over each point displays its value. The horizontal dashed line is one of two values: the median WAR per season of pitchers or the median WAR per season of position players.

library(ggiraph)

head(war_combo_avg, 3)

## # A tibble: 3 x 7
##   bbref_id  Name       yearId    WAR POS   type  `Median WAR`
##   <chr>     <chr>       <int>  <dbl> <chr> <chr>        <dbl>
## 1 luquedo01 Dolf Luque   1918 -0.140 P     WAR           2.38
## 2 luquedo01 Dolf Luque   1919  1.14  P     WAR           2.38
## 3 luquedo01 Dolf Luque   1922  3.10  P     WAR           2.38

war_line <- war_combo_avg %>% 
      filter(Name == "Johnny Bench")

line_filtered <- war_line %>% 
      filter(type == "WAR4")

p <- ggplot(data = war_line) + 
      geom_point_interactive(aes(x = yearId, y = WAR, group = type, tooltip = WAR), color = alpha("#000000", 0.5)) +
      geom_point_interactive(data = line_filtered, aes(x = yearId, y = WAR, color = type, tooltip = WAR), size = 2.5, shape = 17) +
      geom_line(aes(x = yearId, y = WAR)) +
      # all the Median WAR values the same, taking mean is just me hacking to get a value instead of a vector for the y-intercept
      geom_hline(aes(yintercept = mean(`Median WAR`), linetype = "Typical HOFer"), color = alpha("#C6011F", 0.5), size = 1.25) +
      scale_linetype_manual(values = 2, guide = guide_legend(override.aes = list(color = "#C6011F"))) +
      scale_y_continuous(limits = c(min(war_line$WAR)-5, max(war_line$WAR)+5)) +
      labs(title = "WAR") +
      theme_minimal() +
      theme(axis.title = element_blank(),
            panel.grid.major.x = element_blank(),
            panel.grid.minor = element_blank(),
            legend.title = element_blank(),
            legend.justification = c(0,1),
            legend.position = c(.1, 1),
            legend.box = "horizontal",
            legend.background = element_blank(),
            legend.direction = "horizontal",
            plot.title = element_text(size = 20, margin = margin(b = 10))
      )

ggiraph(ggobj = p)

Dashboard

I won’t be going over the shinydashboard code in detail but you can check it out on your own, here. There is some html I’d like to highlight though.

dashBody <- dashboardBody(
      # Changes color of header
      tags$head(
            tags$style(HTML('
                            /* Changes color of title portion of header */
                            .skin-blue .main-header .logo {
                            background-color: #C6011F;
                            }
                            
                            .skin-blue .main-header .logo:hover {
                            background-color: #C6011F;
                            }
                            
                            /* Changes color of rest of header */
                            .skin-blue .main-header .navbar {
                            background-color: #C6011F;
                            }
                            
                            /* Changes color of sidebar toggle when hovered */
                            .skin-blue .main-header .navbar .sidebar-toggle:hover{
                            background-color: #000000;
                            }
                            
                            '))
            
            ),

Placing this HTML at the beginning of dashboardBody will allow you to choose the colors of various elements of the header.

# Stops errors being displayed in plot windows
      tags$style(type="text/css",
                 ".shiny-output-error { visibility: hidden; }",
                 ".shiny-output-error:before { visibility: hidden; }"
      ),

Normally, while the dashboard is waiting for user input, an error will be displayed in place of the charts. Placing this code at the beginning of dashboardBody will hide this error. The code should be on the same level as tags$head( above.

Without further ado, here’s the final product…

(Due to my website’s sidebar, the dashboard will probably appear stacked. Here’s a link to the dashboard that should display full-screen.)

Conclusion

This dashboard is actually only one item in a more tricked-out version that I finished a few weeks ago. If you’d like to take this even further, you can see my other dashboard here and the code is on my github. The processing scripts are a little rough, so be prepared. It was a learning experience 😊. Hopefully, I’ll get around to making them more presentable this fall.

This project combined two loves of mine: baseball and r – which I really enjoyed. There wasn’t any complex modeling but it really challenged me in ways I didn’t think it would. The visual design decisions were more difficult than I anticipated, and it also allowed me to level-up in purrr and tidyeval. Hope you enjoyed it.

References

[1] C. Boettiger. knitcitations: Citations for ‘Knitr’ Markdown Files. R package version 1.0.8. 2017. URL: https://CRAN.R-project.org/package=knitcitations.

[2] W. Chang and B. Borges Ribeiro. shinydashboard: Create Dashboards with ‘Shiny’. R package version 0.6.1. 2017. URL: https://CRAN.R-project.org/package=shinydashboard.

[3] D. Gohel. ggiraph: Make ‘ggplot2’ Graphics Interactive. R package version 0.4.2. 2017. URL: https://CRAN.R-project.org/package=ggiraph.

[4] B. Karambelkar. widgetframe: ‘Htmlwidgets’ in Responsive ‘iframes’. https://github.com/bhaskarvk/widgetframe, https://bhaskarvk.github.io/widgetframe/. 2018.

[5] H. Wickham. tidyverse: Easily Install and Load the ‘Tidyverse’. R package version 1.2.1. 2017. URL: https://CRAN.R-project.org/package=tidyverse.

[6] Y. Xie. DT: A Wrapper of the JavaScript Library ‘DataTables’. R package version 0.4. 2018. URL: https://rstudio.github.io/DT.

A Baseball Dashboard in Time for Opening Weekend (part two)

Wed, 21 Mar 2018 00:00:00 +0000

@ctrent I’ve always thought that it’d be fun to debate the @Reds HOF like the real one. Set a high , but debatable, bar. Bring on the JAWS
— Craig Wales (@C_Dubs1) August 22, 2017

it would be interesting, I don't have the math or computer skills to do so https://t.co/p5n9O5NjGT
— C. Trent Rosecrans (@ctrent) August 22, 2017

In part one, we got the player WAR values, primary positions, and determined the tenure qualification. In part two, we’ll perform the JAWS calculations and create dataframes that will be needed for our dashboard. Recall that for these calculations, you’ll need indWar, nomWar, posDat, and warDat from part one.

JAWS Calculation

To compute the JAWS values, we’ll take the average of the sum of the top four WAR values and the sum of the WAR accrued while playing for the Reds

library(tidyverse)

# total WAR during Reds tenure
warSum <- warDat %>%
      group_by(playerId) %>%
      summarize(WARtenure = sum(rWAR)) %>% 
      ungroup()

# Sum of top 4 WAR years
war4Dat <- warDat %>%
      group_by(playerId) %>%
      top_n(4, rWAR) %>%
      tally(rWAR) %>%
      rename(WAR4 = n)

# Calculating JAWS
warJaws <- warSum %>% 
      inner_join(war4Dat, by = 'playerId') %>% 
      mutate(JAWS4 = round((WARtenure + WAR4)/2, 2)) %>% 
      select(playerId, WARtenure, WAR4, JAWS4)

# Add Names and Positions to dataframe
names <- warDat %>% 
      select(playerId, Name) %>% 
      distinct()

warJaws <- warJaws %>%
      inner_join(posDat, by = 'playerId') %>% 
      inner_join(names, by = 'playerId') %>% 
      select(playerId, Name, POS, everything())


head(warJaws, 3)

## # A tibble: 3 x 6
##   playerId  Name         POS   WARtenure  WAR4 JAWS4
##   <chr>     <chr>        <chr>     <dbl> <dbl> <dbl>
## 1 becklja01 Jake Beckley 1B         23.5  16.5  20.0
## 2 bellgu01  Gus Bell     CF         13.0  12.4  12.7
## 3 benchjo01 Johnny Bench C          75.0  30.4  52.7

Weighting Positions and Averages

The number of players at each non-pitcher position differs quite a bit and will skew our averages, so we’ll add “average” Hall of Fame players to each position pool to reduce the bias. Pitchers aren’t compared to positional players statistically so there will be two sets of average calculations. They also aren’t subdivided into Starting and Relief so there will be no need to add “average” players to their pool.

# Only want inductees in our average calculation
indJaws <- warJaws %>% 
      anti_join(nomWar, by = 'playerId')

batJaws <- indJaws %>%
      select(-playerId) %>% 
      filter(POS != "P")

# 1B and CF are highest with 10 members a piece so they won't need filler players
table(batJaws$POS)

## 
## 1B 2B 3B  C CF LF RF SS 
## 10  7  2  4 10  5  5  6

First base and Center Field have the most players so we’ll add “average” players to the other position pools until the amounts are equal.

# Number of filler players needed at each position
neededPOS <- batJaws %>%
      group_by(POS) %>%
      summarize(n = n()) %>% 
      mutate(remPOS = max(n) - n) %>%
      filter(POS != "1B", POS != "CF") %>%
      select(-n)

# List of lists with filler position amounts
posLL <- map2(neededPOS$POS, neededPOS$remPOS, function(POS, n) {
      POS <- rep(POS, n)
})

# Create tibble with all the filler players for each position

# Empty tibble
posFillTib <- tibble(
      Name = character(),
      POS = character(),
      WARtenure = numeric(),
      WAR4 = numeric(),
      JAWS4 = numeric()
      
)

# input: Position; function creates one filler player with avgHOF stats
fillPOS <- function(POS) {
      posFillTib <- posFillTib %>%
            add_row(Name = "avgHOFplayer",
                    POS = POS,
                    WARtenure = median(batJaws$WARtenure),
                    WAR4 = median(batJaws$WAR4),
                    JAWS4 = median(batJaws$JAWS4)
                    
            )
}
# List of lists fed to function; outputs tibble of filler players
fillerPlayers <- map_dfr(posLL, fillPOS)

# Creating weighted distribution of position players
wtBatDistr <- batJaws %>%
      bind_rows(fillerPlayers)

head(wtBatDistr, 3)

## # A tibble: 3 x 5
##   Name         POS   WARtenure  WAR4 JAWS4
##   <chr>        <chr>     <dbl> <dbl> <dbl>
## 1 Jake Beckley 1B         23.5  16.5  20.0
## 2 Gus Bell     CF         13.0  12.4  12.7
## 3 Johnny Bench C          75.0  30.4  52.7

We can now calculate the averages using some cool, nested purrr::map action.

# Calculate weighted averages at each position
wbd_nested <- wtBatDistr %>% 
      group_by(POS) %>% 
      nest()

wt_avg_FUN <- function(df) {
      mutate(df, `Wt Avg WAR` = round(mean(WARtenure), 1),
             `Wt Avg WAR4` = round(mean(WAR4), 1),
             `Wt Avg JAWS4` = round(mean(JAWS4), 1))
}

wbd_avgs <- wbd_nested %>% 
      mutate(stats = map(data, wt_avg_FUN)) %>% 
      select(POS, stats) %>% 
      unnest() %>% 
      select(Name, POS, everything()) %>% 
      filter(Name != "avgHOFplayer")

head(wbd_avgs, 3)

## # A tibble: 3 x 8
##   Name          POS   WARtenure  WAR4 JAWS4 `Wt Avg WAR` `Wt Avg WAR4`
##   <chr>         <chr>     <dbl> <dbl> <dbl>        <dbl>         <dbl>
## 1 Jake Beckley  1B        23.5  16.5  20.0          22.3          15.4
## 2 Sean Casey    1B        16.6  13.3  14.9          22.3          15.4
## 3 Gordy Coleman 1B         7.27  7.18  7.23         22.3          15.4
## # ... with 1 more variable: `Wt Avg JAWS4` <dbl>

Create Dataframes for Visuals

DataTable

Our first visual will be a DT datatable with the WAR and JAWS calculations for each player. The positional JAWS and WAR averages we calculated above using only the inductees will be added to the nominee stat lines according to their primary position. Then pitcher averages are figured, and everything is combined into one dataframe.

# Get positional player nominees
nomBatJaws <- warJaws %>% 
      anti_join(indWar, by = 'playerId') %>% 
      filter(POS != "P") %>% 
      select(-playerId)

# Sync averages to nominee positions and combine with inductee averages dataframe
wtBatJaws <- nomBatJaws %>% 
      mutate(`Wt Avg WAR` = plyr::mapvalues(POS, from = wbd_avgs$POS,
                                            to = wbd_avgs$`Wt Avg WAR`) %>% as.numeric(),
             `Wt Avg WAR4` = plyr::mapvalues(POS, from = wbd_avgs$POS,
                                             to = wbd_avgs$`Wt Avg WAR4`) %>% as.numeric(),
             `Wt Avg JAWS4` = plyr::mapvalues(POS, from = wbd_avgs$POS,
                                              to = wbd_avgs$`Wt Avg JAWS4`) %>% as.numeric()) %>% 
      bind_rows(wbd_avgs)


# Pitcher averages
pitJaws <- warJaws %>% 
      anti_join(nomWar, by = 'playerId') %>% 
      select(-playerId) %>% 
      filter(POS == "P") %>%
      mutate(`Wt Avg WAR` = round(mean(WARtenure), 1),
             `Wt Avg WAR4` = round(mean(WAR4), 1),
             `Wt Avg JAWS4` = round(mean(JAWS4), 1))

# Get pitcher Nominees
nomPitJaws <- warJaws %>% 
      anti_join(indWar, by = 'playerId') %>% 
      filter(POS == "P") %>% 
      select(-playerId)

# Sync (pitcher pool not actually weighted)
wtPitJaws <- nomPitJaws %>% 
      mutate(`Wt Avg WAR` = plyr::mapvalues(POS, from = pitJaws$POS,
                                            to = pitJaws$`Wt Avg WAR`) %>% as.numeric(),
             `Wt Avg WAR4` = plyr::mapvalues(POS, from = pitJaws$POS,
                                             to = pitJaws$`Wt Avg WAR4`) %>% as.numeric(),
             `Wt Avg JAWS4` = plyr::mapvalues(POS, from = pitJaws$POS, to = pitJaws$`Wt Avg JAWS4`) %>% as.numeric()) %>% 
      bind_rows(pitJaws)


display_table <- wtBatJaws %>% 
      bind_rows(wtPitJaws) %>% 
      arrange(Name)

head(display_table, 3)

## # A tibble: 3 x 8
##   Name         POS   WARtenure  WAR4 JAWS4 `Wt Avg WAR` `Wt Avg WAR4`
##   <chr>        <chr>     <dbl> <dbl> <dbl>        <dbl>         <dbl>
## 1 Aaron Boone  3B         11.6  10.0  10.8         20.4          14.9
## 2 Adam Dunn    LF         16.4  11.9  14.2         29.0          16.6
## 3 Barry Larkin SS         70.2  26.2  48.2         23.5          14.2
## # ... with 1 more variable: `Wt Avg JAWS4` <dbl>

Cleveland Dot Plots

When comparing position players, position to position isn’t the only comparison that can be made. In some situations, it’s more fair to look at wider, positional group statistics. There are five groups that we’ll use: corner infielders, middle infielders, outfielders, corners, and middle. These groups along with the positional JAWS and WAR calculations will be visualized with Cleveland Dot Plots.

# Build df with group positions
cornerIF <- warJaws %>% 
      filter(POS == "1B" | POS == "3B") %>%
      mutate(POS = plyr::mapvalues(POS, from = c("1B", "3B"),
                                   to = c("CI", "CI")))

middleIF <- warJaws %>% 
      filter(POS == "2B" | POS == "SS") %>%
      mutate(POS = plyr::mapvalues(POS, from = c("2B", "SS"),
                                   to = c("MI", "MI")))

outField <- warJaws %>% 
      filter(POS == "LF" | POS == "CF" | POS == "RF") %>%
      mutate(POS = plyr::mapvalues(POS, from = c("LF", "CF", "RF"),
                                   to = c("OF", "OF", "OF")))

corners <- warJaws %>% 
      filter(POS == "1B" | POS == "3B" | POS == "LF" | POS == "RF") %>% 
      mutate(POS = plyr::mapvalues(POS, from = c("1B", "LF", "RF", "3B"),
                                   to = c("CO", "CO", "CO", "CO")))

middle <- warJaws %>% 
      filter(POS == "2B" | POS == "SS" | POS == "C" | POS == "CF") %>% 
      mutate(POS = plyr::mapvalues(POS, from = c("2B", "SS", "C", "CF"),
                                   to = c("Md", "Md", "Md", "Md")))

other_groups <- cornerIF %>% 
      bind_rows(middleIF, outField, corners, middle)


# Calculate averages of each group

other_groups_i <- other_groups %>% 
      anti_join(nomWar, by = 'playerId')

og_nested <- other_groups_i %>% 
      group_by(POS) %>% 
      nest()

avg_FUN <- function(df) {
      mutate(df, WAR_avg = round(mean(WARtenure), 1),
             WAR4_avg = round(mean(WAR4), 1),
             JAWS_avg = round(mean(JAWS4), 1))
}

group_avgs_i <- og_nested %>% 
      mutate(stats = map(data, avg_FUN)) %>% 
      select(POS, stats) %>% 
      unnest() %>% 
      select(playerId, Name, POS, everything())

# Add Nominees

other_groups_n <- other_groups %>% 
      anti_join(indWar, by = 'playerId')

group_avgs <- other_groups_n %>% 
      mutate(WAR_avg = plyr::mapvalues(POS, from = group_avgs_i$POS,
                                       to = group_avgs_i$WAR_avg) %>% as.numeric(),
             WAR4_avg = plyr::mapvalues(POS, from = group_avgs_i$POS,
                                        to = group_avgs_i$WAR4_avg) %>% as.numeric(),
             JAWS_avg = plyr::mapvalues(POS, from = group_avgs_i$POS,
                                        to = group_avgs_i$JAWS_avg) %>% as.numeric()) %>% 
      bind_rows(group_avgs_i)

# Prepare dataframe for JAWS dot chart
dot_table <- display_table %>% 
      rename(JAWS_avg = `Wt Avg JAWS4`, WAR_avg = `Wt Avg WAR`) %>% 
      bind_rows(group_avgs)

jaws_group <- dot_table %>% 
      select(Name, POS, JAWS4, JAWS_avg) %>% 
      rename(Group = POS, `Avg HOF` = JAWS_avg) %>% 
      gather(key = "Stat", value = "Value", -c(Name, Group))

# Prepare dataframe for WAR dot chart
war_group <- dot_table %>% 
      select(Name, POS, WARtenure, WAR_avg) %>% 
      rename(Group = POS, `Avg HOF` = WAR_avg, WAR = WARtenure) %>% 
      gather(key = "Stat", value = "Value", -c(Name, Group))

glimpse(war_group)

## Observations: 368
## Variables: 4
## $ Name  <chr> "Aaron Boone", "Adam Dunn", "Barry Larkin", "Bid McPhee"...
## $ Group <chr> "3B", "LF", "SS", "2B", "SS", "P", "P", "P", "C", "P", "...
## $ Stat  <chr> "WAR", "WAR", "WAR", "WAR", "WAR", "WAR", "WAR", "WAR", ...
## $ Value <dbl> 11.61, 16.44, 70.17, 52.39, 13.55, 29.07, 22.26, 7.43, 1...

Interactive Line Chart

The final visual will be a line graph of player WAR values for each season played with the Reds. We’ll add some emphasis to the four largest WAR values and a horizontal line to indicate a typical Hall of Famer.

# WAR4 + years; add type column
war4Dat <- warDat %>%
      group_by(playerId) %>%
      top_n(4, rWAR) %>% 
      ungroup() %>% 
      select(-teamId) %>% 
      add_column(type = rep("WAR4", 328))

# Not WAR4 + years; add type column
notWar4 <- warDat %>% 
      anti_join(war4Dat, by = c("playerId", "yearId")) %>% 
      select(-teamId) %>% 
      add_column(type = rep("WAR", 427))

war_combined <- notWar4 %>% 
      bind_rows(war4Dat)


#  Positional and Pitcher seasonal average WAR values

pitMedWar <- war_combined %>% 
      filter(POS == "P") %>% 
      summarize(`Median Pitcher WAR` = median(rWAR))

posMedWAR <- war_combined %>% 
      filter(POS != "P") %>% 
      summarize(`Median Position WAR` = median(rWAR))

war_combo_avg <- war_combined %>% 
      mutate(`Median WAR` = if_else(POS == "P",
                                    pitMedWar$`Median Pitcher WAR`[[1]],
                                    posMedWAR$`Median Position WAR`[[1]])) %>% 
      rename(bbref_id = playerId, WAR = rWAR) %>% 
      select(bbref_id, Name, everything())

Save Objects

Only four objects will be required for the final post in this series: display_table, jaws_group, war_group, and war_combo_avg.

Conclusion

In this post, we calculated the JAWS statistic and positional averages that can be used to evaluate nominees and compare members of the Reds Hall of Fame. We also created positional group averages which could come in handy in certain situations such as with players that were more versatile and played multiple positions throughout their career. Lastly, we produced the data sets that will be used in our visuals for part three.

References

[1] C. Boettiger. knitcitations: Citations for ‘Knitr’ Markdown Files. R package version 1.0.8. 2017. URL: https://CRAN.R-project.org/package=knitcitations.

[2] H. Wickham. “The Split-Apply-Combine Strategy for Data Analysis”. In: Journal of Statistical Software 40.1 (2011), pp. 1–29. URL: http://www.jstatsoft.org/v40/i01/.

[3] H. Wickham. tidyverse: Easily Install and Load the ‘Tidyverse’. R package version 1.2.1. 2017. URL: https://CRAN.R-project.org/package=tidyverse.

A Baseball Dashboard in Time for Opening Weekend (part one)

Fri, 09 Mar 2018 00:00:00 +0000

@ctrent I’ve always thought that it’d be fun to debate the @Reds HOF like the real one. Set a high , but debatable, bar. Bring on the JAWS
— Craig Wales (@C_Dubs1) August 22, 2017

it would be interesting, I don't have the math or computer skills to do so https://t.co/p5n9O5NjGT
— C. Trent Rosecrans (@ctrent) August 22, 2017

Baseball fan? ☑️ Math? ☑️ Computers skills? ☑️

It’s always nice when project ideas fall into your lap. Let’s build an dashboard that can be used to evaluate nominees for a franchise’s hall of fame.

JAWS

For the uninitiated, the first thing you need to understand is WAR. WAR attempts to encapsulate a player’s yearly contribution into one statistic. JAWS is calculated by taking the average of a player’s total WAR over their career and the sum of their seven highest WAR values. The JAWS statistic is meant to be a starting point in the discussion of a nominee’s creditials for the Hall of Fame. Jaffe provides a thorough explanation here. There’s also a more succinct description at Baseball-Reference.

The question is can JAWS, whose domain of applicability is the MLB Hall of Fame, be applied to a franchise’s Hall of Fame. Instead of career WAR, we’ll be using only the WAR the player accrued while he played for the Cincinnati Reds. The likely sticking point is the seven year qualification since free agency makes it less likely that players remain with a team for that length of duration. The number of inductees in a franchise hall of fame probably is considerably less than the MLB hall of fame, so the trick will be to chose a tenure long enough to qualify a high percentage of the inductees and still allow JAWS to provide an adequate measure.

Scrape Hall of Fame Inductee Names

First, we need to get the names of the members of the Reds Hall of Fame. There are a few places with this information including the Reds Hall of Fame website, Baseball-Reference, and Wikipedia. None had the information available to download or presented it in a tidy format. Wikipedia is a source that has wide-ranging utility. This is a good opportunity to become familiar with scraping the website.

Honestly, I expected this part to be more of a hassle, but rvest made the process quite painless. Use Google Chrome’s inspect feature to obtain the xpath by scrolling down to the table with the member names, right-clicking on the page, and clicking inspect. In the left panel under the Elements tab, you’ll see HTML code. Hovering over each line will shade an object on the page. Once we find the line of code that corresponds to the table we want, we right-click that line of code, choose copy, and copy xpath.

library(tidyverse)
library(rvest)

url <- "https://en.wikipedia.org/wiki/Cincinnati_Reds_Hall_of_Fame_and_Museum#Cincinnati_Reds_Hall_of_Fame_members"
members <- url %>%
      read_html() %>%
      html_nodes(xpath='//*[@id="mw-content-text"]/div/table[2]') %>%
      html_table()
members <- members[[1]]

glimpse(members)

## Observations: 86
## Variables: 5
## $ Year     <chr> "1958", "1958", "1958", "1958", "1958", "1959", "1959...
## $ No.      <chr> "30", "4", "10", "33", "31", "24", "18", "44, 47", "—...
## $ Inductee <chr> "Paul Derringer", "Ernie Lombardi", "Frank McCormick"...
## $ Position <chr> "P", "C", "1B", "P", "P/3B\nManager", "RF", "P", "P",...
## $ Tenure   <chr> "1933–1942", "1932–1941", "1934–1945", "1937–1943\n19...

Year is the year inducted into the Reds HOF.
No. is the number on the back of player’s jersey.
Inductee is the player’s name.
Position is the positions played.
Tenure is the number of years played as a Red and is formatted as a range

For our calculation, we’ll need Inductee, Position, and Tenure. There are formatting problems with Position and Tenure, but that information can be obtained elsewhere.

There are only six nominees in the 2018 class so we can just copy/paste their information from the announcement: third baseman Aaron Boone (1997-2003), outfielder Adam Dunn (2001-2008), pitcher John Franco (1984-1989),pitcher Danny Graves (1997-2005), third baseman Scott Rolen (2009-2012) and outfielder Reggie Sanders (1991-1998).

WAR Values

To get our WAR values, we’ll utilize two data sets from the openWARData package: idTT (player IDs) and rWAR (Baseball-Reference WAR). Our member names are used to filter the idTT data to get IDs and the IDs to filter the rWAR data to get the WAR values.

library(openWARData)

# Combining first and last names to match the member names we scraped
idTTa <- idTT %>%
      select(key_bbref, name_last, name_first) %>%
      mutate(name_whole = paste(name_first, name_last))

# Missing values come along for the ride so they need removed
indID <- map_dfr(members[,"Inductee"], function(x) {
      filter(idTTa, name_whole == x & key_bbref != "")})

Some players were excluded from indID because in members, they have accent marks in their names. Likewise excluded, a father/son duo who have the same names in idTT but have Sr/Jr suffixes in members. All of these players will be added to indID. Also, administrative personnel were removed during the filtering process, since obviously, they have no WAR values.

missNamList <- list("Dolf Luque", "Leo Cardenas", "Tony Perez", "Dave Concepcion", "Ken Griffey",
                    "Jose Rijo", "Cesar Geronimo", "Pedro Borbon")
indID <- map_dfr(missNamList, function(x) {
      filter(idTTa, name_whole == x & key_bbref != "")}) %>% 
      bind_rows(indID) %>% 
      mutate(name_whole = if_else(key_bbref == "griffke02", "Ken Griffey Jr", name_whole))

Not many people have original names, including baseball players, so we need to remove the extra Pete Rose (Jr.), Joe Morgan, Mike McCormick, Pedro Borbon, and George Wright. Sparky Anderson and Fred Hutchinson were managers so they can be dropped as well.

indID <- filter(indID, key_bbref != "rosepe02" & key_bbref != "morgajo01"
                    & key_bbref != "mccormi03" & key_bbref != "andersp01" 
                    & key_bbref != "wrighge03" & key_bbref != "hutchfr01"
                    & key_bbref != "borbope02"    
                )
glimpse(indID)

## Observations: 81
## Variables: 4
## $ key_bbref  <fct> luquedo01, cardele01, perezto01, conceda01, griffke...
## $ name_last  <fct> Luque, Cardenas, Perez, Concepcion, Griffey, Griffe...
## $ name_first <fct> Dolf, Leo, Tony, Dave, Ken, Ken, Jose, Cesar, Pedro...
## $ name_whole <chr> "Dolf Luque", "Leo Cardenas", "Tony Perez", "Dave C...

Now for the nominees…

nomNamList <- list("Aaron Boone", "Adam Dunn", "John Franco", "Danny Graves", "Scott Rolen",
                   "Reggie Sanders")
nomID <- map_dfr(nomNamList, function(x) {
      filter(idTTa, name_whole == x & key_bbref != "")})

# Snagged an extra Reggie Sanders
nomID <- filter(nomID, key_bbref != "sandere01")

We have IDs for the inductees and nominees, so now we can get those Reds WAR values.

# Inductees
indWar <- map_dfr(as.character(indID$key_bbref), function(x) {
      filter(rWAR, playerId == x)}) %>%
      select(playerId, yearId, teamId, rWAR) %>%
      mutate_if(is.factor, as.character) %>% 
      filter(teamId == "CIN")

# add Name column
indWar <- indID %>% 
      select(name_whole, key_bbref) %>% 
      rename(Name = name_whole, playerId = key_bbref) %>% 
      inner_join(indWar, by = 'playerId')

## Warning: Column `playerId` joining factor and character vector, coercing
## into character vector

# Nominees
nomWar <- map_dfr(as.character(nomID$key_bbref), function(x) {
      filter(rWAR, playerId == x)}) %>%
      select(playerId, yearId, teamId, rWAR) %>%
      mutate_if(is.factor, as.character) %>% 
      filter(teamId == "CIN")

# add Name column
nomWar <- nomID %>% 
      select(name_whole, key_bbref) %>% 
      rename(Name = name_whole, playerId = key_bbref) %>% 
      inner_join(nomWar, by = 'playerId')

## Warning: Column `playerId` joining factor and character vector, coercing
## into character vector

glimpse(indWar)

## Observations: 721
## Variables: 5
## $ Name     <chr> "Dolf Luque", "Dolf Luque", "Dolf Luque", "Dolf Luque...
## $ playerId <chr> "luquedo01", "luquedo01", "luquedo01", "luquedo01", "...
## $ yearId   <int> 1918, 1919, 1920, 1921, 1922, 1923, 1924, 1925, 1926,...
## $ teamId   <chr> "CIN", "CIN", "CIN", "CIN", "CIN", "CIN", "CIN", "CIN...
## $ rWAR     <dbl> -0.14, 1.14, 4.56, 4.96, 3.10, 10.77, 2.55, 6.56, 1.1...

EDA

Tenure

We can next turn our attention to making a decision on our central quandary: how long should our tenure requirement be? If we look at tables of the different values, we can calculate the percentage of players that would remain at each cutoff.

# Inductees
indYrs <- indWar %>%
      group_by(playerId) %>% 
      summarize(tenure = n())
table(indYrs$tenure)

## 
##  2  3  4  5  6  7  8  9 10 11 12 13 15 16 17 18 19 
##  1  2  3  5  6  9 12  8 10  8  6  2  1  1  1  1  3

# Nominees
nomYrs <- nomWar %>%
      group_by(playerId) %>% 
      summarize(tenure = n())
table(nomYrs$tenure)

## 
## 4 6 7 8 9 
## 1 1 1 2 1

Cutoff	% Remaining
7 yrs	67%
6 yrs	78%
5 yrs	86%
4 yrs	92%

Looking at the nominees, it turns out Scott Rolen only played four seasons for the Reds. The goal of this project is to evaluate nominees, so four years would be the necessary cutoff in order for Rolen to be included. If Rolen wasn’t part of this class, I’d consider five years but not above five.

So the inductees that didn’t make the cut were the following: Billy Werber, Bill McKechnie, and Wayne Granger. The Wright boys, George and Harry, also aren’t in there. They played with the Reds prior to 1871 and their WAR wasn’t available. Our final inductee pool has 76 players.

indWar <- filter(indWar, playerId != "grangwa01" & playerId != "mckecbi01"
                     & playerId != "werbebi01" & playerId != "wrighge01"
                     & playerId != "wrighha01")

warDat <- indWar %>% 
      bind_rows(nomWar)

Position

We need to figure out the primary positions for players as they tend to play multiple positions during their career. When comparing JAWS scores between inductees and nominees, it’s usually done by position. So, if we were to examine Scott Rolen’s case, we’d look at his JAWS score and compare it to other Reds third basemen such as Frank Robinson or Chris Sabo.

Jaffe makes this determination by calculating the total WAR at each position and selecting the position with the greatest value. Currently, I can’t find a relatively convenient way to obtain the necessary data to make that calculation. We’ll make our determination by using the Lahman package and its Fielding data set to find the position which has the most games played as a Red.

library(Lahman)

head(Fielding, 3)

##    playerID yearID stint teamID lgID POS  G GS InnOuts PO  A  E DP PB WP
## 1 abercda01   1871     1    TRO   NA  SS  1 NA      NA  1  3  2  0 NA NA
## 2  addybo01   1871     1    RC1   NA  2B 22 NA      NA 67 72 42  5 NA NA
## 3  addybo01   1871     1    RC1   NA  SS  3 NA      NA  8 14  7  0 NA NA
##   SB CS ZR
## 1 NA NA NA
## 2 NA NA NA
## 3 NA NA NA

# Fielding dataset has different designations for 1800's Reds teams: CN1 and CN2.
posDat <- map2_dfr(warDat$playerId, warDat$yearId, function(x,y) {
      filter(Fielding, playerID == x & yearID == y)}) %>% 
      filter(teamID == "CIN" | teamID == "CN1" | teamID == "CN2")

# Getting position with most games as a Red
posDat <- posDat %>%
      select(playerID, POS, G) %>% 
      group_by(playerID, POS) %>% 
      summarize(sumG = sum(G)) %>% 
      filter(sumG == max(sumG)) %>% 
      ungroup() %>% 
      select(playerID, POS)


# Jim O'Toole's Baseball-Reference ID in the Fielding data set is incorrect but he was a pitcher his whole career. Adding him to the df.
setdiff(warDat$playerId, posDat$playerID)

## [1] "o'tooji01"

posDat <- posDat %>% 
      add_row(playerID = "o'tooji01", POS = "P") %>% 
      rename(playerId = playerID)

glimpse(posDat)

## Observations: 82
## Variables: 2
## $ playerId <chr> "becklja01", "bellgu01", "benchjo01", "billija01", "b...
## $ POS      <chr> "1B", "OF", "C", "P", "P", "3B", "P", "OF", "P", "C",...

The outfield position can be further divided into right field, center field, and left field using the Appearances data set in Lahman. It would be desirable to also split the pitching position into relief and starting but unfortunately the Lahman package doesn’t afford us this capability explicitly. I think the information could be derived from the games started statistic and some others but that task will have be left for another time.

head(Appearances, 3)

##   yearID teamID lgID  playerID G_all GS G_batting G_defense G_p G_c G_1b
## 1   1871    TRO   NA abercda01     1 NA         1         1   0   0    0
## 2   1871    RC1   NA  addybo01    25 NA        25        25   0   0    0
## 3   1871    CL1   NA allisar01    29 NA        29        29   0   0    0
##   G_2b G_3b G_ss G_lf G_cf G_rf G_of G_dh G_ph G_pr
## 1    0    0    1    0    0    0    0   NA   NA   NA
## 2   22    0    3    0    0    0    0   NA   NA   NA
## 3    2    0    0    0   29    0   29   NA   NA   NA

# Get outfielder IDs
ofDat <- posDat %>% 
      filter(POS == "OF")

# Get yearId from warDat
ofYears <- map_dfr(ofDat$playerId, function(x) {
      filter(warDat, playerId == x)
})
      
# Number of games played at each OF position for each season
ofSplit <- map2_dfr(ofYears$playerId, ofYears$yearId, function(x,y) {
      filter(Appearances, playerID == x & yearID == y)}) %>% 
      rename(LF = G_lf, CF = G_cf, RF = G_rf) %>% 
      gather('LF', 'CF', 'RF', key = "POS", value = "G")

# Primary outfield position = most games played at that position
splitSum <- ofSplit %>% 
      select(playerID, POS, G) %>%
      rename(playerId = playerID) %>%
      group_by(playerId, POS) %>% 
      summarize(sumG = sum(G)) %>% 
      filter(sumG == max(sumG)) %>% 
      ungroup() %>% 
      select(playerId, POS)

# Replacing "OF" values in posDat
ofPos <- posDat %>% 
      filter(POS == "OF") %>% 
      select(-POS) %>% 
      inner_join(splitSum, by = "playerId")

posDat <- posDat %>% 
      filter(POS != "OF") %>%
      bind_rows(ofPos)

# Add POS column
warDat <- warDat %>% 
      inner_join(posDat, by = 'playerId')

Save Objects

We’ve generated quite a few objects in part one of this series. If you’d like to keep your environment relatively clean, we’ll only need a few of these going into the calculations of part two: indWar, nomWar, posDat, and warDat.

Conclusion

We have the ingredients for the JAWS calculation and our dashboard. In this part, we scraped Wikipedia to get the Hall of Fame members’ names. Those names were used to get Baseball-Reference IDs which in turn were used to obtain WAR values. Next, by examining the data, we determined our tenure qualification, and primary player positions were determined by the greatest number of games played at a position. Next, we’ll perform the calculations in part two and visualize them in a shinydashboard in part three.

References

[1] B. Baumer and G. Matthews. openWARData: Data Associated with openWAR. R package version 0.1.1.9004. 2015. URL: https://github.com/beanumber/openWARData.

[2] M. Friendly. Lahman: Sean ‘Lahman’ Baseball Database. R package version 6.0-0. 2017. URL: https://CRAN.R-project.org/package=Lahman.

[3] H. Wickham. rvest: Easily Harvest (Scrape) Web Pages. R package version 0.3.2. 2016. URL: https://CRAN.R-project.org/package=rvest.

[4] H. Wickham. tidyverse: Easily Install and Load the ‘Tidyverse’. R package version 1.2.1. 2017. URL: https://CRAN.R-project.org/package=tidyverse.

JAWS-4 Dashboard User Guide

Fri, 02 Mar 2018 00:00:00 +0000

Introduction

The purpose of this dashboard is to provide tools to evaluate nominees for the Reds Hall of Fame. Its primary feature is the JAWS-4 statistic. JAWS-4 is a version of Jay Jaffe’s JAWS statistic that’s been modified to apply to a franchise’s Hall of Fame.

The JAWS statistic is meant to be a starting point in the discussion of a nominee’s creditials for the Hall of Fame. Jaffe provides a thorough explanation here. There’s also a more succinct description at Baseball-Reference.

Other features include a Hall of Fame score which relates a player’s statistics to a typical member of the Hall of Fame and player stat ranks and percentiles. Lastly, there are multiple tables to compare players in other categories like the postseason, fielding, and awards.

Controls

For those unfamilar with shinydashboard and DataTables, there are some basic functions you should be aware of.

The toggle button in the header collapses/displays the sidebar.
The column visibility button adds/removes columns from view.
The PDF and CSV buttons download the data from that table in .pdf and .csv format.
1. PDF: If the rows are filtered, then only those rows will be present in the downloaded document. It includes only rows on page 1 of the table. The number of entries per page can be specified at the bottom left corner of many of the tables. Regardless of which columns are visible, all columns will be included up to a maximum of 19 columns.
2. CSV: Only difference from PDF is that there is no column limit. So every column is included regardless of the size of the table.
The filter window uses regex to filter the table. Note: you cannot specify the column to which the search criteria is applied. Examples:
1. bench|rose|Larkin returns rows that correspond to those players – ben|bar|ros will also return those players (along with Ernie Lombardi).
2. 1B|LF selects all rows with positon equal to first base or left field but also returns Dolf Luque.
3. e$ returns players whose names end in “e” like Bid McPhee but not Joe Morgan. b$ can also be used to select all rows with position equal to 1B, 2B, or 3B.
4. ^e returns players’ names that begin with the letter “e” such as Eric Davis
5. ^[ep] returns all players whose name begins with an “e” or a “p” but also returns every pitcher.
6. Numbers may also be used. 3358 will return all rows with that string of numbers in that order.

Features

Home

This page shows the current JAWS median values and weighted median values for each group/position. The ridge plot visualizes the distributions for each group. Please see the links in the introduction for explanations of these values.

JAWS-4

The text input allows the user to select a player. Then dot plots are rendered that show how that player’s total WAR as a Red and his JAWS4 score compare with that of a typical Hall of Famer. The line chart shows the player’s WAR for every year he was a Red. Hovering over each point displays its value. The horizontal dashed line is one of two values: the median WAR per season of pitchers or the median WAR per season of position players. The data table shows weighted JAWS and WAR values according to each player’s primary position.

Profile

Tables show various statistical categories while the deviation plot gives a calculated score that relates the player’s statistics to a typical Hall of Famer. The score gives users an estimate of where the player has excelled and faltered which many bolster or hinder his case. It also provides the user with an idea of which statistics to examine further on the Stat Rank page.

Rough Guide:

Rating	Score
Excellent	2
Good	0.5
Median	0
Poor	-0.5
Awful	-2

Stat Rank

Ranks and percentiles of player statistics for both the Hall of Fame and franchise history can be viewed on this page. There are also Hall of Fame and franchise tables so the user can see which players rank above and below the nominee.

Numbers

Here the user can have all the stats in front of them and compare players. Also, clickable links to player pages at Baseball-Reference and FanGraphs are provided under the Id columns.

Notes

When entering player names and stats, entries are case sensitive.
All tables contain both nominees and inducteees.
To qualify for the JAWS-4 calculation the player must have been tenured with the Reds for at least 4 seasons.
To qualify for other statistical tables players needed at least 1500 plate appearances or 500 innings.
Known issues and inconsistencies are listed and discussed here.
Explanations about the decision-making and details involved in the calculations are here.

Acknowledgements

Data

Data for this project was gathered from Baseball-Reference, FanGraphs, and Sean Lahman’s Baseball Database

Packages

Support

Special Thanks to

Louisville RStats