基于行中的其他值有条件地更新R tibble值

Question

我有一份包含 NA 和 "1" 值的 tibble，我需要在距离少于 4 列的两个 "1" 值之间的同行所有值中加入 "1"。例如，以这个例子的 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”，因为它们都在两个距离小于4列的“1”值之间的一行中。 如下所示：

> 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

提前感谢您的帮助！

- rjb

---

有趣。你尝试过什么？ - rdelrossi

你可能想要转置这个矩阵，这样你就可以按列而不是行来处理数据。例如：ex_input %>% rowid_to_column() %>% pivot_longer(-rowid) %>% pivot_wider(names_from = rowid) 这并不是一个解决方案，但可能是一个很好的起点。 - Dan Adams

窗口函数可能会对此有所帮助，但尚未确定如何从中获取所需内容。如果有帮助的话，{runner} 看起来很有前途，zoo::rollapply() 和 data.table::frollapply() 也是如此。 - Dan Adams

Answer 1

这里有一个可能的解决方案（尽管在某些地方不太优雅）。首先，我将数据放入长格式中。接下来，我将数据拆分为每行的数据帧列表，然后使用data.table中的shift从前后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

- AndrewGB

---

干得好。看起来 A 4 是 1，但应该是 NA。不过看起来很接近！ - Dan Adams

@DanAdams 谢谢！感谢你指出这个问题。在 case_when 语句之前只需要加上一个 group_by 就可以了。 - AndrewGB

做得非常好。我折腾了一会儿后放弃了，所以很高兴看到能用的东西！ - Dan Adams

@DanAdams 谢谢。有一段时间我差点放弃了！可能我花在上面的时间太长了，哈哈。 - AndrewGB

Answer 2

我们可以识别那些连续的NA长度小于等于4但不在行首或行尾的位置，并在这些位置上把"1"赋值给ex_input。首先，我稍微修改了rle基础函数，使其返回一个更易于处理的数据框。

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)会将数据框转换为TRUE和FALSE，从而避免了一些使用rle时的烦恼。在apply步骤之后，我们有了要替换的位置向量，这些向量可以是NULL。 使用imap，我们可以访问列表索引，并将其插入到[的行槽中，返回不可见值，因为我们只关心副作用。

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

- Donald Seinen

---

这个解决方案被接受，因为它是最通用的（即当一行中的值相差不到奇数时，它可以解决问题 - 另外两个解决方案需要相差偶数）。然而，更广义的解决方案需要将ids$start：ids$end替换为类似unlist(map2(ids$start, ids$end, seq))的东西，以填补一行中有多个间隙的情况。 - rjb

Answer 3

这在基础R中可行（不包括一切都是tibble的情况）。

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

- D.J