R: Группировка по значениям до порога

Question

У меня есть дата-кадр с временем обнаружения помеченной рыбы. Мне нужно сгруппировать его на основе tagID и события обнаружения, которое является каждым обнаружением для отдельного тега, пока оно не будет отсутствовать в течение периода, превышающего пороговое время.

Вот примерный набор данных:

set.seed (999)
df <- data.frame (tag_id = c(rep("3DD.01",8),rep("3DD.04",24),rep("3DD.02",18)),
  absent_time = rchisq (50, 5))
max_time <- 7 #threshold value

Я могу построить цикл ниже, но он слишком неэффективен для запуска полного набора данных (1,6 миллиона строк). Столбец df$count очерчивает группу.

vec_count <- rep (1,50)
for(i in 2:nrow(df)){
  if (df$tag_id[i] != df$tag_id[i - 1]){
    tmp <- vec_count[i -1] +1
  } else if (df$absent_time[i - 1] < max_time){
    tmp <- vec_count[i - 1]
  } else{
    tmp <- vec_count[i - 1] +1
  }
  tmp
  vec_count[i] <- tmp
}
df$count <- vec_count

Есть ли какой-нибудь способ, которым я могу векторизовать это и избежать запуска 8-часового цикла? Я так близок к мутированию и пайпингу, но пока безуспешно.

Спасибо за любую помощь, которую вы можете оказать!

Answer 1

Поскольку ваши вычисления зависят от непосредственно предшествующей строки, я не достаточно умен, чтобы векторизовать вашу задачу. Некоторые предложения должны проверить dplyr функции lag и другие функции окна .

( ОБНОВЛЕНИЕ : я добавляю решение, используя dplyr и некоторые оконные функции - см. Решение № 3 - я оставляю другие решения, поскольку они все еще могут быть полезны),

Одна вещь, которую я предполагаю, состоит в том, что ваше текущее решение является правильным (но медленным) - пожалуйста, просто проверьте, что оно делает то, что вы думаете, оно делает.

Вот 3 решения.

1.) Не повторяйте доступ к data.frame через цикл for.

Вместо того, чтобы обращаться к компонентам вашего data.frame, используя df$tag_id и df$absent_time, используйте вместо него два вектора - то есть используйте отдельные векторы для tag_id и absent_time. Как правило, доступ к data.frames обходится дороже, чем доступ к матрице или векторам. Вот решение. Это сэкономит много времени, но все равно, вероятно, займет слишком много времени.

tag_id = df$tag_id
absent_time = df$absent_time
vec_count <- rep (1, length(tag_id))
for(i in 2:length(tag_id)){
  if (tag_id[i] != tag_id[i - 1]){
    tmp <- vec_count[i -1] +1
  } else if (absent_time[i - 1] < max_time){
    tmp <- vec_count[i - 1]
  } else{
    tmp <- vec_count[i - 1] +1
  }
  vec_count[i] <- tmp
}
df$count2 <- vec_count

2.) Ваш цикл достаточно прост, чтобы вы могли получить быструю версию C ++ с использованием Rcpp за совсем немного времени,Я не программист на C ++, но смог получить это за несколько минут. Я хотел бы отослать вас к превосходной главе Хедли Уикхема здесь . Если ваш фактический набор данных сложнее, чем вы дали, просто помните о таких вещах, как, как обрабатываются пропущенные значения.

library(Rcpp)
cppFunction("IntegerVector fastloop(CharacterVector tag_id, 
                       NumericVector absent_time, 
                       int max_time) {
      // Create a vector filled with 1s
      int vec_size = tag_id.length();
      IntegerVector vec_count (vec_size, 1);
      // Go through your loop: starts at 0 in C++
      for (int i = 1; i < vec_size; i++) {
        int tmp = 0;
        if (tag_id[i] != tag_id[i - 1]) {
          tmp = vec_count[i - 1] + 1;
        } else if (absent_time[i - 1] < max_time) {
          tmp = vec_count[i - 1];
        } else {
          tmp = vec_count[i - 1] + 1;
        }
        vec_count[i] = tmp;
      }
      return vec_count;
}")
# Will take a few seconds to compile

