Skip to content
 

A horse-race graph!

Responding to my question about graphing horse race results, Megan Pledger writes:

While waiting up late to snipe at an internet auction, I put together some simple data of a horse race and used ggplot to plot it. It’s discrete time race data rather than continuous time and has very simple choice options for the horse. The graph is a starting point!

horse_race.gif

[The picture doesn’t fully fit on the blog window here; right-click and select “view image” to see the whole thing.]

My reply: Very nice–thanks! I won’t look a gift horse in the mouth . . . but if I were to be picky, I’d suggest making the tods smaller, the lines thinner, and the colors of the five horses more distinct. All these tricks should make the lines easier to follow. I’d also suggest gray rather than black for the connecting lines.

I think I’d also supplement it with a blown-up version of the last bit (from 80-100 on the x-axis), since that’s where some interesting things are happening.

And here’s the code:


library(ggplot2)
set.seed(1)
race.track<-matrix(0,10,100) #x,y pos of every point on track horse.pos<-matrix(0,5,2) #x,y pos of 5 horses race<-matrix(0,800,4) #keeps the time and position of each horse race.pos<-0 #indexes the race matrix close<-matrix(0,5,1) #distance to objective for setting who moves first timeh<-1 #start at time 1 # can go 1 or 2 moves straight ahead at one time point # more likely to go 1 move on a bend go.straight<-function(race.track,old.pos,bend) { if (bend) dist<-rbinom(1,1,prob=0.25) if (!bend) dist<-rbinom(1,1,prob=0.75) new.pos<-old.pos+matrix(c(0,1+dist),1,2) if (new.pos[1,2]>100) new.pos[1,2]<-100 new.pos } #head for the rail, only 1 move diag go.inside<-function(race.track,old.pos) { new.pos<-old.pos+matrix(c(-1,1),1,2) if (new.pos[1,1]<1 ) new.pos[1,1]<-1 new.pos } #head for space, only 1 move diag go.outside<-function(race.track,old.pos) { new.pos<-old.pos+matrix(c(1,1),1,2) if (new.pos[1,1]>10 ) new.pos[1,1]<-10 new.pos } # set starting pos of horses and put them on the track for (i in 1:5) { horse.pos[i,]<-c(i*2,1) race.track[horse.pos[i,]]<-1 race.pos<-race.pos+1 race[race.pos,1]<-timeh race[race.pos,2]<-i race[race.pos,3:4]<-horse.pos[i,] } #while noone is at the finish line do while (sum(race.track[,100])==0){ #is any horse on a bend? bend<-(horse.pos[,2]>30&horse.pos[,2]<40)|(horse.pos[,2]>70&horse.pos[,2]<80) #update time timeh<-timeh+1 # should the horse be cutting the corner on a bend or charging for the finish line for (j in 1:5) { if (bend[j]) close[j]<-((horse.pos[j,1]-1)^2+(horse.pos[j,2]-100)^2)^.5 if (!bend[j]) close[j]<- 100-horse.pos[j,2] ord<-order(close) } #update each horses position starting with the one nearest the objective for (i in 1:5) { old.pos<-matrix(horse.pos[ord[i],],1,2) # on a straight - go straight, if noone is in the way if (!bend[ord[i]]) { new.pos<-go.straight(race.track,old.pos,bend[ord[i]]) if (race.track[new.pos]==1) new.pos<-go.outside(race.track,old.pos) if (race.track[new.pos]==1) new.pos<-go.inside(race.track,old.pos) } # on a bend - go to the rail, if noone is in the way if (bend[ord[i]]) { new.pos<-go.inside(race.track,old.pos) if (race.track[new.pos]==1) new.pos<-go.straight(race.track,old.pos,bend[ord[i]]) if (race.track[new.pos]==1) new.pos<-go.outside(race.track,old.pos) } #move if not blocked if (race.track[new.pos]!=1) { race.track[new.pos]<-1 race.track[old.pos]<-0 horse.pos[ord[i],]<-new.pos } #update race details race.pos<-race.pos+1 race[race.pos,1]<-timeh race[race.pos,2]<-ord[i] race[race.pos,3:4]<-horse.pos[ord[i],] } } #keep the actual race movements mini<-min((1:800)[race[,1]==0])-1 # convert race data to a data frame, jitter across positions so can see all horses "on the rail" race.df<-data.frame(along=race[1:mini,4],across=jitter(race[1:mini,3]), timeh=race[1:mini,1],horse=race[1:mini,2]) #sort for plotting paths race1.df<-race.df[order(race.df$timeh, race.df$across),] #keep for plotting every 5 time points race2.df<- race1.df[(round((race1.df$timeh-1)/5)== (race1.df$timeh-1)/5),] #keep for plotting final position race3.df<- race1.df[race1.df$timeh==max(race1.df$timeh),] #do plot ggplot(race1.df, aes(x = along, y = across, colour =horse)) + geom_line(aes(group = horse, colour = horse), size = 1.25) + geom_path(aes(group = timeh), data=race2.df, colour = "grey40", size = 1 )+ geom_path(aes(group = timeh), data=race3.df, colour = "gold", size = 1.5 )+ geom_point(size=3) + geom_point(data=race3.df,size=5)