他のデータフレームの条件に基づいてデータフレームの値を減算する

Question

同じ次元のデータフレームが2つあります。 1つのデータフレーム（df1）は「1」と「0」とから成り、他方のデータフレーム（df2）は可変値を有する。私は、条件に基づいてdf2値を減算することによって、新しいデータフレーム（df3）を作成したいと思います。条件は、df1に「1」があるときはいつでも、この位置はdf2で識別されるべきである（例えば、行1列目、列4列目）。前の列（1行目、3列目）のdf2の値を基底{0.98}とみなし、次の2列（1列目、4列目（0.6）、5列目（0.75））の値をこの基本値から1つずつ減算されます。私は差し引いた後、以下のようにDF3たい

df1: 
ID 2005 2006 2007 2008 2009 
1  NA  NA  0  1  0 
2  NA  NA  0  1  1 
3  0  0  0  NA  0 
4  0  1  0  0  1 

df2: 
ID 2005 2006 2007 2008 2009 
1  NA  0.7  0.98  0.6  0.75 
2  NA  0.2  0.43  0.3  0.5 
3  0.1 -0.98 0.01  0.09 0.1 
4  0.05 -0.1 0.05  0.12 0.23 

： は、それは、以下のサンプルで説明されて

df3: 
ID 2005 2006 2007 2008 2009 
1  NA  NA  0  -0.38 -0.23 
2  NA  NA  0  -0.13  0.07 
3  NA  NA  NA  NA  NA 
4  0  -0.15  0  0  0.11 

ここROW3はない「1」がDF1に存在しないため、すべてのNAですので、ノー減算。

"which"関数を使用して位置を特定したいと思いますが、先行する列からの減算が少し複雑になっています。あなたの助けが高く評価されます。

ありがとうございました。サバ

Answer 1

は、私が得た結果はOPの例と異なっていますこの場合は明確に定義されていないため、

df [2,5]とdf [2,6]は両方とも1ですが、OPのdf3はdf [2,5]を基底とみなしてdf [ 6]。私のコードは、1の値を持つすべての場所を基底として使用し、それを減らします。 OPが異なる行動を期待していた場合、OPはこのケースのルールをより明確に定義できますか？各ステップの

s1 <- "ID 2005 2006 2007 2008 2009 
1  NA  NA  0  1  0 
2  NA  NA  0  1  1 
3  0  0  0  NA  0 
4  0  1  0  0  1" 

s2 <- "ID 2005 2006 2007 2008 2009 
1  NA  0.7  0.98  0.6  0.75 
2  NA  0.2  0.43  0.3  0.5 
3  0.1 -0.98 0.01  0.09 0.1 
4  0.05 -0.1 0.05  0.12 0.23" 
# data.table is only used for reading data, df1 and df2 are regular data.frame 
library(data.table) 
df1 <- fread(s1, header = TRUE, data.table = FALSE) 
df2 <- fread(s2, header = TRUE, data.table = FALSE) 

計算指標データを設定

、一つの行列を変更にすべての変更を組み合わせることは、NAに他の位置を設定します。注サブスクリプション送信の問題を避けるために、列を左右に追加しました。

# remove the ID column since it also have value of 1 
df1_values <- df1[, 2:ncol(df1)] 
df2_values <- df2[, 2:ncol(df2)] 
# add extra columns to avoid subscription out of bounds 
df1_values <- cbind(0, df1_values, 0, 0) 
df2_values <- cbind(0, df2_values, 0, 0) 
ones_index <- which(df1_values == 1, arr.ind = TRUE) 
one_column_shift <- matrix(c(0, 1), nrow = nrow(ones_index), ncol = 2, byrow = TRUE) 
base_index <- ones_index - one_column_shift 
zero_matrix <- matrix(0, nrow = nrow(df1_values), ncol = ncol(df1_values)) 
base_matrix <- zero_matrix 
base_matrix[base_index] <- df2_values[base_index] 
col2_matrix <- zero_matrix 
col2_matrix[base_index + one_column_shift] <- df2_values[base_index] 
col3_matrix <- zero_matrix 
col3_matrix[base_index + one_column_shift + one_column_shift] <- df2_values[base_index] 
changes_matrix <- base_matrix + col2_matrix + col3_matrix 
changes_matrix[which(changes_matrix == 0, arr.ind = TRUE)] <- NA 
result <- df2_values - changes_matrix 
result <- cbind(ID = df1[, 1], result[, 2:(ncol(result) - 2)]) 

> result 
    ID 2005 2006 2007 2008 2009 
1 1 NA NA 0 -0.38 -0.23 
2 2 NA NA 0 -0.43 -0.23 
3 3 NA NA NA NA NA 
4 4 0 -0.15 0 0.00 0.11 

ベンチマーク

set.seed(101) 
df1 <- data.frame(1:10000, matrix(sample(c(NA,0,1), 10000*7, replace = TRUE), ncol = 7)) 
df2 <- data.frame(1:10000, matrix(rnorm(10000*7), ncol = 7)) 

Unit: milliseconds 
      expr  min  lq  mean median  uq  max neval 
selected_code 30.28814 37.44009 81.45066 38.27878 41.1185 264.1638 10 

Answer 2

ここでは、高速base Rソリューションです：ここでは

