A Closer Look at TAT Time Dependence

Some More Lubridate Magic

Therefore, we need to assign every point in our myData dataframe a day of the week. The lubridate function wday() does this for us.

start
## [1] "2014-01-01 02:39:00 UTC"
wday(start, label = TRUE)
## [1] Wed
## Levels: Sun < Mon < Tues < Wed < Thurs < Fri < Sat
#if you want them as numbers, just leave the label option out.
wday(start)
## [1] 4

So, January 1, 2014 was a Wednesday, which is the 4th day of the week. Let’s assign the day of the week for all our days and then bind this to our data.

weekday <- wday(myData$collected)
myData <- cbind(myData,weekday)
head(myData)
##               ordered           collected            received
## 1 2014-01-01 17:53:00 2014-01-01 17:54:00 2014-01-01 18:08:00
## 2 2014-01-01 15:10:00 2014-01-01 15:19:00 2014-01-01 15:21:00
## 3 2014-01-01 17:07:00 2014-01-01 17:15:00 2014-01-01 17:17:00
## 4 2014-01-01 18:20:00 2014-01-01 18:30:00 2014-01-01 18:35:00
## 5 2014-01-01 11:19:00 2014-01-01 11:25:00 2014-01-01 11:29:00
## 6 2014-01-01 11:00:00 2014-01-01 11:08:00 2014-01-01 11:11:00
##              resulted      otf weekday
## 1 2014-01-01 18:45:00  52 mins       4
## 2 2014-01-01 16:33:00  83 mins       4
## 3 2014-01-01 18:09:00  62 mins       4
## 4 2014-01-01 19:45:00  85 mins       4
## 5 2014-01-01 13:33:00 134 mins       4
## 6 2014-01-01 11:47:00  47 mins       4

Now let’s plot all of the Monday–data for the whole year and look at the with–day–trends for Mondays. We are going to convert all of the TATs and times at which they are collected to decimal numbers so we don’t run into any hassles. (Yes, I ran into hassles when I did not do this.)

This little function accomplishes this for us:

#convert the time to decimal number of hours since midnight for simplicity in plotting
timeconvert = function(t){hour(t)+minute(t)/60}
mondayData <- subset(myData,weekday == 2)
mondayTimes <- timeconvert(mondayData$collected)
mondayData <- cbind(mondayData,times = mondayTimes)
mondayData$otf <- as.numeric(mondayData$otf)
head(mondayData)
##                 ordered           collected            received
## 225 2014-01-06 23:35:00 2014-01-06 23:30:00 2014-01-07 00:09:00
## 226 2014-01-06 11:02:00 2014-01-06 11:10:00 2014-01-06 11:14:00
## 227 2014-01-06 14:08:00 2014-01-06 14:20:00 2014-01-06 14:24:00
## 228 2014-01-06 10:06:00 2014-01-06 10:16:00 2014-01-06 10:19:00
## 229 2014-01-06 14:42:00 2014-01-06 15:09:00 2014-01-06 15:16:00
## 230 2014-01-06 20:02:00 2014-01-06 20:17:00 2014-01-06 20:22:00
##                resulted otf weekday    times
## 225 2014-01-07 00:46:00  71       2 23.50000
## 226 2014-01-06 12:42:00 100       2 11.16667
## 227 2014-01-06 16:02:00 114       2 14.33333
## 228 2014-01-06 11:44:00  98       2 10.26667
## 229 2014-01-06 16:04:00  82       2 15.15000
## 230 2014-01-06 20:55:00  53       2 20.28333

So this seems to have worked and now we can make a scatter plot.

Monday Monday, So Good to Me?

plot(mondayData$times,mondayData$otf, pch = 19, col = "#00000020", cex = 0.5, ylim = c(0,200), xlim = c(0,24), xaxt = "n", xlab = "Hour of Day", ylab = "Turnaround Time (min)")
axis(side = 1, 0:24, at = 0:24, las = 2, cex.axis = 0.6, col.axis = "gray30")

But now for the interesting part. We want to see how the median TAT is related to the time of day. We might want to look at, say, the running median over one–hour window all day long.  Notice that I have made the times, t, go from 0.5 to 23.5 because these are the only times for which a 60 min moving median can be calculated. Otherwise we’d have this really annoying situation where we’d have to fetch data from the last half-hour of Sunday and the first half-hour of Tuesday. I don’t need that level of perfectionism at present.

plot(mondayData$times,mondayData$otf, pch = 19, col = "#00000020",cex = 0.5, ylim = c(30,100),xlim = c(0,24), xaxt = "n", xlab = "Hour of Day", ylab = "Turnaround Time (min)")
axis(side = 1, 0:24, at = 0:24, las = 2, cex.axis = 0.6, col.axis = "gray30")

#60 min moving median calculation:
#Create a point at every minute of the day
t <- seq(from = 0.5,to = 23.5, by = 1/60)
#create and empty vector to store the data
med.tats <- vector()

for(i in 1:length(t)){
  #get all points within an hour of the minute
  tats <- subset(mondayData,(mondayData$times >= (t[i]-0.5)) & (mondayData$times < (t[i]+0.5)))
  #alternatively using filter() from the dplyr package
  #tats <- filter(mondayData, times >= (t[i] - 0.5) & times < (t[i] + 0.5))
  med.tats[i] <- median(tats$otf)
}

lines(t,med.tats, col = "blue")
grid(NA,NULL)

Removing the For–ness

