我有两个相同维度的数据框。一个数据帧（df1）由＆＃34; 1＆＃34;和＆＃34; 0＆＃34;，而另一个数据帧（df2）具有不同的值。我想通过根据条件减去df2值来创建一个新的数据框（df3）。条件是每当有＆＃34; 1＆＃34;在df1中，该位置应在df2中标识（例如，其第1行，第4列）。现在，前一列（第1行，第3列）中df2的值应视为基数{0.98}，接下来的两列（第1行，第4列{0.6}和第5列{0.75}）中的值应为从该基值逐个减去。 下面的示例对此进行了解释：
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如下：
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都是NA，因为没有＆＃34; 1＆＃34;在df1中，所以没有减法。
我想使用＆＃34;其中＆＃34;函数来识别位置，但前一列的减法使我有点复杂。我们将非常感谢您的帮助。
感谢。萨巴
答案 0 :(得分：0)
这是一个快速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)
这是一个更大的例子：
df1[2,c("2008","2009")] = 1 1以下是该算法如何工作的简要说明。从OP的例子中，我们可以推断出在确定输出时，较小列号的“基数”优先。我们知道这一点，因为df3[2,c("2007","2008","2009")] = 0 -0.13 0.07和受影响的行/列的结果数据框是：df3[2,"2008"]。如果不是这种情况，则df1[2,"2009"] = 1将为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
以下是一些有保留的基准测试（尽管它们不会生成相同的对象，但输出类似，足以保证效率比较）：
insecure答案 1 :(得分：-1)
我得到的结果与OP的例子不同，因为这种情况没有明确定义：
df [2,5]和df [2,6]都是1，但OP的df3似乎只取df [2,5]作为基数而忽略了df [2,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