Применение правил к растущему окну

Я хочу пройтись по кадру данных Out, используя окно, которое:

  1. Растет на один шаг за раз (таким образом, задняя часть окна фиксируется, а передняя часть окна увеличивается — окно становится больше)

  2. При каждом приращении над окном должны выполняться следующие правила:

    if (mean(Speed_out) <= 0.152682)
Behaviour <- Lying
else if (Movement_Out == “left”) <= 20.8 && (mean(Speed_Out) >= 
0.200921)
Behaviour <- Grazing

  3. Если никакие правила не выполняются, окно должно увеличиваться на один шаг за раз, пока правило не будет выполнено.

  4. Как только правило выполняется, все предыдущие приращения должны быть помечены Behaviour, назначенным этому правилу выше.

  5. Следующее окно должно начинаться со следующего элемента после окончания последнего окна.

  6. Начальный размер окна должен быть регулируемым (размер окна в начале и после каждого закрытого окна).

Примечания:

Единицы (Movement_Out == “left”) <= 20.8 означают, что если "left" занимает менее 20,8% окна.

Пример:

Вот краткий пример вывода, который я хотел бы получить из данных, представленных ниже, где начальный размер окна был установлен на 4:

    Speed_Out Movement_Out  Behaviour
1      0.220         left    Lying 
2      0.155         left    Lying
3      0.120      forward    Lying
4      0.090   non-moving    Lying   <== window terminates here
5      0.125   non-moving    Grazing <== new window starts here   
6      0.125   non-moving    Grazing
7      0.155   non-moving    Grazing
8      0.340      forward    Grazing
9      0.370      forward    Grazing <== window terminates here
10     0.185      forward    Grazing <== new window starts here
11     0.155        right    Grazing
12     0.220   non-moving    Grazing
13     0.220   non-moving    Grazing 
14     0.280   non-moving    Grazing <== window terminates here
15     0.215   non-moving    Grazing <== new window starts here
16     0.060        right    Grazing
17     0.340   non-moving    Grazing
18     0.555      forward    Grazing <== window terminates here
19     0.275        right    And so on..
20     0.215      forward

Dataframe для вашего использования

