Шаги оптимизации расширяют дату последовательности, пересекаются и вычисляются по группам с помощью data.table
У меня есть огромный набор данных, где я использую пакет data.table из-за быстрых вычислений. Имея этот тип набора данных:
library(data.table)
library(dplyr)
dt <- data.table(
gr1 = rep(LETTERS[1:2], each = 4),
gr2 = rep(letters[3:6], each = 2),
date1 = as.Date(c('2020-01-01', '2020-02-01', '2020-02-01', '2020-02-04', '2020-01-01', '2020-02-01', '2020-02-01', '2020-02-04')),
date2 = as.Date(c('2020-01-05', '2020-02-05', '2020-02-02', '2020-02-07', '2020-01-05', '2020-02-05', '2020-02-02', '2020-02-07')),
value = 1:8
)
dt
gr1 gr2 date1 date2 value
1: A c 2020-01-01 2020-01-05 1
2: A c 2020-02-01 2020-02-05 2
3: A d 2020-02-01 2020-02-02 3
4: A d 2020-02-04 2020-02-07 4
5: B e 2020-01-01 2020-01-05 5
6: B e 2020-02-01 2020-02-05 6
7: B f 2020-02-01 2020-02-02 7
8: B f 2020-02-04 2020-02-07 8
Я хочу суммировать столбец value по тем датам (результат последовательности диапазонов дат), которые присутствуют во всех gr2, которые соответствуют одному и тому же gr1. (независимый расчет между gr1).
Мой обходной путь:
- Создайте набор данных со столбцом
date, расширяющим диапазоны дат (date1иdate2)
dt2 <- dt[, .(gr1, gr2, date = seq(date1, date2, by = 'day'), value), by = 1:nrow(dt)]
- Добавить столбец
is_shared, еслиdateприсутствует на всехgr2для каждогоgr1, используя функцииReduceиintersect, можно найти здесь
dt2[, date := as.character(date)]
dt3 <- split(dt2, by = 'gr1') %>% lapply(function(x) {
dates <- Reduce(intersect, x[, .(list(unique(date))), gr2]$V1)
x[, is_shared := date %in% dates][]
}) %>% rbindlist()
dt3
gr1 gr2 date value is_shared
1: A c 2020-01-01 1 FALSE
2: A c 2020-01-02 1 FALSE
3: A c 2020-01-03 1 FALSE
4: A c 2020-01-04 1 FALSE
5: A c 2020-01-05 1 FALSE
6: A c 2020-02-01 2 TRUE
7: A c 2020-02-02 2 TRUE
8: A c 2020-02-03 2 FALSE
9: A c 2020-02-04 2 TRUE
10: A c 2020-02-05 2 TRUE
11: A d 2020-02-01 3 TRUE
12: A d 2020-02-02 3 TRUE
13: A d 2020-02-04 4 TRUE
14: A d 2020-02-05 4 TRUE
15: A d 2020-02-06 4 FALSE
16: A d 2020-02-07 4 FALSE
17: B e 2020-01-01 5 FALSE
18: B e 2020-01-02 5 FALSE
19: B e 2020-01-03 5 FALSE
20: B e 2020-01-04 5 FALSE
21: B e 2020-01-05 5 FALSE
22: B e 2020-02-01 6 TRUE
23: B e 2020-02-02 6 TRUE
24: B e 2020-02-03 6 FALSE
25: B e 2020-02-04 6 TRUE
26: B e 2020-02-05 6 TRUE
27: B f 2020-02-01 7 TRUE
28: B f 2020-02-02 7 TRUE
29: B f 2020-02-04 8 TRUE
30: B f 2020-02-05 8 TRUE
31: B f 2020-02-06 8 FALSE
32: B f 2020-02-07 8 FALSE
- Отфильтруйте общие даты и вычислите расчет с помощью
gr1
dt4 <- dt3[is_shared == TRUE][, .(value = sum(value)), by = .(gr1, date)]
dt4
gr1 date value
1: A 2020-02-01 5
2: A 2020-02-02 5
3: A 2020-02-04 6
4: A 2020-02-05 6
5: B 2020-02-01 13
6: B 2020-02-02 13
7: B 2020-02-04 14
8: B 2020-02-05 14
Проблема:
- Огромный размер
dt2 splitиlapplyшаг вызывает сбой в моей системе (15 ГБ ОЗУ и 4 ГБ подкачки)
Возможные оптимизации:
- Избегайте объектов DT2 и DT3 из-за расширения дат из диапазонов дат.
- Я пытался использовать
.Iпри создании последовательности дат по строке, но у меня возникла ошибка'from' must be of length 1. Поэтому я изменил на1:nrow(dt), что создает ненужный столбец с именемnrow(удален при апостериорных вычислениях). - Не преобразовывать
dateв класс символов наdt2(необходимо при поиске с%in%вlapply
Обновлено: добавление реального случая
dt <- data.table(
id1 = c(rep(1, 8), rep(2, 4)),
id2 = rep(c(10, 20, 30), each = 4),
id3 = rep(rep(LETTERS[1:2], each = 2), 3),
gr = rep(1:2, 6),
date1 = as.Date(rep(c('2020-01-01', '2020-01-05'), 6)),
date2 = as.Date(rep(c('2020-01-10', '2020-01-12'), 6)),
value = 1:12
)
dt
id1 id2 id3 gr date1 date2 value
1: 1 10 A 1 2020-01-01 2020-01-10 1
2: 1 10 A 2 2020-01-05 2020-01-12 2
3: 1 10 B 1 2020-01-01 2020-01-10 3
4: 1 10 B 2 2020-01-05 2020-01-12 4
5: 1 20 A 1 2020-01-01 2020-01-10 5
6: 1 20 A 2 2020-01-05 2020-01-12 6
7: 1 20 B 1 2020-01-01 2020-01-10 7
8: 1 20 B 2 2020-01-05 2020-01-12 8
9: 2 30 A 1 2020-01-01 2020-01-10 9
10: 2 30 A 2 2020-01-05 2020-01-12 10
11: 2 30 B 1 2020-01-01 2020-01-10 11
12: 2 30 B 2 2020-01-05 2020-01-12 12
Цель:
- Создать/расширить набор данных со столбцом
date, состоящим из дат междуdate1иdate2 - Для каждой комбинации
id1-id2-id3отфильтруйте общие даты, присутствующие во всехgr - Суммируйте соответствующие
value
Вы правы, извините. Я мог завершить рабочий процесс, я изменил заголовок и попытался его оптимизировать.
Ответы 3
Попробуй это,
fun <- function(d1, d2, v, g2) {
tmp <- as.data.table(tidyr::unnest(
cbind(data.table(v=v, d=Map(seq, d1, d2, by = "days")), g2=g2),
d))
allg3 <- unique(g2)
tmp[, .SD[all(allg3 %in% g2),], by = d][, .(value = sum(v)), by = d]
}
dt[, fun(date1, date2, value, gr2), by = gr1]
# gr1 d value
# <char> <Date> <int>
# 1: A 2020-02-01 5
# 2: A 2020-02-02 5
# 3: A 2020-02-04 6
# 4: A 2020-02-05 6
# 5: B 2020-02-01 13
# 6: B 2020-02-02 13
# 7: B 2020-02-04 14
# 8: B 2020-02-05 14
Не существует (пока? data.table#2146 и data.table#3672) data.table-внутренней аннест-функции, и обсуждение в этих проблемах предполагает, что tidyr::unnest достаточно эффективен, чтобы предотвратить переход в одни сами.
Спасибо. Я собираюсь попробовать с моими реальными данными, надеюсь, это не сбой. Одно сомнение, с uniqueN(gr2) > 1 это не гарантирует, что он будет на всех gr2 на одном и том же gr1, верно? На gr1=A может быть 3 разных gr2, но на gr1=B может быть 5 разных gr2. date должен быть включен, если существует во всех gr2 из gr1=A ИЛИ во всех gr2 из gr1=B. По этой причине я использовал intersect
Раньше в вашем вопросе говорилось «общий доступ к тому, что принадлежит» вместо текущего «присутствует на всех», так что да, его нужно будет обновить, чтобы учесть ваши измененные ограничения. Смотрите мою правку. (Вероятно, вы захотите протестировать выборочные данные, которые на самом деле включают как «соответствует», так и «не удовлетворяет» этому ограничению.)
Да, ты прав. Вопрос редактировался много раз. В следующий раз постараюсь выложить максимально приблизительный итоговый вопрос, извините. И большое спасибо за ваше время. Я собираюсь попробовать вашу функцию
Еще одно возможное решение с эталонным сравнением с решениями OP и @ r2evan:
library(data.table)
library(collapse) # for the function "fndistinct"
library(dplyr)
fun <- function(d1, d2, v, g2) {
# needed for r2evan's solution
tmp <- as.data.table(tidyr::unnest(
cbind(data.table(v=v, date=Map(seq, d1, d2, by = "days")), g2=g2),
date))
allg3 <- unique(g2)
tmp[, .SD[all(allg3 %in% g2),], by = date][, .(value = sum(v)), by = date]
}
решение ОП
f1 <- function(dt) {
# OP solution
dt2 <- dt[, .(gr1, gr2, date = seq(date1, date2, by = 'day'), value), by = 1:nrow(dt)]
dt3 <- split(dt2, by = 'gr1') %>% lapply(function(x) {
dates <- Reduce(intersect, x[, .(list(unique(date))), gr2]$V1)
x[, is_shared := date %in% dates][]
}) %>% rbindlist()
dt3[is_shared == TRUE][, .(value = sum(value)), by = .(gr1, date)]
}
Вариант 2:
f2 <- function(dt, idcols = grep("id", names(dt)), grcol = grep("gr", names(dt))) {
d <- as.integer(dt$date2 - dt$date1) + 1L
setDT(
c(
lapply(dt[, ..idcols], rep.int, times = d),
list(
date = as.Date(sequence(d, dt$date1), origin = "1970-01-01"),
value = rep.int(dt$value, d),
# the count of unique gr by ids
n = rep.int(fndistinct(dt[[grcol]], dt[, ..idcols], 1), d)
)
)
)[
# aggregate value by id and date
# keep only if the count is equal to the number of unique gr
, .(value = if (n[1] == .N) sum(value) else value[0]),
c(names(dt)[idcols], "date")
]
}
Сравнительный анализ:
microbenchmark::microbenchmark(f1 = f1(dt),
r2evans = dt[, fun(date1, date2, value, gr2), by = gr1],
f2 = f2(dt, 1L, 2L),
check = "identical")
#> Unit: microseconds
#> expr min lq mean median uq max neval
#> f1 5042.1 5390.60 6225.412 6182.55 6763.70 9123.5 100
#> r2evans 11061.0 11836.35 12555.882 12145.10 12865.85 19127.9 100
#> f2 694.9 835.70 885.403 879.80 932.80 1127.3 100
Данные:
dt <- data.table(
gr1 = rep(LETTERS[1:2], each = 4),
gr2 = rep(letters[3:6], each = 2),
date1 = as.Date(c('2020-01-01', '2020-02-01', '2020-02-01', '2020-02-04', '2020-01-01', '2020-02-01', '2020-02-01', '2020-02-04')),
date2 = as.Date(c('2020-01-05', '2020-02-05', '2020-02-02', '2020-02-07', '2020-01-05', '2020-02-05', '2020-02-02', '2020-02-07')),
value = 1:8
)
Для данных "реального случая":
f2(dt)
#> id1 id2 id3 date value
#> 1: 1 10 A 2020-01-05 3
#> 2: 1 10 A 2020-01-06 3
#> 3: 1 10 A 2020-01-07 3
#> 4: 1 10 A 2020-01-08 3
#> 5: 1 10 A 2020-01-09 3
#> 6: 1 10 A 2020-01-10 3
#> 7: 1 10 B 2020-01-05 7
#> 8: 1 10 B 2020-01-06 7
#> 9: 1 10 B 2020-01-07 7
#> 10: 1 10 B 2020-01-08 7
#> 11: 1 10 B 2020-01-09 7
#> 12: 1 10 B 2020-01-10 7
#> 13: 1 20 A 2020-01-05 11
#> 14: 1 20 A 2020-01-06 11
#> 15: 1 20 A 2020-01-07 11
#> 16: 1 20 A 2020-01-08 11
#> 17: 1 20 A 2020-01-09 11
#> 18: 1 20 A 2020-01-10 11
#> 19: 1 20 B 2020-01-05 15
#> 20: 1 20 B 2020-01-06 15
#> 21: 1 20 B 2020-01-07 15
#> 22: 1 20 B 2020-01-08 15
#> 23: 1 20 B 2020-01-09 15
#> 24: 1 20 B 2020-01-10 15
#> 25: 2 30 A 2020-01-05 19
#> 26: 2 30 A 2020-01-06 19
#> 27: 2 30 A 2020-01-07 19
#> 28: 2 30 A 2020-01-08 19
#> 29: 2 30 A 2020-01-09 19
#> 30: 2 30 A 2020-01-10 19
#> 31: 2 30 B 2020-01-05 23
#> 32: 2 30 B 2020-01-06 23
#> 33: 2 30 B 2020-01-07 23
#> 34: 2 30 B 2020-01-08 23
#> 35: 2 30 B 2020-01-09 23
#> 36: 2 30 B 2020-01-10 23
хороший эталон. Но ваши функции не заботятся о all(allg3 %in% g2), как это делает @r2evans, не так ли?
Ах, я не был уверен, что вы имели в виду изначально. В этом случае ответ проще (и быстрее). Смотрите обновленный ответ.
Кажется, это работает нормально. Но в моем реальном случае у меня есть три разных столбца типа gr1. Одним из них в ближайшем будущем может быть тип символов. Учитывая ваше замечание о сортировке, они тоже будут сортироваться, но разные gr1 могут иметь одинаковые gr2. У меня есть предупреждение в промежуточной таблице данных о возврате из-за rep.int(g, g). Может быть, это вызвано group (впервые вижу), который я изменил на attr(group(dt[, 1:4], 0, 1), "group.sizes")
Решение r2evans было в порядке, потому что я добавил больше gr1s на by = и все, но скорость вашей функции потрясающая
Я не уверен, как именно это должно повлиять на ожидаемый результат. Можете ли вы обновить свой пример, чтобы он больше соответствовал вашим фактическим данным?
Я добавил более близкий пример
Спасибо, это было очень полезно. Произошла ошибка в уникальной логике подсчета gr. Я обновил ответ, чтобы обрабатывать переменное количество столбцов id.
Кроме того, я не думаю, что новое решение требует сортировки столбцов.
Я применил обе функции, r2evans и вашу, к реальному случаю исходных 850 000 строк. Функция r2evans выполняет свою работу за 15 минут, а ваша — за 9 секунд. Поскольку я искал наиболее оптимизированный способ выполнения работы, я считаю ваше решение лучшим. Хотя я очень ценю усилия, самоотверженность и терпение всех людей, которые участвовали. Со всеми ответами у меня есть очень ценный материал для продолжения обучения. Большое спасибо
В приведенном ниже подходе используются data.table неэквивалентные соединения и цепочка, чтобы избежать материализации каких-либо промежуточных результатов. Не уверен, что это потенциально может привести к проблемам с памятью с вашим полным размером data.set, но я считаю, что он должен быть производительным.
## Generate an index of all dates included in ranges
Index <- data.table(date = seq.Date(from = dt[,min(date1)],
to = dt[,max(date2)],
by = 1))
## Create an extra column since data.table dt[dt2, ...] style
## joins modify the original key columns
Index[, dateKey := date]
## Set keys ahead of time
setkey(dt,date1,date2)
setkey(Index,dateKey)
## Perform a non-equijoin to expand to the equivalent of dt2
Index[dt, on = .(dateKey >= date1, dateKey <= date2)][
## Determine whether dates are shared
, is_shared := .N > 1, keyby = .(gr1,date)][
## Subset only shared dates and sum values by gr1 and date
is_shared == TRUE, .(value = sum(value)), keyby = .(gr1,date)]
Что касается бенчмаркинга, результаты, продемонстрированные @jblood94 (измеряемые в микросекундах) для набора данных из 8-12 строк, как правило, вряд ли будут репрезентативными для более крупного набора данных. Предоставленный вами набор данных был превосходен для демонстрации входных и выходных данных, которые вы хотели получить в удобоваримой форме, но создание гораздо большего синтетического набора данных с подсчетом групп, длиной диапазона дат и общим временным интервалом, аналогичным вашему текущему набору данных, было бы необходимо для действительного сравнения производительности.
В приведенном ниже коде демонстрируется подход к созданию произвольно большого набора данных и сравнению текущих предлагаемых подходов, каждый из которых выполняется только один раз. Как подход data.table, описанный в этом ответе, так и решение f2() @jblood94, по-видимому, очень хорошо масштабируются. Однако я заметил, что разные подходы давали разные результаты с этими синтетическими данными, не будучи уверенным, что сначала результат «правильный». Почти уверен, что я сталкиваюсь с артефактом сравнения различных редакций вопроса и ответа OP/@jblood94.
Кроме того, другой вариант показывает, как преобразование столбцов даты в класс data.tableIDate немного повышает производительность.
library(data.table)
library(collapse) # for the function "fndistinct"
library(dplyr)
## Number of rows in synthetic data
N = 1e5
## Larger date ranges and mean duration will impact resulting
## intermediate result sizes significantly
start <- as.Date("2020-01-01")
end <- as.Date("2022-12-31")
range <- seq.Date(from = start,
to = end,
by = 1)
meanDuration <- 60
sdDuration <- meanDuration/2
## Cardinality of groups will also impact results
gr1Set <- as.character(seq_len(100))
gr2Set <- as.character(seq_len(20))
dt <- data.table(
gr1 = sample(gr1Set, N, replace = T),
gr2 = sample(gr2Set, N, replace = T),
date1 = sample(range, N, replace = T),
date2 = as.Date(NA),
value = sample(1:10, N, replace = T)
)[order(gr1,gr2,date1)]
dt[, date2 := date1 + ceiling(pmax(1,rnorm(N, mean = meanDuration,sd = sdDuration)))]
str(dt)
## Create copies so functions each get a "clean" set of data
## Since data.table modifies by reference
dt1 <- copy(dt)
dt2 <- copy(dt)
dt3 <- copy(dt)
dt4 <- copy(dt)
dt5 <- copy(dt)
Определения функций:
fun <- function(d1, d2, v, g2) {
# needed for r2evan's solution
tmp <- as.data.table(tidyr::unnest(
cbind(data.table(v=v, date=Map(seq, d1, d2, by = "days")), g2=g2),
date))
allg3 <- unique(g2)
tmp[, .SD[all(allg3 %in% g2),], by = date][, .(value = sum(v)), by = date]
}
f1 <- function(dt) {
# OP solution
dt2 <- dt[, .(gr1, gr2, date = seq(date1, date2, by = 'day'), value), by = 1:nrow(dt)]
dt3 <- split(dt2, by = 'gr1') %>% lapply(function(x) {
dates <- Reduce(intersect, x[, .(list(unique(date))), gr2]$V1)
x[, is_shared := date %in% dates][]
}) %>% rbindlist()
dt3[is_shared == TRUE][, .(value = sum(value)), by = .(gr1, date)]
}
f2 <- function(dt, idcols, grcol) {
d <- as.integer(dt$date2 - dt$date1) + 1L
setDT(
c(
lapply(dt[, ..idcols], rep.int, times = d),
list(
date = as.Date(sequence(d, dt$date1), origin = "1970-01-01"),
value = rep.int(dt$value, d),
# the count of unique gr by ids
n = rep.int(fndistinct(dt[[grcol]], dt[, ..idcols], 1), d)
)
)
)[
# aggregate value by id and date
# keep only if the count is equal to the number of unique gr
, .(value = if (n[1] == .N) sum(value) else value[0]),
c(names(dt)[idcols], "date")
]
}
matt <- function(dt){
## Generate an index of all dates included in ranges
Index <- data.table(date = seq.Date(from = dt[,min(date1)],
to = dt[,max(date2)],
by = 1))
## Create an extra column since data.table dt[dt2, ...] style
## joins modify the original key columns
Index[, dateKey := date]
## Set keys ahead of time
setkey(dt,date1,date2)
setkey(Index,dateKey)
## Perform a non-equijoin to expand to the equivalent of dt2
Index[dt, on = .(dateKey >= date1, dateKey <= date2)][
## Determine whether dates are shared
, is_shared := .N > 1, keyby = .(gr1,date)][
## Subset only shared dates and sum values by gr1 and date
is_shared == TRUE, .(value = sum(value)), keyby = .(gr1,date)][]
}
mattIDate <- function(dt){
## Generate an index of all dates included in ranges
Index <- data.table(date = as.IDate(seq.Date(from = dt[,min(date1)],
to = dt[,max(date2)],
by = 1)))
## Create an extra column since data.table dt[dt2, ...] style
## joins modify the original key columns
Index[, dateKey := date]
## Convert to data.table IDates for performance
dt[,date1 := as.IDate(date1)]
dt[,date2 := as.IDate(date2)]
## Set keys ahead of time
setkey(dt,date1,date2)
setkey(Index,dateKey)
## Perform a non-equijoin to expand to the equivalent of dt2
Index[dt, on = .(dateKey >= date1, dateKey <= date2)][
## Determine whether dates are shared
, is_shared := .N > 1, keyby = .(gr1,date)][
## Subset only shared dates and sum values by gr1 and date
is_shared == TRUE, .(value = sum(value)), keyby = .(gr1,date)][]
}
И бенчмаркинг для 100 000 входных строк:
microbenchmark::microbenchmark(f1 = f1(dt1),
r2evans = dt2[, fun(date1, date2, value, gr2), by = gr1],
f2 = f2(dt3, 1L, 2L),
matt = matt(dt4),
mattIDate = mattIDate(dt5),
#check = "identical",
times = 1)
# Unit: milliseconds
# expr min lq mean median uq max neval
# f1 8269.9858 8269.9858 8269.9858 8269.9858 8269.9858 8269.9858 1
# r2evans 37229.5579 37229.5579 37229.5579 37229.5579 37229.5579 37229.5579 1
# f2 821.1306 821.1306 821.1306 821.1306 821.1306 821.1306 1
# matt 1335.4477 1335.4477 1335.4477 1335.4477 1335.4477 1335.4477 1
# mattIDate 1037.2043 1037.2043 1037.2043 1037.2043 1037.2043 1037.2043 1
Я всегда волнуюсь, когда вижу, что «вывод будет таким». Обычно это означает, что вопрос неполный. Пожалуйста, укажите точное и полное значение, которое позволит проверить.