R группировка по условию в данных.таблица
в R, у меня есть большие данные.таблица. Для каждой строки Я хочу подсчитать строки с аналогичным значением x1 (+/- некоторый допуск, tol). Я могу заставить это работать, используя adply, но это слишком медленно. Это похоже на данные.таблица была бы хороша для-на самом деле, я уже использую данные.таблицы для вычислений.
есть ли способ сделать это полностью с Данные.стол? Вот пример:
library(data.table)
library(plyr)
my.df = data.table(x1 = 1:1000,
x2 = 4:1003)
tol = 3
adply(my.df, 1, function(df) my.df[x1 > (df$x1 - tol) & x1 < (df$x1 + tol), .N])
результаты:
x1 x2 V1
1: 1 4 3
2: 2 5 4
3: 3 6 5
4: 4 7 5
5: 5 8 5
---
996: 996 999 5
997: 997 1000 5
998: 998 1001 5
999: 999 1002 4
1000: 1000 1003 3
обновление:
вот пример набора данных, который немного ближе к моим реальным данным:
set.seed(10)
x = seq(1,100000000,100000)
x = x + sample(1:50000, length(x), replace=T)
x2 = x + sample(1:50000, length(x), replace=T)
my.df = data.table(x1 = x,
x2 = x2)
setkey(my.df,x1)
tol = 100000
og = function(my.df) {
adply(my.df, 1, function(df) my.df[x1 > (df$x1 - tol) & x1 < (df$x1 + tol), .N])
}
microbenchmark(r_ed <- ed(copy(my.df)),
r_ar <- ar(copy(my.df)),
r_og <- og(copy(my.df)),
times = 1)
Unit: milliseconds
expr min lq median uq max neval
r_ed <- ed(copy(my.df)) 8.553137 8.553137 8.553137 8.553137 8.553137 1
r_ar <- ar(copy(my.df)) 10.229438 10.229438 10.229438 10.229438 10.229438 1
r_og <- og(copy(my.df)) 1424.472844 1424.472844 1424.472844 1424.472844 1424.472844 1
очевидно, что решения от @eddi и @Arun намного быстрее, чем мои. Теперь я просто должен попытаться понять Роллс.
4 ответов
вот быстрее data.table
решение. Идея состоит в том, чтобы использовать функциональность слияния data.table
, но прежде чем мы это сделаем, нам нужно немного изменить данные и сделать столбец x1
numeric вместо integer. Это связано с тем, что OP использует строгое неравенство и для использования скользящих соединений с этим нам придется уменьшить допуск на небольшую сумму, сделав его числом с плавающей запятой.
my.df[, x1 := as.numeric(x1)]
# set the key to x1 for the merges and to sort
# (note, if data already sorted can make this step instantaneous using setattr)
setkey(my.df, x1)
# and now we're going to do two rolling merges, one with the upper bound
# and one with lower, then get the index of the match and subtract the ends
# (+1, to get the count)
my.df[, res := my.df[J(x1 + tol - 1e-6), list(ind = .I), roll = Inf]$ind -
my.df[J(x1 - tol + 1e-6), list(ind = .I), roll = -Inf]$ind + 1]
# and here's the bench vs @Arun's solution
ed = function(my.df) {
my.df[, x1 := as.numeric(x1)]
setkey(my.df, x1)
my.df[, res := my.df[J(x1 + tol - 1e-6), list(ind = .I), roll = Inf]$ind -
my.df[J(x1 - tol + 1e-6), list(ind = .I), roll = -Inf]$ind + 1]
}
microbenchmark(ed(copy(my.df)), ar(copy(my.df)))
#Unit: milliseconds
# expr min lq median uq max neval
# ed(copy(my.df)) 7.297928 10.09947 10.87561 11.80083 23.05907 100
# ar(copy(my.df)) 10.825521 15.38151 16.36115 18.15350 21.98761 100
Примечание:x1 является целым числом, не нужно преобразовывать в числовое и вычитать небольшую сумму из tol
можно использовать tol - 1L
вместо tol - 1e-6
выше.
см. ответ @eddi для более быстрого решения (для этой конкретной проблемы). Он также работает, когда x1
не является целым числом.
алгоритм, который вы ищете является Интервал Дерево. И есть пакет программе bioconductor под названием IRanges это выполняет эту задачу. Это трудно превзойти.
require(IRanges)
require(data.table)
my.df[, res := countOverlaps(IRanges(my.df$x1, width=1),
IRanges(my.df$x1-tol+1, my.df$x1+tol-1))]
объяснение:
если вы сломаете код, вы можете записать его в три строки:
ir1 <- IRanges(my.df$x1, width=1)
ir2 <- IRanges(my.df$x1-tol+1, my.df$x1+tol-1)
cnt <- countOverlaps(ir1, ir2)
то, что мы по существу делаем, это создать два " диапазона "(просто введите ir1
и ir2
чтобы посмотреть, как они). Затем мы спрашиваем, для каждой записи в ir1
сколько они перекрываются в ir2
(это часть "дерево интервалов"). И это очень эффективно. Неявно аргумент type
to countOverlaps
, по умолчанию "type = any". Вы можете исследовать другие типы, если хотите. Это очень полезно. Также имеет значение findOverlaps
функция.
Примечание: могут быть более быстрые решения (на самом деле есть, см. @eddi) для этого конкретного случая, где ширина ir1 = 1. Но для проблем, где переменной ширины и/или > 1, это должно быть самым быстрым.
бенчмаркинг:
ag <- function(my.df) my.df[, res := sum(abs(my.df$x1-x1) < tol), by=x1]
ro <- function(my.df) {
my.df[,res:= { y = my.df$x1
sum(y > (x1 - tol) & y < (x1 + tol))
}, by=x1]
}
ar <- function(my.df) {
my.df[, res := countOverlaps(IRanges(my.df$x1, width=1),
IRanges(my.df$x1-tol+1, my.df$x1+tol-1))]
}
require(microbenchmark)
microbenchmark(r1 <- ag(copy(my.df)), r2 <- ro(copy(my.df)),
r3 <- ar(copy(my.df)), times=100)
Unit: milliseconds
expr min lq median uq max neval
r1 <- ag(copy(my.df)) 33.15940 39.63531 41.61555 44.56616 208.99067 100
r2 <- ro(copy(my.df)) 69.35311 76.66642 80.23917 84.67419 344.82031 100
r3 <- ar(copy(my.df)) 11.22027 12.14113 13.21196 14.72830 48.61417 100 <~~~
identical(r1, r2) # TRUE
identical(r1, r3) # TRUE
вот чистые данные.решение таблицы:
my.df[, res:=sum(my.df$x1 > (x1 - tol) & my.df$x1 < (x1 + tol)), by=x1]
my.df <- adply(my.df, 1,
function(df) my.df[x1 > (df$x1 - tol) & x1 < (df$x1 + tol), .N])
identical(my.df[,res],my.df[,V1])
#[1] TRUE
однако это все равно будет относительно медленно, если у вас есть много уникальных x1
. В конце концов, вам нужно сделать огромное количество сравнений, и я не могу придумать способ избежать этого прямо сейчас.
используя тот факт, что
abs(x-y) < tol ~ y-tol <= x <= y+ tol
вы можете повысить производительность в 2 раза.
## wrap codes in 2 function for benchmarking
library(data.table)
library(plyr)
my.df = data.table(x1 = 1:1000,
x2 = 4:1003)
tol = 3
ag <- function()
my.df[, res := sum(abs(my.df$x1-x1) < tol), by=x1]
ro <- function()
my.df[,res:= { y = my.df$x1
sum(y > (x1 - tol) & y < (x1 + tol))
}, by=x1]
## check equal results
identical(ag(),ro())
TRUE
library(microbenchmark)
## benchmarks
microbenchmark(ag(),
ro(),times=1)
Unit: milliseconds
expr min lq median uq max neval
ag() 32.75638 32.75638 32.75638 32.75638 32.75638 1
ro() 63.50043 63.50043 63.50043 63.50043 63.50043 1