按新年拆分日期行答案

【问题标题】：Split date rows by new year按新年拆分日期行
【发布时间】：2019-05-19 10:11:38
【问题描述】：

我有来自一家医院的数据，其中包含许多变量，还有每一行的起止日期，它告诉我们每一行何时“有效”。每行最长有效期为一年。

test = data.frame(ID=c(10,10,10,12,12), Disease=c("P","P","P","D","P"), Pass=c("US","US","US","EN","EN"),
                  Payment=c(110,110,115,240,255), 
                  from_date=as.POSIXct(c("2008-01-09","2009-01-09","2010-01-09","2008-01-01","2013-12-31")),
                  to_date=as.POSIXct(c("2009-01-08","2010-01-08","2011-01-08","2008-12-31","2014-12-30"))
                  )

对于从一年到另一年的行，我想拆分行，这样我最终得到两行而不是原始行，并且还操纵 from_date 和 to_date，这样我最终得到一个如下所示的新数据集：

  test_desired = data.frame(ID=c(10,10,10,10,10,10,12,12,12), Disease=c("P","P","P","P","P","P","D","P","P"), Pass=c("US","US","US","US","US","US","EN","EN","EN"),
                              Payment=c(110,110,110,110,115,115,240,255,255), 
                              from_date=as.POSIXct(c("2008-01-09","2009-01-01","2009-01-09","2009-01-01","2010-01-09","2011-01-01","2008-01-01","2013-12-31","2014-01-01")),
                              to_date=as.POSIXct(c("2008-12-31","2009-01-08","2009-12-31","2010-01-08","2010-12-31","2011-01-08","2008-12-31","2013-12-31","2014-12-30"))
    )

尝试：

library(lubridate) #for function "year" below
test_desired=test
row=c()
tmp=c()
for(i in 1:nrow(test_desired)){
  if(year(test_desired$from_date)[i]<year(test_desired$to_date)[i]){
    test_desired$to_date[i] = as.POSIXct(paste0(year(test_desired$from_date[i]),"-12-31"))
    row = test_desired[i,]
    row$from_date = as.POSIXct(paste0(year(test$to_date[i]),"-01-01"))
    row$to_date = test$to_date[i]
    tmp=rbind(tmp,row)

  } else next
}
test_desired=rbind(test_desired,tmp)
library(dplyr)
test_desired=arrange(test_desired,ID,from_date)

有没有更优雅的方法，例如使用 dplyr？

【问题讨论】：

标签： r

【解决方案1】：

这是一个基于 tidyverse 的解决方案。它与 Lennyy 的类似，但条件检查更少，并且添加时间没有问题（它们可能出现在小标题中，但显示为 00:00:00）。我添加了ungroup()，因为听起来您在某处有一个分组变量（在 Lennyy 的解决方案下评论）。如果你不这样做，它可以被删除：

library(dplyr)
library(lubridate)
library(purrr)

test %>% 
    ungroup() %>% # This isn't necessary if there are no groupings.
    split(rownames(test)) %>% 
    map_dfr(function(df){
        if (year(df$from_date) == year(df$to_date)) return(df)
        bind_rows(mutate(df, to_date = rollback(floor_date(to_date, "y"))),
                  mutate(df, from_date = floor_date(to_date, "y"))
                  )
    }
    )

#### OUTPUT ####

  ID Disease Pass Payment  from_date    to_date
1 10       P   US     110 2008-01-09 2008-12-31
2 10       P   US     110 2009-01-01 2009-01-08
3 10       P   US     110 2009-01-09 2009-12-31
4 10       P   US     110 2010-01-01 2010-01-08
5 10       P   US     115 2010-01-09 2010-12-31
6 10       P   US     115 2011-01-01 2011-01-08
7 12       D   EN     240 2008-01-01 2008-12-31
8 12       P   EN     255 2013-12-31 2013-12-31
9 12       P   EN     255 2014-01-01 2014-12-30