df$count3 <- fastloop(df$tag_id, df$absent_time, 7)
identical(as.integer(df$count), df$count3)

ОБНОВЛЕНИЕ 3.) Вот решение dplyr, которое не нуждается в циклах.

library(dplyr)
df <- df %>%
  mutate(
    # Create 2 lagged variables (lag defaults to 1 period)
    lag_tag = lag(tag_id),
    lag_absent = lag(absent_time),
    # Create a 1/0 variable indicating whether we add 1 or not
    plus_1 = ifelse(tag_id != lag_tag, 1, 
                    ifelse(lag_absent < max_time, 0, 1)),
    # First row will be NA -- replace with 1
    plus_1 = replace(plus_1, 1, 1),
    # Use cumsum function on plus_1
    cum_count = cumsum(plus_1)
  )

identical(df$cum_count, df$count) # TRUE

Я положил ваш ток для цикла и мойтри решения в функции и попробуйте больший случайно сгенерированный набор данных, чтобы продемонстрировать улучшения производительности. Извините за неловкое заявление microbenchmark. ,.

old_solution <- function(x) {
  vec_count <- rep (1, nrow(x))
  for(i in 2:nrow(x)){
    if (x$tag_id[i] != x$tag_id[i - 1]){
      tmp <- vec_count[i -1] +1
    } else if (x$absent_time[i - 1] < max_time){
      tmp <- vec_count[i - 1]
    } else{
      tmp <- vec_count[i - 1] +1
    }
    vec_count[i] <- tmp
  }
  return(vec_count)
}


new_solution <- function(tag_id, absent_time) {
  vec_count <- rep (1, length(tag_id))
  for(i in 2:length(tag_id)){
    if (tag_id[i] != tag_id[i - 1]){
      tmp <- vec_count[i -1] +1
    } else if (absent_time[i - 1] < max_time){
      tmp <- vec_count[i - 1]
    } else{
      tmp <- vec_count[i - 1] +1
    }
    vec_count[i] <- tmp
  }
  return(vec_count)
}

dplyr_solution <- function(x) {
  x <- x %>%
    mutate(
      # Create 2 lagged variables (lag defaults to 1 period)
      lag_tag = lag(tag_id),
      lag_absent = lag(absent_time),
      # Create a 1/0 variable indicating whether we add 1 or not
      #  based on the condition you specified. 
      plus_1 = ifelse(tag_id != lag_tag, 1, 
                      ifelse(lag_absent < max_time, 0, 1)),
      # First row will be NA -- replace it with 1
      plus_1 = replace(plus_1, 1, 1),
      # Use cumsum function on plus_1
      cum_count = cumsum(plus_1)
    )
  return(x$cum_count)
}

set.seed (999)
# Imagine that I am creating unique IDs and not just repeating the same 3
df2 <- data.frame (tag_id = rep(c(rep("3DD.01",8),rep("3DD.04",24),rep("3DD.02",18)), 1000),
                  absent_time = rchisq (50000, 5))
max_time <- 7 #threshold value


library(microbenchmark)

microbenchmark(old_solution(df2), 
               new_solution(df2$tag_id, df2$absent_time),
               fastloop(df2$tag_id, df2$absent_time, 7),
               dplyr_solution(df2),
               times = 20L)

Unit: milliseconds
                                      expr       min         lq        mean     median        uq       max neval
                         old_solution(df2) 3544.8781 3702.99770 4076.295815 3771.94990 3995.6506 6849.6148    20
 new_solution(df2$tag_id, df2$absent_time) 2006.9711 2177.62850 2470.002845 2260.42390 2320.6644 4147.8885    20
  fastloop(df2$tag_id, df2$absent_time, 7)    1.4835    1.64955    2.242745    2.06805    2.6967    3.7357    20
                       dplyr_solution(df2)    8.0995    8.98240   13.660475   13.42025   17.1172   22.4442    20
 cld
   c
  b 
 a  
 a  

Как видите, решения Rcpp и dplyr довольно быстрые.