Car Race Visualisation R Code

Here you will find the source code for the car race visualisation, as described in the upcoming book Graphic Guide to R

Copyright 2018 Antony Lees

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at

   http://www.apache.org/licenses/LICENSE-2.0 

Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.

settings <- function() {
  size(1000, 600)
}

setup <- function() {
  lane_gap <- (height-50) / length(mtcars$qsec)
  cars <<- list() # list for cars
  for (i in 1:length(mtcars$qsec)) {
    car_name <- rownames(mtcars)[i]
    car_qsec <- mtcars$qsec[i]
    new_car <- car(car_qsec, car_name, i * lane_gap) 
    cars[[length(cars) + 1]] <- new_car
  }
  percentiles <- quantile(mtcars$qsec)
  race_lines <<- list() # list for race lines
  race_lines[[1]] <- race_line(percentiles[2], "75%")
  race_lines[[2]] <- race_line(percentiles[3], "50%")
  race_lines[[3]] <- race_line(percentiles[4], "25%")
}

draw <- function() {
  background(150)
  for (i in 1:length(cars)) {
    the_car <- cars[[i]]
    the_car <- display(the_car)
    cars[[i]] <- the_car
  }

  for (i in 1:length(race_lines)) {
    the_race_line <- race_lines[[i]]
    the_race_line <- display(the_race_line)
    race_lines[[i]] <- the_race_line
  }
}

# things that can race
raceable <- function(qsec, name, y, class=character()) {
     structure(
       list(
         speed = 15 / qsec, # not real speed
         x = 0,
         y = y,
         colour = color(random(255), random(255), ran-dom(255)),
         name = name
       ),
       class = c(class, "raceable")
     )
}

# car class
car <- function(qsec, name, y) {
   raceable(
     qsec = qsec,
     name = name,
     y = y,
     class = "car"
  )
}

# race line class
race_line <- function(qsec, name) {
   raceable(
     qsec = qsec,
     name = name,
     y = 0,
     class = "race_line"
  )
}

display <- function(obj) { # generic method
  UseMethod("display") 
}

display.raceable <- function(object) {
  object$x <- object$x + object$speed
  return(object)  
}

display.car <- function(object) {
  fill(object$colour)
  rect(object$x, object$y, 20, 10)
  ellipse(object$x + 5, object$y + 10, 5, 5)
  ellipse(object$x + 15, object$y + 10, 5, 5)
  fill(0)# black text
  text(object$name, object$x, object$y + 25)
  object <- NextMethod()
  return(object)
}

display.race_line <- function(object) {
   stroke(120)
   line(object$x, object$y, object$x, height)
   text(object$name, object$x - 20, object$y + 15)
   object <- NextMethod()
   return(object)
}