Many R folks don’t like for–loops and would rather use the apply() family of functions. I’m not sure I always understand contempt towards loops for small simple tasks but if you wanted to accomplish the same looping task without using a for–loop, you could do as follows:

t <- seq(from = 0.5, to = 23.5, by = 1/60)
movingmed<-function(t,x){
  tats <- filter(x, times >= (t - 0.5) & times < (t + 0.5))
  median(tats$otf)
}
med.tats <- sapply(t, movingmed, x=mondayData)

Smoothing

This approach is reasonable but the problem (I have found) is that it is computationally expensive on large data sets. For this reason, it is nice to use a canned smoothing algorithm like LOWESS which is much faster. The parameter f of the lowess function has a default of 2/3 which in our case results in a fit that is way–too smoothed. I played around with f until I got something that more or less tracked with the 60–min moving median. There are many approaches to smoothing–don’t get lost in the vortex.

Lowess Smoothing

plot(mondayData$times,mondayData$otf, pch = 19, col = "#00000020",cex = 0.5, ylim = c(30,100),xlim = c(0,24), xaxt = "n", xlab = "Hour of Day", ylab = "Turnaround Time (min)")
axis(side = 1, 0:24, at = 0:24, las = 2, cex.axis = 0.6, col.axis = "gray30")
#running median
#create a point at every minute of the day
t <- seq(from = 0.5,to = 23.5, by = 1/60)
med.tats <- vector()
for(i in 1:length(t)){
  #get all points within an hour of the minute
  tats <- subset(mondayData,(mondayData$times >= (t[i] - 0.5)) & (mondayData$times < (t[i] + 0.5)))
  #alternatively using filter() from the dplyr package
  #tats <- filter(mondayData, times >= (t[i] - 0.5) & times < (t[i] + 0.5))
  med.tats[i] <- median(tats$otf)
}
lines(t,med.tats, col = "blue")
grid(col = "black")
mondayFit <- lowess(mondayData$times,mondayData$otf,f = 0.05)
lines(mondayFit,col = "red")

So, that’s cool. Now lets loop over all the days of the week and make plots for each day.

#create a 2x4 plot window
par(mfrow = c(2,4))
#loop over days
for (i in 1:7){
  #make the lowess fit
  mydayData <- subset(myData,weekday == i)
  mydayTimes <- timeconvert(mydayData$collected)
  mydayData <- cbind(mydayData,times = mydayTimes)
  mydayFit <- lowess(mydayData$times,mydayData$otf,f = 0.05)
  plot(NA,NA,ylim = c(30,100), xlim = c(0,24), xaxt = "n", xlab = "Hour of Day", ylab = "Turnaround Time (min)")
  axis(side = 1, 0:24, at = 0:24, las = 2, cex.axis = 0.6, col.axis = "gray30")
  
  #running median
  #create a point at every minute of the day
  t <- seq(from = 0.5,to = 23.5, by = 1/60)
  med.tats <- vector()
  for(j in 1:length(t)){
    #get all points within an hour of the minute
    tats <- subset(mydayData,(mydayData$times >= (t[j] - 0.5)) & (mydayData$times < (t[j] + 0.5)))
    #alternatively using filter() from the dplyr package
    #tats <- filter(mydayData, times >= (t[j] - 0.5) & times < (t[j] + 0.5))
    med.tats[j] <- median(tats$otf)
  }
  lines(t,med.tats, col = "blue")
  grid(col = "black")
  mydayFit <- lowess(mydayData$times,mydayData$otf,f = 0.05)
  lines(mydayFit,col = "red")
  
  #put in horizontal gridding
  grid(NA,NULL)
  #you could add a legend on all the plots if you wanted
  #legend("bottomright", c("moving median","lowess"), lty = c(1,1), col = c("blue","red", byt = "n"))
}

Now, let’s overplot all the lowess fits on a single graph and see what practical observations we can make. I have increased the lowess() smoothing to make things easier to look at.

par(mfrow = c(1,1))
plot(0,0,ylim = c(40,80),xlim = c(0,24), xaxt = "n", xlab = "Hour of Day", ylab = "Turnaround Time (min)")
axis(side = 1, 0:24, at = 0:24, las = 2, cex.axis = 0.6, col.axis = "gray30")
for (i in 1:7){
  mydayData <- subset(myData,weekday == i)
  mydayTimes <- timeconvert(mydayData$collected)
  mydayData <- cbind(mydayData,times = mydayTimes)
  mydayFit <- lowess(mydayData$times,mydayData$otf,f = 0.1)
  lines(mydayFit, col = rainbow(7)[i], ylim = c(40,80),xlim = c(0,24), xaxt = "n", xlab = "Hour of Day", ylab = "Turnaround Time (min)", main = paste("TAT for",wday(i,label = TRUE),"in 2014"))
}
legend("bottomright",as.character(wday(1:7,label = TRUE)), col = rainbow(7), lty = rep(1,7), cex = 0.5)

Observations

We can immediately see some issues. Weekends in the early hours of the morning are bad. 8 am is bad across all days. Noon is generally problematic and particularly so on Saturdays. There is also a slowdown in mid–afternoon and in the early evenings. Saturday midnight is the most problematic time, although the endpoints of the figure have fewer local weighting points and their confidence intervals are wider. This is something we can cover another time.

Remember, also, this is only the median we have looked at. Other horrors may be lurking in the 90th percentile.

Next time what we will do is move all of this TAT visualization to a 3D representation so we can more easily spot the problematic times.

-Dan

The lot is cast into the lap, but its every decision is from the LORD.

Proverbs 16:33