У меня есть метрика, которая распределяется между четырьмя категориями a, b, c, d
.Расчет каннибализации/атрибуции в R
В течение определенного периода времени я отслеживаю движение в метрике для каждой категории. Сумма этих движений представляет собой количество, которое либо вышло, либо вступило в систему из другого места («внешний»).
# SETUP -------------------------------------------------------------------
categories <- letters[1:4]
set.seed(1)
movements <- lapply(categories, function(...) {round(runif(10, -10,10))*10})
names(movements) <- categories
movements[['external']] <- Reduce(`+`, movements)*-1
problem <- as.data.frame(movements)
problem
a b c d external
1 -50 -60 90 0 20
2 -30 -60 -60 20 130
3 10 40 30 0 -80
4 80 -20 -70 -60 70
5 -60 50 -50 70 -10
6 80 0 -20 30 -90
7 90 40 -100 60 -90
8 30 100 -20 -80 -30
9 30 -20 70 40 -120
10 -90 60 -30 -20 80
Где некоторые категории претерпели позитивные сдвиги и другие претерпели негативное движение, мы можем сделать вывод, перевод внутри системы.
# ADD TRANSFER COLUMNS AND INITIALISE TO 0 --------------------------------
transfer_matrix <- combn(c(categories, 'external'), 2)
transfer_list <- combn(c(categories, 'external'), 2, simplify=F)
problem[,sapply(transfer_list, paste, collapse='.')] <- 0
paste(names(problem), collapse=', ')
[1] "a, b, c, d, external, a.b, a.c, a.d, a.external, b.c, b.d, b.external, c.d, c.external, d.external"
Например a
уменьшилось на 50 и c
увеличилось на 90, таким образом, мы можем сделать вывод, существует переход от a
к c
, которые будут храниться в переменной a.c
.
Правило для расчета передач пропорционально. Поэтому, когда «a» уменьшилось на 50 и b
уменьшилось на 60, то 50/(50 + 60) увеличения c
следует отнести к 'a'
, а 60/(50 + 60) увеличения в c
должно быть приписывается b
. И аналогично для передач в и из системы.
Ниже показан полный ручной расчет для всех переменных, мне нужно, для первой строки:
# MANUAL CALCULATION ------------------------------------------------------
row_limit <- 1 # change to e.g. 1:10
problem[row_limit, 'a.b'] <- 0
problem[row_limit, 'a.c'] <- 90*(-50/(-50+-60))
problem[row_limit, 'a.d'] <- 0
problem[row_limit, 'a.external'] <- 20 * -50/(-50+-60)
problem[row_limit, 'b.c'] <- 90*(-60/(-50+-60))
problem[row_limit, 'b.d'] <- 0
problem[row_limit, 'b.external'] <- 20 * -60/(-50+-60)
problem[row_limit, 'c.d'] <- 0
problem[row_limit, 'c.external'] <- 0
problem[row_limit, 'd.external'] <- 0
Обратите внимание, что поскольку a.c = -c.a
только подмножество всех возможных переводов необходимо рассчитать.
Мой вопрос в том, как я могу запрограммировать приведенные выше вычисления в краткой и эффективной форме для обработки 10-20 категорий и большого количества строк?
Обычно я использую data.table, но открываю любые предложения пакетов для использования.
Ниже приведен код для проверки вывода:
# CHECKING ----------------------------------------------------------------
check <- function(problem, category, categories, transfer_list, transfer_matrix) {
out_columns <- sapply(transfer_list[transfer_matrix[1,] == category], paste, collapse='.')
in_columns <- sapply(transfer_list[transfer_matrix[2,] == category], paste, collapse='.')
stopifnot(length(c(out_columns, in_columns)) == length(categories)-1)
out_sum <- 0
if(length(out_columns) == 1) {
out_sum <- problem[,out_columns]
} else if(length(out_columns) > 1) {
out_sum <- Reduce(`+`, problem[,out_columns])
}
in_sum <- 0
if(length(in_columns) == 1) {
in_sum <- problem[,in_columns]
}
else if(length(in_columns) > 1) {
in_sum <- Reduce(`+`, problem[,in_columns])
}
lhs <- out_sum - in_sum
rhs <- -problem[, category]
sprintf('%s vs %s',lhs, rhs)
}
# For each category, actual vs expected
sapply(c(categories,'external'), check, problem=problem, categories=c(categories,'external'), transfer_list=transfer_list,transfer_matrix=transfer_matrix)
a b c d
[1,] "50 vs 50" "60 vs 60" "-90 vs -90" "0 vs 0"
[2,] "0 vs 30" "0 vs 60" "0 vs 60" "0 vs -20"
[3,] "0 vs -10" "0 vs -40" "0 vs -30" "0 vs 0"
[4,] "0 vs -80" "0 vs 20" "0 vs 70" "0 vs 60"
[5,] "0 vs 60" "0 vs -50" "0 vs 50" "0 vs -70"
[6,] "0 vs -80" "0 vs 0" "0 vs 20" "0 vs -30"
[7,] "0 vs -90" "0 vs -40" "0 vs 100" "0 vs -60"
[8,] "0 vs -30" "0 vs -100" "0 vs 20" "0 vs 80"
[9,] "0 vs -30" "0 vs 20" "0 vs -70" "0 vs -40"
[10,] "0 vs 90" "0 vs -60" "0 vs 30" "0 vs 20"
Не могли бы вы упростить это до небольшого воспроизводимого примера? Возможно, упростите проблему, с которой вы столкнулись? Это займет некоторое время, чтобы понять и решить, что вы пытаетесь сделать/как это сделать лучше, и в этом случае будет вопрос «напишите мой код», который не разрешен. –
Хм ... у вас возникли проблемы с кодом/воспроизведением результатов? Я согласен, что это длинный вопрос ... Я мог бы удалить часть кода, например. блок блоков переноса и блок проверки, если вы считаете, что это поможет. – logworthy
Я не собираюсь запускать все это и пытаюсь его отладить. Если у вас есть конкретная проблема, отбросьте ее на общий пример. –