2016-09-13 3 views
0

У меня есть метрика, которая распределяется между четырьмя категориями 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" 
+0

Не могли бы вы упростить это до небольшого воспроизводимого примера? Возможно, упростите проблему, с которой вы столкнулись? Это займет некоторое время, чтобы понять и решить, что вы пытаетесь сделать/как это сделать лучше, и в этом случае будет вопрос «напишите мой код», который не разрешен. –

+0

Хм ... у вас возникли проблемы с кодом/воспроизведением результатов? Я согласен, что это длинный вопрос ... Я мог бы удалить часть кода, например. блок блоков переноса и блок проверки, если вы считаете, что это поможет. – logworthy

+0

Я не собираюсь запускать все это и пытаюсь его отладить. Если у вас есть конкретная проблема, отбросьте ее на общий пример. –

ответ

1

Вот одна идея. Я считаю, что результат соответствует тому, что вы хотите.

#x is a row from problem df 
#y is a column from transfer_matrix 
check_pairs <- function(x,y){ 
    #split y into which columns are being compared . e.g. if col 1 is 'd' vs 'external', then ... 
    a <- y[1] #would be 'd' 
    b <- y[2] #would be 'external' 
    #if both pos, both neg, or one val is 0, then return 0 
    if(sign(x[a]) == sign(x[b]) | sign(x[[a]]) == 0){ 
     return(0) 
    }else{ #else return formula from your manual calculation 
     return(x[[b]] * x[[a]]/sum(x[sign(x)==sign(x[[a]]) ])) 
    } 
} 

#for each row of the problem matrix, compare to each column of the transfer_matrix 
check_matrix_cols <- function(x){ 
    return(apply(transfer_matrix, 2, function(y) check_pairs(x,y))) 
} 

problem[,-seq(length(c(categories, 'external')))] <- t(apply(problem, 1, check_matrix_cols)) 

sapply(c(categories,'external'), check, problem=problem, categories=c(categories,'external'), transfer_list=transfer_list,transfer_matrix=transfer_matrix) 

      a   b    c   d   external  
[1,] "50 vs 50" "60 vs 60"  "-90 vs -90" "0 vs 0"  "-20 vs -20" 
[2,] "30 vs 30" "60 vs 60"  "60 vs 60" "-20 vs -20" "-130 vs -130" 
[3,] "-10 vs -10" "-40 vs -40" "-30 vs -30" "0 vs 0"  "80 vs 80"  
[4,] "-80 vs -80" "20 vs 20"  "70 vs 70" "60 vs 60" "-70 vs -70" 
[5,] "60 vs 60" "-50 vs -50" "50 vs 50" "-70 vs -70" "10 vs 10"  
[6,] "-80 vs -80" "0 vs 0"  "20 vs 20" "-30 vs -30" "90 vs 90"  
[7,] "-90 vs -90" "-40 vs -40" "100 vs 100" "-60 vs -60" "90 vs 90"  
[8,] "-30 vs -30" "-100 vs -100" "20 vs 20" "80 vs 80" "30 vs 30"  
[9,] "-30 vs -30" "20 vs 20"  "-70 vs -70" "-40 vs -40" "120 vs 120" 
[10,] "90 vs 90" "-60 vs -60" "30 vs 30" "20 vs 20" "-80 vs -80" 
Смежные вопросы