Использование скользящего окна для определения и возврата первого успеха

Question

У меня есть и экспериментирую, где я смотрю на посещения птиц кормушками. Если они go для правильной подачи, это считается успехом. Считается, что они узнали, кого кормить, после успешного посещения 16/20 (80%).

Я хочу написать фрагмент кода R, который проходит через весь фрейм данных по птицам и идентифицирует первый случай 80% успеха с движущимся окном 20 посещений.

Приведенный ниже код работает, но он неуклюжий. Конечным результатом является получение тибла, в котором каждая строка представляет уникальную птицу и точку, в которой они впервые достигают 80% успеха.

# My attempt
library(tidyverse)

# Some sample data
data <- tibble(
  bird = rep("a121", 99), 
  success = sample(c(1,0), 99, replace = TRUE, prob = c(0.7, 0.3)),
  visit = 1:99) %>%
  bind_rows(tibble(
    bird = rep("b232", 99), 
    success = sample(c(1,0), 99, replace = TRUE, prob = c(0.75, 0.15)),
    visit = 1:99)) %>%
  bind_rows(tibble(
    bird = rep("c211", 99), 
    success = sample(c(1,0), 99, replace = TRUE, prob = c(0.7, 0.3)),
    visit = 1:99)) %>%
  mutate(observation = 1:297) %>%
  select(observation, everything())

# Identify first time 80% success rate met with a sliding window of 20

res <- NULL 

slide.funct <- function(data, window, step){ 
  birds <- unique(pull(data, bird)) # Identify the birds in the data
  for (j in birds) {
    sub_data <- filter(data, bird == j) # Work with one bird at a time

    # Might need a line to ensure the data is ordered by time

    total <- nrow(sub_data)
    spots <- seq(from = 1, to = (total - window), by = step)
    result <- vector(length = length(spots))
    for(i in 1:length(spots)){
      result[i] <- mean(sub_data$success[spots[i]:(spots[i] + window)]) # Success rate by window
      position <- Position(function(x) x >= 0.8 , result) + 19 # First point at which success > 80%
    }
    res <- bind_rows(res, sub_data[position, ]) # Build up info for each bird
  }
  res <- res %>% mutate(observation = observation + 19) %>% 
    select(observation, bird)
  return(res)
}

slide.funct(data, 19, 1)

#> # A tibble: 3 x 2
#>   observation bird 
#>         <dbl> <chr>
#> 1          53 a121 
#> 2         138 b232 
#> 3         237 c211

Это только первая стадия процесса, так как есть еще что сделать вниз по течению. Тем не менее, я не уверен, что вышеуказанная функция достаточно надежна. Я посмотрел на пакет «зоопарк», но не думал, что это может помочь здесь. Я также собираюсь использовать код tidyverse там, где могу, поэтому, если есть лучшие варианты для достижения вышеизложенного, я был бы очень рад их услышать.

Answer 1

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

Для каждой птицы отфильтруйте строки, для которых 20 строк до этой точки имеют средний успех 0,80 или более, а затем верните первую такую ​​строку. На всякий случай, если есть птицы, для которых 0,80 никогда не достигаются, присоединяйтесь к отдельным птицам. Если бы мы были уверены, что каждая птица достигает 0,80, или если мы не возражали, что птицы, которые не достигли 0,80, исключаются из результата, мы могли бы опустить эту строку.

library(dplyr)
library(tibble)
library(tidyr)
library(zoo)

data %>%
  group_by(bird) %>%
  filter(rollmeanr(success, 20, fill = NA) >= 0.80) %>%
  slice(1) %>%
  ungroup %>%
  select(observation, bird) %>%
  right_join(distinct(data["bird"]), by = "bird")
## # A tibble: 3 x 2
##   observation bird 
##         <int> <chr>
## 1          46 a121 
## 2         127 b232 
## 3         218 c211 

Обратите внимание, что результаты slide.funct в вопросе не верны. Например, мы отмечаем, что

mean(data$success[27:46])
## [1] 0.8

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

slide.funct(data, 19, 1)
## # A tibble: 3 x 2
##   observation bird 
##         <dbl> <chr>
## 1          65 a121 
## 2         146 b232 
## 3         237 c211 

Примечание

Ввод в воспроизводимой форме - аналогичен вопросу, но добавлен set.seed.

library(dplyr)
library(tibble)

set.seed(123)

data <- tibble(
  bird = rep("a121", 99), 
  success = sample(c(1,0), 99, replace = TRUE, prob = c(0.7, 0.3)),
  visit = 1:99) %>%
  bind_rows(tibble(
    bird = rep("b232", 99), 
    success = sample(c(1,0), 99, replace = TRUE, prob = c(0.75, 0.15)),
    visit = 1:99)) %>%
  bind_rows(tibble(
    bird = rep("c211", 99), 
    success = sample(c(1,0), 99, replace = TRUE, prob = c(0.7, 0.3)),
    visit = 1:99)) %>%
  mutate(observation = 1:297) %>%
  select(observation, everything())