Объединить перекрывающиеся интервалы в R

Question

Я пытаюсь объединить перекрывающиеся интервалы, чтобы вычислить сумму уникальных интервалов при удалении исключенных интервалов.

Вот минимальный рабочий пример:

mydata <- data.frame(interval = c(1,2,3,4,5,6,7,8,9,10),
                     timeoutStart = c(280,500,NA,NA,NA,NA,NA,NA,NA,NA),
                     timeoutEnd = c(310,530,NA,NA,NA,NA,NA,NA,NA,NA),
                     cheeringStart = c(1,181,205,330,460,740,NA,NA,NA,NA),
                     cheeringEnd = c(120,199,300,420,475,760,NA,NA,NA,NA),
                     possessionStart = c(80,180,210,250,350,450,550,650,750,800),
                     possessionEnd = c(130,200,220,280,400,499,600,700,800,950)
)

interval timeoutStart timeoutEnd cheeringStart cheeringEnd possessionStart possessionEnd
       1          280        310             1         120              80           130
       2          500        530           181         199             180           200
       3           NA         NA           205         300             210           220
       4           NA         NA           330         420             250           280
       5           NA         NA           460         475             350           400
       6           NA         NA           740         760             450           499
       7           NA         NA            NA          NA             550           600
       8           NA         NA            NA          NA             650           700
       9           NA         NA            NA          NA             750           800
      10           NA         NA            NA          NA             800           950

В минимальном рабочем примере вышеЯ хотел бы подсчитать общее время, которое команда проводит за аплодисменты или владеет мячом (исключая тайм-ауты).Значения в матрице представляют время начала и окончания (секунды, прошедшие с начала игры) различных интервалов для каждого результата (timeout, cheering или possession).Результаты не являются взаимоисключающими и могут происходить одновременно.Однако я не хочу «пересчитывать» перекрывающиеся интервалы cheering и possession.То есть я хочу объединить перекрывающиеся интервалы cheering и possession, чтобы я мог суммировать «уникальные» интервалы.

Например, один интервал аплодисментов происходит от 740 до 760 секунд, тогда какинтервал владения перекрывается с этим интервалом (от 750 до 800 секунд).Интервал объединения составит от 740 до 800 секунд (продолжительность = 60 секунд).

После объединения перекрывающихся интервалов для cheering и possession я хочу исключить интервалы тайм-аута.Например, для уникального интервала от 205 до 300 секунд я хочу исключить интервал ожидания от 280 до 310 секунд.Таким образом, уникальный интервал, исключающий интервал времени ожидания, будет от 205 до 280 секунд (продолжительность = 75 секунд).

Я хочу рассчитать продолжительность каждого уникального интервала (End - Start), исключая интервалы времени ожиданияи затем вычислите сумму всех этих уникальных интервалов (исключая интервалы времени ожидания).Наконец, я хотел бы иметь возможность включать или исключать интервалы из расчета на основе значения другой переменной (keep = 0 или 1) в этой строке.

Давайте предположим, что Start и End столбцы времени предварительно не отсортированы.Я также хотел бы, чтобы подход был обобщаемым, чтобы можно было легко добавлять несколько дополнительных наборов столбцов для включения в сумму (например, дриблинг, прохождение и т. Д.).Я посмотрел на другие ответы, но не нашел способа обобщить их решения для моей ситуации.

Answer 1

Как насчет этого?

mydata <- data.frame(interval = c(1,2,3,4,5,6,7,8,9,10),
                     timeoutStart = c(280,500,NA,NA,NA,NA,NA,NA,NA,NA),
                     timeoutEnd = c(310,530,NA,NA,NA,NA,NA,NA,NA,NA),
                     cheeringStart = c(1,181,205,330,460,740,NA,NA,NA,NA),
                     cheeringEnd = c(120,199,300,420,475,760,NA,NA,NA,NA),
                     possessionStart = c(80,180,210,250,350,450,550,650,750,800),
                     possessionEnd = c(130,200,220,280,400,499,600,700,800,950),
                     keep = c(rep(FALSE, 2), rep(TRUE, 8)) #added for illustration
)

