我想加快创建成对矩阵的功能，该矩阵描述在一组位置中所有其他对象之前和之后一个对象被选择的次数。
下面是一个示例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]是在{em>之后{em> fruits[m]被fruits[n]拾取的次数。 mat[n,m]是在{em> 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解决方案-我无法使它们在实际数据上正常工作。
我非常感谢这篇文章引起的所有兴趣和解答-我的目的是学习和改进性能，从给出的所有评论和解决方案中当然可以学到很多东西。谢谢！
答案 0 :(得分：10)
一个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索引不是必需的，但可能会提高较大数据集的性能。
由于这个问题引起了很多关于性能的评论，我决定检查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
在示例数据集上，其运行速度比data.table解决方案快> 500倍，这可能是因为它没有笛卡尔积问题。不应在输入错误时使用此功能，并且希望商店/订单按升序排列。
考虑到为data.table解决方案查找3行代码所花费的时间，与更长的Rcpp解决方案/调试过程相比，我不建议您使用{{1 }}，除非存在真正的性能瓶颈。
但是要记住，如果必须要有性能，Rcpp可能值得付出努力。
答案 1 :(得分：7)
这是一种可以进行简单修改以使其速度提高5倍的方法。
loop.function2 <- function(df){
spl_df = split(df[, c(1L, 3L)], df[[2L]])
mat <- array(0L,
dim=c(length(spl_df), length(spl_df)),
dimnames = list(names(spl_df), names(spl_df)))
for (m in 1:(length(spl_df) - 1L)) {
xm = spl_df[[m]]
mShop = xm$Shop
for (n in ((1+m):length(spl_df))) {
xn = spl_df[[n]]
mm = match(mShop, xn$Shop)
inds = which(!is.na(mm))
mOrder = xm[inds, "Order"]
nOrder = xn[mm[inds], "Order"]
mat[m, n] <- sum(nOrder < mOrder)
mat[n, m] <- sum(mOrder < nOrder)
}
}
mat
}
有3个主要概念：
df[df$Fruits == fruits[m], ]行的效率很低，因为您将进行length(Fruits)^2次相同的比较。相反，我们可以使用split()，这意味着我们只扫描一次水果。df$var可以在每个循环中提取向量。在这里，我们将xm的分配放在内部循环之外，并尝试将子集/提取所需的内容最小化。combn，因为我们可以同时执行match()和sum(xmOrder > xnOrder)来重新使用sum(xmOrder < xnOrder)条件。性能：
bench::mark(loop.function(df), loop.function2(df))
# A tibble: 2 x 13
## expression min median
## <bch:expr> <bch:tm> <bch:>
##1 loop.function(df) 3.57ms 4.34ms
##2 loop.function2(df) 677.2us 858.6us
我的直觉是，对于更大的数据集，@ Waldi的data.table解决方案会更快。但是对于较小的数据集，这应该相当不错。
最后，这是另一种{@ 3}}的方法，它似乎比@Waldi慢：
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
IntegerMatrix loop_function_cpp(List x) {
int x_size = x.size();
IntegerMatrix ans(x_size, x_size);
for (int m = 0; m < x_size - 1; m++) {
DataFrame xm = x[m];
CharacterVector mShop = xm[0];
IntegerVector mOrder = xm[1];
int nrows = mShop.size();
for (int n = m + 1; n < x_size; n++) {
DataFrame xn = x[n];
CharacterVector nShop = xn[0];
IntegerVector nOrder = xn[1];
for (int i = 0; i < nrows; i++) {
for (int j = 0; j < nrows; j++) {
if (mShop[i] == nShop[j]) {
if (mOrder[i] > nOrder[j])
ans(m, n)++;
else
ans(n, m)++;
break;
}
}
}
}
}
return(ans);
}
loop_wrapper = function(df) {
loop_function_cpp(split(df[, c(1L, 3L)], df[[2L]]))
}
loop_wrapper(df)
``
答案 2 :(得分：5)
似乎无法在原始数据帧df上进行矢量化。但是，如果您使用reshape2::dcast()对其进行转换，则每个商店有一行：
require(reshape2)
df$Fruit <- as.character(df$Fruit)
by_shop <- dcast(df, Shop ~ Fruit, value.var = "Order")
# Shop apple orange pear
# 1 A 1 2 3
# 2 B NA 1 2
# 3 C 2 NA 1
# 4 D 2 3 1
# 5 E 1 1 1
...，那么您可以轻松地至少对[m，n]的每种组合进行向量化：
fruits <- unique(df$Fruit)
outer(fruits, fruits,
Vectorize(
function (m, n, by_shop) sum(by_shop[,m] > by_shop[,n], na.rm = TRUE),
c("m", "n")
),
by_shop)
# [,1] [,2] [,3]
# [1,] 0 0 2
# [2,] 2 0 1
# [3,] 1 2 0
这可能是您希望与outer一起使用的解决方案。更快的解决方案是对水果[m，n]的所有组合进行真正的矢量化，但是我一直在考虑它，但我看不到有任何办法。因此，我不得不使用Vectorize函数，该函数当然比真正的矢量化要慢得多。
与原始功能进行基准比较：
Unit: milliseconds
expr min lq mean median uq max neval
loop.function(df) 3.788794 3.926851 4.157606 4.002502 4.090898 9.529923 100
loop.function.TMS(df) 1.582858 1.625566 1.804140 1.670095 1.756671 8.569813 100
功能和基准代码（还添加了暗号的保留）：
require(reshape2)
loop.function.TMS <- function(df) {
df$Fruit <- as.character(df$Fruit)
by_shop <- dcast(df, Shop ~ Fruit, value.var = "Order")
fruits <- unique(df$Fruit)
o <- outer(fruits, fruits, Vectorize(function (m, n, by_shop) sum(by_shop[,m] > by_shop[,n], na.rm = TRUE), c("m", "n")), by_shop)
colnames(o) <- rownames(o) <- fruits
o
}
require(microbenchmark)
microbenchmark(loop.function(df), loop.function.TMS(df))
答案 3 :(得分：2)
好的，这是一个解决方案：
library(tidyverse)
# a dataframe with all fruit combinations
df_compare <- expand.grid(row_fruit = unique(df$Fruit)
, column_fruit = unique(df$Fruit)
, stringsAsFactors = FALSE)
df_compare %>%
left_join(df, by = c("row_fruit" = "Fruit")) %>%
left_join(df, by = c("column_fruit" = "Fruit")) %>%
filter(Shop.x == Shop.y &
Order.x < Order.y) %>%
group_by(row_fruit, column_fruit) %>%
summarise(obs = n()) %>%
pivot_wider(names_from = row_fruit, values_from = obs) %>%
arrange(column_fruit) %>%
mutate_if(is.numeric, function(x) replace_na(x, 0)) %>%
column_to_rownames("column_fruit") %>%
as.matrix()
apple orange pear
apple 0 0 2
orange 2 0 1
pear 1 2 0
如果您不知道第二个代码部分（df_compare %>% ...）中发生了什么，请将“管道”（%>%）读为'then'。从df_compare到任何管道之前运行代码，以查看中间结果。