Разделить данные непрерывных временных рядов на непостоянное время windows для нескольких периодов времени и нескольких групп - PullRequest
Новая
       37

Разделить данные непрерывных временных рядов на непостоянное время windows для нескольких периодов времени и нескольких групп

5 голосов
/ 04 мая 2020

У меня есть два набора данных: df1 содержит windows времени, которое соответствует пиковой активности id. Это непостоянные временные ряды, и существует несколько windows (событий) на id, т. Е. Каждый id имеет несколько периодов пиковой активности. Ниже приведен воспроизводимый пример, который я составил, но не является реальными данными (ПРИМЕЧАНИЕ: я обновил данные в соответствии с комментариями ниже). 

df1<-data.frame(start_date=seq(as.POSIXct("2014-09-04 00:00:00"), by = "hour", length.out = 10),
                end_date=seq(as.POSIXct("2014-09-04 05:00:00"), by = "hour", length.out = 10),
                             values=runif(20,10,50),id=rep(seq(from=1,to=5,by=1),2))

df2 - это набор непрерывных временных рядов активности автор: id. Я хочу подмножество date.date для каждого входа / пиковой активности в df1 (на id). 

date1<-data.frame(date=seq(as.POSIXct("2012-09-04 02:00:00"), by = "hour", length.out = 20), id=1)
date2<-data.frame(date=seq(as.POSIXct("2014-09-03 07:00:00"), by = "hour", length.out = 20),id=2)
date3<-data.frame(date=seq(as.POSIXct("2014-09-04 01:00:00"), by = "hour", length.out = 20),id=3)
df2<-data.frame(date=rbind(date1,date2,date3),values=runif(60,50,90))

Цель: подмножество непрерывных временных рядов в df2 только между start_time и end_time в df1 (по идентификатору), и сохранить поле values из каждого df . Есть несколько похожий вопрос здесь , но в этом случае период времени был stati c и известен. Я борюсь с тем, как это сделать, учитывая несколько событий для каждого идентификатора.

Ответы [ 2 ]

4 голосов
/ 12 мая 2020

data.table имеет функцию foverlaps, которая делает то, что вам нужно.

foverlaps означает «быстрое перекрытие соединений». Функция принимает два фрейма данных (в данном случае data.tables) и возвращает соединение.

Обе таблицы data.tables нуждаются в столбцах start и end для вычисления перекрытий. Поскольку у вас есть только один столбец даты в df2, я просто создаю столбец dummy_end с той же датой, что и date.date в df2.

Вы можете использовать параметры by.x и by.y, чтобы указать столбцы start и end. Однако вы также можете использовать для этого ключи, используя оператор setkey. Последние два элемента setkey должны быть столбцами start и end. Преимущество использования setkey заключается в том, что вы можете добавить дополнительные ключи (перед началом и концом) для дальнейшей фильтрации объединения. В данном случае я также установлю ключ для id.

[, dummy_end := NULL] используется для удаления столбца dummy_end. 

library(data.table)
dt1 <- data.table(df1)
dt2 <- data.table(df2)
setnames(dt2,"date.id","id") #change name to "id" for easier comparison
dt2[, dummy_end := date.date] #create dumme end date column 
setkey(dt1, id, start_date, end_date)
setkey(dt2, id, date.date,  dummy_end)

foverlaps(dt2, dt1, nomatch = NULL)[, dummy_end := NULL]

Что касается производительности, foverlaps немного быстрее, чем dplyr для этой конкретной проблемы (но все же медленнее, чем базовый R). Действительно, ниже вы можете увидеть, что я переделал микробенчмарк Пола, чтобы добавить data.table. Однако мне нравится чистый и простой синтаксис data.table.

DATA and Benchmark 

library(dplyr)
library(microbenchmark)
library(data.table)

df1 <- data.frame(start_date=seq(as.POSIXct("2014-09-04 00:00:00"), 
       by = "hour", length.out = 10),
       end_date=seq(as.POSIXct("2014-09-04 05:00:00"), 
       by = "hour", length.out = 10),
       values=runif(20,10,50),id=rep(seq(from=1,to=5,by=1),2))

date1 <-data.frame(date = seq(as.POSIXct("2012-09-04 02:00:00"), 
                              by = "hour", 
                              length.out = 20), id = 1)
date2 <-data.frame(date = seq(as.POSIXct("2014-09-03 07:00:00"), 
                              by = "hour", 
                              length.out = 20),id = 2)
