r - 如何比较一组列与另一组列？

Question

考虑我们有以下数据

df <- data.frame(jan=c(10,7,1),
           feb=c(20,9,2),
           mar=c(30,6,3),
           apr=c(5,5,4),
           may=c(0,9,5),
           jun=c(10,8,6)
)


  jan feb mar apr may jun
1  10  20  30   5   0  10
2   7   9   6   5   9   8
3   1   2   3   4   5   6

我期望导出一个新的标志变量，该变量是通过将 1 组列(一月、二月、三月)与(四月、五月、六月)进行比较而导出的，如果一组的值与另一组的值匹配，则 flag=' Y'，否则为“N”。

这里 jan 值与第一行的 jun 匹配，因此标志为 Y。

  jan feb mar apr may jun flag
1  10  20  30   5   0  10    Y
2   7   9   6   5   9   8    Y
3   1   2   3   4   5   6    N

Answer 1

如果关注性能，则采用矢量化方法:

set1 <- c("jan", "feb", "mar")
set2 <- c("apr", "may", "jun")

iY <- unique(
  data.table(
    r = rep(1:nrow(df), each = ncol(df)),
    val = c(unlist(t(df[c(set1, set2)]))),
    set = rep(1:2, c(length(set1), length(set2))),
    key = c("r", "val")
  )[r == shift(r) & val == shift(val) & set != shift(set), r]
)
df$flag <- "N"
df$flag[iY] <- "Y"
df
#>   jan feb mar apr may jun flag
#> 1  10  20  30   5   0  10    Y
#> 2   7   9   6   5   9   8    Y
#> 3   1   2   3   4   5   6    N

在更大的数据集上针对其他几个解决方案进行基准测试。首先将解决方案实现为函数。

df <- setNames(
  as.data.frame(matrix(sample(10, 6e4, 1), 1e4, 6)),
  c("jan", "feb", "mar", "apr", "may", "jun")
)

f1 <- function(df, set1, set2) {
  df$flag <- sapply(1:nrow(df), \(x) 
                    ifelse(any(unlist(df[x, set1]) %in% unlist(df[x, set2])), "Y", "N"))
  df
}

f2 <- function(df, set1, set2) {
  iY <- unique(
    data.table(
      r = rep(1:nrow(df), each = ncol(df)),
      val = c(unlist(t(df[c(set1, set2)]))),
      set = rep(1:2, c(length(set1), length(set2))),
      key = c("r", "val")
    )[r == shift(r) & val == shift(val) & set != shift(set), r]
  )
  df$flag <- "N"
  df$flag[iY] <- "Y"
  df
}

f3 <- function(df, set1, set2) {
  df$flag <- c("N", "Y")[(lengths(
    Map(
      intersect,
      asplit(df[set1], 1),
      asplit(df[set2], 1)
    )
  ) > 0) + 1]
  df
}

基准

microbenchmark::microbenchmark(
  f1 = f1(df, set1, set2),
  f2 = f2(df, set1, set2),
  f3 = f3(df, set1, set2),
  check = "equal"
)
#> Unit: milliseconds
#>  expr      min        lq       mean   median        uq       max neval
#>    f1 733.1518 778.70590 927.068694 848.8564 999.61955 1687.4810   100
#>    f2   4.9241   5.64215   6.283577   6.3074   6.82695    9.2447   100
#>    f3 119.9982 134.07060 165.306384 151.6871 189.23330  282.1914   100