Мне нужен цикл для удаления строк в соответствии с временной меткой в ​​R

Juan Carlos Joaquin спросил: 28 апреля 2018 в 08:56 в: r

Я работаю над проектом, где у меня есть несколько миллионов строк, и каждый из них содержит метку времени. Каждая строка также содержит уникальный идентификатор этого события. Текущее состояние состоит в том, что строки с одним и тем же идентификатором события могут иметь временную отметку в 1 минуту (не может быть двух событий с дельта-меткой времени менее 1 минуты).

То, что я хочу имитировать, - это ситуация, которая произошла бы, если минимальная временная метка будет 3 минуты.

    TIME_STAMP              PREV_TIME_STAMP      Unique ID 
06-27-2021 07:07:22       06-27-2021 06:30:00         1 
06-27-2021 07:18:26       06-27-2021 07:07:22         1 
06-27-2021 07:20:26       06-27-2021 07:18:26         1 
06-27-2021 07:22:26       06-27-2021 07:20:26         1 
06-27-2021 07:22:26       06-27-2021 07:22:26         1 
06-27-2021 15:18:05       06-27-2021 15:11:00         2 
06-27-2021 15:19:05       06-27-2021 15:18:05         2 
06-27-2021 12:31:37       06-27-2021 12:30:00         2 
06-27-2021 12:35:05       06-27-2021 12:30:00         2

Проблема в том, что я не могу сделать только новый столбец с разницей между сообщениями, мне нужен цикл для этого - почему? см. ниже:

Из таблицы следует следующая ситуация:

  • Первая строка принимается как дельта 37 минут.
  • Вторая строка принимается как дельта составляет 11 минут.
  • Третья строка НЕ ПРИНИМАЕТСЯ, поскольку дельта составляет 1,5 минуты.
  • Четвертая строка ПРИНИМАЕТСЯ как предыдущее событие NOT 07:20:26, это 07:18:26 (строка три удалена, так что это не считается!). Таким образом, время дельты для 4-й строки - 07:22:26 - 07:18:26 = 4 минуты > 3 минуты, что означает принятый

Таким образом, необходимо определить временную метку референта (это предыдущее время ACCEPTED), а дельта между новым временем и предыдущим временем, КОТОРЫЕ ПРИНИМАЮТСЯ, должно быть 3 минуты или выше.

Я надеюсь, что мне удалось это объяснить достаточно хорошо. Если нет, ответьте, и я предоставлю как можно больше информации.

Спасибо заранее!

РЕДАКТИРОВАТЬ:

df <- data.frame(TIME_STAMP = as.POSIXct(strptime(
  c("06-27-2021 07:07:22", 
    "06-27-2021 07:18:26",
    "06-27-2021 07:20:26",
    "06-27-2021 07:22:26",
    "06-27-2021 07:22:26",
    "06-27-2021 15:18:05",
    "06-27-2021 15:19:05",
    "06-27-2021 12:31:37",
    "06-27-2021 12:35:05"), "%m-%d-%Y %H:%M:%S")),
  PREV_TIME_STAMP = as.POSIXct(strptime(
    c("06-27-2021 06:30:00",
      "06-27-2021 07:07:22",
      "06-27-2021 07:18:26",
      "06-27-2021 07:20:26",
      "06-27-2021 07:22:26",
      "06-27-2021 15:11:00",
      "06-27-2021 15:18:05",
      "06-27-2021 12:30:00",
      "06-27-2021 12:30:00"), "%m-%d-%Y %H:%M:%S")),
  ID = c(1,1,1,1,1,2,2,2,2))

3 ответа

Roland ответил: 28 апреля 2018 в 10:48

Сначала вы должны переупорядочить данные и удалить избыточность ваших двух столбцов времени:

