Есть ли более быстрый способ создания нового вектора путем сравнения 4 других векторов через строки i и i-1 в R?

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) 

Он отлично работает с небольшим набором данных, заполненным числами, но с номером строки свыше 50 КБ, заполненным датами, требуется около 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 - тиббл, так что, возможно, вы знакомы с 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)