Fatal编程技术网
  • r/
  • R 填写间隔和填充栏

R 填写间隔和填充栏

r

R 填写间隔和填充栏,r,data.table,R,Data.table,我有这样的数据： set.seed(4597) lower = sort(runif(10L)) upper = c(lower[-1], 1) # randomly drop some intervals from the "complete" data # (which is in practice "unknown") obs = cbind(lower, upper)[-sample(10, 4), ] library(data.table) # augment with a

我有这样的数据：

set.seed(4597)
lower = sort(runif(10L))
upper = c(lower[-1], 1)

# randomly drop some intervals from the "complete" data 
#   (which is in practice "unknown")
obs = cbind(lower, upper)[-sample(10, 4), ]

library(data.table)
# augment with a column associated to each interval
DT = data.table(obs)[ , v := rpois(.N, 10)]
DT[]
#         lower     upper  v
# 1: 0.08810018 0.1026903  7
# 2: 0.31929301 0.4530299  6
# 3: 0.45302992 0.5248329  6
# 4: 0.58620724 0.8027425  9
# 5: 0.80274248 0.9054854 10
# 6: 0.98218176 1.0000000 10
除第1-2行、第3-4行和第5-6行外，大多数间隔从一行到另一行“排列”

我想为每种情况添加行，例如，在每种情况下，都有
lower=.102
和
upper
=
.319
，并将
v
设置为
0

使事情进一步复杂化的是，
lower
和
upper
具有数字差异，因此测试
.453==.453
（第3行和第4行）可能会失败：

# adding random tiny noise
DT[ , upper := 
      upper + 
      sample(-1:1, .N, TRUE)*10^sample(0:2, .N, TRUE)*.Machine$double.eps]
我目前的做法似乎相当混乱；我想知道还有什么其他的选择可能更有效（我必须做这个操作数万次，如果不是数百万次的话）

有更好的方法吗

下面是一个规模更大的测试用例：

set.seed(4597)
KK = 1e5
DT = data.table(ID = 1:KK)
DT = DT[ , {
  lower = sort(runif(10L))
  upper = c(lower[-1], 1)
  idx = sample(10, 4)
  .(lower = lower[-idx], upper = upper[-idx])
}, by = ID]
DT[ , v := rpois(.N, 10)]
DT[]

DT[ , upper := 
      upper + 
      sample(-1:1, .N, TRUE)*10^sample(0:2, .N, TRUE)*.Machine$double.eps]

system.time({
DT[ , {
  lower_lead = shift(lower, type = 'lead', fill = upper[.N])
  # "new" points come when the led value of lower 
  #   doesn't match upper (to numerical precision)
  new = abs(lower_lead - upper) > .0001
  # augment lower with the new point
  new_lower = c(lower, upper[new])
  # don't sort right away, need to keep indices to augment v
  idx = order(new_lower)
  new_lower = new_lower[idx]
  new_v = v[idx]
  new_v[is.na(new_v)] = 0
  # re-shift new_lower to get upper
  new_upper = shift(new_lower, type = 'lead', fill = upper[.N])
  .(lower = new_lower, upper = new_upper, v = new_v)
}, by = ID][]
})
#    user  system elapsed 
#   4.592   0.018   4.609
我的方法是从给定的
下限
和
上限
创建断点向量，并从与给定间隔连接的断点中导出所有潜在间隔。给定数据中的差距由
NA
表示

这里，需要进行修改以删除长度低于给定ε的区间

eps <- 0.0001
DT[DT[, {tmp <- sort(c(lower, upper)); 
.(lower = head(tmp, -1L), upper = tail(tmp, -1L))}][
  upper - lower > eps], on = .(lower, upper)][is.na(v), v := 0][]
资料 
库（data.table）
对于x！=按组移位（y），您可以使用一个技巧来避免
by=
：


system.time({
  # w are positions of a "lower" that is above the preceding "upper"
  w <- DT[(abs(lower - shift(upper)) > eps) & (rowid(ID) != 1L), which=TRUE]
  new = DT[, .(ID = ID[w], lower = upper[w-1L], upper = lower[w], v = 0L)]
  fres = rbind(DT, new)
  setkey(fres, ID, lower)
})
#    user  system elapsed 
#   0.050   0.012   0.061 

