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

Question

У меня есть следующий набор данных:

A <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0)
B <- c(0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0)
C <- c(0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1)
df <- cbind(A, B, C) 
> df
      A B C
 [1,] 1 0 0
 [2,] 1 0 1
 [3,] 1 1 1
 [4,] 1 1 1
 [5,] 1 1 1
 [6,] 1 1 1
 [7,] 1 0 1
 [8,] 1 1 1
 [9,] 1 1 1
[10,] 1 1 0
[11,] 0 1 0
[12,] 1 1 0
[13,] 0 0 1

Я хочу сделать две вещи для каждого столбца: во-первых, я хочу изменить все 1, которые находятся в двух местах от 0 до 0.Затем я хочу выбрать области столбцов, где есть по крайней мере четыре последовательных 1;другими словами, если появляется 1, который не находится в последовательной строке из четырех или более 1, он станет 0. Полученный набор данных должен выглядеть следующим образом:

> df
      A B C
 [1,] 1 0 0
 [2,] 1 0 0
 [3,] 1 0 0
 [4,] 1 0 1
 [5,] 1 0 1
 [6,] 1 0 1
 [7,] 1 0 1
 [8,] 1 0 0
 [9,] 0 0 0
[10,] 0 0 0
[11,] 0 0 0
[12,] 0 0 0
[13,] 0 0 0

Как лучше всегосделай это?Спасибо!

Answer 1

Вот еще один возможный подход с использованием функций base.Объяснение встроено в код.

apply(df, 2, function(x) {
    #identify 0 locations, create indices 2 places away from these locations 
    #and set these to 0
    idx <- unique(unlist(lapply(which(x==0L), `+`, -2L:2L)))
    x[idx[idx > 0L & idx <= length(x)]] <- 0L        

    #create run length encoding, filter for those with value=1 but less than 4 
    #and set those lengths to 0
    r <- rle(x)
    r$values[r$lengths < 4L & r$values==1L]  <- 0L
    inverse.rle(r)
})

вывод:

      A B C
 [1,] 1 0 0
 [2,] 1 0 0
 [3,] 1 0 0
 [4,] 1 0 1
 [5,] 1 0 1
 [6,] 1 0 1
 [7,] 1 0 1
 [8,] 1 0 0
 [9,] 0 0 0
[10,] 0 0 0
[11,] 0 0 0
[12,] 0 0 0
[13,] 0 0 0

Answer 2

Вы можете использовать lag и lead для сравнений (для первой части).

Вот пример использования ваших данных (это оригинальная версия перед любыми изменениями вашего вопроса):

library(dplyr)
library(tidyverse)
df <-
as.tibble(df) %>%
  mutate(A_lag=lag(A)) %>%
  mutate(B_lag=lag(B)) %>%
  mutate(C_lag=lag(C)) %>%
  mutate(A_lag2=lag(A,2)) %>%
  mutate(B_lag2=lag(B,2)) %>%
  mutate(C_lag2=lag(C,2)) %>%
  mutate(A_lead=lead(A)) %>%
  mutate(B_lead=lead(B)) %>%
  mutate(C_lead=lead(C)) %>%
  mutate(A_lead2=lead(A,2)) %>%
  mutate(B_lead2=lead(B,2)) %>%
  mutate(C_lead2=lead(C,2)) %>%
  as.data.frame()

a <- df[,c(1,4,7,10,13)]
b <- df[,c(2,5,8,11,14)]
c <- df[,c(3,6,9,12,15)]

df <- data.frame(A=apply(a,1,min,na.rm=T),
           B=apply(b,1,min,na.rm=T),
           C=apply(c,1,min,na.rm=T)
)

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

   A B C
1  1 0 0
2  1 0 0
3  1 0 0
4  1 0 1
5  1 0 1
6  1 0 1
7  1 0 1
8  1 0 0
9  0 0 0
10 0 1 0
11 0 1 0
12 0 1 0
13 0 1 0

Результат этого шага соответствует вашей логике для него.

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

Ваш пример выходных данных показывает столбец B как все 0, хотя последние 4 строки в нем - все 1 в результате логики из предыдущего шага.

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

# You could do it without a for loop if need be
myfun <- function(x) {
  for(i in 1:length(x)){
    x[i] <- ifelse((sum(x[i:(max(0,i-3))]) == 4) | (sum(x[i:(min(length(x),i+3))]) == 4),1,0)
  }
  return(x)
}

apply(df,2,myfun)