#add whatever columns you want to use to calculate the merged interval
#they must be in the same order in both vectors
#e.g. if 'cheeringStart' is at index 1, so must 'cheeringEnd'
intervalStartCols <- c('cheeringStart', 'possessionStart')
intervalEndCols <- c('cheeringEnd', 'possessionEnd')
intervalCols <- c(intervalStartCols, intervalEndCols)
timeoutCols <- c('timeoutStart', 'timeoutEnd')

mydata$mergedDuration <- apply(mydata, MARGIN = 1, FUN = function(row){

  #return zero if all NAs
  if(all(is.na(row[intervalCols]))) return(0)

  if(!all(is.na(row[timeoutCols]))){
    timeout.start <- row['timeoutStart']
    timeout.end <- row['timeoutEnd']
  } else {
    timeout.end <- 0
  }

  #identify the maximum time (this will be the end of the merged interval)
  max.end <- max(row[intervalEndCols], na.rm=TRUE)

  #set intial values
  duration <- 0
  segment.complete <- FALSE
  start.i <- which(row[intervalStartCols] == min(row[intervalStartCols], na.rm=TRUE))
  next.step <- row[intervalStartCols][start.i]

  waypoints <- row[intervalCols]
  waypoints <- waypoints[!is.na(waypoints)]
  waypoints <- waypoints[waypoints!=next.step]

  #calculate interval duration adjusting for overlap
  while(next.step < max.end){

    start <- row[intervalStartCols][start.i]

    next.step <- waypoints[waypoints == min(waypoints[waypoints!=next.step])]
    if(segment.complete){
      start.i <- which(row[intervalStartCols] == next.step)
      segment.complete <- FALSE
    }
    end.i <- which(row[intervalEndCols] == next.step)

    waypoints <- waypoints[waypoints!=next.step]

    if(length(end.i) > 0 && length(start.i) >0 && end.i == start.i) {

      segment.start <- row[intervalStartCols][start.i]
      segment.end <- row[intervalEndCols][end.i]
      segment.duration <- segment.end - segment.start

      #adjust for timeout
      timeout.adj <- {
        if (timeout.end == 0) 0 #this is the NA case
        else if(timeout.start > segment.end | timeout.end < segment.start) 0
        else if(timeout.end > segment.end & timeout.start < segment.start) segment.duration
        else if(timeout.end < segment.end) timeout.end - segment.start
        else segment.end - timeout.start
      }

      duration <- duration + segment.duration - timeout.adj
      segment.complete <- TRUE
    }

  }

  duration
})

#sum duration using 'keep' column as mask
summed.duration <- sum(mydata[mydata$keep, 'mergedDuration'])
print(summed.duration)

Answer 2

здесь представлены решения, использующие data.table foverlaps(), для выполнения наложения-объединения.Это только частичное решение ... предоставление желаемого результата поможет.Но вы, вероятно, можете использовать этот код, чтобы получить то, что вы хотите ..

, если ваши данные названы df

library( data.table )

#create data.tables for cheers and possession
cheers.dt <- data.table( interval.cheer = df$interval, 
                     start.cheer = df$cheeringStart, 
                     end.cheer = df$cheeringEnd )[!is.na(start.cheer),]
possession.dt <- data.table( interval.pos = df$interval, 
                             start.pos = df$possessionStart, 
                             end.pos = df$possessionEnd )
#set keys
setkey( cheers.dt, start.cheer, end.cheer )
#perform overlap-join
foverlaps( possession.dt, 
           cheers.dt, 
           by.x = c( "start.pos", "end.pos" ), 
           type = "any", 
           mult = "all", 
           nomatch = NULL )

#    interval.cheer start.cheer end.cheer interval.pos start.pos end.pos
# 1:              1           1       120            1        80     130
# 2:              2         181       199            2       180     200
# 3:              3         205       300            3       210     220
# 4:              3         205       300            4       250     280
# 5:              4         330       420            5       350     400
# 6:              5         460       475            6       450     499
# 7:              6         740       760            9       750     800

Я советую вам прочитать о data.table foverlaps() -функция и неравные соединения.