Thursday, May 11, 2017

Formula 1 plotting app with Shiny!

F1 Plotter

Just for fun…

No work today but it’s raining out so I decided to make a web plotter that plots Formula 1 historical results using shiny. Since this isn’t bioinformatics related I won’t go through the code as I normally would but I did comment on it inline below for those who want to follow along.
You can check out the plotter here or run it by copying and pasting the code below into the R terminal.
I will point out one neat feature: the ggplot add-on package emoGG. As the name suggests this package lets you use emojis in place of the normal shapes when plotting in ggplot. It’s easy to use. You simply search for the emoji using keywords:
library(emoGG)
emoji_search("trophy")
##       emoji  code  keyword
## 1612 trophy 1f3c6      win
## 1613 trophy 1f3c6    award
## 1614 trophy 1f3c6  contest
## 1615 trophy 1f3c6    place
## 1616 trophy 1f3c6      ftw
## 1617 trophy 1f3c6 ceremony
## 3102      o  2b55   circle
## 3103      o  2b55    round
Then use the emoji code when calling ‘geom_emoji()’. Below is a plot from the app (you can see the code below). You can see I’ve added a layer with trophy emojis for Daniel Ricciardo’s first place finishes:
Anyway enjoy the app (if you’re a Formula 1 fan). Here’s the code for it:
library(RCurl)
library(httr)
library(XML)
library(shiny)
library(ggplot2)
library(dplyr)
library(emoGG)

#set up the server side
server <- function(input, output) {
  
#this block converts the Constructors to their color for plotting purposes
  cols <- c("Ferrari" = "red", 
            "Force India" = "pink",
            "Mercedes" = "turquoise",
            "Red Bull" = "darkblue",
            "Williams" = "grey70",
            "Toro Rosso" = "blue",
            "Haas" = "brown",
            "Renault" = "yellow",
            "Sauber" = "cornflowerblue",
            "McLaren" = "orange",
            "Minardi" = "darkgoldenrod1",
            "HRT" = "grey10",
            "Caterham" = "forestgreen",
            "Lotus" = "black",
            "Manor" = "blue4",
            "BMW Sauber" = "darkgray"
  )
  
  #get the driver name from the ui side. format it for input into the scrape
  chauffeur <- reactive({
    a <- tolower(input$driver)
    a <- gsub(" ", "-", a)
    a
  })
 
  #scrape and build the data table by parsing the XML
   results <- reactive({
    url <- paste0("http://www.statsf1.com/en/",chauffeur(),"/grand-prix.aspx")
    h <- handle(url)
    res <- GET(handle = h)
    resXML <- htmlParse(content(res, as = "text"))
    
    #The XML isnt great so I need to remove blank rows at the end and header names
    #Each vector being created below will be a column in the final data frame
    Year<- getNodeSet(resXML, '//*//tr/td[2]') %>% sapply(., xmlValue)
    Year <- Year[Year != ""]
    Year <- Year[-c(1)]
    GrandPrix<- getNodeSet(resXML, '//*//tr/td[3]') %>% sapply(., xmlValue)
    GrandPrix <- GrandPrix[GrandPrix != ""]
    GrandPrix <- GrandPrix[-c(1)]
    Team<- getNodeSet(resXML, '//*//tr/td[4]') %>% sapply(., xmlValue)
    Team <- Team[-c(1)]
    Team <- Team[Team != ""]
    Num<- getNodeSet(resXML, '//*//tr/td[5]') %>% sapply(., xmlValue)
    Num <- Num[Num != ""]
    Num <- Num[-c(1)]
    Constructor<- getNodeSet(resXML, '//*//tr/td[6]') %>% sapply(., xmlValue)
    Constructor <- Constructor[Constructor != ""]
    Constructor <- Constructor[-c(1)]
    Car <- getNodeSet(resXML, '//*//tr/td[7]') %>% sapply(., xmlValue)
    Car <- Car[-c(1)]
    Car <- Car[Car != ""]
    Engine<- getNodeSet(resXML, '//*//tr/td[8]') %>% sapply(., xmlValue)
    Engine <- Engine[-c(1)]
    Engine <- Engine[Engine != ""]
    Type<- getNodeSet(resXML, '//*//tr/td[9]') %>% sapply(., xmlValue)
    Type <- Type[Type != ""]
    Type <- Type[-c(1)]
    Tyre<- getNodeSet(resXML, '//*//tr/td[10]') %>% sapply(., xmlValue)
    Tyre <- Tyre[Tyre != ""]
    Tyre <- Tyre[-c(1)]
    Grid<- getNodeSet(resXML, '//*//tr/td[11]') %>% sapply(., xmlValue)
    Grid <- Grid[Grid != ""]
    Race<- getNodeSet(resXML, '//*//tr/td[12]') %>% sapply(., xmlValue)
    Race <- Race[Race != ""]
    Race[Race == "ab"] <- "22" #Change the ab to 22 for non finishes
    Note<- getNodeSet(resXML, '//*//tr/td[13]') %>% sapply(., xmlValue)
    Note <- Note[Note != ""]

    #put it all into a data frame and call it to set the reactive variable
    df <- data.frame(Year,GrandPrix,Team,Num,Constructor,Car,Engine,Type,Tyre,Grid,Race,Note, stringsAsFactors = F)
    df$YR_RACE <- paste0(Year,"_",GrandPrix)
    df
  })
   
   #pull out any wins
  wins <- reactive({
    x <- results()[which(results()$Race == "1"),]
    x$Race <- as.numeric(x$Race) - 1
    x
  })
  
  #plot it all
  #check out geom_emoji!!! It's what makes the trophies:
  #https://github.com/dill/emoGG
  p <- reactive({
    ggplot(data=results(), aes(x=YR_RACE, y=as.numeric(as.character(Race)), colour=results()$Constructor)) +
      geom_point() +
      #add the wins
      geom_emoji(data=wins(), aes(x=wins()$YR_RACE, y=as.numeric(as.character(wins()$Race)), colour=wins()$Constructor), emoji="1f3c6") +
      #set up the axis, label 22 as DNF for non finishes
      scale_y_reverse(breaks=c(1,2,3,10,22), labels = c("1","2","3","10","DNF"), lim=c(22,-1)) +
     theme(axis.text.y = element_text(color = c("black", "black", "black", "black", "red")),
            axis.ticks.y = element_line(color = c("black", "black", "black", "black", "red"),
                                        size = c(1,1,1,1,1,1))) +
      scale_colour_manual(values = cols) +
      labs(colour='Constructor') +
      ylab("Race Finish") +
      xlab("Grand Prix") +
      theme(axis.text.x = element_text(size = rel(0.8),angle = 90, hjust = 1))
  })
  
  output$plot1 <- renderPlot({
    print(p())
  })
    
  output$table1 <- renderTable({
    results()[-c(13)]
  })
}

