我试图在多变量设置中测量某些数据的经验累积分布。也就是说，给定像
这样的数据集library(data.table) # v 1.9.7
set.seed(2016)
dt <- data.table(x=rnorm(1000), y=rnorm(1000), z=rnorm(1000))
dt
x y z
1: -0.91474 2.07025 -1.7499
2: 1.00125 -1.80941 -1.3856
3: -0.05642 1.58499 0.8110
4: 0.29665 -1.16660 0.3757
5: -2.79147 -1.75526 1.2851
---
996: 0.63423 0.13597 -2.3710
997: 0.21415 1.03161 -1.5440
998: 1.15357 -1.63713 0.4191
999: 0.79205 -0.56119 0.6670
1000: 0.19502 -0.05297 -0.3288
我想计算样本的数量，使（x <= X，y <= Y，z <= Z）对于（X，Y，Z）上界的某些网格，如
bounds <- CJ(X=seq(-2, 2, by=.1), Y=seq(-2, 2, by=.1), Z=seq(-2, 2, by=.1))
bounds
X Y Z
1: -2 -2 -2.0
2: -2 -2 -1.9
3: -2 -2 -1.8
4: -2 -2 -1.7
5: -2 -2 -1.6
---
68917: 2 2 1.6
68918: 2 2 1.7
68919: 2 2 1.8
68920: 2 2 1.9
68921: 2 2 2.0
现在，我已经发现我可以优雅地做到这一点（使用非等联接）
dt[, Count := 1]
result <- dt[bounds, on=c("x<=X", "y<=Y", "z<=Z"), allow.cartesian=TRUE][, list(N.cum = sum(!is.na(Count))), keyby=list(X=x, Y=y, Z=z)]
result[, CDF := N.cum/nrow(dt)]
result
X Y Z N.cum CDF
1: -2 -2 -2.0 0 0.000
2: -2 -2 -1.9 0 0.000
3: -2 -2 -1.8 0 0.000
4: -2 -2 -1.7 0 0.000
5: -2 -2 -1.6 0 0.000
---
68917: 2 2 1.6 899 0.899
68918: 2 2 1.7 909 0.909
68919: 2 2 1.8 917 0.917
68920: 2 2 1.9 924 0.924
68921: 2 2 2.0 929 0.929
但是当我开始增加bin计数时，这种方法效率非常低并且变得非常慢。我认为data.table滚动加入功能的多变量版本可以解决问题，但据我所知，这是不可能的。有什么建议加快这个吗？
答案 0 :(得分：5)
想出来。
# Step1 - map each sample to the nearest X, Y, and Z above it. (In other words, bin the data.)
X <- data.table(X=seq(-2, 2, by=.1)); X[, x := X]
Y <- data.table(Y=seq(-2, 2, by=.1)); Y[, y := Y]
Z <- data.table(Z=seq(-2, 2, by=.1)); Z[, z := Z]
dt <- X[dt, on="x", roll=-Inf, nomatch=0]
dt <- Y[dt, on="y", roll=-Inf, nomatch=0]
dt <- Z[dt, on="z", roll=-Inf, nomatch=0]
# Step2 - aggregate by unique (X, Y, Z) triplets and count the samples directly below each of these bounds.
bg <- dt[, .N, keyby=list(X, Y, Z)]
# Step4 - Get the count of samples directly below EVERY (X, Y, Z) bound
bounds <- CJ(X=X$X, Y=Y$Y, Z=Z$Z)
kl <- bg[bounds, on=c("X", "Y", "Z")]
kl[is.na(N), N := 0]
# Step5 (the tricky part) - Consider a single (Y, Z) pair. X will be in ascending order. So we can do a cumsum on X for each (Y, Z) to count x <= X | Y,Z. Now if you hold X and Z fixed, you can do a cumsum on Y (which is also in ascending order) to count x <= X, y <= Y | Z. And then just continue this process.
kl[, CountUntil.XgivenYZ := cumsum(N), by=list(Y, Z)]
kl[, CountUntil.XYgivenZ := cumsum(CountUntil.XgivenYZ), by=list(X, Z)]
kl[, CountUntil.XYZ := cumsum(CountUntil.XYgivenZ), by=list(X, Y)]
# Cleanup
setnames(kl, "CountUntil.XYZ", "N.cum")
kl[, CDF := N.cum/nrow(dt)]
对于任何想要它的人，我将其概括为使用任意数量的变量并将该函数转储到我的R包中mltools。
例如，要解决此问题，您可以执行
library(mltools)
bounds <- list(x=seq(-2, 2, by=.1), y=seq(-2, 2, by=.1), z=seq(-2, 2, by=.1))
empirical_cdf(x=dt, ubounds=bounds)
x y z N.cum CDF
1: -2 -2 -2.0 0 0.000
2: -2 -2 -1.9 0 0.000
3: -2 -2 -1.8 0 0.000
4: -2 -2 -1.7 0 0.000
5: -2 -2 -1.6 0 0.000
---
68917: 2 2 1.6 899 0.899
68918: 2 2 1.7 909 0.909
68919: 2 2 1.8 917 0.917
68920: 2 2 1.9 924 0.924
68921: 2 2 2.0 929 0.929
答案 1 :(得分：3)
<强>更新
下面，我提供了一个通用的base R解决方案（它适用于非均匀网格）。 比OP提供的最快发布的解决方案更快（稍后将详细介绍）。由于OP暗示，生成N.cum列是真正的瓶颈，因此我将我的工作集中在这项任务上（即，一旦获得CDF，生成N.cum是一项微不足道的任务。）< / p>
JoeBase <- function(dtt, s) {
m <- matrix(c(dtt$x, dtt$y, dtt$z), ncol = 3)
N.Cum <- array(vector(mode = "integer"), dim = rev(sapply(s, length)))
for (i in seq_along(s[[1]])) {
t1 <- m[,1] <= s[[1]][i]
for (j in seq_along(s[[2]])) {
t2 <- t1 & (m[,2] <= s[[2]][j])
for (k in seq_along(s[[3]])) {
N.Cum[k,j,i] <- sum(t2 & (m[,3] <= s[[3]][k]))
}
}
}
as.vector(N.Cum)
}
上述算法利用了矢量化操作，特别是逻辑矢量t1和t2的创建和利用。此向量用于获取满足原始data.table中所有3列条件的行数。我们只需依靠R通过sum的动作从逻辑向量到整数向量的内部强制。
弄清楚如何填充三维整数数组N.Cum是一个挑战，因为它稍后将通过as.vector转换为向量。这需要一些试验和错误来了解as.vector的行为方式。令我惊讶的是，＆＃34;最后＆＃34;和＆＃34;第一＆＃34;维度必须被置换才能忠实地对向量进行强制转换（前几次，我有N.Cum [i，j，k]而不是N.Cum [k，j，i]）。< / p>
首先，让测试平等：
library(data.table)
## Here is the function I used to test against. I included the generation
## of "bounds" and "bg" as "result" depends on both of these (N.B. "JoeBase" does not)
BenDT <- function(dt, s) {
X <- data.table(X=s[[1]]); X[, x := X]
Y <- data.table(Y=s[[2]]); Y[, y := Y]
Z <- data.table(Z=s[[3]]); Z[, z := Z]
dt <- X[dt, on="x", roll=-Inf, nomatch=0]
dt <- Y[dt, on="y", roll=-Inf, nomatch=0]
dt <- Z[dt, on="z", roll=-Inf, nomatch=0]
bg <- dt[, .N, keyby=list(X, Y, Z)]
bounds <- CJ(X=X$X, Y=Y$Y, Z=Z$Z)
kl <- bg[bounds, on=c("X", "Y", "Z")]
kl[is.na(N), N := 0]
# Counting
kl[, CountUntil.XgivenYZ := cumsum(N), by=list(Y, Z)]
kl[, CountUntil.XYgivenZ := cumsum(CountUntil.XgivenYZ), by=list(X, Z)]
kl[, CountUntil.XYZ := cumsum(CountUntil.XYgivenZ), by=list(X, Y)]
# Cleanup
setnames(kl, "CountUntil.XYZ", "N.cum")
kl[, CDF := N.cum/nrow(dt)]
kl
}
t1 <- BenDT(dt, seq(-2,2,0.1))
t2 <- JoeBase(dt, seq(-2,2,0.1))
all.equal(t1$N.cum, t2)
[1] TRUE
现在，我们测试速度。首先，我们将使用cmpfun包中的compiler编译这两个函数。第一个基准反映了较小范例的效率。
library(compiler)
c.JoeBase <- cmpfun(JoeBase)
c.BenDT <- cmpfun(BenDT)
c.OldBenDT <- cmpfun(OldBenDT) ## The previous best solution that Ben contributed
st <- list(seq(-2, 2, 0.1), seq(-2, 2, 0.1), seq(-2, 2, 0.1))
microbenchmark(c.BenDT(dt, st), c.OldBenDT(dt, st), c.JoeBase(dt, st), times = 10)
Unit: milliseconds
expr min lq mean median uq max neval cld
c.BenDT(dt, st) 34.24872 34.78908 38.87775 37.4924 43.37179 46.12859 10 a
c.OldBenDT(dt, st) 1485.68178 1532.35878 1607.96669 1593.9813 1619.58908 1845.75876 10 b
c.JoeBase(dt, st) 1880.71648 1962.38160 2049.43985 2007.4880 2169.93078 2281.02118 10 c
以下是旧测试
然而，当箱数增加时，c.JoeBase确实开始占主导地位（超过5倍）。
st <- list(seq(-5, 5, 0.1), seq(-5, 5, 0.1), seq(-5, 5, 0.1))
microbenchmark(c.JoeBase(dt, st), c.OldBenDT(dt, st), times = 5)
Unit: seconds
expr min lq mean median uq max neval cld
c.JoeBase(dt, st) 23.50927 23.53809 29.61145 24.52748 30.81485 45.66759 5 a
c.OldBenDT(dt, st) 110.60209 123.95285 133.74601 124.97929 125.96186 183.23394 5 b
在进行进一步测试后，我对结果有些疑虑（@Ben在评论中指出了类似的情绪）。我非常确定c.JoeBase似乎更快，因为我的旧计算机存在局限性。正如@stephematician在他的回答中指出的那样，原始解决方案是内存密集型的，如果你只是在system.time上执行c.OldBenDT，你会发现大部分时间都花费在system上。 {1}}类别和user类别与user类c.JoeBase相当。我6岁的Mac只有4GB的内存，我猜测这些操作正在进行大量的内存交换。观察：
## test with very tiny buckets (i.e. 0.025 instead of 0.1 above)
st <- list(seq(-1.5, 1.5, 0.025), seq(-1.5, 1.5, 0.025), seq(-1.5, 1.5, 0.025))
system.time(c.JoeBase(dt, st))
user system elapsed
36.407 4.748 41.170
system.time(c.OldBenDT(dt, st))
user system elapsed
49.653 77.954 475.304
system.time(c.BenDT(dt, st)) ## Ben's new solution is lightning fast
user system elapsed
0.603 0.063 0.668
无论如何，@ Ben的最新解决方案远非优越。看看这些新的基准：
st <- list(seq(-5, 5, 0.1), seq(-5, 5, 0.1), seq(-5, 5, 0.1))
microbenchmark(c.JoeBase(dt, st), BenDT(dt, st), times = 5)
Unit: milliseconds
expr min lq mean median uq max neval cld
c.JoeBase(dt, st) 26517.0944 26855.7819 28341.5356 28403.7871 29926.213 30004.8018 5 b
BenDT(dt, st) 342.4433 359.8048 400.3914 379.5319 423.336 496.8411 5 a
data.table又一次胜利。
答案 2 :(得分：2)
关于替代方案的一个注释，但显而易见的解决方案：
set.seed(2016)
dt <- data.table(x=rnorm(20000), y=rnorm(20000), z=rnorm(20000))
system.time({
dt <- t(as.matrix(dt))
bounds <- as.matrix(expand.grid(z=seq(-2,2,0.1),
y=seq(-2,2,0.1),
x=seq(-2,2,0.1)))
bounds <- bounds[,ncol(bounds):1]
n_d <- ncol(bounds)
x <- apply(bounds,
1,
function(x) sum(colSums(dt < x) == n_d))
})
我的机器上的这个解决方案的计算时间大约是JoeBase和OldBenDT解决方案的两倍。主要区别？ 内存使用。它更像处理器绑定。
我不知道比较R中的内存使用情况的精确方法，但memory.size(max=T)函数报告使用5Gb内存用于之前的方法（不是非等连接方法），而仅使用40Mb apply方法的记忆（注意：我在样本分布中使用了20000个点）。
我认为这对您可以执行的计算规模具有重要意义。
答案 3 :(得分：-1)
应该更快地计算比例并在一个步骤中进行连接，这样就不必实现中间结果：
set.seed(2016)
dt <- data.table(x=rnorm(1000), y=rnorm(1000), z=rnorm(1000))
setkey(dt)
bounds <- CJ(x=seq(-2, 2, by=.1), y=seq(-2, 2, by=.1), z=seq(-2, 2, by=.1))
a <- dt[bounds,.N / nrow(dt),on=c("x<x","y<y","z<z"),
by=.EACHI,
allow.cartesian=T]