Rowwise operation with adaptive range using dplyr

Question

Based on my earlier question, I would like to calculate colocation (i.e. two people appearing at the same time) instances given a smartcard data. Here is a made-up sample consisting of ten records:

library(lubridate)

smartcard <- c(1,2,3,2,1,2,4,4,1,1)
boarding_stop <- c("C23", "C14", "C23", "C23", "C23", "C14", "C14", "C23", "C14", "C23")
boarding_time <- as.times(c("07:24:01", "07:26:18", "07:37:19", "08:29:22", "08:34:10", "15:55:23", 
  "16:20:22", "17:07:31", "17:13:34", "17:35:52"))
colocation <- data.frame(smartcard, boarding_time, boarding_stop)
colocation
   smartcard boarding_time boarding_stop
1          1      07:24:01           C23
2          2      07:26:18           C14
3          3      07:37:19           C23
4          2      08:29:22           C23
5          1      08:34:10           C23
6          2      15:55:23           C14
7          4      16:20:22           C14
8          4      17:07:31           C23
9          1      17:13:34           C14
10         1      17:35:52           C23

Given a colocation buffer of 30 minutes (i.e. passenger 1 arriving at 07:24 would colocate with another passenger when they arrive before 07:54), I would like to record all instances that pairs of passengers satisfy this condition, and record the boarding_stop, boarding_time, and their smartcard ID.

For example, I would find that passenger 1 and 3 colocate at C23 at 07:37:19. Ultimately, I would want an output of the form

boarding_stop boarding_time smartcard1 smartcard2
          C23      07:37:19          1          3
          C23      08:34:10          2          1
          C23      07:35:52          4          1
          C14      16:20:22          2          4

My earlier attempt is to code through several for loops that lookup individual pairs of trip information and identify whether the two trips are recorded at the train station within a half-hour interval. Once found, then append a new row with information on time, smartcard passengers and location.

Output<- read.table(text = "boarding_stop boarding_time smartcard1 smartcard2", header = TRUE)
for s in unique(colocaion$boarding_stop):
  for i in 1:nrow(colocation):
    for j in 1:nrow(colocation):
      if colocation$boarding_time[[j,2]] <= colocation$boarding_time[[i,2]] + "00:30:00" &
         colocation$boarding_time[[j,2]] >= colocation$boarding_time[[i,2]]:
           Output %>% add_row(boarding_stop = colocation$boarding_stop[[j,3]],
                              boarding_time = colocation$boarding_time[[j,2]],
                              smartcard1 = colocation$smartcard[[i,1]], 
                              smartcard2 = colocation$smartcard[[j,1]])
    end
  end
end

My initial approach using dplyr would involve group_by to first group unique stations. But since the half-hour buffer time changes for each pair of trips, I don't think I can simply mutate and summarise to capture colocation. I thank @Matt for his answer in the earlier question. Any help on this would be greatly appreciated.

Answer 1

EDIT: dplyr solution

#Change to timestamp and create time range

dt <- dt %>% 
  mutate(boarding_time = parse_date_time(boarding_time,orders = "HMS"),
         boardtime_time_plus=boarding_time+hm("00:30"),
         boardtime_time_minus=boarding_time-hm("00:30"))

# cartesian join within each boarding_stop and then filter
dt %>% 
  mutate(fake_col=TRUE) %>% 
  left_join(dt %>% mutate(fake_col=TRUE),by=c("fake_col","boarding_stop")) %>% 
  group_by(boarding_stop) %>% 
  ungroup() %>% 
  filter(smartcard.x!=smartcard.y,boardtime_time_minus.x<=boarding_time.y,boardtime_time_plus.x>=boarding_time.y) %>% 
  select(boarding_stop,boarding_time=boarding_time.x,smartcard1=smartcard.x,smartcard2=smartcard.y) %>% 
  group_by(paste0(boarding_stop,"-",(smartcard1+smartcard2))) %>% 
  filter(boarding_time==max(boarding_time)) %>% 
  ungroup() %>% 
  mutate(boarding_time=format(boarding_time,"%H:%M:%S")) %>% 
  select(-5)
#> # A tibble: 4 x 4
#>   boarding_stop boarding_time smartcard1 smartcard2
#>   <chr>         <chr>              <int>      <int>
#> 1 C23           07:37:19               3          1
#> 2 C23           08:34:10               1          2
#> 3 C14           16:20:22               4          2
#> 4 C23           17:35:52               1          4

This is a data.table solution. I am not familiar with dplyr so I guess you need to play around filter to do this.

library(data.table)
library(lubridate)


dt <- fread('smartcard boarding_time boarding_stop
        1      07:24:01           C23
        2      07:26:18           C14
        3      07:37:19           C23
        2      08:29:22           C23
        1      08:34:10           C23
        2      15:55:23           C14
        4      16:20:22           C14
        4      17:07:31           C23
        1      17:13:34           C14
        1      17:35:52           C23')
#Change to timestamp
dt[,boarding_time:=parse_date_time(boarding_time,orders = "HMS")]

#Create time range
dt[,`:=`(boardtime_time_plus=boarding_time+hm("00:30"),
        boardtime_time_minus=boarding_time-hm("00:30"))]

#non equal join and excluding joined on itself
dtd <- dt[dt,on=.(boarding_stop,boardtime_time_minus<=boarding_time,boardtime_time_plus>=boarding_time)][smartcard!=i.smartcard,]

# a bit format and select the max datetime for each combination
# there definitely should have elegant way to do this but i havent figured out
dtd[,.(boarding_stop,boarding_time = format(boarding_time,"%H:%M:%S"),smartcard1=smartcard,smartcard2=i.smartcard)][
  dtd[,.I[boarding_time==max(boarding_time)],by=.(paste0(boarding_stop,"-",(smartcard1+smartcard2)))]$V1,]
#>    boarding_stop boarding_time smartcard1 smartcard2
#> 1:           C23      07:37:19          3          1
#> 2:           C23      08:34:10          1          2
#> 3:           C14      16:20:22          4          2
#> 4:           C23      17:35:52          1          4

^{Created on 2020-04-25 by the reprex package (v0.3.0)}