构造数据集

下面是一个可重复的例子，构造两个数据集，一个是基于 data.frame 的列表，另一个是就要 data.table 的列表：

x <- list(
  a = data.frame(r1 = c("S1", "S2"), r3 = c("S2", "S1")),
  b = data.frame(r1 = c("S1", "S2"), r5 = c("S2", "S1")),
  c = data.frame(r2 = c("S1", "S2"), r4 = c("S2", "S1")),
  d = data.frame(r4 = c("S1", "S2"), r5 = c("S2", "S1"))
)

str(x)
#> List of 4
#>  $ a:'data.frame':   2 obs. of  2 variables:
#>   ..$ r1: chr [1:2] "S1" "S2"
#>   ..$ r3: chr [1:2] "S2" "S1"
#>  $ b:'data.frame':   2 obs. of  2 variables:
#>   ..$ r1: chr [1:2] "S1" "S2"
#>   ..$ r5: chr [1:2] "S2" "S1"
#>  $ c:'data.frame':   2 obs. of  2 variables:
#>   ..$ r2: chr [1:2] "S1" "S2"
#>   ..$ r4: chr [1:2] "S2" "S1"
#>  $ d:'data.frame':   2 obs. of  2 variables:
#>   ..$ r4: chr [1:2] "S1" "S2"
#>   ..$ r5: chr [1:2] "S2" "S1"

x2 <- list(
  a = data.table::data.table(r1 = c("S1", "S2"), r3 = c("S2", "S1")),
  b = data.table::data.table(r1 = c("S1", "S2"), r5 = c("S2", "S1")),
  c = data.table::data.table(r2 = c("S1", "S2"), r4 = c("S2", "S1")),
  d = data.table::data.table(r4 = c("S1", "S2"), r5 = c("S2", "S1"))
)

str(x2)
#> List of 4
#>  $ a:Classes 'data.table' and 'data.frame':  2 obs. of  2 variables:
#>   ..$ r1: chr [1:2] "S1" "S2"
#>   ..$ r3: chr [1:2] "S2" "S1"
#>   ..- attr(*, ".internal.selfref")=<externalptr> 
#>  $ b:Classes 'data.table' and 'data.frame':  2 obs. of  2 variables:
#>   ..$ r1: chr [1:2] "S1" "S2"
#>   ..$ r5: chr [1:2] "S2" "S1"
#>   ..- attr(*, ".internal.selfref")=<externalptr> 
#>  $ c:Classes 'data.table' and 'data.frame':  2 obs. of  2 variables:
#>   ..$ r2: chr [1:2] "S1" "S2"
#>   ..$ r4: chr [1:2] "S2" "S1"
#>   ..- attr(*, ".internal.selfref")=<externalptr> 
#>  $ d:Classes 'data.table' and 'data.frame':  2 obs. of  2 variables:
#>   ..$ r4: chr [1:2] "S1" "S2"
#>   ..$ r5: chr [1:2] "S2" "S1"
#>   ..- attr(*, ".internal.selfref")=<externalptr>

从存储的信息来看，这两个列表是没有任何差异的。

相同的数据，不同的操作函数存在差异

在进行连接操作时，我们会发现 dplyr 的结果会报错！

purrr::reduce(x, dplyr::full_join)
#> Joining, by = "r1"
#> Error: `by` must be supplied when `x` and `y` have no common variables.
#> ℹ use by = character()` to perform a cross-join.
purrr::reduce(x, merge)
#>   r5 r4 r1 r3 r2
#> 1 S1 S2 S2 S1 S1
#> 2 S2 S1 S1 S2 S2

看起来似乎有点不可理喻，但实际上上面我构造的数据集是有点特别的：前 2 个子集和第 3 个子集是没有可以连接的列的，第 4 个子集起到桥梁作用。所以使用 dplyr 提供的连接函数报错是正常的，但有意思的是，基础包提供的 merge() 函数可以完成连接操作，真是优秀（感兴趣的朋友可以看下测试下 merge 函数源代码）！

x
#> $a
#>   r1 r3
#> 1 S1 S2
#> 2 S2 S1
#> 
#> $b
#>   r1 r5
#> 1 S1 S2
#> 2 S2 S1
#> 
#> $c
#>   r2 r4
#> 1 S1 S2
#> 2 S2 S1
#> 
#> $d
#>   r4 r5
#> 1 S1 S2
#> 2 S2 S1