MakeDF3 <- function(dfB, dfN) { ## dfB --> Binary, dfN --> Numeric 
    di <- dim(dfB); n <- di[1]; m <- di[2] 
    dfOut <- data.frame(matrix(rep(NA, m*n), nrow = n)) 
    mBool <- matrix(rep(TRUE, m*n), nrow = n) 
    myNames <- names(dfB) 
    names(dfOut) <- myNames 
    ## Here is the speed increase... i.e. looping over columns as opposed to rows 
    for (j in 3:(m-1L)) { 
     myOne <- which(dfB[,j]==1) 
     myRow <- intersect(myOne, which(mBool[,j-1L])) 
     dfOut[myRow,j-1L] <- 0 
     mBool[myRow,j-1L] <- FALSE 
     for (i in j:(j+1L)) { 
      myRow <- intersect(myOne, which(mBool[,i])) 
      dfOut[myRow,i] <- dfN[myRow,i]-dfN[myRow,j-1L] 
      mBool[myRow,i] <- FALSE 
     } 
    } 
    myOne <- which(dfB[,m]==1) 
    myRow <- intersect(myOne,which(mBool[,m-1L])) 
    dfOut[myRow,m-1L] <- 0 
    myRow <- intersect(myOne,which(mBool[,m])) 
    dfOut[myRow,m] <- dfN[myRow,m]-dfN[myRow,m-1L] 
    dfOut[,1L] <- dfB[,1L] 
    dfOut 
} 

出力例を示します。ここでは

df1 <- data.frame(1:4,c(NA, NA, 0, 0),c(NA, NA, 0, 1),c(0, 0, 0, 0), c(1, 1, NA, 0), c(0, 1, 0, 1)) 
df2 <- data.frame(1:4,c(NA, NA, 0.1, 0.05),c(0.7,0.2,-0.98,-0.1),c(0.98,0.43,0.01,0.05), c(0.6,0.3,0.09,0.12), c(0.75,0.5,0.1,0.23)) 
names(df2) <- c("ID", as.character(2005:2009)) 
names(df1) <- c("ID", as.character(2005:2009)) 
MakeDF3(df1, df2) 
    ID 2005 2006 2007 2008 2009 
1 1 NA NA 0 -0.38 -0.23 
2 2 NA NA 0 -0.13 0.07 
3 3 NA NA NA NA NA 
4 4 0 -0.15 0 0.00 0.11 

は大きな例です。ここで

set.seed(101) 
df3 <- data.frame(1:10000, matrix(sample(c(NA,0,1), 10000*7, replace = TRUE), ncol = 7)) 
df4 <- data.frame(1:10000, matrix(rnorm(10000*7), ncol = 7)) 
names(df3) <- c("ID", as.character(2005:2011)) 
names(df4) <- c("ID", as.character(2005:2011)) 
df5 <- MakeDF3(df3, df4) 

は簡単な説明ですアルゴリズムの仕組みについてOPの例から、より小さい列番号の「ベース」が出力を決定する際に優先されると推論できます。 df1[2,c("2008","2009")] = 1 1と結果の行/列のデータフレームはdf3[2,c("2007","2008","2009")] = 0 -0.13 0.07であるため、これはわかります。これが当てはまらない場合はdf1[2,"2009"] = 1であるためdf3[2,"2008"]は0になります。これが私のアルゴリズムの仕組みです。基本的に、私は列をループし、私は以前に計算されていない行のみを更新します（これはmBool行列で決定されます）。ここで

head(df3) 
    ID 2005 2006 2007 2008 2009 2010 2011 
1 1 0 1 NA 0 1 0 1 
2 2 NA 0 1 0 1 1 0 
3 3 1 0 NA 1 NA 0 0 
4 4 0 0 NA 1 NA NA NA 
5 5 NA 0 1 NA 0 1 1 
6 6 NA 1 0 NA 0 0 0 

head(round(df4, 2)) 
    ID 2005 2006 2007 2008 2009 2010 2011 
1 1 -0.61 1.56 -0.60 0.58 -1.70 -0.86 0.25 
2 2 0.37 -1.59 1.25 -1.46 0.38 1.40 2.16 
3 3 -0.11 -0.39 -0.04 -1.04 1.09 -2.25 0.50 
4 4 0.15 -0.34 0.97 1.19 -0.90 0.62 0.32 
5 5 0.61 -0.10 0.17 -0.10 0.33 -0.20 1.87 
6 6 1.87 -0.72 -1.52 -1.06 1.13 -0.23 -1.13 

head(round(df5,2)) 
    ID 2005 2006 2007 2008 2009 2010 2011 
1 1 0 2.16 0.01 0.00 -2.28 -1.44 1.11 
2 2 NA 0.00 2.84 0.13 1.84 2.86 1.78 ### Note that 2.16 - 0.38 = 1.78 (see df3[2,"2010"] above) 
3 3 NA NA 0.00 -1.00 1.14 NA NA 
4 4 NA NA 0.00 0.22 -1.87 NA NA 
5 5 NA 0.00 0.27 0.01 0.00 -0.53 1.54 
6 6 0 -2.58 -3.38 NA NA NA NA 

予約といくつかのベンチマーク（それらが同一のオブジェクトを生成しませんが、出力は効率の比較を保証するために十分に類似があります）、次のとおりです。

microbenchmark(MakeDF3(df3,df4),Dracodoc(df3,df4)) 
Unit: milliseconds 
       expr  min  lq  mean median  uq  max neval cld 
MakeDF3(df3, df4) 16.54374 19.01940 26.06108 20.23607 21.38977 168.8745 100 a 
Dracodoc(df3, df4) 26.64295 30.79689 59.82243 33.50883 38.02572 191.6978 100 b