Out <- structure(list(Speed_Out = c(0.22, 0.155, 0.12, 0.09, 0.125, 
0.125, 0.155, 0.34, 0.37, 0.185, 0.155, 0.22, 0.22, 0.28, 0.215, 
0.06, 0.34, 0.555, 0.275, 0.215, 0.185, 0.06, 0.245, 0.31, 0.345, 
0.375, 0.375, 0.87, 1.025, 0.405, 0, 0.185, 0.31, 0.155, 0.125, 
0.22, 0.375, 0.345, 0.345, 0.405, 0.31, 0.34, 0.245, 0.155, 0.19, 
0.22, 0.185, 0.12, 0.185, 0.155, 0.245, 0.31, 0.155, 0.155, 0.25, 
0.215, 0.09, 0.06, 0.245, 0.495, 0.495, 0.34, 0.28, 0.31, 0.28, 
0.25, 0.25, 0.185, 0.155, 0.25, 0.28, 0.28, 0.34, 0.215, 0.125, 
0.155, 0.34, 0.34, 0.09, 0.59, 1.71, 1.18, 0.185, 0.215, 0.185, 
0.185, 0.155, 0.19, 0.19, 0.19, 0.87, 2.045, 2.73, 1.585, 0.22, 
0.25, 0.435, 0.405, 0.405, 0.405, 0.715, 0.62, 0.37, 0.4, 0.185, 
0.375, 0.59, 0.525, 0.245, 0.495, 0.495, 0.68, 0.775, 0.25, 0.31, 
0.34, 0.28, 0.28, 0.25, 1.55, 2.695, 1.705, 1.21, 0.87, 0.25, 
1.52, 1.52, 0.405, 0.81, 2.08, 2.915, 1.705, 0.435, 0.22, 0.78, 
1.215, 0.84, 0.495, 0.495, 0.56, 0.375, 0.28, 0.715, 1.025, 0.495, 
0.65, 1.18, 1.09, 0.995, 0.87, 0.435, 0.125, 0.435, 0.555, 0.775, 
1.12, 1.555, 1.15, 0.25, 0.87, 0.93, 0.28, 0.31, 0.31, 0.375, 
0.78, 0.655, 0.53, 0.62, 0.525, 0.37, 0.555, 1.025, 0.655, 1.12, 
1.585, 0.715, 0.155, 0.28, 1.12, 2.11, 1.645, 0.715, 0.465, 0.84, 
0.81, 0.655, 0.84, 0.435, 0.28, 0.215, 0.93, 1.335, 0.65, 0.185, 
0.155, 0.34, 0.4, 0.37, 0.435, 0.405, 0.28, 0.28, 0.25, 0.25, 
0.745, 1.24, 0.805, 1.055, 1.085, 0.465, 0.375, 0.5, 0.59, 0.37, 
0.185, 0.34, 0.37, 0.435, 0.405, 0.06, 0.125, 0.25, 0.31, 0.405, 
0.78, 0.56, 0.215, 0.495, 0.87, 1.025, 0.62, 0.405, 0.405, 0.405, 
0.31, 0.215, 0.465, 0.435, 0.34, 0.275, 0.215, 0.25, 0.22, 0.22, 
0.125, 0.245, 0.34, 0.31, 0.37, 0.31, 0.31, 0.245, 0.185, 0.25, 
0.22, 0.22, 0.31, 0.28, 0.22, 0.28, 0.53, 0.655, 0.375, 0.19, 
0.405, 0.435, 0.28, 0.215, 0.77, 0.96, 1.865, 1.83, 0.495, 0.655, 
1.615, 1.395, 0.31, 0.31, 0.25, 0.28, 0.34, 0.34), Movement_Out = structure(c(2L, 
2L, 1L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 4L, 3L, 3L, 3L, 3L, 4L, 3L, 
1L, 4L, 1L, 1L, 2L, 2L, 3L, 4L, 3L, 2L, 4L, 1L, 2L, 1L, 3L, 3L, 
1L, 3L, 2L, 4L, 3L, 1L, 3L, 1L, 1L, 1L, 4L, 3L, 3L, 3L, 3L, 1L, 
3L, 3L, 3L, 2L, 4L, 3L, 3L, 4L, 2L, 3L, 1L, 1L, 2L, 4L, 1L, 2L, 
4L, 3L, 3L, 4L, 3L, 3L, 2L, 4L, 2L, 1L, 2L, 4L, 4L, 2L, 4L, 2L, 
1L, 2L, 3L, 1L, 2L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 2L, 1L, 3L, 3L, 
2L, 2L, 3L, 1L, 2L, 4L, 3L, 4L, 2L, 3L, 1L, 4L, 4L, 3L, 1L, 2L, 
1L, 1L, 4L, 1L, 2L, 4L, 2L, 1L, 1L, 2L, 4L, 2L, 2L, 4L, 1L, 1L, 
2L, 4L, 2L, 4L, 2L, 1L, 2L, 2L, 4L, 2L, 4L, 2L, 4L, 3L, 1L, 4L, 
2L, 1L, 1L, 2L, 4L, 2L, 4L, 2L, 4L, 4L, 2L, 4L, 1L, 1L, 4L, 2L, 
4L, 4L, 3L, 4L, 4L, 2L, 1L, 1L, 1L, 4L, 1L, 1L, 4L, 4L, 2L, 2L, 
4L, 1L, 2L, 2L, 4L, 4L, 4L, 2L, 2L, 1L, 4L, 4L, 2L, 3L, 1L, 2L, 
2L, 4L, 4L, 1L, 2L, 4L, 4L, 2L, 2L, 4L, 2L, 4L, 2L, 4L, 1L, 1L, 
2L, 1L, 4L, 4L, 3L, 4L, 2L, 4L, 3L, 1L, 1L, 2L, 1L, 1L, 4L, 2L, 
4L, 2L, 4L, 3L, 1L, 4L, 1L, 1L, 2L, 4L, 2L, 1L, 4L, 1L, 4L, 3L, 
2L, 3L, 2L, 4L, 3L, 3L, 2L, 1L, 3L, 1L, 1L, 3L, 2L, 3L, 3L, 3L, 
1L, 2L, 4L, 2L, 3L, 2L, 1L, 4L, 3L, 2L, 4L, 4L, 2L, 4L, 1L, 1L, 
2L, 2L, 4L, 1L, 2L, 4L, 2L, 4L, 3L, 4L), .Label = c("forward", 
"left", "non-moving", "right"), class = "factor")), .Names = c("Speed_Out", 
"Movement_Out"), row.names = c(NA, 283L), class = "data.frame")

