Subtrahieren von Werten eines Datenrahmens basierend auf einer Bedingung für einen anderen Datenrahmen

Question

Ich habe zwei Datenrahmen mit derselben Dimension. Ein Datenrahmen (df1) besteht aus "1" und "0", während der andere Datenrahmen (df2) unterschiedliche Werte aufweist. Ich möchte einen neuen Datenrahmen (df3) erstellen, indem ich df2-Werte basierend auf einer Bedingung subtrahiere. Die Bedingung ist, dass, wenn in df1 "1" ist, dieser Ort in df2 identifiziert werden sollte (z. B. seine Reihe 1st, Spalte 4). Nun sollte der Wert von df2 in der vorhergehenden Spalte (Zeile 1st, Spalte 3) als Basis {0,98} betrachtet werden, und die Werte in den nächsten zwei Spalten (Zeile 1st, Spalte 4th {0,6} und Spalte 5th {0,75}) sollten sein von diesem Basiswert eins nach dem anderen subtrahiert. Es wird unten in einer Probe erklärt:

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 

I df3 wollen wie nach Abzug folgt sein:

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 

Hier row3 alle NA ist, weil es keine "1" in df1 ist, so dass keine Subtraktion.

Ich möchte "which" -Funktion verwenden, um den Standort zu identifizieren, aber die Subtraktion von der vorherigen Spalte macht es ein bisschen kompliziert für mich. Ihre Hilfe wird sehr geschätzt.

Danke. Saba

Answer 1

Das Ergebnis, das ich aus Beispiel des OP ist anders bekam , weil dieser Fall nicht klar definiert ist:

df [2, 5] und df [2, 6] sind beide 1, aber OPs df3 schien nur df [2, 5] als Basis zu nehmen und ignoriert df [2, 6]. Mein Code wird jeden Ort mit 1 Wert als Basis verwenden und ihn reduzieren. Wenn OP ein anderes Verhalten erwartet, kann OP die Regel für diesen Fall klarer definieren?

Daten eingestellt

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) 

berechnen Index für jeden Schritt, um alle Änderungen in einer Matrix verbinden ändert, eingestellt andere Position zu NA. Hinweis: Ich habe links und rechts Spalten hinzugefügt, um das Problem mit dem Abo-Ausgang zu vermeiden.

# 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 

Benchmark

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

Hier ist eine schnelle base R Lösung:

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 
} 

Hier ist das Beispiel für die Ausgabe:

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 

Hier ist ein größeres Beispiel:

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) 

Hier eine kurze Erklärung wie der Algorithmus funktioniert. Aus dem Beispiel des OP können wir schließen, dass eine "Basis" aus einer kleineren Spaltennummer Vorrang hat, wenn sie die Ausgabe bestimmt. Wir wissen das, weil und der resultierende Datenrahmen für die betroffenen Zeilen/Spalten ist: df3[2,c("2007","2008","2009")] = 0 -0.13 0.07. Wenn dies nicht der Fall wäre, wäre df3[2,"2008"] 0, weil df1[2,"2009"] = 1. So funktioniert mein Algorithmus. Im Grunde schleife ich über die Spalten und aktualisiere nur Zeilen, die zuvor nicht berechnet wurden (dies wird mit der Matrix mBool bestimmt).

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 

Hier sind einige Benchmarks mit Vorbehalten (obwohl sie keine identische Objekte erzeugen dort Ausgänge sind ähnlich genug, um Effizienzvergleich zu rechtfertigen):

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