Rの計算式/帰属を計算する

Question

私は、4つのカテゴリa, b, c, dに分散したメトリックを持っています。

一定期間にわたって、各カテゴリのメトリックの動きを追跡します。これらの動きの合計は、他の場所（「外部」）からシステムを離れるか入力した量を表します。

いくつかのカテゴリが正の動きなどを受けた

# 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 

が負の動きを受けている、我々は、システム内の転送を推測することができます。例えばaについて

# 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" 

50とc減少した90増加しているので、我々は可変a.cに格納されるcからaからの転送があると推測することができます。

転送を計算するためのルールは比例します。従って、aが50だけ減少し、bが60だけ減少した場合、cの増加の50 /（50 + 60）は'a'に帰するべきであり、cの増加の60 /（50 + 60）は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" 

Answer 1

は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"