library(data.table)
DT <- fread("    TIME_STAMP,           Unique ID 
            06-27-2021 06:30:00,       1 
            06-27-2021 07:07:22,       1 
            06-27-2021 07:18:26,       1 
            06-27-2021 07:20:26,       1 
            06-27-2021 07:22:26,       1 
            06-27-2021 07:22:26,       1 
            06-27-2021 15:11:00,       2
            06-27-2021 15:18:05,       2 
            06-27-2021 15:19:05,       2 
            06-27-2021 12:31:37,       2 
            06-27-2021 12:35:05,       2")

Затем вы можете сделать это легко с помощью Rcpp:

library(Rcpp)cppFunction(
  'LogicalVector deleteRow(const NumericVector x) {
     const double n = x.size();
     double j = 0;
     LogicalVector res = LogicalVector(n);
     for (double i = 1; i < n; i++) {
       if (x(i) - x(j) < 180) {
         res[i] = true;
       } else {
         j = i;
       }
     }  return res;
  }')DT[, TIME_STAMP := as.POSIXct(TIME_STAMP, format = "%m-%d-%Y %H:%M:%S", tz = "GMT")]
setkey(DT, `Unique ID`, TIME_STAMP) #ensure sorting
DT[, delete := deleteRow(TIME_STAMP), by = `Unique ID`]
#             TIME_STAMP Unique ID delete
# 1: 2021-06-27 06:30:00         1  FALSE
# 2: 2021-06-27 07:07:22         1  FALSE
# 3: 2021-06-27 07:18:26         1  FALSE
# 4: 2021-06-27 07:20:26         1   TRUE
# 5: 2021-06-27 07:22:26         1  FALSE
# 6: 2021-06-27 07:22:26         1   TRUE
# 7: 2021-06-27 12:31:37         2  FALSE
# 8: 2021-06-27 12:35:05         2  FALSE
# 9: 2021-06-27 15:11:00         2  FALSE
#10: 2021-06-27 15:18:05         2  FALSE
#11: 2021-06-27 15:19:05         2   TRUE
chinsoon12 ответил: 28 апреля 2018 в 05:23

Предполагая, что это просто опечатка в последних двух записях preV_TIME_STAMP для ID = 2, вот еще один метод, использующий Reduce, используя набор данных Ronald's.

   #sort by TIME_STAMP to make sure older entries come up first
DT[order(TIME_STAMP), 
    #convert numeric to POSIX
    as.POSIXct(
        #get a distinct set of timestamp that is greater than 3 minutes
        unique(
            #use curr if more than 3 mins from prev, else keep the prev value
            Reduce(function(x,y) if(as.double(y-x,units="mins") >= 3) y else x, 
                  TIME_STAMP, 
                  accumulate=TRUE)
            ),
        origin="1970-01-01", tz="GMT"), 
    by=`Unique ID`]

изменить: поделиться таймингами. tl; dr Метод Roland ускорен

library(data.table)
set.seed(0L)
M <- 2e6
nIDs <- M/1e3
DT <- data.table(
    ID=sample(nIDs, M, replace=TRUE),
    TIME_STAMP=as.POSIXct(as.numeric(Sys.time())+sample(60*(0:4), M, replace=TRUE), origin="1970-01-01", tz="GMT"))
setorder(DT, ID, TIME_STAMP)
DT2 <- copy(DT)library(Rcpp)
cppFunction(
    'LogicalVector deleteRow(const NumericVector x) {
     const double n = x.size();
     double j = 0;
     LogicalVector res = LogicalVector(n);
     for (double i = 1; i < n; i++) {
       if (x(i) - x(j) < 180) {
         res[i] = true;
       } else {
         j = i;
       }
     }  return res;
  }')filter1 <- function(start, width) {
    end <- start + width - 1L                       # closed interval
    o <- order(c(start, end))
    is_start <- rep(c(TRUE, FALSE), each = length(start))[o]    event <- rep(c(1, -1), each = length(start))[o] # 1 == open, -1 == close
    cvg <- cumsum(event)                            # number of open intervals
    must <- (event == 1 & cvg == 1)[is_start]    open <- start[must]                             # non-overlapping events
    close <- end[must] + 1L
    might <- findInterval(start, sort(c(open, close))) %% 2 == 0    must | might
}filter_all <- function(start, width) {
    idx <- !logical(length(start))
    repeat {
        idx0 <- filter1(start[idx], width)
        if (sum(idx0)  == sum(idx))
            break
        idx[idx] <- idx0
    }
    idx
}basemtd <- function() {
    DT[, filter_all(TIME_STAMP, 3), by=ID]
}rcppmtd <- function() {    
    DT[, delete := deleteRow(TIME_STAMP), by=ID]
}dtmtd2 <- function() {
    DT2[, 
        as.POSIXct(
            unique(
                Reduce(function(x,y) if(as.double(y-x,units="mins") >= 3) y else x, 
                      TIME_STAMP, 
                      accumulate=TRUE)
                ),
            origin="1970-01-01", tz="GMT"), 
        by=ID]
}library(microbenchmark)
microbenchmark(basemtd(), rcppmtd(), dtmtd2(), times=3L)

timings:

