Это возможно с помощью функции foverlaps в пределах data.table, и следующий метод фактически выполняет молитву по завершению вашего фактического варианта использования - A, что составляет тысячи строк, и таблицу B, котораяэто почти миллионы строк - в разумные сроки.
На примере вашей игрушки:
library(data.table)
A <- fread("
loc
150
250
400")
B <- fread("
loc value
25 7
77 19
170 10
320 15")
## Create a 'dummy' value to create an interval w/same start and end in A
A[,loc_Dummy := loc]
## Create values bounding the match range for loc in B
B[,loc_Plus100 := loc + 100]
B[,loc_Minus100 := loc - 100]
## Set up for the overlap join
setkey(A,loc,loc_Dummy)
setkey(B,loc_Minus100, loc_Plus100)
## Create a table of only matches instead of doing a full cartesian join of all cases
Matches <- foverlaps(A[,.(loc, loc_Dummy)],
B[,.(loc_Minus100,loc_Plus100,value)])
## Create a summary table
Matches[,.(n = .N, sum = sum(value), avg = mean(value)), by = .(loc)]
# loc n sum avg
# 1: 150 2 29 14.5
# 2: 250 2 25 12.5
# 3: 400 1 15 15.0
Увеличение - yikes!
Однако - это на самом деле чрезвычайно вычислительно интенсивная проблема.Масштабирование до фактических размеров дел показывает здесь проблему - используя 10 000 строк для таблицы A и 1 000 000 строк для таблицы B, этот метод завершается за 91 секунд на сервере, на котором я работаю, но использует более 112 ГБ памяти !
A <- data.table(loc = sample.int(1000, size = 1e4, replace = TRUE))
B <- data.table(loc = sample.int(1000, size = 1e6, replace = TRUE),
value = sample.int(100, size = 1e6, replace = TRUE))
system.time({
A[,loc_Dummy := loc]
B[,loc_Plus100 := loc + 100]
B[,loc_Minus100 := loc - 100]
setkey(A,loc,loc_Dummy)
setkey(B,loc_Minus100, loc_Plus100)
Matches <- foverlaps(A[,.(loc, loc_Dummy)],
B[,.(loc_Minus100,loc_Plus100,value)])
Summary <- Matches[,.(n = .N, sum = sum(value), avg = mean(value)), by = .(loc)]
})
## Warning: Memory usage peaks at ~112 GB!
# user system elapsed
# 56.407 46.258 91.135
Это едва ли соответствует возможностям сервера, которым я пользуюсь, и, вероятно, на самом деле может не подходить для вашего случая.
Если у вас нет сотен гигабайт памяти в вашем распоряжении, вам, вероятно, придется немного более умно подходить к этому и перебирать куски за раз.
Из того, что я могу сказать, ваша проблема на самом деле похожа на ту, которая была поставлена (и решена) Лоренцо Бусетто и подробно описана в сообщении в блоге: Ускорение пространственного анализа за счет интеграции sf иdata.table: контрольный пример .
Разделение на части
Требование более ~ 100 гигабайт памяти не является действительно возможным решением, особенно если вы хотите масштабировать Aили B на порядок выше в какой-то момент.
Однако метод разбиения на куски (вдохновленный постом Лоренцо, связанным выше), который разбивает проблему на 100 частей на самом деле только увеличиваетсяво время выполнения тривиальная величина составляет 116 секунд , но сокращает пиковое использование памяти до менее 3 ГБ !Если бы я планировал сделать это в производстве, я бы сделал что-то вроде следующего.
Одно замечание: я действительно не проводил какой-либо углубленный аудит на точность результатов (Я мог бы указать одну из границ диапазона, неправильно открытых или закрытых), поэтому я бы тщательно изучил вывод с данными, с которыми вы знакомы, прежде чем вводить в эксплуатацию.
A <- data.table(loc = sample.int(1000, size = 1e4, replace = TRUE))
B <- data.table(loc = sample.int(1000, size = 1e6, replace = TRUE),
value = sample.int(100, size = 1e6, replace = TRUE))
system.time({
A[,loc_Dummy := loc]
B[,loc_Plus100 := loc + 100]
B[,loc_Minus100 := loc - 100]
setkey(A,loc)
setkey(B,loc)
ChunkCount <- 100
ChunkSize <- A[,.N/ChunkCount]
ResultList <- vector("list", ChunkCount)
for (j in seq_len(ChunkCount)){
A_loc_Min <- A[((j-1)*ChunkSize + 1):(min(nrow(A),(j)*ChunkSize)), min(loc)]
A_loc_Max <- A[((j-1)*ChunkSize + 1):(min(nrow(A),(j)*ChunkSize)), max(loc)]
A_Sub <- A[loc >= A_loc_Min & loc < A_loc_Max]
B_Sub <- B[loc_Plus100 >= A_loc_Min & loc_Minus100 < A_loc_Max]
setkey(A_Sub,loc,loc_Dummy)
setkey(B_Sub,loc_Minus100, loc_Plus100)
Matches <- foverlaps(A_Sub[,.(loc, loc_Dummy)],
B_Sub[,.(loc_Minus100,loc_Plus100,value)])
ResultList[[j]] <- Matches[,.(n = .N, sum = sum(value), avg = mean(value)), by = .(loc)]
}
Summary <- rbindlist(ResultList)
})
# user system elapsed
# 109.125 16.864 116.129
Проверка
Обновление: предложения @Alexis и @ Frank в комментариях приводят к одному и тому же набору результатов, у меня получается немного другой, но только по количеству.Если кто-то еще сможет подтвердить, что правильный ответ действительно предоставлен @ Alexis / @ Frank, то я был бы рад отозвать свой ответ, поскольку оба метода выполняются быстрее, чем предложенный мной.
set.seed(1234)
A <- data.table(loc = sample.int(1000, size = 1e3, replace = TRUE))
B <- data.table(loc = sample.int(1000, size = 1e4, replace = TRUE),
value = sample.int(10, size = 1e4, replace = TRUE))
## Matt
Matt_A <- copy(A)
Matt_B <- copy(B)
Matt_A[,loc_Dummy := loc]
Matt_B[,loc_Plus100 := loc + 100]
Matt_B[,loc_Minus100 := loc - 100]
setkey(Matt_A,loc,loc_Dummy)
setkey(Matt_B,loc_Minus100, loc_Plus100)
Matches <- foverlaps(Matt_A[,.(loc, loc_Dummy)],
Matt_B[,.(loc_Minus100,loc_Plus100,value)])
Summary_Matt <- Matches[,.(n = .N, sum = sum(value), avg = mean(value)), keyby = .(loc)]
## Alexis
Rcpp::sourceCpp("RowRanges.cpp")
A_loc <- sort(A$loc, decreasing = FALSE)
B <- B[order(B$loc),]
Alexis <- foo(unique(A_loc), B$loc, B$value)
Summary_Alexis <- as.data.table(Alexis)
colnames(Summary_Alexis) <- c("n","sum","avg")
Summary_Alexis[,loc := unique(A_loc)]
setcolorder(Summary_Alexis, c("loc","n","sum","avg"))
## Frank
Frank <- A[, up := loc + 100][
, dn := loc - 100][
, c("n", "s", "m") := B[copy(.SD), on=.(loc >= dn, loc <= up), .(.N, sum(value), mean(value)), by=.EACHI][
, .(N, V2, V3)]][]
Summary_Frank <- unique(Frank[,.(loc,n, sum = s, avg = m)][order(loc)])
## Comparing
all.equal(Summary_Frank,Summary_Alexis)
# [1] TRUE
all.equal(Summary_Frank,Summary_Matt)
# [1] "Column 'n': Mean relative difference: 1.425292"