基于数据帧同一行中不同列的值的累积和（避免循环）
Cumulative sum base on the value of different columns in the same row of a dataframe (avoiding loops)
我有一个包含数十万行的数据框，但可以在下面举例说明：
> mydata
ID TYPE HEIGHT WEIGHT
1 20 6 194 77.1
2 20 2 175 63.5
3 20 6 197 59.6
4 20 1 185 74.3
5 20 1 162 94.4
6 21 1 188 58.9
7 21 6 182 81.2
8 21 6 169 82.8
9 21 2 151 78.5
这是重现它的代码：
mydata <- data.frame(ID=c(20,20,20,20,20,21,21,21,21),
TYPE=(c(6,2,6,1,1,1,6,6,2)),
HEIGHT=c(194,175,197,185,162,188,182,169,151),
WEIGHT=c(77.1,63.5,59.6,74.3,94.4,58.9,81.2,82.8,78.5))
我需要做的是：对于每个 ID，通过 TYPE、 计算 WEIGHTS 的总和，但仅针对那些元素（在相同的 ID），HEIGHT 比当前行中包含的 ID 高 。
新的数据框应该再包含三列（每列一列 TYPE），最终应该是这样的：
> mydata_new
ID TYPE HEIGHT WEIGHT SUM.W.TYPE6 SUM.W.TYPE2 SUM.W.TYPE1
1 20 6 194 77.1 59.6 0.0 0.0
2 20 2 175 63.5 136.7 0.0 74.3
3 20 6 197 59.6 0.0 0.0 0.0
4 20 1 185 74.3 136.7 0.0 0.0
5 20 1 162 94.4 136.7 63.5 74.3
6 21 1 188 58.9 0.0 0.0 0.0
7 21 6 182 81.2 0.0 0.0 58.9
8 21 6 169 82.8 81.2 0.0 59.9
9 21 2 151 78.5 164.0 0.0 58.9
如果可能的话，我想避免用循环遍历每一行，因为考虑到我的大量数据集，这会花费太长时间。任何聪明的解决方案？也许使用一些合适的包，例如 dplyr、data.table，或者简单地使用 apply 或 sapply?
我想了解如何创建基于同一行不同列中的值但也依赖于单独分组（即 TYPE）的累计和。
发布我原来是评论的回答：
#initializations
mydata$Sum.W.Type1 <- 0
mydata$Sum.W.Type2 <- 0
mydata$Sum.W.Type6 <- 0
#assignment
mydata[,5:7] <-
sapply(c(1, 2, 6), function(y)
apply(mydata, 1,
function(x, TYPE = y)
sum(ifelse(mydata[mydata$ID == x[1] & mydata$TYPE == TYPE,]$HEIGHT > x[3],
mydata[mydata$ID == x[1] & mydata$TYPE == TYPE,]$WEIGHT, 0))))
mydata
ID TYPE HEIGHT WEIGHT Sum.W.Type1 Sum.W.Type2 Sum.W.Type6
1 20 6 194 77.1 0.0 0.0 59.6
2 20 2 175 63.5 74.3 0.0 136.7
3 20 6 197 59.6 0.0 0.0 0.0
4 20 1 185 74.3 0.0 0.0 136.7
5 20 1 162 94.4 74.3 63.5 136.7
6 21 1 188 58.9 0.0 0.0 0.0
7 21 6 182 81.2 58.9 0.0 0.0
8 21 6 169 82.8 58.9 0.0 81.2
9 21 2 151 78.5 58.9 0.0 164.0
根据您的数据范围，初始化以及需要分配的列数都会发生变化。但是，这应该足以让你到达那里。
这是另一种 data.table 解决方案。
mydata[, c(.SD, setNames(lapply(sort(unique(TYPE)),
function(type) apply(outer(HEIGHT, HEIGHT, "<"), 1,
function(higher) sum(WEIGHT[TYPE == type & higher]))),
paste0("SUM.W.TYPE", sort(unique(TYPE))))), ID]
# ID TYPE HEIGHT WEIGHT SUM.W.TYPE1 SUM.W.TYPE2 SUM.W.TYPE6
# 1: 20 6 194 77.1 0.0 0.0 59.6
# 2: 20 2 175 63.5 74.3 0.0 136.7
# 3: 20 6 197 59.6 0.0 0.0 0.0
# 4: 20 1 185 74.3 0.0 0.0 136.7
# 5: 20 1 162 94.4 74.3 63.5 136.7
# 6: 21 1 188 58.9 0.0 0.0 0.0
# 7: 21 6 182 81.2 58.9 0.0 0.0
# 8: 21 6 169 82.8 58.9 0.0 81.2
# 9: 21 2 151 78.5 58.9 0.0 164.0
使用outer函数创建了一个比较矩阵，以找出具有较大高度行的索引，并将权重与类型相结合以获得总和。
这是一种类似于@Psidom 的方法。
library(data.table)
setDT(mydata)
mydata_new<-mydata[,c(.SD,{ types<-(unique(TYPE));
setNames(lapply(types, function(curtype) {
heights<-(HEIGHT);
sapply(heights, function(curheight) {
sum(WEIGHT[HEIGHT>curheight & TYPE==curtype])
})
}),paste0('SUM.W.TYPE',types))}),by='ID']
区别在于我的不使用 outer，我怀疑它是 memory/performance 猪。
这是一个基准：
library(data.table)
#create fake data with 300,000 rows
mydata <- data.frame(ID=rep(1:10,30000),
TYPE=rep(1:20,each=15000),
HEIGHT=as.integer(runif(300000,150,200)),
WEIGHT=round(runif(300000,50,100),1))
setDT(mydata)
system.time({
mydata_new<-mydata[,c(.SD,{ types<-(unique(TYPE));
setNames(lapply(types, function(curtype) {
heights<-(HEIGHT);
sapply(heights, function(curheight) {
sum(WEIGHT[HEIGHT>curheight & TYPE==curtype])
})
}),paste0('SUM.W.TYPE',types))}),by='ID']
})
#user system elapsed
#1125.244 1.460 1127.665
system.time({
psidata<-mydata[, c(.SD, setNames(lapply(sort(unique(TYPE)),
function(type) apply(outer(HEIGHT, HEIGHT, "<"), 1,
function(higher) sum(WEIGHT[TYPE == type & higher]))),
paste0("SUM.W.TYPE", sort(unique(TYPE))))), ID]
})
#user system elapsed
#3854.596 731.272 4774.742
all.equal(mydata_new, psidata)
#TRUE
system.time({
frankdata<-copy(mydata)
ut = sort(unique(mydata$TYPE))
frankdata[order(-HEIGHT), paste0("sum_",ut) := lapply(ut,
function(x) shift(cumsum( WEIGHT*(TYPE==x) ), fill=0)
), by=ID]
})
#user system elapsed
#0.148 0.000 0.148
到目前为止，Frank's 是性能的赢家。
这是使用最近实施的 non-equi 联接功能的另一个 data.table 解决方案。您需要抓住 development version of data.table, v1.9.7
require(data.table) # v1.9.7
setDT(mydata) # convert data.frame to data.table without copying
foo <- function(x, val) {
y = x[TYPE == val]
y[x, on = .(ID, HEIGHT > HEIGHT),
.(sum_val = sum(WEIGHT, na.rm = TRUE)),
by = .EACHI
][, sum_val]
}
for (type in unique(mydata$TYPE)) {
cat("type = ", sprintf("%2.0f", type), "\n", sep="")
mydata[, paste("sum", type, sep="_") := foo(mydata, type)][]
}
mydata
# ID TYPE HEIGHT WEIGHT sum_6 sum_2 sum_1
# 1: 20 6 194 77.1 59.6 0.0 0.0
# 2: 20 2 175 63.5 136.7 0.0 74.3
# 3: 20 6 197 59.6 0.0 0.0 0.0
# 4: 20 1 185 74.3 136.7 0.0 0.0
# 5: 20 1 162 94.4 136.7 63.5 74.3
# 6: 21 1 188 58.9 0.0 0.0 0.0
# 7: 21 6 182 81.2 0.0 0.0 58.9
# 8: 21 6 169 82.8 81.2 0.0 58.9
# 9: 21 2 151 78.5 164.0 0.0 58.9
在来自@Dean 的 300K 行数据集上，每个 TYPE 需要 ~19s 或 ~1s。
正如 OP 中所建议的那样，累积总和适用于此处：
library(data.table)
setDT(mydata)
ut = sort(unique(mydata$TYPE))
mydata[order(-HEIGHT), paste0("sum_",ut) := lapply(ut,
function(x) shift(cumsum( WEIGHT*(TYPE==x) ), fill=0)
), by=ID]
ID TYPE HEIGHT WEIGHT sum_1 sum_2 sum_6
1: 20 6 194 77.1 0.0 0.0 59.6
2: 20 2 175 63.5 74.3 0.0 136.7
3: 20 6 197 59.6 0.0 0.0 0.0
4: 20 1 185 74.3 0.0 0.0 136.7
5: 20 1 162 94.4 74.3 63.5 136.7
6: 21 1 188 58.9 0.0 0.0 0.0
7: 21 6 182 81.2 58.9 0.0 0.0
8: 21 6 169 82.8 58.9 0.0 81.2
9: 21 2 151 78.5 58.9 0.0 164.0
重复身高测量。到目前为止，这仅在每个 ID 中所有身高都不同的情况下才有效（如 OP 当前示例中所示）。然而，OP 在评论中提到高度可能会重复。感谢@DeanMacGregor，这是该案例的扩展：
# run the code above, and then...
mydata[order(-HEIGHT), paste0('sum_',ut) :=
.SD[.N]
, by=.(ID,TYPE,HEIGHT), .SDcols=paste0('sum_',ut)]
或一步 by 完成：
ut = sort(unique(mydata$TYPE))
mydata[order(-HEIGHT), paste0("sum_",ut) := {
sd = lapply(ut, function(x) shift(cumsum( WEIGHT*(TYPE==x) ), fill=0))
setDT(sd)[, .SD[1L], by=.(HEIGHT,TYPE)][, c("HEIGHT","TYPE") := NULL]
}, by=ID]
我有一个包含数十万行的数据框，但可以在下面举例说明：
> mydata
ID TYPE HEIGHT WEIGHT
1 20 6 194 77.1
2 20 2 175 63.5
3 20 6 197 59.6
4 20 1 185 74.3
5 20 1 162 94.4
6 21 1 188 58.9
7 21 6 182 81.2
8 21 6 169 82.8
9 21 2 151 78.5
这是重现它的代码：
mydata <- data.frame(ID=c(20,20,20,20,20,21,21,21,21),
TYPE=(c(6,2,6,1,1,1,6,6,2)),
HEIGHT=c(194,175,197,185,162,188,182,169,151),
WEIGHT=c(77.1,63.5,59.6,74.3,94.4,58.9,81.2,82.8,78.5))
我需要做的是：对于每个 ID，通过 TYPE、 计算 WEIGHTS 的总和，但仅针对那些元素（在相同的 ID），HEIGHT 比当前行中包含的 ID 高 。
新的数据框应该再包含三列（每列一列 TYPE），最终应该是这样的：
> mydata_new
ID TYPE HEIGHT WEIGHT SUM.W.TYPE6 SUM.W.TYPE2 SUM.W.TYPE1
1 20 6 194 77.1 59.6 0.0 0.0
2 20 2 175 63.5 136.7 0.0 74.3
3 20 6 197 59.6 0.0 0.0 0.0
4 20 1 185 74.3 136.7 0.0 0.0
5 20 1 162 94.4 136.7 63.5 74.3
6 21 1 188 58.9 0.0 0.0 0.0
7 21 6 182 81.2 0.0 0.0 58.9
8 21 6 169 82.8 81.2 0.0 59.9
9 21 2 151 78.5 164.0 0.0 58.9
如果可能的话，我想避免用循环遍历每一行，因为考虑到我的大量数据集，这会花费太长时间。任何聪明的解决方案？也许使用一些合适的包，例如 dplyr、data.table，或者简单地使用 apply 或 sapply?
我想了解如何创建基于同一行不同列中的值但也依赖于单独分组（即 TYPE）的累计和。
发布我原来是评论的回答：
#initializations
mydata$Sum.W.Type1 <- 0
mydata$Sum.W.Type2 <- 0
mydata$Sum.W.Type6 <- 0
#assignment
mydata[,5:7] <-
sapply(c(1, 2, 6), function(y)
apply(mydata, 1,
function(x, TYPE = y)
sum(ifelse(mydata[mydata$ID == x[1] & mydata$TYPE == TYPE,]$HEIGHT > x[3],
mydata[mydata$ID == x[1] & mydata$TYPE == TYPE,]$WEIGHT, 0))))
mydata
ID TYPE HEIGHT WEIGHT Sum.W.Type1 Sum.W.Type2 Sum.W.Type6
1 20 6 194 77.1 0.0 0.0 59.6
2 20 2 175 63.5 74.3 0.0 136.7
3 20 6 197 59.6 0.0 0.0 0.0
4 20 1 185 74.3 0.0 0.0 136.7
5 20 1 162 94.4 74.3 63.5 136.7
6 21 1 188 58.9 0.0 0.0 0.0
7 21 6 182 81.2 58.9 0.0 0.0
8 21 6 169 82.8 58.9 0.0 81.2
9 21 2 151 78.5 58.9 0.0 164.0
根据您的数据范围，初始化以及需要分配的列数都会发生变化。但是，这应该足以让你到达那里。
这是另一种 data.table 解决方案。
mydata[, c(.SD, setNames(lapply(sort(unique(TYPE)),
function(type) apply(outer(HEIGHT, HEIGHT, "<"), 1,
function(higher) sum(WEIGHT[TYPE == type & higher]))),
paste0("SUM.W.TYPE", sort(unique(TYPE))))), ID]
# ID TYPE HEIGHT WEIGHT SUM.W.TYPE1 SUM.W.TYPE2 SUM.W.TYPE6
# 1: 20 6 194 77.1 0.0 0.0 59.6
# 2: 20 2 175 63.5 74.3 0.0 136.7
# 3: 20 6 197 59.6 0.0 0.0 0.0
# 4: 20 1 185 74.3 0.0 0.0 136.7
# 5: 20 1 162 94.4 74.3 63.5 136.7
# 6: 21 1 188 58.9 0.0 0.0 0.0
# 7: 21 6 182 81.2 58.9 0.0 0.0
# 8: 21 6 169 82.8 58.9 0.0 81.2
# 9: 21 2 151 78.5 58.9 0.0 164.0
使用outer函数创建了一个比较矩阵，以找出具有较大高度行的索引，并将权重与类型相结合以获得总和。
这是一种类似于@Psidom 的方法。
library(data.table)
setDT(mydata)
mydata_new<-mydata[,c(.SD,{ types<-(unique(TYPE));
setNames(lapply(types, function(curtype) {
heights<-(HEIGHT);
sapply(heights, function(curheight) {
sum(WEIGHT[HEIGHT>curheight & TYPE==curtype])
})
}),paste0('SUM.W.TYPE',types))}),by='ID']
区别在于我的不使用 outer，我怀疑它是 memory/performance 猪。
这是一个基准：
library(data.table)
#create fake data with 300,000 rows
mydata <- data.frame(ID=rep(1:10,30000),
TYPE=rep(1:20,each=15000),
HEIGHT=as.integer(runif(300000,150,200)),
WEIGHT=round(runif(300000,50,100),1))
setDT(mydata)
system.time({
mydata_new<-mydata[,c(.SD,{ types<-(unique(TYPE));
setNames(lapply(types, function(curtype) {
heights<-(HEIGHT);
sapply(heights, function(curheight) {
sum(WEIGHT[HEIGHT>curheight & TYPE==curtype])
})
}),paste0('SUM.W.TYPE',types))}),by='ID']
})
#user system elapsed
#1125.244 1.460 1127.665
system.time({
psidata<-mydata[, c(.SD, setNames(lapply(sort(unique(TYPE)),
function(type) apply(outer(HEIGHT, HEIGHT, "<"), 1,
function(higher) sum(WEIGHT[TYPE == type & higher]))),
paste0("SUM.W.TYPE", sort(unique(TYPE))))), ID]
})
#user system elapsed
#3854.596 731.272 4774.742
all.equal(mydata_new, psidata)
#TRUE
system.time({
frankdata<-copy(mydata)
ut = sort(unique(mydata$TYPE))
frankdata[order(-HEIGHT), paste0("sum_",ut) := lapply(ut,
function(x) shift(cumsum( WEIGHT*(TYPE==x) ), fill=0)
), by=ID]
})
#user system elapsed
#0.148 0.000 0.148
到目前为止，Frank's 是性能的赢家。
这是使用最近实施的 non-equi 联接功能的另一个 data.table 解决方案。您需要抓住 development version of data.table, v1.9.7
require(data.table) # v1.9.7
setDT(mydata) # convert data.frame to data.table without copying
foo <- function(x, val) {
y = x[TYPE == val]
y[x, on = .(ID, HEIGHT > HEIGHT),
.(sum_val = sum(WEIGHT, na.rm = TRUE)),
by = .EACHI
][, sum_val]
}
for (type in unique(mydata$TYPE)) {
cat("type = ", sprintf("%2.0f", type), "\n", sep="")
mydata[, paste("sum", type, sep="_") := foo(mydata, type)][]
}
mydata
# ID TYPE HEIGHT WEIGHT sum_6 sum_2 sum_1
# 1: 20 6 194 77.1 59.6 0.0 0.0
# 2: 20 2 175 63.5 136.7 0.0 74.3
# 3: 20 6 197 59.6 0.0 0.0 0.0
# 4: 20 1 185 74.3 136.7 0.0 0.0
# 5: 20 1 162 94.4 136.7 63.5 74.3
# 6: 21 1 188 58.9 0.0 0.0 0.0
# 7: 21 6 182 81.2 0.0 0.0 58.9
# 8: 21 6 169 82.8 81.2 0.0 58.9
# 9: 21 2 151 78.5 164.0 0.0 58.9
在来自@Dean 的 300K 行数据集上，每个 TYPE 需要 ~19s 或 ~1s。
正如 OP 中所建议的那样，累积总和适用于此处：
library(data.table)
setDT(mydata)
ut = sort(unique(mydata$TYPE))
mydata[order(-HEIGHT), paste0("sum_",ut) := lapply(ut,
function(x) shift(cumsum( WEIGHT*(TYPE==x) ), fill=0)
), by=ID]
ID TYPE HEIGHT WEIGHT sum_1 sum_2 sum_6
1: 20 6 194 77.1 0.0 0.0 59.6
2: 20 2 175 63.5 74.3 0.0 136.7
3: 20 6 197 59.6 0.0 0.0 0.0
4: 20 1 185 74.3 0.0 0.0 136.7
5: 20 1 162 94.4 74.3 63.5 136.7
6: 21 1 188 58.9 0.0 0.0 0.0
7: 21 6 182 81.2 58.9 0.0 0.0
8: 21 6 169 82.8 58.9 0.0 81.2
9: 21 2 151 78.5 58.9 0.0 164.0
重复身高测量。到目前为止，这仅在每个 ID 中所有身高都不同的情况下才有效（如 OP 当前示例中所示）。然而，OP 在评论中提到高度可能会重复。感谢@DeanMacGregor，这是该案例的扩展：
# run the code above, and then...
mydata[order(-HEIGHT), paste0('sum_',ut) :=
.SD[.N]
, by=.(ID,TYPE,HEIGHT), .SDcols=paste0('sum_',ut)]
或一步 by 完成：
ut = sort(unique(mydata$TYPE))
mydata[order(-HEIGHT), paste0("sum_",ut) := {
sd = lapply(ut, function(x) shift(cumsum( WEIGHT*(TYPE==x) ), fill=0))
setDT(sd)[, .SD[1L], by=.(HEIGHT,TYPE)][, c("HEIGHT","TYPE") := NULL]
}, by=ID]