#this list will be input into the selectInput()
drivers <- list(
  "Fernando ALONSO",
  "Valtteri BOTTAS" ,
  "Marcus ERICSSON" ,
  "Antonio GIOVINAZZI" ,
  "Romain GROSJEAN" ,
  "Lewis HAMILTON" ,
  "Nico HULKENBERG",
  "Daniil KVYAT" ,
  "Kevin MAGNUSSEN" ,
  "Felipe MASSA" ,
  "Esteban OCON" ,
  "Jolyon PALMER" ,
  "Sergio PEREZ" ,
  "Kimi RAIKKONEN" ,
  "Daniel RICCIARDO" ,
  "Carlos SAINZ" ,
  "Lance STROLL" ,
  "Stoffel VANDOORNE" ,
  "Max VERSTAPPEN" ,
  "Sebastian VETTEL" ,
  "Pascal WEHRLEIN"
)

#very simple ui page...
ui <- fluidPage(
  headerPanel('Formula 1 Results'),
  mainPanel(
    selectInput("driver", "Choose a driver", drivers, selected = NULL, multiple = FALSE,
                selectize = TRUE, width = NULL, size = NULL)
  ),
  mainPanel(plotOutput("plot1"),
              tableOutput("table1"),
            width = 10)
)

#call the app
shinyApp(ui = ui, server = server)

Session

sessionInfo()
## R version 3.3.3 (2017-03-06)
## Platform: x86_64-apple-darwin13.4.0 (64-bit)
## Running under: macOS Sierra 10.12.3
## 
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  methods   base     
## 
## other attached packages:
## [1] dplyr_0.5.0    shiny_1.0.1    XML_3.98-1.7   httr_1.2.1    
## [5] RCurl_1.95-4.8 bitops_1.0-6   emoGG_0.0.2    ggplot2_2.2.1 
## 
## loaded via a namespace (and not attached):
##  [1] Rcpp_0.12.10     knitr_1.15.1     magrittr_1.5     munsell_0.4.3   
##  [5] xtable_1.8-2     colorspace_1.3-2 R6_2.2.0         stringr_1.2.0   
##  [9] plyr_1.8.4       tools_3.3.3      grid_3.3.3       gtable_0.2.0    
## [13] png_0.1-7        DBI_0.6          htmltools_0.3.5  yaml_2.1.14     
## [17] lazyeval_0.2.0   rprojroot_1.2    digest_0.6.12    assertthat_0.1  
## [21] tibble_1.2       mime_0.5         evaluate_0.10    rmarkdown_1.4   
## [25] stringi_1.1.3    scales_0.4.1     backports_1.0.5  httpuv_1.3.3    
## [29] proto_1.0.0

No comments:

Post a Comment

Pokemods! An educational outreach initiative

Pokemodels! An educational outreach initiative This post originally appeared on The Node . Getting the next generation...