date3 <-data.frame(date = seq(as.POSIXct("2014-09-04 01:00:00"), 
                              by = "hour", length.out = 20),id = 3)
df2 <-data.frame(date = rbind(date1,date2,date3), values = runif(60,50,90))

dt1 <- data.table(df1)
dt2 <- data.table(df2)
setnames(dt2,"date.id","id") #change name to "id" for easier comparison
dt2[, dummy_end := date.date] #create dumme end date column 
setkey(dt1, id, start_date, end_date)
setkey(dt2, id, date.date,  dummy_end)

dplyr2 <- function(df1, df2) {
  df <- left_join(df1, df2, by = c("id" = "date.id")) %>%
    group_by(id) %>%
    filter(date.date >= start_date &
             date.date <= end_date) %>%
    select(start_date,
           end_date,
           x_values = values.x,
           y_values = values.y,
           id,
           date.date) %>%
    ungroup()
}

baseR2 <- function(df1, df2) {
  df_bR <- merge(df1, df2, by.x = "id", by.y = "date.id")
  df_bR <- subset(
    df_bR,
    subset = df_bR$date.date >=  df_bR$start_date &
      df_bR$date.date <=  df_bR$end_date,
    select = c(start_date, end_date, values.x, values.y, id, date.date)
  )
}

data.table2 <- function(dt1, dt2) {
  foverlaps(dt2, dt1,nomatch = NULL)[, dummy_end := NULL]
}


microbenchmark(baseR = baseR2(df1, df2),
               dplyr = dplyr2(df1, df2),
               data.table=data.table2(dt1, dt2),
               times = 50)
Unit: milliseconds
       expr    min     lq     mean median     uq     max neval
      baseR 1.2328 1.3973 1.632302 1.4713 1.5596  7.0549    50
      dplyr 8.2126 8.6865 9.628708 8.8531 9.2621 19.5883    50
 data.table 6.6931 7.3884 7.974340 7.9406 8.3973 11.0060    50
3 голосов
/ 07 мая 2020

Ваша цель не совсем ясна для меня, но это мое прочтение: если время (игнорировать дату) в date.date находится в пределах start_date и end_date, вы хотели бы подмножество по Id.

Вот как я приблизился к этому: 

library(dplyr)

df1<-data.frame(start_date=seq(as.POSIXct("2014-09-04 00:00:00"), by = "hour", length.out = 10),
                end_date=seq(as.POSIXct("2014-09-04 05:00:00"), by = "hour", length.out = 10),
                values=runif(20,10,50),id=rep(seq(from=1,to=5,by=1),2))

date1<-data.frame(date=seq(as.POSIXct("2012-10-01 00:00:00"), by = "hour", length.out = 20), id=1)
date2<-data.frame(date=seq(as.POSIXct("2014-10-01 07:00:00"), by = "hour", length.out = 20), id=2)
date3<-data.frame(date=seq(as.POSIXct("2015-10-01 01:00:00"), by = "hour", length.out = 20), id=3)
df2<-data.frame(date=rbind(date1,date2,date3),values=runif(60,50,90))

df <- left_join(df1, df2, by = c("id" = "date.id")) %>%
  mutate(date.date.hms = strftime(date.date, format = "%H:%M:%S"),
         start_date.hms = strftime(start_date, format = "%H:%M:%S"),
         end_date.hms = strftime(end_date, format = "%H:%M:%S")) %>%
  mutate(date.date.hms = as.POSIXct(date.date.hms, format="%H:%M:%S"),
         start_date.hms = as.POSIXct(start_date.hms, format="%H:%M:%S"),
         end_date.hms = as.POSIXct(end_date.hms, format="%H:%M:%S")) %>%
  group_by(id) %>% 
  filter(date.date.hms >= start_date.hms & date.date.hms <= end_date.hms) %>%
  select(start_date, end_date, x_values = values.x, y_values = values.y, id, date.date) %>%
  ungroup()

Это приводит к следующему кадру данных: 