r for-loop sliding-window
person PharmR    schedule 11.04.2018    source источник

Ответы (1)


arrow_upward
1
arrow_downward

Хорошо, я должен сказать, что это было менее тривиально, чем я ожидал. Мой ответ уродлив и, скорее всего, не оптимален, но, похоже, работает.

Кажется, было несколько мест, где, даже когда были приняты во внимание остальные данные, ни одно из условий не было выполнено, поэтому поведение для них осталось на уровне NA.

library(dplyr)

# Create id variable used to join results later
Out <- Out %>%
  mutate(id=row_number())

# Initial window size
window_size <- 4

# Initialize variables used in loop
w <- window_size
i<-1
window_cnt<-1
out_behaviour <- data.frame(id=as.numeric(), Behaviour=as.character(), stringsAsFactors = FALSE)

while (i <= NROW(Out)){

  print(paste0("Row: ", i, ", Window Size: ", w))

  df <- Out[i:(i+w-1),] %>%
    mutate(mean_sp=mean(Speed_Out),
           mvmt=sum(ifelse(Movement_Out=="left",1 ,0))/NROW(.)) %>%
    mutate(Behaviour=case_when(mean_sp <= 0.152682 ~ "Lying",
                               mvmt <= 0.208 & mean_sp >= 0.200921 ~ "Grazing",
                               TRUE ~ as.character(NA)),
           window_nr=window_cnt)

  if (!all(is.na(df$Behaviour))){
    i<-w+i
    w<-window_size
    out_behaviour <- rbind(out_behaviour, df %>% select(id, Behaviour, window_nr))
    window_cnt<-window_cnt+1
  } else {
    if (w<=NROW(Out)-i){
      w<-w+1
    } else {
      w<-window_size
      i<-i+1
    }
  }

  rm(df)
}

# Join Behaviour column bacl to original data frame
Out <- left_join(Out, out_behaviour, by="id") %>% select(-id)

# Clean up workspace
rm(i, w, window_size, window_cnt, out_behaviour)

И первые 20 выходов

   Speed_Out Movement_Out Behaviour window_nr
1      0.220         left     Lying         1
2      0.155         left     Lying         1
3      0.120      forward     Lying         1
4      0.090   non-moving     Lying         1
5      0.125   non-moving   Grazing         2
6      0.125   non-moving   Grazing         2
7      0.155   non-moving   Grazing         2
8      0.340      forward   Grazing         2
9      0.370      forward   Grazing         2
10     0.185      forward   Grazing         3
11     0.155        right   Grazing         3
12     0.220   non-moving   Grazing         3
13     0.220   non-moving   Grazing         3
14     0.280   non-moving   Grazing         3
15     0.215   non-moving   Grazing         4
16     0.060        right   Grazing         4
17     0.340   non-moving   Grazing         4
18     0.555      forward   Grazing         4
19     0.275        right   Grazing         5
20     0.215      forward   Grazing         5

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

person Roberto Moratore    schedule 12.04.2018
comment
Я бы порекомендовал вам также добавить print(i) и print(w) внутри цикла, чтобы увидеть прогресс и убедиться, что вы не застряли в бесконечном цикле. - person Roberto Moratore; 12.04.2018
comment
Отлично - эта работа великолепна! При необходимости достаточно просто добавить правила. Будучи новичком, где бы вы порекомендовали размещать операторы печати? Действительно большое спасибо. - person PharmR; 13.04.2018
comment
@PharmR Я обновил свой ответ, чтобы код стал немного чище, и добавил для вас оператор печати. - person Roberto Moratore; 13.04.2018
comment
Большое спасибо за вашу помощь! - person PharmR; 13.04.2018
comment
Не за что. Было интересно решить задачу :) - person Roberto Moratore; 13.04.2018