根据行中的其他值有条件地更新 R tibble 值

Question

我有一个带有 NA 和“1”值的小标题，我需要为一行中相隔小于 4 列的两个“1”值之间的所有值添加一个“1”（即 3 或更少的列分开）。例如，拿这个例子 tibble:

# Example Tibble
ex_input <- tibble( "A" = c(1, NA, NA, NA), 
             "B" = c(NA, NA, 1, 1), 
             "C" = c(1, 1, NA, NA),
             "D" = c(1, NA, NA, NA),
             "E" = c(1, NA, NA, NA),
             "F" = c(1, NA, NA, NA),
             "G" = c(1, 1, NA, NA),
             "H" = c(1, NA, NA, 1),
             "I" = c(1, NA, NA, NA),
             "J" = c(1, NA, 1, 1))

看起来像：

> print(ex_input)
# A tibble: 4 x 10
      A     B     C     D     E     F     G     H     I     J
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1    NA     1     1     1     1     1     1     1     1
2    NA    NA     1    NA    NA    NA     1    NA    NA    NA
3    NA     1    NA    NA    NA    NA    NA    NA    NA     1
4    NA     1    NA    NA    NA    NA    NA     1    NA     1

最后我需要的是在 B1、D2、C2、E2 和 I2 中添加“1”的输出，因为它们都在两个“1”之间的一行中" 值相隔小于 4 列。像这样：

> print(output)
# A tibble: 4 x 10
      A     B     C     D     E     F     G     H     I     J
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1     1     1     1     1     1     1     1     1     1
2    NA    NA     1     1     1     1     1    NA    NA    NA
3    NA     1    NA    NA    NA    NA    NA    NA    NA     1
4    NA     1    NA    NA    NA    NA    NA     1     1     1

提前感谢您的帮助！

Answer 1

这是一种可能的解决方案（尽管有些地方不太优雅）。我首先把数据放在一个长格式中。接下来，我将数据按组（即每一行）拆分为数据帧列表，然后我使用 data.table 中的 shift 来获取最多前 2 行和后 2 行的值，然后绑定在一起，然后我得到值的总和。逻辑是，如果给定的单元格是 NA，那么两个方向的总和至少应为 2，才能用 1 填充该单元格。然后，我unlist所有的总和，然后绑定回数据的长形式，df_long。第一个case_when用于查找任何大于2的sums，如果是，则将value更改为1。第二个case_when用于处理D2和F2，因为这些不符合您的第一个标准，即在 4 列中每个方向都有 1。但是我们可以用lag和lead向前看和向后看，如果两边都是1，那么我们就可以换成1。

library(tidyverse)
library(data.table)

df_long <- ex_input %>%
  mutate(row = row_number()) %>%
  pivot_longer(-row)

df <- df_long %>%
  group_split(row) %>%
  map(., function(x) rowSums(do.call(cbind, shift(x$value, -2:2)), na.rm = TRUE)) %>%
  unlist() %>%
  bind_cols(df_long, sums = .) %>%
  group_by(row) %>%
  mutate(value = case_when(value == 1 ~ value,
                           sums >= 2 ~ 1,
                           TRUE ~ NA_real_),
         value = case_when(value == 1 ~ value,
                           lead(value) == 1 & lag(value) == 1 ~ 1,
                           TRUE ~ NA_real_)) %>%
  ungroup() %>%
  select(-sums) %>%
  pivot_wider(names_from = name, values_from = value) %>%
  select(-row)

输出

      A     B     C     D     E     F     G     H     I     J
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1     1     1     1     1     1     1     1     1     1
2    NA    NA     1     1     1     1     1    NA    NA    NA
3    NA     1    NA    NA    NA    NA    NA    NA    NA     1
4    NA     1    NA    NA    NA    NA    NA     1     1     1

Answer 2

这在 base-R 中有效（不把所有内容都算作小题）。

for(i in seq(nrow(ex_input))){
  r <- ex_input[i,]
  for(cl in seq(ncol(r))){
    
    if(cl+4 > ncol(r)){break()}
    r2 <- r[cl:c(cl+4)]  
    if(sum(r2, na.rm = T) >= 2){

      colms <- which(colnames(r2) %in% names(r2[which(!is.na(r2))]))
      r[seq(min(colms+cl-1), max(colms+cl-1))] <- 1
      
      ex_input[i,] <- r
    }
  }
}  

ex_input
    
# A tibble: 4 x 10
      A     B     C     D     E     F     G     H     I     J
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1     1     1     1     1     1     1     1     1     1
2    NA    NA     1     1     1     1     1    NA    NA    NA
3    NA     1    NA    NA    NA    NA    NA    NA    NA     1
4    NA     1    NA    NA    NA    NA    NA     1     1     1

Answer 3

我们可以识别NA的运行个长度小于或等于4的位置，不在一行的开头或结尾，并根据ex_input分配一个“1”在那些。首先，我将基数 rle 稍微更改为 return a data.frame，这更容易使用。

rlen <- function (x) {
  if (!is.vector(x) && !is.list(x)) stop("'x' must be a vector of an atomic type")
  n <- length(x)
  if (n == 0L) return(data.frame(lengths = integer(), values = x))
  y <- x[-1L] != x[-n]
  i <- c(which(y | is.na(y)), n)
  within(
    data.frame(
      lengths = diff(c(0L, i)),
      values = x[i]), {
        end = cumsum(lengths)
        start = c(1, end)[1:length(end)]
      })
}

is.na(ex_input) 将 data.frame 转换为 TRUE 和 FALSE，避免了 rle 的一些麻烦。在 apply 步骤之后，我们有要替换的位置向量，可以是 NULL。使用 imap，我们可以访问列表索引，并将其插入 [ 的行槽中，returning 是无形的，因为我们在处理副作用。

library(tidyverse)
y <- apply(is.na(ex_input), 1, function(x){
  ids <- rlen(x) %>%
    mutate(rnum = seq_along(lengths)) %>%
    filter(rnum != nrow(.) & rnum != 1 & values & end-start <= 4)
  if(nrow(ids) != 0) ids$start:ids$end
})

invisible(imap(y, ~ if(!is.null(.x)) ex_input[.y, .x] <<- 1))
ex_input

# A tibble: 4 x 10
      A     B     C     D     E     F     G     H     I     J
  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1     1     1     1     1     1     1     1     1     1     1
2    NA    NA     1     1     1     1     1    NA    NA    NA
3    NA     1    NA    NA    NA    NA    NA    NA    NA     1
4    NA     1    NA    NA    NA    NA    NA     1     1     1

根据行中的其他值有条件地更新 R tibble 值

Conditionally update R tibble values based on other values in the row

r

tibble