How to splice an existing date-bounded row of data into two new rows based on the date of a new vari-CodePudding

In my longitudinal data set, each row represents a time period of observation for each person, and each row is bounded by a start and end date. The rows are numbered ('episode'), and contain many row-specific variables (eg, 'edu_level') that I need to retain throughout the following steps.

I created a new date variable, hx_start, which can relate to the start and end date of each row of data in 1 of 3 ways (below). For each scenario, I need to edit (splice) the existing row of data accordingly, using dplyr:

1. Between a given row's start and end date (ie, as it does for persons 2 and 4) In this case, I want to splice the existing row into two new ones, so that the date of hx_start is the start date of one of the rows. The other row would retain the original row's start date and its end date would be one day before the date of hx_start.

2. On the same date as someone's row start date (ie, person 1) In this case, no change is needed.

3. On the same date as someone's row end date (ie, person 3) Same as #1: I need to splice the existing row into two new ones, so that the date of hx_start is the start date of one of the rows. The other row would retain the original row's start date and its end date would be one day before the date of hx_start.

So far, I have created a new data set that has 2 duplicates of each row, assuming that I will need to edit up to 2 rows per existing row, and then drop the originals (or retain only the original, in the case of person 1). Importantly, I need a way to carry forward all of the other variables from the original row to all new rows without naming them all, if possible (there are many in my real data set).

#Load packages
library(lubridate)
#> 
#> Attaching package: 'lubridate'
#> The following objects are masked from 'package:base':
#> 
#>     date, intersect, setdiff, union

#Create data set
person <- c(1, 2, 3, 4)
episode <- c(33, 50, 65, 70)
start <- c('2013-01-01', '2010-01-21', '2009-09-18', '2010-05-26')
end <- c('2013-06-04', '2010-06-19', '2009-12-31', '2010-12-24')
hx_start <- c('2013-01-01', '2010-03-09', '2009-12-31', '2010-07-04')
edu_level <- c(2, 3, 2, 1)

#Populate data frame
d <- cbind(person, episode, start, hx_start, end, edu_level)
d <- as.data.frame(d)
#Format dates and add to data frame
d$start <- as.Date(start, format = '%Y-%m-%d')
d$end <- as.Date(end, format = '%Y-%m-%d')
d$hx_start <- as.Date(hx_start, format = '%Y-%m-%d')

#Create 2 duplicates of this row for each person 
d1 <- d[rep(seq_len(nrow(d)), each = 3), ]

d1
#>     person episode      start   hx_start        end edu_level
#> 1        1      33 2013-01-01 2013-01-01 2013-06-04         2
#> 1.1      1      33 2013-01-01 2013-01-01 2013-06-04         2
#> 1.2      1      33 2013-01-01 2013-01-01 2013-06-04         2
#> 2        2      50 2010-01-21 2010-03-09 2010-06-19         3
#> 2.1      2      50 2010-01-21 2010-03-09 2010-06-19         3
#> 2.2      2      50 2010-01-21 2010-03-09 2010-06-19         3
#> 3        3      65 2009-09-18 2009-12-31 2009-12-31         2
#> 3.1      3      65 2009-09-18 2009-12-31 2009-12-31         2
#> 3.2      3      65 2009-09-18 2009-12-31 2009-12-31         2
#> 4        4      70 2010-05-26 2010-07-04 2010-12-24         1
#> 4.1      4      70 2010-05-26 2010-07-04 2010-12-24         1
#> 4.2      4      70 2010-05-26 2010-07-04 2010-12-24         1

^{Created on 2022-03-23 by the reprex package (v2.0.0)}

CodePudding user response：

You can do this by creating a small helper function. I've done this using data.table formatting

library(data.table)

f <- function(s,m,e) {
  if(m>s) return(list("start" = c(m,s),"hx_start" = c(m,m),"end" = c(e,m-1)))
  if(m == s) return (list("start" = s,"hx_start" = m,"end" =e))
}

setDT(d)[,!c(3:5)][d[ ,f(start,hx_start,end), by=person], on=.(person)]

Output:

   person episode edu_level      start   hx_start        end
1:      1      33         2 2013-01-01 2013-01-01 2013-06-04
2:      2      50         3 2010-03-09 2010-03-09 2010-06-19
3:      2      50         3 2010-01-21 2010-03-09 2010-03-08
4:      3      65         2 2009-12-31 2009-12-31 2009-12-31
5:      3      65         2 2009-09-18 2009-12-31 2009-12-30
6:      4      70         1 2010-07-04 2010-07-04 2010-12-24
7:      4      70         1 2010-05-26 2010-07-04 2010-07-03

Notice that:

For person 2,4, one row now has hx_start as the start date, and the other row has the original start date, while the end date is one day before the hx_start date.
For person 1, there has been no change
For person 3, one row now has hx_start as the start date, and the other row has the original start date, while the end date is one day before the hx_start date.

Tidyverse option (also uses function above)

inner_join(
  d %>% select(-c(start,hx_start,end)), 
  d %>% 
  rowwise() %>% 
  summarize(person = max(person),
            dates = list(f(start,hx_start,end))) %>% 
  unnest_wider(dates) %>% 
  unnest(cols=everything()), 
  by = "person"
)

Output:

   person episode edu_level      start   hx_start        end
1:      1      33         2 2013-01-01 2013-01-01 2013-06-04
2:      2      50         3 2010-03-09 2010-03-09 2010-06-19
3:      2      50         3 2010-01-21 2010-03-09 2010-03-08
4:      3      65         2 2009-12-31 2009-12-31 2009-12-31
5:      3      65         2 2009-09-18 2009-12-31 2009-12-30
6:      4      70         1 2010-07-04 2010-07-04 2010-12-24
7:      4      70         1 2010-05-26 2010-07-04 2010-07-03