Unit: milliseconds
      expr         min           lq                mean      median                    uq         max neval
 basemtd()   3579.0786   3601.19295   3608.667733333333   3623.3073   3623.46230000000014   3623.6173     3
 rcppmtd()     37.0085     37.53650     39.001500000000     38.0645     39.99800000000000     41.9315     3
  dtmtd2() 210238.1842 210901.39020 211303.247133333323 211564.5962 211835.77860000001965 212106.9610     3
Martin Morgan ответил: 29 апреля 2018 в 06:07
Ухоженная! В basemtd() ширина должна быть 180 (проверьте с помощью identical()). Я думаю, что вам нужно время только на функции, а не на data.table, на отсортированные штампы времени; для меня filter_all() примерно в 15 раз медленнее, чем deleteRow() (исключая время для изучения C ++ и Rcpp!)
chinsoon12 ответил: 29 апреля 2018 в 06:17
@MartinMorgan вы имеете в виду ave(DT$TIME_STAMP, DT$ID, filter_all)? позвольте мне обновить тайминги с помощью этого
Martin Morgan ответил: 29 апреля 2018 в 08:58
Я имел в виду x = sort(DT$TIME_STAMP); microbenchmark(filter_all(x, 180), deletRows(x), ...), чтобы измерить производительность различных реализаций, а не другие аспекты, не связанные с проблемой.
Martin Morgan ответил: 05 мая 2018 в 08:34

Это можно сделать итеративно. Идея состоит в том, чтобы указать точки, в которые должен быть включен, использовать их для удаления точек, которые не может быть включенными, и повторять до тех пор, пока не будет выполнено.

некоторые простые данные, а не метки времени, но целые числа (временные метки легко преобразуются в целые числа с помощью as.integer()), предполагая, что нас интересует "ширина" 10 - начинается менее 10 единиц, чтобы отфильтровать .

set.seed(123)
start <- sort(sample(100, 10))
width <- 10

Мы записываем функцию для начала и ширины

filter1 <- function(start, width) {

Создаем интервалы для каждого запуска

    end <- start + width - 1L                       # closed interval

выяснить, как положить начало и конец по порядку, и запомнить, какое событие запуска соответствует порядку

    o <- order(c(start, end))
    is_start <- rep(c(TRUE, FALSE), each = length(start))[o]

события запуска кодировки как 1, конец события как -1 и вычислять "охват", количество открытых событий

    event <- rep(c(1, -1), each = length(start))[o] # 1 == open, -1 == close
    cvg <- cumsum(event)                            # number of open intervals

Мы точно знаем, что хотим сохранить начальные события, где охват увеличивается до 1 , поэтому сохраните те

    must <- (event == 1 & cvg == 1)[is_start]
    open <- start[must]                                # non-overlapping events

и найдите событие, которое НЕ в этих интервалах

    close <- end[must] + 1L
    might <- findInterval(start, sort(c(open, close))) %% 2 == 0

вернет значения, которые, как мы знаем, хорошо, и t мы еще не исключили

    must | might                        # best guess, so far
}

Полная функция

filter1 <- function(start, width) {
    end <- start + width - 1L                       # closed interval
    o <- order(c(start, end))
    is_start <- rep(c(TRUE, FALSE), each = length(start))[o]    event <- rep(c(1, -1), each = length(start))[o] # 1 == open, -1 == close
    cvg <- cumsum(event)                            # number of open intervals
    must <- (event == 1 & cvg == 1)[is_start]    open <- start[must]                             # non-overlapping events
    close <- end[must] + 1L
    might <- findInterval(start, sort(c(open, close))) %% 2 == 0    must | might
}

Теперь у нас есть сокращенный вектор возможных кандидатов; мы итерации до тех пор, пока длина кандидатов не изменится

filter_all <- function(start, width) {
    idx <- !logical(length(start))
    repeat {
        idx0 <- filter1(start[idx], width)
        if (sum(idx0)  == sum(idx))
            break
        idx[idx] <- idx0
    }
    idx
}

в действии:

> set.seed(123)
> (start <- sort(sample(100, 10)))
 [1]  5 29 41 42 50 51 79 83 86 91
> keep <- filter_all(start, 10)
> start[keep]
[1]  5 29 41 51 79 91

Это может быть неверно (но может быть сделано так) в случае, когда интервалы заканчиваются и начинаются в одном и том же месте. Наихудшая производительность будет линейной по числу запусков (когда конец одного интервала точно перекрывает начало другого, единицы ширины вдоль), но похоже, что он часто будет приблизительно логарифмическим.

Это может применяется к группам, использующим data.table или базовые R-функции, такие как ave().