data.table 不支持上述 merge 连接

我们可以再看下基于 data.table 构造的数据集结果：

purrr::reduce(x2, dplyr::full_join)
#> Joining, by = "r1"
#> Error: `by` must be supplied when `x` and `y` have no common variables.
#> ℹ use by = character()` to perform a cross-join.
purrr::reduce(x2, merge)
#> Error in merge.data.table(out, elt, ...): Elements listed in `by` must be valid column names in x and y

两个函数操作都报错了，说明对 data.table 是不适用的。本质上是 data.table 体格的泛型函数不支持类似基础包中的操作。

如何编写代码支持对上述数据集的连接操作？

一般工作情况下，不同的数据子集都存在可以连接的列，所以无论上述哪种方法都可以胜任工作。但特殊情况下，即类似我上述构造的数据集：数据子集不是所有但两两之间都存在共有的列，但按照一定的顺序确实能够将其合并。

下面给出探索后的解决代码：

to_join <- x2[[1]]
be_join <- x2[-1]

# https://stackoverflow.com/questions/30542128/circular-shift-of-vector-by-distance-n
shifter <- function(x, n = 1) {
  if (n == 0) x else c(tail(x, -n), head(x, n))
}

while (length(be_join) > 0) {
  col_exist <- colnames(be_join[[1]]) %in% colnames(to_join)
  if (any(col_exist)) {
    to_join <- merge(to_join, be_join[[1]], by = colnames(be_join[[1]])[col_exist])
    be_join[[1]] <- NULL
  } else {
    be_join <- shifter(be_join)
  }
}

上述代码中执行下面的操作：

1. 构造两个集合 to_join 和 be_join，to_join 初始化为数据集的第一个子集，而 be_join 为其他子集。

2. 如果 be_join 不为空，进行如下的循环：

   1. 检查 be_join 第一个子集的列与 to_join 存在共同列

      1. 如果存在，则将这个子集和 to_join 按共同列合并

      2. 如果不存在，使用循环位移一位，将当前 be_join 的第 2 个子集移动为 第 1 个。

   2. 等待循环结束

我们可以查看结果：

to_join[, c("r1", "r2", "r3", "r4", "r5")]
#>    r1 r2 r3 r4 r5
#> 1: S1 S2 S2 S1 S2
#> 2: S2 S1 S1 S2 S1

对比下面结果是相同的（虽然顺序颠倒了）。

purrr::reduce(x, merge)[, c("r1", "r2", "r3", "r4", "r5")]
#>   r1 r2 r3 r4 r5
#> 1 S2 S1 S1 S2 S1
#> 2 S1 S2 S2 S1 S2

更新

在后面的一些使用过程中发现基础包的 merge() 函数在进行连接操作时会输出有问题的结果，所以建议使用的小伙伴仔细检查结果。下面更新了一个用于合并的函数：

reduceG <- function(G) {
  # Reduce elements of G if at least two elements
  # contain common column names
  # G >= 2 elements here
  if (length(G) < 2) {
    return(G)
  }
  cnames <- purrr::map(G, colnames)
  check_list <- combn(seq_along(cnames), 2, simplify = FALSE)
  common <- purrr::map(check_list, ~ intersect(cnames[[.[1]]], cnames[[.[2]]]))

  # Index to reduce
  ri <- purrr::map_lgl(common, ~ length(.) != 0)
  if (any(ri)) {
    purrr::map2(check_list[ri], common[ri], .f = function(x, y) {
      if (!is.na(G[x[1]]) & !is.na(G[x[2]])) {
        # Update global G in reduceG
        G[[min(x)]] <<- merge(G[[x[1]]], G[[x[2]]], by = y)
        # to make sure the data is removed and the index
        # is kept to avoid "subscript out of bounds" error
        G[[max(x)]] <<- NA
      }
    })
    # Remove elements set to NA
    G <- G[!is.na(G)]
    return(reduceG(G))
  } else {
    return(G)
  }
}

测试结果：

reduceG(x)[[1]]
#>   r5 r1 r3 r4 r2
#> 1 S1 S2 S1 S2 S1
#> 2 S2 S1 S2 S1 S2
reduceG(x2)[[1]]
#>    r5 r1 r3 r4 r2
#> 1: S1 S2 S1 S2 S1
#> 2: S2 S1 S2 S1 S2