以超过一小时的间隔拆分行/以R表示的时间转换问题

我有ID、关闭时间和打开时间的数据。我需要将跨越一个小时的每一行分成多行，每个ID对应一行，这样每一行都有一个打开和关闭时间，而不是跨越一个小时的顶部。理想情况下，这将使打开和关闭时间仅在同一小时内的行保持不变。它还将在每一行中保留ID

例如，如果我有一个从上午11:55到下午1:10的开放时间，我希望从相应的列中得到三行。11:55-12，12-1和1-1:10的一个

我相信我已经想出了一个解决方案，但它很复杂：

dat <- tibble(ID = c(2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L),
                  open_time = structure(c( 1509378717, 1509475803, 1509460317, 1509372561, 1508445791, 1508962523, 1509483224, 1509483978, 1509483727),
                                        tzone = "America/New_York",
                                        class = c("POSIXct", "POSIXt")),
                  close_time = structure(c( 1509383226, 1509476435, 1509462052, 1509376589, 1508445791, 1508962523, 1509483543, 1509483983, 1509483727),
                                         tzone = "America/New_York",
                                         class = c("POSIXct", "POSIXt")))

split_by_hour <- function(open_time, close_time){

  # get hours to span
  hour_start <- lubridate::ceiling_date(open_time, 'hour')
  hour_end <- lubridate::floor_date(close_time, 'hour')

  # hour sequence to create rows
  hour_seq <- seq(hour_start, hour_end, by = 'hour')

  # create tibble
  time_tbl <- tibble(
    open_time = lubridate::ymd_hms(c(open_time, hour_seq), tz = "America/New_York"),
    close_time = lubridate::ymd_hms(c(hour_seq, close_time), tz = "America/New_York")
  )

  time_tbl
}

row_hour_breakout <- function(rw){

  if(lubridate::floor_date(rw$open_time, 'hour') != lubridate::floor_date(rw$close_time, 'hour')){
    # if hours are different, use helper function and bind columns
    time_splits <- split_by_hour(rw$open_time, rw$close_time)
    dplyr::bind_cols(ID = rep(rw$ID, nrow(time_splits)),
                     time_splits)
  } else{
    # else return normal row
    rw[, c("ID", "open_time", "close_time")] 
  }
}

break_tbl_hourly <- function(hour_dat){
  purrr::by_row(hour_dat, row_hour_breakout, .labels = FALSE)[[1]] %>%
    dplyr::bind_rows()
}

>dat
# A tibble: 9 x 3
     ID           open_time          close_time
  <int>              <dttm>              <dttm>
1     2 2017-10-30 11:51:57 2017-10-30 13:07:06
2     1 2017-10-31 14:50:03 2017-10-31 15:00:35
3     2 2017-10-31 10:31:57 2017-10-31 11:00:52
4     1 2017-10-30 10:09:21 2017-10-30 11:16:29
5     2 2017-10-19 16:43:11 2017-10-19 16:43:11
6     1 2017-10-25 16:15:23 2017-10-25 16:15:23
7     2 2017-10-31 16:53:44 2017-10-31 16:59:03
8     1 2017-10-31 17:06:18 2017-10-31 17:06:23
9     2 2017-10-31 17:02:07 2017-10-31 17:02:07

> break_tbl_hourly(dat)
# A tibble: 14 x 3
      ID           open_time          close_time
   <int>              <dttm>              <dttm>
 1     2 2017-10-30 11:51:57 2017-10-30 12:00:00
 2     2 2017-10-30 12:00:00 2017-10-30 13:00:00
 3     2 2017-10-30 13:00:00 2017-10-30 13:07:06
 4     1 2017-10-31 14:50:03 2017-10-31 15:00:00
 5     1 2017-10-31 15:00:00 2017-10-31 15:00:35
 6     2 2017-10-31 10:31:57 2017-10-31 11:00:00
 7     2 2017-10-31 11:00:00 2017-10-31 11:00:52
 8     1 2017-10-30 10:09:21 2017-10-30 11:00:00
 9     1 2017-10-30 11:00:00 2017-10-30 11:16:29
10     2 2017-10-19 20:43:11 2017-10-19 20:43:11
11     1 2017-10-25 20:15:23 2017-10-25 20:15:23
12     2 2017-10-31 20:53:44 2017-10-31 20:59:03
13     1 2017-10-31 21:06:18 2017-10-31 21:06:23
14     2 2017-10-31 21:02:07 2017-10-31 21:02:07

---

dat您可以使用拆分应用联合收割机策略。在这种情况下，我们必须逐个处理
dat
中的每一行。所以整个事情看起来像

do.call(rbind, lapply(split(dat, seq(nrow(dat))), expand.row))

其中，
expand.row
是一个函数，它接受包含
正好一行，并输出包含一行或多行的数据帧

split（…）
部分创建一个1行数据帧列表
lappy（…，expand.row）
将
expand.row
应用于列表中的每个元素，并将结果收集到不同的列表中
do.call（rbind，…）
将第二个列表中的元素堆叠在一起，以获得结果数据帧

我们现在要做的就是写
展开.row

expand.row <- function(x) {
    with(x, {
        h <- trunc(open_time, 'hour') + 3600 # nearest full hour > open_time
        if (h > close_time)
            p <- c(open_time, close_time)
        else
            p <- unique(c(open_time, seq(h, close_time, 3600), close_time))
        n <- length(p)
        data.frame(ID = ID, open_time = p[seq(1, n - 1)],
                   close_time = p[seq(2, n)])
    })
}

expand.row <- function(x) {
    with(x, {
        h <- trunc(open_time, 'hour') + 3600 # nearest full hour > open_time
        if (h > close_time)
            p <- c(open_time, close_time)
        else
            p <- unique(c(open_time, seq(h, close_time, 3600), close_time))
        n <- length(p)
        data.frame(ID = ID, open_time = p[seq(1, n - 1)],
                   close_time = p[seq(2, n)])
    })
}

do.call(rbind, lapply(split(dat, seq(nrow(dat))), expand.row))
#    ID           open_time          close_time
#1.1  2 2017-10-30 16:51:57 2017-10-30 17:00:00
#1.2  2 2017-10-30 17:00:00 2017-10-30 18:00:00
#1.3  2 2017-10-30 18:00:00 2017-10-30 18:07:06
#2.1  1 2017-10-31 19:50:03 2017-10-31 20:00:00
#2.2  1 2017-10-31 20:00:00 2017-10-31 20:00:35
#3.1  2 2017-10-31 15:31:57 2017-10-31 16:00:00
#3.2  2 2017-10-31 16:00:00 2017-10-31 16:00:52
#4.1  1 2017-10-30 15:09:21 2017-10-30 16:00:00
#4.2  1 2017-10-30 16:00:00 2017-10-30 16:16:29
#5    2 2017-10-19 22:43:11 2017-10-19 22:43:11
#6    1 2017-10-25 22:15:23 2017-10-25 22:15:23
#7    2 2017-10-31 21:53:44 2017-10-31 21:59:03
#8    1 2017-10-31 22:06:18 2017-10-31 22:06:23
#9    2 2017-10-31 22:02:07 2017-10-31 22:02:07