logo标签列表

在R中查找所有具有重叠开始和结束日期的日期范围

rdatetimedate-range
3

我有一个数据框，长这样：

w<-read.table(header=TRUE,text="
start.date   end.date
2006-06-26 2006-07-24
2006-07-19 2006-08-16
2007-06-09 2007-07-07
2007-06-24 2007-07-22
2007-07-03 2007-07-31
2007-08-04 2007-09-01
2007-08-07 2007-09-04
2007-09-05 2007-10-03
2007-09-14 2007-10-12
2007-10-19 2007-11-16
2007-11-17 2007-12-15
2008-06-18 2008-07-16
2008-06-28 2008-07-26
2008-07-11 2008-08-08
2008-07-23 2008-08-20")

我想获取一个输出，将重叠的开始日期和结束日期合并成一个日期范围。对于这个示例集，我希望得到：

w<-read.table(header=TRUE,text="
start.date   end.date
2006-06-26 2006-08-16
2007-06-09 2007-07-31
2007-08-04 2007-09-04
2007-09-05 2007-10-12
2007-10-19 2007-11-16
2007-11-17 2007-12-15
2008-06-18 2008-08-20")

这个问题类似于R中的日期汇总，但我不需要对我的数据进行任何分组，因此那里提供的答案很困惑。

另外，对于我的数据框中的某些部分，下面针对我的问题提出的代码无法工作：

x<-read.table(header=TRUE,text="start.date   end.date
2006-01-19 2006-01-20
2006-01-25 2006-01-29
2006-02-24 2006-02-25
2006-03-15 2006-03-22
2006-04-29 2006-04-30
2006-05-24 2006-05-25
2006-06-26 2006-08-16
2006-07-05 2006-07-10
2006-07-12 2006-07-21
2006-08-13 2006-08-15
2006-08-18 2006-08-19
2006-08-28 2006-09-02")

我感到困惑，为什么它不能正常工作？
4
library(dplyr); w %>% mutate(gr = cumsum(start.date-lag(end.date, default=1)>=0 )) %>% group_by(gr) %>% summarise(start.date = min(start.date), end.date = max(end.date))这段代码使用了dplyr包，并对数据框w进行了处理。它基于start.date和end.date列的值，将数据分成多个组，并计算出每个组的起始日期和结束日期。其中，gr变量是通过cumsum函数和逻辑运算符生成的，用于标记组的变化点。最后，使用group_by和summarise函数生成摘要信息。 - Khashaa
可能是在R中进行日期滚动的重复问题。 - Ronak Shah
1
这不是那个问题的重复@RonakShah——那个问题在考虑日期的连续性，而我的问题则在考虑日期的重叠。 - lg929
4个回答
4

Bioconductor上的IRanges软件包中包含函数reduce，可用于将重叠的开始和结束日期合并为一个日期范围。

IRanges适用于整数范围，因此您需要将数据从Date类转换为integer类，然后再转换回来。这可以封装在一个函数中：

collapse_date_ranges <- function(w, min.gapwidth = 1L) {
  library(data.table)
  library(magrittr)
  IRanges::IRanges(start = as.integer(as.Date(w$start.date)), 
                   end = as.integer(as.Date(w$end.date))) %>% 
    IRanges::reduce(min.gapwidth = min.gapwidth) %>% 
    as.data.table() %>% 
    .[, lapply(.SD, lubridate::as_date),
      .SDcols = c("start", "end")]
}

collapse_date_ranges(w, 0L)
#        start        end
#1: 2006-06-26 2006-08-16
#2: 2007-06-09 2007-07-31
#3: 2007-08-04 2007-09-04
#4: 2007-09-05 2007-10-12
#5: 2007-10-19 2007-11-16
#6: 2007-11-17 2007-12-15
#7: 2008-06-18 2008-08-20

collapse_date_ranges(x, 0L)
#        start        end
#1: 2006-01-19 2006-01-20
#2: 2006-01-25 2006-01-29
#3: 2006-02-24 2006-02-25
#4: 2006-03-15 2006-03-22
#5: 2006-04-29 2006-04-30
#6: 2006-05-24 2006-05-25
#7: 2006-06-26 2006-08-16
#8: 2006-08-18 2006-08-19
#9: 2006-08-28 2006-09-02

解释

  • 为了避免名称冲突，我更喜欢使用双冒号运算符::来访问IRanges包中的单个函数，而不是使用library(IRanges)来加载整个包。
  • 起始日期和结束日期被转换为整数（as.Date仅确保正确的类），并创建一个IRanges对象。
  • reduce完成所有繁重的工作。参数min.gapwidth在这里是必需的，因为reduce默认折叠相邻的范围（见下文）。
  • 最后，结果从整数转换回日期。（您也可以使用dplyr代替data.table。）
  • 该解决方案适用于样本数据集w和x。 x包括一种特殊情况，其中一个日期范围嵌套到其他日期范围中以完全覆盖。

附录：折叠相邻日期范围

样例结果显示，相邻的数据范围不应该被合并，例如，范围从2007-10-19到2007-11-16与范围从2007-11-17到2007-12-15是分开的，尽管第二个范围仅在第一个范围结束后一天开始。
为了防止相邻日期范围被合并，可以使用min.gapwidth参数的默认值。
collapse_date_ranges(w)
#        start        end
#1: 2006-06-26 2006-08-16
#2: 2007-06-09 2007-07-31
#3: 2007-08-04 2007-10-12
#4: 2007-10-19 2007-12-15
#5: 2008-06-18 2008-08-20
1

试试这个：

w[] <- lapply(w, function(x) as.Date(x, '%Y-%m-%d'))
w <- w[order(w$start.date),] # sort the data by start dates if already not sorted
w$group <- 1:nrow(w) # common intervals should belong to same group
merge.indices <- lapply(2:nrow(w), function(x) {
                    indices <- which(findInterval(w$end.date[1:(x-1)], w$start.date[x])==1)
                    if (length(indices) > 0) indices <- c(indices, x) 
                    indices})
# assign the intervals the right groups
for (i in 1:length(merge.indices)) {
  if (length(merge.indices[[i]]) > 0) {
    w$group[merge.indices[[i]]] <- min(w$group[merge.indices[[i]]])
  }
}

do.call(rbind, lapply(split(w, w$group), function(x) data.frame(start.date=min(x[,1]), end.date=max(x[,2]))))

它将有重叠的区间概念上合并为同一组，如下所示： enter image description here 输出结果为：
   start.date   end.date
1  2006-01-19 2006-01-20
2  2006-01-25 2006-01-29
3  2006-02-24 2006-02-25
4  2006-03-15 2006-03-22
5  2006-04-29 2006-04-30
6  2006-05-24 2006-05-25
7  2006-06-26 2006-08-16
11 2006-08-18 2006-08-19
12 2006-08-28 2006-09-02
当我将新数据输入到你们两个提出的代码中时，似乎它不再起作用了@Khashaa。我不确定如何在评论中插入示例数据，因此我将更新我的问题并添加新数据。 - lg929
请问您能否解释一下为什么它不起作用，如果我正确理解了我们的要求，我认为它仍然可以产生所需的输出。 - Sandipan Dey
在我提供的最后一个样本数据中，第8-10行应该合并到第7行“2006-06-26 2006-08-16”，但是代码现在创建了一个新的日期范围“2006-06-26 2006-07-10”。 - lg929
这三个起始/结束日期范围："2006-07-05 2006-07-10"、"2006-07-12 2006-07-21"、"2006-08-13 2006-08-15"，应该是"2006-06-26 2006-08-16"日期范围的一部分，因为它们与"2006-06-26 2006-08-16"相重叠。它们不应该被包含在结果数据框中，但它们仍然出现了。如果我表述不够清晰，请告诉我。 - lg929
已经明白了，更新了帖子并提供了更通用的解决方案，它应该适用于早期和当前数据集。 - Sandipan Dey
0

对于任何参考此旧问题的人，这里有一个使用专门处理区间的软件包的新选项：

library(tidyverse)
library(ivs)

w <- read.table(header = TRUE, text = "
start.date   end.date
2006-06-26 2006-07-24
2006-07-19 2006-08-16
2007-06-09 2007-07-07
2007-06-24 2007-07-22
2007-07-03 2007-07-31
2007-08-04 2007-09-01
2007-08-07 2007-09-04
2007-09-05 2007-10-03
2007-09-14 2007-10-12
2007-10-19 2007-11-16
2007-11-17 2007-12-15
2008-06-18 2008-07-16
2008-06-28 2008-07-26
2008-07-11 2008-08-08
2008-07-23 2008-08-20")

w |> 
  mutate(iv = iv(start.date, end.date)) |> 
  summarise(iv = iv_groups(iv), .groups = "drop")
#>                         iv
#> 1 [2006-06-26, 2006-08-16)
#> 2 [2007-06-09, 2007-07-31)
#> 3 [2007-08-04, 2007-09-04)
#> 4 [2007-09-05, 2007-10-12)
#> 5 [2007-10-19, 2007-11-16)
#> 6 [2007-11-17, 2007-12-15)
#> 7 [2008-06-18, 2008-08-20)

由reprex package (v2.0.1)于2022年5月27日创建

0

解决方案。

w<-read.table(header=TRUE, stringsAsFactor=F, text="
start.date   end.date
2006-06-26 2006-07-24
2006-07-19 2006-08-16
2007-06-09 2007-07-07
2007-06-24 2007-07-22
2007-07-03 2007-07-31
2007-08-04 2007-09-01
2007-08-07 2007-09-04
2007-09-05 2007-10-03
2007-09-14 2007-10-12
2007-10-19 2007-11-16
2007-11-17 2007-12-15
2008-06-18 2008-07-16
2008-06-28 2008-07-26
2008-07-11 2008-08-08
2008-07-23 2008-08-20")

w <- data.frame(lapply(w, as.Date))

library(lubridate)

idx.rle <- rle(as.numeric(sapply(1:(nrow(w)-1), function(i) int_overlaps(interval(w[i,1],w[i,2]), interval(w[i+1,1],w[i+1,2])))))




i.starts <- nrow(w)-rev(cumsum(rev(idx.rle$length)))
i.ends <-  1+cumsum(idx.rle$length)

 do.call(rbind,
    lapply(1:length(idx.rle$lengths),
           function(i) {
               i.start <- i.starts[i]
               i.end <-  i.ends[i]
               if(idx.rle$values[i]==1) {
                   d <- data.frame(start.date=w[i.start,1],
                                   end.date=max(w[i.start:i.end,2]) );
                   names(d) <- names(w);
                   d
               } else {
                   if(idx.rle$lengths[i]>1&i>1&i<length(idx.rle$lengths)) {
                       data.frame(w[(i.start+1):(i.end-1),] )
                   } else {
                       if (idx.rle$lengths[i]>=1&i==1) {
                           data.frame(w[(i.start):(i.end-1),])
                       } else {
                           if(idx.rle$lengths[i]>=1&i==length(idx.rle$lengths)) data.frame(w[(i.start+1):(i.end),] ) 
                       }
                   }
               }
           }))
我收到了这个错误：match.names(clabs, names(xi)) 中的错误： 名称与先前的名称不匹配。 - lg929
你在"w"中使用了不准确的"start.date"和"end.date"名称。我已经修复了它。 - p2004r
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接