解释：数据框被拆分为行列表。然后我使用map_dfr 在from_date 和to_date 包含不同年份的每个数据帧上运行该函数。 map_dfr 还将生成的数据帧绑定在一起。在匿名函数中，我按年份将to_date 降级，然后将其回滚到上个月的最后一天以在第一行中获取新的to_date，或者将其保留为新的from_date在第二行。

【讨论】：

【解决方案2】：

使用 from_date 和 to_date 我们可以使用seq.Date 创建一个日期序列，然后按年份拆分该序列，最后选择每年的最小值和最大值。然后使用apply、separate_rows和separate得到最终结果。

cr_date <- function(d1, d2){
    #browser()
    sequence_date <- seq.Date(as.Date(d1), as.Date(d2), by='day') 
    lst_dates <- lapply(split(sequence_date, lubridate::year(sequence_date)),
                        function(x) paste0(min(x), '|', max(x)))
    result <- paste0(lst_dates, collapse = ';')
    return(result)
  }

#Test
#cr_date(as.Date('2008-01-09'),as.Date('2009-01-08'))
test$flag <- apply(test, 1, function(x) cr_date(x['from_date'], x['to_date']))

library(tidyr)
separate_rows(test, flag, sep=';') %>% 
  separate(flag, into = c('from_date_new','to_date_new'), '\\|') %>% 
  mutate_at(vars('from_date_new','to_date_new'), list(~as.Date(.)))


    ID Disease Pass Payment  from_date    to_date from_date_new to_date_new
  1 10       P   US     110 2008-01-09 2009-01-08    2008-01-09  2008-12-31
  2 10       P   US     110 2008-01-09 2009-01-08    2009-01-01  2009-01-08
  3 10       P   US     110 2009-01-09 2010-01-08    2009-01-09  2009-12-31
  4 10       P   US     110 2009-01-09 2010-01-08    2010-01-01  2010-01-08
  5 10       P   US     115 2010-01-09 2011-01-08    2010-01-09  2010-12-31
  6 10       P   US     115 2010-01-09 2011-01-08    2011-01-01  2011-01-08
  7 12       D   EN     240 2008-01-01 2008-12-31    2008-01-01  2008-12-31
  8 12       P   EN     255 2013-12-31 2014-12-30    2013-12-31  2013-12-31
  9 12       P   EN     255 2013-12-31 2014-12-30    2014-01-01  2014-12-30

【讨论】：

这给了我一个错误，to_dates 变成了 NA: Warning message: Expected 2pieces。在 3547 行 [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20 中填充了 NA 的缺失部分, ...]。
是的，它是由单独生产的。我的数据集非常大，您是否正在寻找特别的东西？
那么，最后一个问题，这不维护新日期列的日期格式，对吗？
@Erosennin 是的，这是正确的。请参阅我处理此问题的更新。

【解决方案3】：

这仅使用基础 R。

首先请注意，只使用没有时间的日期，因此我们应该使用Date 类，而不是POSIXct。后者可能会不必要地引入时区错误，除非您非常小心，因此在最后的注释中显示使用的输入，我们假设我们从包含 Date 类数据的 test2 开始。 Note 中的代码还显示了如何将其转换为 Date 类，如果它已经是 POSIXct。

给定test2，我们添加from_year、to_year 和eoy（年末日期）列给出test3。然后我们遍历行，如果年份相同则返回该行，否则返回拆分行。这给出了我们rbind 在一起的一排和两排数据帧的列表。

test3 <- transform(test2, 
  from_year = format(from_date, "%Y"),
  to_year = format(to_date, "%Y"),
  eoy = as.Date(sub("-.*", "-12-31", from_date)))

nr <- nrow(test2)
do.call("rbind", lapply(1:nr, function(i) with(test3[i, ],
  if (from_year == to_year) test2[i, ]
  else data.frame(ID, Disease, Pass, Payment, 
      from_date = c(from_date, eoy+1),
      to_date = c(eoy, to_date)))
))

注意

假定输入以可重现的形式。如上所述，它使用Date 类。

test2 <- transform(test, 
  from_date = as.Date(from_date),
  to_date = as.Date(to_date))

【讨论】：

【解决方案4】：

