有没有一种更快的方法通过在 R 中的第 i 行和 i-1 行比较其他 4 个向量来创建新向量?

Question

>假设您有一个包含其购买历史记录的客户数据集。

数据按客户及其活动日期排序 又名购买

目标是计算他们的购买频率，但要快

Data <- tibble(Customer = c("Person A", "Person A", "Person A", "Person A", "Person A", "Person A","Person B", "Person C","Person C"),
First_Activity_Date = c(1,1,1,1,1,1,1,1,1),   # imagine these numbers as dates
Activity_Date = c(1,2,3,4,5,6,1,1,2),         
Last_Activity_Date =c(6,6,6,6,6,6,1,2,2)
)
View(Data)
tic()
h <- vector( "integer", length = 9)
f <- function(x, y, z, q){
for( i in 1:length(x)){
if ( identical(z[i],y[i])) { h[i] <- 1 }
else if ( identical(x[i],x[i-1]) && (z[i]<=q[i])) { h[i] <- (h[i-1]+1) }
}
return(h)
}
Data <- mutate(Data, Frequency = f(Customer, First_Activity_Date, 
Activity_Date, Last_Activity_Date) )
View(Data)
toc()

#Data <- select( Data, Customer, First_Activity_Date, Activity_Date, Last_Activity_Date) 
#remove(h)
#remove(f) 

它适用于填充数字的小数据集，但行号超过 50K 填充日期需要大约 2 分钟。

有没有办法矢量化这个函数/计算？

Answer 1

让我们建立一个替代解决方案

f1 <- function(x, y, z, q) {

使用传递给函数的参数在函数内分配结果向量

h <- integer(length(x)) # allocate the result inside the function

循环由可以"矢量化"的部分组成(一个函数调用，而不是循环的每次迭代的函数调用)。编写矢量化版本

tst_1 <- z == y        # 'hoist' outside loop as vectorized comparison
h[tst_1] <- 1L         # update h; '1L': integer, not '1': numeric

条件的else部分在i == 1时有一个错误，因为人们试图将x[1]与不存在的x[0]进行比较。假设我们从不输入i == 1的条件，所以矢量化版本是

tst_2 <- !tst_1 & c(FALSE, tail(x, -1) == head(x, -1)) & z <= q

实现h更新的最直接方法是一个简单的循环，例如

for (i in which(tst_2))
h[i] <- h[i - 1] + 1L

并最终返回结果

h
}

完整的功能，稍作调整，是

f1 <- function(x, y, z, q) {
h <- integer(length(x)) # allocate the result inside the function
## if (...)
h[z == y] <- 1L
## else if (...)
tst <- !h & c(FALSE, x[-1] == x[-length(x)]) & z <= q
for (i in which(tst))
h[i] <- h[i - 1] + 1L
h
}

通过专注于剩余的for()循环，可以进一步提高性能，但也许这已经让您达到了所需的性能，而不会太神秘？

还可以更干净地分离选择相关事件的"过滤器"操作

keep <- (y >= z) & (z <= q)
x0 <- x[keep]

从每个组的操作过程来看。在这里，您将创建一个从 1 到组成员数的按组序列。有几种方法是

h0 <- ave(seq_along(x0), x0, FUN=seq_along)

或

grp_size = rle(x0)$lengths
offset = rep(cumsum(c(0L, grp_size[-length(grp_size)])), grp_size)
h0 <- seq_len(sum(grp_size)) - offset

或

grp_size = tabulate(match(x0, unique(x0)))
offset = rep(cumsum(c(0L, grp_size[-length(grp_size)])), grp_size)
h0 <- seq_len(sum(grp_size)) - offset

此问题的其他解决方案可在StackOverflow的其他地方找到。 最后一步是创建返回值

h <- integer(length(x))
h[keep] <- h0
h

Data是一个tibble，所以也许你对dplyr很熟悉。以可理解但不一定有效的方式实现结果的一种方法是

d0 <- Data %>%
filter(
Activity_Date >= First_Activity_Date, 
Activity_Date <= Last_Activity_Date
) %>% 
group_by(Customer) %>%
mutate(Frequency = seq_along(Customer))
left_join(Data, d0)