R:矢量化循环以创建成对矩阵

Question

我想加速一个函数，用于创建一个成对矩阵，该矩阵描述在一组位置中在所有其他对象之前和之后选择对象的次数。
这是一个示例 df :

  df <- data.frame(Shop = c("A","A","A","B","B","C","C","D","D","D","E","E","E"),
                   Fruit = c("apple", "orange", "pear",
                             "orange", "pear",
                             "pear", "apple",
                             "pear", "apple", "orange",
                             "pear", "apple", "orange"),
                   Order = c(1, 2, 3,
                            1, 2,
                            1, 2, 
                            1, 2, 3,
                            1, 1, 1))

在每个 Shop 中， Fruit 由客户在给定的 Order 中挑选。
以下函数创建一个 m x n 成对矩阵:

loop.function <- function(df){
  
  fruits <- unique(df$Fruit)
  nt <- length(fruits)
  mat <- array(dim=c(nt,nt))
  
  for(m in 1:nt){
    
    for(n in 1:nt){
      
      ## filter df for each pair of fruit
      xm <- df[df$Fruit == fruits[m],]
      xn <- df[df$Fruit == fruits[n],]
      
      ## index instances when a pair of fruit are picked in same shop
      mm <- match(xm$Shop, xn$Shop)
      
      ## filter xm and xn based on mm
      xm <- xm[! is.na(mm),]
      xn <- xn[mm[! is.na(mm)],]
      
      ## assign number of times fruit[m] is picked after fruit[n] to mat[m,n]
      mat[m,n] <- sum(xn$Order < xm$Order)
    }
  }
  
  row.names(mat) <- fruits
  colnames(mat) <- fruits
  
  return(mat)
}

其中 mat[m,n] 是在 fruits[m] 之后选择 fruits[n] 的次数。 mat[n,m] 是在 fruits[m] 之前选择 fruits[n] 的次数。如果同时采摘成对的水果(例如在 Shop E 中)，则不会记录。
查看预期输出:

>loop.function(df)
       apple orange pear
apple      0      0    2
orange     2      0    1
pear       1      2    0

您可以在这里看到 pear 在 apple 之前被选择了两次(在 Shop C 和 D 中)，并且 apple 在 pear 之前被选择了一次(在 Shop A 中)。
我正在努力提高我对矢量化的了解，尤其是在代替循环方面，所以我想知道如何对这个循环进行矢量化。
(我感觉可能有使用 outer() 的解决方案，但我对矢量化函数的了解仍然非常有限。)
更新
对于 times = 10000 、 loop.function() 、 tidyverse.function() 、 loop.function2() 和 datatable.function() ，请参阅使用真实数据 loop.function.TMS() 进行基准测试:

Unit: milliseconds
                    expr            min        lq       mean    median         uq      max     neval   cld
      loop.function(dat)     186.588600 202.78350 225.724249 215.56575 234.035750 999.8234    10000     e
     tidyverse.function(dat)  21.523400  22.93695  26.795815  23.67290  26.862700 295.7456    10000   c 
     loop.function2(dat)     119.695400 126.48825 142.568758 135.23555 148.876100 929.0066    10000    d
 datatable.function(dat)       8.517600   9.28085  10.644163   9.97835  10.766749 215.3245    10000  b 
  loop.function.TMS(dat)       4.482001   5.08030   5.916408   5.38215   5.833699  77.1935    10000 a 

对我来说最有趣的结果可能是 tidyverse.function() 在真实数据上的表现。稍后我将不得不尝试添加 Rccp 解决方案 - 我无法让它们处理真实数据。
我感谢大家对这篇文章的兴趣和回答——我的目的是学习和提高性能，从所有给出的评论和解决方案中肯定有很多东西要学习。谢谢!

Answer 1

一个 data.table解决方案 :

library(data.table)
setDT(df)
setkey(df,Shop)
dcast(df[df,on=.(Shop=Shop),allow.cartesian=T][
           ,.(cnt=sum(i.Order<Order&i.Fruit!=Fruit)),by=.(Fruit,i.Fruit)]
      ,Fruit~i.Fruit,value.var='cnt')

    Fruit apple orange pear
1:  apple     0      0    2
2: orange     2      0    1
3:   pear     1      2    0

Shop index 在这个例子中不是必需的，但可能会提高更大数据集的性能。
由于这个问题对性能提出了很多评论，我决定检查一下 Rcpp可以带来:

library(Rcpp)
cppFunction('NumericMatrix rcppPair(DataFrame df) {

std::vector<std::string> Shop = Rcpp::as<std::vector<std::string> >(df["Shop"]);
Rcpp::NumericVector Order = df["Order"];
Rcpp::StringVector Fruit = df["Fruit"];
StringVector FruitLevels = sort_unique(Fruit);
IntegerVector FruitInt = match(Fruit, FruitLevels);
int n  = FruitLevels.length();

std::string currentShop = "";
int order, fruit, i, f;

NumericMatrix result(n,n);
NumericVector fruitOrder(n);

for (i=0;i<Fruit.length();i++){
    if (currentShop != Shop[i]) {
       //Init counter for each shop
       currentShop = Shop[i];
       std::fill(fruitOrder.begin(), fruitOrder.end(), 0);
    }
    order = Order[i];
    fruit = FruitInt[i];
    fruitOrder[fruit-1] = order;
    for (f=0;f<n;f++) {
       if (order > fruitOrder[f] & fruitOrder[f]>0 ) { 
         result(fruit-1,f) = result(fruit-1,f)+1; 
    }
  }
}
rownames(result) = FruitLevels;
colnames(result) = FruitLevels;
return(result);
}
')

rcppPair(df)

       apple orange pear
apple      0      0    2
orange     2      0    1
pear       1      2    0

在示例数据集上，运行 > 快 500 倍 比 data.table解决方案，可能是因为它没有笛卡尔积问题。这不应该在错误输入时保持稳健，并期望商店/订单按升序排列。
考虑到查找 data.table 的 3 行代码所花费的几分钟时间。解决方案，与更长的时间相比 Rcpp解决方案/调试过程，我不建议去 Rcpp除非有真正的性能瓶颈。
然而有趣的是要记住，如果性能是必须的， Rcpp可能值得付出努力。