您也可以使用dplyr 和lubridate 尝试以下操作。它的工作原理如下： 1. 使用rbind 复制数据帧。 2. 首先在ID 上排列，其次在from_date 上，第三在test 中给出的行顺序上。 3. 在偶数行中，将from_date 更改为大年初一。 4. 在奇数行中，将to_date 更改为上一年的最后一天。 5、最后排除from_date和to_date相差只有1秒的行。

test %>% 
  rbind(test) %>% 
  arrange(ID, from_date) %>% 
  mutate(from_date = if_else(row_number() %% 2 == 0, ceiling_date(from_date, "year") + 1, from_date),
         to_date = if_else(row_number() %% 2 == 1, floor_date(to_date, "year") - 1, to_date)) %>% 
  filter(from_date - to_date != 1)

  ID Disease Pass Payment           from_date             to_date
1 10       P   US     110 2008-01-09 00:00:00 2008-12-31 23:59:59
2 10       P   US     110 2009-01-01 00:00:01 2009-01-08 00:00:00
3 10       P   US     110 2009-01-09 00:00:00 2009-12-31 23:59:59
4 10       P   US     110 2010-01-01 00:00:01 2010-01-08 00:00:00
5 10       P   US     115 2010-01-09 00:00:00 2010-12-31 23:59:59
6 10       P   US     115 2011-01-01 00:00:01 2011-01-08 00:00:00
7 12       D   EN     240 2008-01-01 00:00:01 2008-12-31 00:00:00
8 12       P   EN     255 2013-12-31 00:00:00 2013-12-31 23:59:59
9 12       P   EN     255 2014-01-01 00:00:01 2014-12-30 00:00:00

唯一的缺点可能是添加了时间，但您当然可以删除这些时间。如果一个时期可能在第三年继续，您可以使用相同的逻辑，但使用第二个 rbind 和 row_number() %% 3 == 0

【讨论】：

我得到一个错误：错误：列from_date不能被修改，因为它是一个分组变量
当您从 OP 加载 test 时，没有分组变量。否则先运行ungroup
哦，我认为我对 dplyr 缺乏了解是这里的问题，对不起！如何取消组合？
@Erosennin 只需在test %>%下方添加ungroup() %>%

【解决方案5】：

我只是使用data.table，它还提供了yearfunction 并使用as.POSIXct 忽略可能较慢的日期转换逻辑。

我还假设to_date 和from_date 可能仅相差一年（不超过一年！）。

library(data.table)  # also provides a "year" function

setDT(test)

# Create additional rows for the new year
additional_rows <- test[year(from_date) < year(to_date), ]
additional_rows[, from_date := as.POSIXct(paste0(year(to_date),"-01-01"))]

# Shorten the "from_date" of the affected original rows
test[year(from_date) < year(to_date), to_date := as.POSIXct(paste0(year(from_date),"-12-31"))]

# Create a combined data table as result
result <- rbind(test, additional_rows)
setkey(result, ID, Payment, from_date)  # just to sort the data like the "test_desired" sort order

导致

> result
   ID Disease Pass Payment  from_date    to_date
1: 10       P   US     110 2008-01-09 2008-12-31
2: 10       P   US     110 2009-01-01 2009-01-08
3: 10       P   US     110 2009-01-09 2009-12-31
4: 10       P   US     110 2010-01-01 2010-01-08
5: 10       P   US     115 2010-01-09 2010-12-31
6: 10       P   US     115 2011-01-01 2011-01-08
7: 12       D   EN     240 2008-01-01 2008-12-31
8: 12       P   EN     255 2013-12-31 2013-12-31
9: 12       P   EN     255 2014-01-01 2014-12-30

【讨论】：

我在测试这个解决方案时遇到了困难，因为我正在使用 dplyr 和 lubridate 并加载 data.table 掩盖了一些我已经在使用的功能。
有哪些困难（症状）？一个“简单”的解决方案是修改library 语句的顺序（首先加载的包会胜出，直到您使用包名指定函数名，例如data.table::year。所以：尝试将library(data.table) 放在末尾所有其他 library 语句，它应该可以工作......