system.time({
mres = DT[ , {
  lower_lead = shift(lower, type = 'lead', fill = upper[.N])
  # "new" points come when the led value of lower 
  #   doesn't match upper (to numerical precision)
  new = abs(lower_lead - upper) > .0001
  # augment lower with the new point
  new_lower = c(lower, upper[new])
  # don't sort right away, need to keep indices to augment v
  idx = order(new_lower)
  new_lower = new_lower[idx]
  new_v = v[idx]
  new_v[is.na(new_v)] = 0L
  # re-shift new_lower to get upper
  new_upper = shift(new_lower, type = 'lead', fill = upper[.N])
  .(lower = new_lower, upper = new_upper, v = new_v)
}, by = ID][]
})
#    user  system elapsed 
#   4.447   0.025   4.471 



也就是说，
mres
包含来自
DT
的199908行，这些行的值发生了变化（可能使用下一行的
lower
，而不是原来的
lower
？）。
这里有一些东西接近于我最初将这个问题概念化为“碰撞”
上部
和
下部_引导
向量，并消除重复项。（旁注：如果有一个
tol
参数来
unique
使用该种子运行您的代码，那就太好了，我看到了不同但相似的结果：@Frank谢谢，我一定是在准备示例的迭代过程中失去了同步。已编辑。有关更大规模的测试用例，请参见编辑；这比我的方法慢20%左右，并最终得到不同数量的行（我不知道为什么，但我的第一个猜测是由于数字问题）。我及时添加了重新排序（这仍然可以忽略不计）。

       lower     upper  v
1: 0.1026903 0.2634059 14
2: 0.2634059 0.3192930  0
3: 0.3192930 0.4530299 11
4: 0.4530299 0.5248329 12
5: 0.5248329 0.5862072  5
6: 0.5862072 0.8027425  5
7: 0.8027425 0.9054854 15



library(data.table)
DT <- fread(
  "#  i      lower     upper  v
# 1: 0.1026903 0.2634059 14
# 2: 0.3192930 0.4530299 11
# 3: 0.4530299 0.5248329 12
# 4: 0.5248329 0.5862072  5
# 5: 0.5862072 0.8027425  5
# 6: 0.8027425 0.9054854 15", drop = 1:2
)
set.seed(1L)
DT[ , upper := 
      upper + 
      sample(-1:1, .N, TRUE)*10^sample(0:2, .N, TRUE)*.Machine$double.eps]



system.time({
  # w are positions of a "lower" that is above the preceding "upper"
  w <- DT[(abs(lower - shift(upper)) > eps) & (rowid(ID) != 1L), which=TRUE]
  new = DT[, .(ID = ID[w], lower = upper[w-1L], upper = lower[w], v = 0L)]
  fres = rbind(DT, new)
  setkey(fres, ID, lower)
})
#    user  system elapsed 
#   0.050   0.012   0.061 

system.time({
mres = DT[ , {
  lower_lead = shift(lower, type = 'lead', fill = upper[.N])
  # "new" points come when the led value of lower 
  #   doesn't match upper (to numerical precision)
  new = abs(lower_lead - upper) > .0001
  # augment lower with the new point
  new_lower = c(lower, upper[new])
  # don't sort right away, need to keep indices to augment v
  idx = order(new_lower)
  new_lower = new_lower[idx]
  new_v = v[idx]
  new_v[is.na(new_v)] = 0L
  # re-shift new_lower to get upper
  new_upper = shift(new_lower, type = 'lead', fill = upper[.N])
  .(lower = new_lower, upper = new_upper, v = new_v)
}, by = ID][]
})
#    user  system elapsed 
#   4.447   0.025   4.471 



fsetequal(fres, mres)
# FALSE

DT[fres, on=.(ID, upper), .N, nomatch=0]
# [1] 600000
DT[mres, on=.(ID, upper), .N, nomatch=0]
# [1] 400092