> df
# A tibble: 62 x 6
   start_date          end_date            x_values y_values    id date.date          
   <dttm>              <dttm>                 <dbl>    <dbl> <dbl> <dttm>             
 1 2014-09-04 00:00:00 2014-09-04 05:00:00     31.5     77.5     1 2012-10-01 00:00:00
 2 2014-09-04 00:00:00 2014-09-04 05:00:00     31.5     54.5     1 2012-10-01 01:00:00
 3 2014-09-04 00:00:00 2014-09-04 05:00:00     31.5     70.3     1 2012-10-01 02:00:00
 4 2014-09-04 00:00:00 2014-09-04 05:00:00     31.5     85.5     1 2012-10-01 03:00:00
 5 2014-09-04 00:00:00 2014-09-04 05:00:00     31.5     82.2     1 2012-10-01 04:00:00
 6 2014-09-04 00:00:00 2014-09-04 05:00:00     31.5     57.4     1 2012-10-01 05:00:00
 7 2014-09-04 01:00:00 2014-09-04 06:00:00     37.0     78.8     2 2014-10-02 01:00:00
 8 2014-09-04 01:00:00 2014-09-04 06:00:00     37.0     51.9     2 2014-10-02 02:00:00
 9 2014-09-04 02:00:00 2014-09-04 07:00:00     34.1     85.8     3 2015-10-01 02:00:00
10 2014-09-04 02:00:00 2014-09-04 07:00:00     34.1     69.4     3 2015-10-01 03:00:00

Мой подход заключался в том, чтобы сначала присоединиться к DF по Id, а затем разделить информацию о времени от даты (в столбцы .hms) в виде строки и преобразовать ее обратно в объект POSIXct. Это добавляет сегодняшнюю дату ко времени, но это нормально, если я просто хочу применить фильтр по времени (а не по дате). В результате получается DF, в котором записи имеют date.date TIME в пределах start_date и end_date. теперь его легко разбить по столбцу Id.

Это то, что вам нужно?

ОБНОВЛЕНИЕ

LauraR объяснил, что даты в df1 и df2 перекрываются. В своем примере она обновила df1 и df2. С этим обновлением я могу переписать код без преобразования POSIXct в символ и наоборот. похоже, что as.POSIXct - медленная операция.

Теперь я могу сделать следующее:

  • удалить все преобразования даты и времени и только проверять, находится ли дата-время в df2 в пределах диапазона даты и времени df1
  • перепишите код в dplyr и baseR: мы знаем, что конвейер создает значительные накладные расходы.
  • превратить код в функции, чтобы я мог их протестировать.

С кодом : 

library(dplyr)
library(microbenchmark)

df1 <- data.frame(start_date=seq(as.POSIXct("2014-09-04 00:00:00"), by = "hour", length.out = 10),
                  end_date=seq(as.POSIXct("2014-09-04 05:00:00"), by = "hour", length.out = 10),
                  values=runif(20,10,50),id=rep(seq(from=1,to=5,by=1),2))

date1 <-data.frame(date = seq(as.POSIXct("2012-09-04 02:00:00"), 
                              by = "hour", 
                              length.out = 20), id = 1)
date2 <-data.frame(date = seq(as.POSIXct("2014-09-03 07:00:00"), 
                              by = "hour", 
                              length.out = 20),id = 2)
date3 <-data.frame(date = seq(as.POSIXct("2014-09-04 01:00:00"), 
                              by = "hour", l
                              ength.out = 20),id = 3)
df2 <-data.frame(date = rbind(date1,date2,date3), values = runif(60,50,90))

dplyr2 <- function(df1, df2) {
  df <- left_join(df1, df2, by = c("id" = "date.id")) %>%
    group_by(id) %>%
    filter(date.date >= start_date &
             date.date <= end_date) %>%
    select(start_date,
           end_date,
           x_values = values.x,
           y_values = values.y,
           id,
           date.date) %>%
    ungroup()
}

baseR2 <- function(df1, df2) {
  df_bR <- merge(df1, df2, by.x = "id", by.y = "date.id")
  df_bR <- subset(
    df_bR,
    subset = df_bR$date.date >=  df_bR$start_date &
      df_bR$date.date <=  df_bR$end_date,
    select = c(start_date, end_date, values.x, values.y, id, date.date)
  )
}

data_baseR <- baseR2(df1, df2)
data_dplyr <- dplyr2(df1, df2)

microbenchmark(baseR = baseR2(df1, df2),
               dplyr = dplyr2(df1, df2),
               times = 5)

Этот код намного быстрее, чем раньше, и я уверен, что он потребует меньше памяти. Сравнение dplyr и baseR: 

> data_baseR <- baseR2(df1, df2)
> microbenchmark(baseR = baseR2(df1, df2),
+                dplyr = dplyr2(df1, df2),
+                times = 5)
Unit: microseconds
  expr    min     lq    mean median     uq    max neval
 baseR  897.5  905.3 1868.66  991.2 1041.0 5508.3     5
 dplyr 5755.9 5970.2 6158.88 6277.4 6393.3 6397.6     5

показывает, что код baseR выполняется намного быстрее.

...