CODEWITHSUNDEEP
rgroup-bydplyrdatediffcumsum
r_newb
r_newb

Reputation: 13

How to generate a unique ID for each group based on relative date interval in R using dplyr?

I have a cohort of data with multiple person visits and want to group visits with a common ID based on person # and the time of the visit. The condition is if an start is within 24 hours of a the previous exit, then I want those to have the same ID.

Sample of what data looks like:

dat <- data.frame(
Person_ID = c(1,1,1,2,3,3,3,4,4),
Admit_Date_Time = as.POSIXct(c("2017-02-07 15:26:00","2017-04-21 10:20:00", 
"2017-04-22 12:12:00", "2017-10-16 01:31:00","2017-01-24 02:41:00","2017-    01-24 05:31:00", "2017-01-28 04:26:00", "2017-12-01 01:31:00","2017-12-01 
01:31:00"), format = "%Y-%m-%d %H:%M"),
Discharge_Date_Time  = as.POSIXct(c("2017-03-01 11:42:00","2017-04-22 
05:56:00",
"2017-04-26 21:01:00",
"2017-10-18 20:11:00",
"2017-01-27 22:15:00",
"2017-01-26 15:35:00",
"2017-01-28 09:25:00",
"2017-12-05 18:33:00",
"2017-12-04 16:41:00"),format = "%Y-%m-%d %H:%M" ),
Visit_ID = c(1:9))

this is what I tried to start:

dat1 <- 
dat %>%
arrange(Person_ID, Admit_Date_Time) %>%
group_by(Person_ID) %>%
mutate(Previous_Visit_Interval = difftime(lag(Discharge_Date_Time, 
1),Admit_Date_Time, units = "hours")) %>%
mutate(start = c(1,Previous_Visit_Interval[-1] < hours(-24)), run = 
cumsum(start))

dat1$ID = as.numeric(as.factor(paste0(dat1$Person_ID,dat1$run)))

Which is almost right, except it does not give the correct ID for visit 7 (person #3). Since there are three visits and the second visit is entirely within the first, and the third starts within 24 hours of the first but not the second.

Upvotes: 1

Views: 456

Answers (2)

Jon Spring
Jon Spring

Reputation: 66415

There's probably a way to shorten this, but here's an approach using tidyr::gather and spread. By gathering into long format, we can track the cumulative admissions inside each visit. A new visit is recorded whenever there's a new Person_ID or that Person_ID completed a visit (cumulative admissions went to zero) at least 24 hours prior.

library(tidyr)
dat1 <- dat %>%
  # Gather into long format with event type in one column, timestamp in another
  gather(event, time, Admit_Date_Time:Discharge_Date_Time) %>%

  # I want discharges to have an effect up to 24 hours later. Sort using that.
  mutate(time_adj = if_else(event == "Discharge_Date_Time", 
                            time + ddays(1), 
                            time)) %>%
  arrange(Person_ID, time_adj) %>%

  # For each Person_ID, track cumulative admissions. 0 means a visit has completed. 
  #   (b/c we sorted by time_adj, these reflect the 24hr period after discharges.)
  group_by(Person_ID) %>%
  mutate(admissions = if_else(event == "Admit_Date_Time", 1, -1)) %>%
  mutate(admissions_count = cumsum(admissions)) %>%
  ungroup() %>%

  # Record a new Hosp_ID when either (a) a new Person, or (b) preceded by a 
  #   completed visit (ie admissions_count was zero).
  mutate(Hosp_ID_chg = 1 * 
           (Person_ID != lag(Person_ID, default = 1) |   # (a)
            lag(admissions_count, default = 1) == 0),    # (b)
         Hosp_ID = cumsum(Hosp_ID_chg)) %>%

  # Spread back into original format
  select(-time_adj, -admissions, -admissions_count, -Hosp_ID_chg) %>%
  spread(event, time)

Results

> dat1
# A tibble: 9 x 5
  Person_ID Visit_ID Hosp_ID Admit_Date_Time     Discharge_Date_Time
      <dbl>    <int>   <dbl> <dttm>              <dttm>             
1         1        1       1 2017-02-07 15:26:00 2017-03-01 11:42:00
2         1        2       2 2017-04-21 10:20:00 2017-04-22 05:56:00
3         1        3       2 2017-04-22 12:12:00 2017-04-26 21:01:00
4         2        4       3 2017-10-16 01:31:00 2017-10-18 20:11:00
5         3        5       4 2017-01-24 02:41:00 2017-01-27 22:15:00
6         3        6       4 2017-01-24 05:31:00 2017-01-26 15:35:00
7         3        7       4 2017-01-28 04:26:00 2017-01-28 09:25:00
8         4        8       5 2017-12-01 01:31:00 2017-12-05 18:33:00
9         4        9       5 2017-12-01 01:31:00 2017-12-04 16:41:00

Upvotes: 1

Wimpel
Wimpel

Reputation: 27732

Here's a data.table approach using an overlap-join

library( data.table )
library( lubridate )
setDT( dat )
setorder( dat, Person_ID, Admit_Date_Time )
#create a 1-day extension after each discharge
dt2 <- dat[, discharge_24h := Discharge_Date_Time %m+% days(1)][]
#now create id
setkey( dat, Admit_Date_Time, discharge_24h )
#create data-table with overlap-join, create groups based on overlapping ranges
dt2 <- setorder( 
  foverlaps( dat, 
             dat, 
             mult = "first", 
             type = "any", 
             nomatch = 0L 
             ), 
  Visit_ID )[, list( Visit_ID = i.Visit_ID, 
                     Hosp_ID = .GRP ), 
             by = .( Visit_ID )][, Visit_ID := NULL]

#reorder the result
setorder( dt2[ dat, on = "Visit_ID" ][, discharge_24h := NULL], Visit_ID )[]

#    Visit_ID Hosp_ID Person_ID     Admit_Date_Time Discharge_Date_Time
# 1:        1       1         1 2017-02-07 15:26:00 2017-03-01 11:42:00
# 2:        2       2         1 2017-04-21 10:20:00 2017-04-22 05:56:00
# 3:        3       2         1 2017-04-22 12:12:00 2017-04-26 21:01:00
# 4:        4       3         2 2017-10-16 01:31:00 2017-10-18 20:11:00
# 5:        5       4         3 2017-01-24 02:41:00 2017-01-27 22:15:00
# 6:        6       4         3 2017-01-24 05:31:00 2017-01-26 15:35:00
# 7:        7       4         3 2017-01-28 04:26:00 2017-01-28 09:25:00
# 8:        8       5         4 2017-12-01 01:31:00 2017-12-05 18:33:00
# 9:        9       5         4 2017-12-01 01:31:00 2017-12-04 16:41:00

Upvotes: 0

Related Questions