是否有合并数据帧和循环浏览组合的更快方法？

Question

我有两个数据框：

1. dfA每行有10个观察值。
2. dfB在所有单个观察结果中都有相应的价格。

我的任务是查看dfA中的任意两行，找出​​两行中的哪些元素，对匹配项的价格求和，并将结果存储在新的数据帧dfC中。

例如，假设我们有dfA：

row 1: A, B, C, X, X, X, X, X, X, X  
row 2: Z, Z, A, Z, C, Z, Z, B, Z, Z

并且在dfB中：

A, 63  
B, 22  
C, 99  
...

[第1行和第2行的重叠是A，B和C，所以我想要(63 + 22 + 99) / 1000和dfC[1, 2]中的dfC[2, 1]。

以下代码完成了我所需要的，但是随着n变大，它效率不高。我实际的dfA有1000行以上，可能要花10分钟才能运行，所以我正在寻找更有效地编写此代码的方法。

set.seed(42)
n <- 10
dfA <- data.frame(replicate(10 ,sample(LETTERS,n,rep=TRUE)), stringsAsFactors = F)
dfB <- data.frame(ID = LETTERS, Price = as.numeric(sample(1:100, 26, replace=FALSE)), stringsAsFactors = F)

overlapPrice <- function (A, B) {
        if (A == B) {
                return(1)
        } else {
                x <- intersect(t(dfA[A, ]), t(dfA[B, ]))     
                return(sum(dfB$Price[match(x, dfB$ID)])/1000)  
        }
}

dfC <- data.frame(matrix(vector(), n, n))    
for (i in (1:n)) {
        for (j in (i:n)) {
                dfC[i, j]  <-   overlapPrice(i, j)  
                dfC[j, i]  <-   dfC[i, j]  

        }
} 

Answer 1

使用outer可以加快速度

f1 <- function(i, j) {
       x <- intersect(t(dfA[i, ]),  t(dfA[j, ]))
       sum(dfB$Price[match(x, dfB$ID)])/1000
    }
out <-  outer(seq_len(n), seq_len(n), FUN = Vectorize(f1))
diag(out) <- 1
all.equal(dfC, as.data.frame(out), check.attributes = FALSE)
#[1] TRUE

Answer 2

像这样跨行工作，可以更快地将dfA转换成矩阵，否则就从构成数据帧的所有向量中重复设置子集。

matA <- as.matrix(dfA)

接下来，让我们使用combn，它将只创建每个配对一次，因此您无需两次计算每个组合。 combn()可以使一个函数在每个组合上运行，其中该函数采用一个向量，该向量表示否则将要输出的combin。

str(combn(seq(3), 2, simplify = FALSE))
#> List of 3
#>  $ : int [1:2] 1 2
#>  $ : int [1:2] 1 3
#>  $ : int [1:2] 2 3
str(combn(seq(3), 2, function(x) rev(x), simplify = FALSE))
#> List of 3
#>  $ : int [1:2] 2 1
#>  $ : int [1:2] 3 1
#>  $ : int [1:2] 3 2

我们可以使用此功能对matA进行子集化，并对每种组合进行计算。

vecC <- combn(nrow(matA), 2, function(x) {
    row1 <- matA[x[1], ]
    row2 <- matA[x[2], ]
    sum(dfB$Price[match(intersect(row1, row2), dfB$ID)]) / 1000
})

vecC
#>  [1] 0.329 0.103 0.119 0.204 0.204 0.255 0.262 0.196 0.146 0.160 0.071 0.204
#> [13] 0.370 0.109 0.260 0.181 0.000 0.066 0.018 0.019 0.018 0.039 0.081 0.000
#> [25] 0.105 0.018 0.108 0.000 0.133 0.113 0.233 0.141 0.148 0.184 0.112 0.190
#> [37] 0.178 0.181 0.000 0.192 0.157 0.273 0.194 0.145 0.169

此结果等于dfC的下三角：

all(vecC == dfC[lower.tri(dfC)])
#> [1] TRUE

但是，很难看到到底是什么，所以让我们将其变成索引和值的数据框：

dfCi <- as.data.frame(t(combn(nrow(matA), 2)))
names(dfCi) <- c('i1', 'i2')
dfCi$value <- vecC

str(dfCi)
#> 'data.frame':    45 obs. of  3 variables:
#>  $ i1   : int  1 1 1 1 1 1 1 1 1 2 ...
#>  $ i2   : int  2 3 4 5 6 7 8 9 10 3 ...
#>  $ value: num [1:45(1d)] 0.329 0.103 0.119 0.204 0.204 0.255 0.262 0.196 0.146 0.16 ...

head(dfCi)
#>   i1 i2 value
#> 1  1  2 0.329
#> 2  1  3 0.103
#> 3  1  4 0.119
#> 4  1  5 0.204
#> 5  1  6 0.204
#> 6  1  7 0.255

如果要重塑形状以重新创建像dfC这样的方矩阵，则可以：

# reverse indices to get points for opposite triangle
dfCiRev <- dfCi
dfCiRev[1:2] <- dfCi[2:1]
names(dfCiRev) <- names(dfCi)

# reshape to wide form (use `pivot_wider` or `reshape` or `dcast` or whatever you prefer)
matC <- as.matrix(tidyr::spread(rbind(dfCi, dfCiRev), i2, value, fill = 1)[-1])
dimnames(matC) <- rep(list(colnames(matA)), 2)

matC
#>        X1    X2    X3    X4    X5    X6    X7    X8    X9   X10
#> X1  1.000 0.329 0.103 0.119 0.204 0.204 0.255 0.262 0.196 0.146
#> X2  0.329 1.000 0.160 0.071 0.204 0.370 0.109 0.260 0.181 0.000
#> X3  0.103 0.160 1.000 0.066 0.018 0.019 0.018 0.039 0.081 0.000
#> X4  0.119 0.071 0.066 1.000 0.105 0.018 0.108 0.000 0.133 0.113
#> X5  0.204 0.204 0.018 0.105 1.000 0.233 0.141 0.148 0.184 0.112
#> X6  0.204 0.370 0.019 0.018 0.233 1.000 0.190 0.178 0.181 0.000
#> X7  0.255 0.109 0.018 0.108 0.141 0.190 1.000 0.192 0.157 0.273
#> X8  0.262 0.260 0.039 0.000 0.148 0.178 0.192 1.000 0.194 0.145
#> X9  0.196 0.181 0.081 0.133 0.184 0.181 0.157 0.194 1.000 0.169
#> X10 0.146 0.000 0.000 0.113 0.112 0.000 0.273 0.145 0.169 1.000

all(matC == as.matrix(dfC))
#> [1] TRUE

最好的部分是计算vecC比dfC快很多：

# A tibble: 3 x 13
  expression     min  median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time result memory time  gc   
  <bch:expr> <bch:t> <bch:t>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm> <list> <list> <lis> <lis>
1 original   36.14ms 37.85ms      24.4      63KB     2.03    12     1      493ms <NULL> <df[,… <bch… <tib…
2 outer      53.33ms 56.67ms      15.1      86KB     2.15     7     1      465ms <NULL> <df[,… <bch… <tib…
3 combn       1.69ms  1.81ms     531.     58.6KB     4.33   245     2      461ms <NULL> <df[,… <bch… <tib…