No activity days detection using R - r

I have a dataframe loaded in RStudio with information about numerous events (millions).
Each row is an entry of a single event and apart from other information it includes two attributes with date information. The first one contains the date when the event began and the second when it ended. But the events are not sequential so they might overlap in time.
fecha fecha_fin
7510607 2014-02-13 20:09:59.8270000 2014-02-27 09:55:40.9700000
7510608 2014-02-13 20:10:01.1870000 2014-02-27 09:55:42.5630000
7557931 2014-02-16 05:32:08.6230000 2014-02-16 14:03:19.4970000
What could be the best and most efficient option to find which calendar days had no activity (without any event in process)? Please, keep in my mind that the duration of the events must be taken into consideration.

I tend to use foverlaps from the data.table package for such cases, e.g.:
library(data.table)
dt <- fread("id,fecha,fecha_fin
7510607,2014-02-01 20:09:59.8270000,2014-02-10 09:55:40.9700000
7510607,2014-02-13 20:09:59.8270000,2014-02-27 09:55:40.9700000
7510608,2014-02-13 20:10:01.1870000,2014-02-27 09:55:42.5630000
7557931,2014-02-16 05:32:08.6230000,2014-02-16 14:03:19.4970000")
setkey(dt, fecha, fecha_fin)
set(dt, j = 1L, value = NULL)
dt <- dt[,lapply(.SD, as.POSIXct, tz = "CET"),.SDcols=1:2]
dt2 <- data.table(fecha=as.POSIXct(seq(min(as.Date(dt$fecha)), max(as.Date(dt$fecha_fin)), "1 day")))[,fecha_fin:=fecha+60*60*24-1]
as.Date(foverlaps(dt2, dt)[is.na(fecha) & is.na(fecha_fin),i.fecha])
# [1] "2014-02-11" "2014-02-12"

Update, with slightly modified code from lukeA:
I hope there is nothing wrong with my benchmarking here...
library(data.table)
library(lubridate)
library(microbenchmark)
# Create dt ---------------------------------------------------------------
size = 99999
# With this size result is an empty set, check smaller sizes like 999 to confirm
# results are same for both functions
create_dt <- function() {
set.seed(2016)
dt <- data.table(
ID = 1:size,
fecha = sample(
seq(ymd('2000/01/01'), ymd('2016/11/16'), by="day"),
size, replace = TRUE)
)
dt[, fecha_fin := fecha + sample(1:3, size, replace = TRUE)]
setkey(dt, fecha, fecha_fin)
set(dt, j = 1L, value = NULL)
dt <- dt[,lapply(.SD, as.POSIXct, tz = "CET"),.SDcols=1:2]
}
dt <- create_dt()
# Declare functions -------------------------------------------------------
f_mdz <- function() {
dt_2 <- data.table(
fecha = seq(min(dt$fecha), max(dt$fecha_fin), by = '1 day')
# Function simplified here!!!
)[, fecha_fin := fecha]
# ---------------------------
as.Date(
foverlaps(dt_2, dt)[is.na(fecha) & is.na(fecha_fin),i.fecha])#,
# origin = '1970-01-01')
}
f_lukeA <- function() {
dt2 <- data.table(
fecha = seq(min(dt$fecha), max(dt$fecha_fin), "1 day")
)[,fecha_fin:=fecha+60*60*24-1]
as.Date(
foverlaps(dt2, dt)[is.na(fecha) & is.na(fecha_fin),i.fecha])
}
# Benchmark! --------------------------------------------------------------
microbenchmark(
dt_mdz <- f_mdz(),
dt_lukeA <- f_lukeA(),
times = 100)
# Unit: milliseconds
# expr min lq mean median uq max neval cld
# dt_mdz <- f_mdz() 46.96793 55.11631 95.59214 60.33659 191.5536 212.4523 100 a
# dt_lukeA <- f_lukeA() 50.57496 56.42464 105.07356 60.81974 194.0779 211.8037 100 a
identical(dt_mdz, dt_lukeA)
Old answer here:
A point of departure (far from being efficient, e.g. row-wise operations on data.table...) for further investigation could be:
library(data.table)
library(lubridate)
library(magrittr)
dt <- data.table(
ID = c(7510607L, 7510608L, 7557931L),
fecha = ymd(c('2014-02-15', '2014-02-16', '2014-02-11')),
fecha_fin = ymd(c('2014-02-27', '2014-02-27', '2014-02-12'))
)
# ID fecha fecha_fin
# 1: 7510607 2014-02-15 2014-02-27
# 2: 7510608 2014-02-16 2014-02-27
# 3: 7557931 2014-02-11 2014-02-12
# Make the data "long"
long_dt <- dt[, .(days = seq(fecha, fecha_fin, by = '1 day')), by = ID]
# Get the diff with days sequence from min to max date
setdiff(
seq(long_dt[, min(days)], long_dt[, max(days)], by = '1 day'),
long_dt[, sort(unique(days))]
) %>% as.Date(origin = '1970-01-01')
# [1] "2014-02-13" "2014-02-14"
Please note I have changed your data to actually have two days (2014-02-13 and 2014-02-14) without any activity.

A base R solution would be this:
df$fecha <- strptime(df$fecha, "%Y-%m-%d")
df$fecha_fin <- strptime(df$fecha_fin, "%Y-%m-%d")
dates_list <- lapply(1:3, function(x){
interval_events <- seq(from = df$fecha[x], to = df$fecha_fin[x], by = "days")
})
interval_events <- unique(do.call("c", dates_list))
interval_complete <- seq(from = min(df$fecha), max(df$fecha_fin), by = "days")
interval_complete[!(interval_complete %in% interval_events)]
#[1] "2014-02-13 CET" "2014-02-14 CET"

Here is a simple one! You just expand the dates and take a union of all the dates.
## Data
dt1=as.Date(c('2014/01/01','2014/01/08','2014/01/05'))
dt2=as.Date(c('2014/01/10','2014/01/14','2014/01/05'))
df=data.frame(id=sample(1:3), dt1=dt1, dt2=dt2)
## Code
date=apply(df, 1, function(x) seq(as.Date(x[2]), as.Date(x[3]), by="day"))
event_dates=as.Date(Reduce(union, date), origin = "1970-01-01")

Related

update table row values conditionally matching multiple columns in R [duplicate]

I have two data.frames that I want to merge together. The first is:
datess <- seq(as.Date('2005-01-01'), as.Date('2009-12-31'), 'days')
sample<- data.frame(matrix(ncol = 3, nrow = length(datess)))
colnames(sample) <- c('Date', 'y', 'Z')
sample$Date <- datess
The second:
a <- data.frame(matrix(ncol = 3, nrow = 5))
colnames(a) <- c('a', 'y', 'Z')
a$Z <- c(1, 3, 4, 5, 2)
a$a <- c(2005, 2006, 2007, 2008, 2009)
a$y <- c('abc', 'def', 'ijk', 'xyz', 'thanks')
And I'd like the merged one to match the year and then fill in the rest of the values for every day of that year.
Date y Z
2005-01-01 abc 1
2005-01-02 abc 1
2005-01-03 abc 1
{cont}
2009-12-31 thanks 2
So far, three different approaches have been posted:
using match()
using dplyr
using merge()
There is a fourth approach called update join suggested by Frank in chat:
library(data.table)
setDT(sample)[, yr := year(Date)][setDT(a), on = .(yr = a), `:=`(y = i.y, Z = i.Z)]
which turned out to be the fastest and most concise of the four.
Benchmark results:
To decide which of the approaches is the most efficient in terms of speed I've set up a benchmark using the microbenchmarkpackage.
Unit: microseconds
expr min lq mean median uq max neval
create_data 248.827 291.116 316.240 302.0655 323.588 665.298 100
match 4488.685 4545.701 4752.226 4649.5355 4810.763 6881.418 100
dplyr 6086.609 6275.588 6513.997 6385.2760 6625.229 8535.979 100
merge 2871.883 2942.490 3183.712 3004.6025 3168.096 5616.898 100
update_join 1484.272 1545.063 1710.651 1659.8480 1733.476 3434.102 100
As sample is modified it has to be created anew before each benchmark run. This is been done by a function which is included in the benchmark as well (create data). The times for create data need to be subtracted from the other timings.
So, even for the small data set of about 1800 rows, update join is the fastest, nearly twice as fast as the second merge, followed by match, and dplyr being last, more than 4 times slower than update join (with the time for create data subtracted).
Benchmark code
datess <- seq(as.Date('2005-01-01'), as.Date('2009-12-31'), 'days')
a <- data.frame(Z = c(1, 3, 4, 5, 2),
a = 2005:2009,
y = c('abc', 'def', 'ijk', 'xyz', 'thanks'),
stringsAsFactors = FALSE)
setDT(a)
make_sample <- function() data.frame(Date = datess, y = NA_character_, Z = NA_real_)
library(data.table)
library(magrittr)
microbenchmark::microbenchmark(
create_data = make_sample(),
match = {
sample <- make_sample()
matched<-match(format(sample$Date,"%Y"),a$a)
sample$y<-a$y[matched]
sample$Z<-a$Z[matched]
},
dplyr = {
sample <- make_sample()
sample <- sample %>%
dplyr::mutate(a = format(Date, "%Y") %>% as.numeric) %>%
dplyr::inner_join(a %>% dplyr::select(a), by = "a")
},
merge = {
sample <- make_sample()
sample2 <- data.frame(Date = datess)
sample2$a <- lubridate::year(sample2$Date)
sample <- base::merge(sample2, a, by="a")
},
update_join = {
sample <- make_sample()
setDT(sample)[, yr := year(Date)][a, on = .(yr = a), `:=`(y = i.y, Z = i.Z)]
}
)
You can use match
matched<-match(format(sample$Date,"%Y"),a$a)
sample$y<-a$y[matched]
sample$Z<-a$Z[matched]
If y and Z are always zero in sample you do not need them there, so all you have to do is join on year like this:
library(dplyr)
sample %>% mutate(a = format(Date, "%Y") %>% as.numeric) %>%
inner_join(a %>% select(a))
Is there anything speaking against having a column with year in your new df? If not you could generate one in 'sample' and use the merge function
require(lubridate) #to make generating the year easy
sample2<-data.frame(Date=datess)
sample2$a<-year(sample2$Date)
df<-merge(sample2,a,by="a")
this will result in something like this:
head(df)
a Date y Z
1 2005 2005-01-01 abc 1
2 2005 2005-01-02 abc 1
3 2005 2005-01-03 abc 1
4 2005 2005-01-04 abc 1
5 2005 2005-01-05 abc 1
6 2005 2005-01-06 abc 1
You could then remove the year column again if it bothers you.

merge data.frames based on year and fill in missing values

I have two data.frames that I want to merge together. The first is:
datess <- seq(as.Date('2005-01-01'), as.Date('2009-12-31'), 'days')
sample<- data.frame(matrix(ncol = 3, nrow = length(datess)))
colnames(sample) <- c('Date', 'y', 'Z')
sample$Date <- datess
The second:
a <- data.frame(matrix(ncol = 3, nrow = 5))
colnames(a) <- c('a', 'y', 'Z')
a$Z <- c(1, 3, 4, 5, 2)
a$a <- c(2005, 2006, 2007, 2008, 2009)
a$y <- c('abc', 'def', 'ijk', 'xyz', 'thanks')
And I'd like the merged one to match the year and then fill in the rest of the values for every day of that year.
Date y Z
2005-01-01 abc 1
2005-01-02 abc 1
2005-01-03 abc 1
{cont}
2009-12-31 thanks 2
So far, three different approaches have been posted:
using match()
using dplyr
using merge()
There is a fourth approach called update join suggested by Frank in chat:
library(data.table)
setDT(sample)[, yr := year(Date)][setDT(a), on = .(yr = a), `:=`(y = i.y, Z = i.Z)]
which turned out to be the fastest and most concise of the four.
Benchmark results:
To decide which of the approaches is the most efficient in terms of speed I've set up a benchmark using the microbenchmarkpackage.
Unit: microseconds
expr min lq mean median uq max neval
create_data 248.827 291.116 316.240 302.0655 323.588 665.298 100
match 4488.685 4545.701 4752.226 4649.5355 4810.763 6881.418 100
dplyr 6086.609 6275.588 6513.997 6385.2760 6625.229 8535.979 100
merge 2871.883 2942.490 3183.712 3004.6025 3168.096 5616.898 100
update_join 1484.272 1545.063 1710.651 1659.8480 1733.476 3434.102 100
As sample is modified it has to be created anew before each benchmark run. This is been done by a function which is included in the benchmark as well (create data). The times for create data need to be subtracted from the other timings.
So, even for the small data set of about 1800 rows, update join is the fastest, nearly twice as fast as the second merge, followed by match, and dplyr being last, more than 4 times slower than update join (with the time for create data subtracted).
Benchmark code
datess <- seq(as.Date('2005-01-01'), as.Date('2009-12-31'), 'days')
a <- data.frame(Z = c(1, 3, 4, 5, 2),
a = 2005:2009,
y = c('abc', 'def', 'ijk', 'xyz', 'thanks'),
stringsAsFactors = FALSE)
setDT(a)
make_sample <- function() data.frame(Date = datess, y = NA_character_, Z = NA_real_)
library(data.table)
library(magrittr)
microbenchmark::microbenchmark(
create_data = make_sample(),
match = {
sample <- make_sample()
matched<-match(format(sample$Date,"%Y"),a$a)
sample$y<-a$y[matched]
sample$Z<-a$Z[matched]
},
dplyr = {
sample <- make_sample()
sample <- sample %>%
dplyr::mutate(a = format(Date, "%Y") %>% as.numeric) %>%
dplyr::inner_join(a %>% dplyr::select(a), by = "a")
},
merge = {
sample <- make_sample()
sample2 <- data.frame(Date = datess)
sample2$a <- lubridate::year(sample2$Date)
sample <- base::merge(sample2, a, by="a")
},
update_join = {
sample <- make_sample()
setDT(sample)[, yr := year(Date)][a, on = .(yr = a), `:=`(y = i.y, Z = i.Z)]
}
)
You can use match
matched<-match(format(sample$Date,"%Y"),a$a)
sample$y<-a$y[matched]
sample$Z<-a$Z[matched]
If y and Z are always zero in sample you do not need them there, so all you have to do is join on year like this:
library(dplyr)
sample %>% mutate(a = format(Date, "%Y") %>% as.numeric) %>%
inner_join(a %>% select(a))
Is there anything speaking against having a column with year in your new df? If not you could generate one in 'sample' and use the merge function
require(lubridate) #to make generating the year easy
sample2<-data.frame(Date=datess)
sample2$a<-year(sample2$Date)
df<-merge(sample2,a,by="a")
this will result in something like this:
head(df)
a Date y Z
1 2005 2005-01-01 abc 1
2 2005 2005-01-02 abc 1
3 2005 2005-01-03 abc 1
4 2005 2005-01-04 abc 1
5 2005 2005-01-05 abc 1
6 2005 2005-01-06 abc 1
You could then remove the year column again if it bothers you.

Using data.table to summarize monthly sequences (count specific events)

I hope this is an acceptable R/data.table problem.
I have a 3-column table with:
id geographic location IDs (303,453 locations)
month month over 25 years 1990-2014
spei a climatic index that varies between -7 and 7.
I need to count the occurrence of droughts at each location over the entire 1990-2014 period. A drought event is defined as "a period in which the SPEI is continuously negative and the SPEI reaches a value of -1.0 or less. Drought starts when the SPEI first falls below zero and ends with the first positive SPEI value following a value of -1.0 or less".
I know this should be feasible using shift() and rolling joins but would very welcome some help!
# Sample table structure
dt <- data.table(
id = rep(1:303453, each=25*12),
month = rep(seq(as.Date("1990-01-01"), as.Date("2014-12-31"), "month"), 303453),
spei = runif(303453*25*12, -7, 7))
# A minimal example with 1 location over 12 months
library(data.table)
library(xts)
dt <- data.table(
id = rep("loc1", each=12),
month = seq(as.Date("2014-01-01"), as.Date("2014-12-31"), "month"),
spei = c(-2, -1.1, -0.5, 1.2, -1.2, 2.3, -1.7, -2.1, 0.9, 1.2, -0.9, -0.2))
spei.ts <- xts(dt$spei, order.by=dt$month, frequency="month")
plot(spei.ts, type="bars")
This shows 3 drought events over a 1-year period. This is what I need to identify and count.
Hoping some of you are more used to working with time series.
Many thanks, --Mel.
Here is a starting point to get the result you want.
Probably experts can suggest improvements in speed.
EDIT: improved speed ~8x by removing paste.
library(data.table)
set.seed(42)
n <- 300 # 303453 will be ~1000 times slower
dt <- data.table(
id = rep(1:n, each=25*12),
month = rep(seq(as.Date("1990-01-01"), as.Date("2014-12-31"), "month"), n),
spei = runif(n*25*12, -7, 7))
system.time({
dt[, `:=`(neg = (spei < 0), neg1 = (spei <= -1))]
dt[, runid := ifelse(neg, rleid(neg), NA)]
res <- dt[!is.na(runid),
.(length = .N[any(neg1)], start = min(month), end = max(month)),
by = .(id, runid)][!is.na(length)]
})
# user system elapsed
# 0.345 0.000 0.344
# counts of droughts per id:
res[, .(nDroughts = .N), by = id]
# list of droughts per id: (NB: don't include 1st positive value after)
res[, .(droughtN = seq_len(.N), start, end), by = id]
Update based on comment...
If all that was needed was the counts then
# Let 'sp' = starting point of potential drought
# Let 'dv' = drought level validation
# The cumsum just gives unique ids to group by.
dt[, sp := (spei <= 0) & (shift(spei, fill = 1) > 0), by = id]
dt[, dv := min(spei) <= -1, by = .(id, cumsum(sp))]
dt[sp & dv, .N, by = id]
yet, as stated in the comments, you've already been there, so you've seen how shift can be used. Since you like the idea of identifying the dates as well. Why not use shift there as well?
# Extending the previous columns...
dt[, ep := (shift(spei, type = "lead", fill = 1) > 0) & (spei <= 0), by = id]
cbind(dt[sp & dv, .(start = month), by = id],
dt[ep & dv, .(end = month), by = id][,id := NULL])
If you wanted the dates to be as indicated by the red lines in the plot just add a month unless its the last one. We can also get the lengths too...
# Extending the previous columns again...
dt[, end.month := shift(month, type = "lead", fill = month[.N]), by = id]
dt[, orig.id := .I]
starts <- dt[sp & dv][, did := .I]
ends <- dt[ep & dv][, did := .I]
starts[ends, on = "did"][
,.(id = id, length = 1 + i.orig.id - orig.id, start = month, end = i.end.month)]
Would yield
id length start end
1: loc1 3 2014-01-01 2014-04-01
2: loc1 1 2014-05-01 2014-06-01
3: loc1 2 2014-07-01 2014-09-01
And it is still fast! With n=300
> microbenchmark(max = max.full(copy(dt))[, .(nDroughts = .N), by = id],
+ thellcounts = thell.counts(copy(dt)),
+ thell .... [TRUNCATED]
Unit: milliseconds
expr min lq mean median uq max neval
max 218.19152 220.30895 342.18605 222.75507 250.36644 1350.15847 10
thellcounts 20.36785 22.27349 28.45167 23.39313 24.38610 78.25046 10
thelldates 28.24378 28.64849 30.59897 30.57793 31.25352 34.51569 10
thelldates2 36.19724 39.79588 42.34457 41.52455 42.41872 57.28073 10
With n=3000
> microbenchmark(max = max.full(copy(dt))[, .(nDroughts = .N), by = id],
+ thellcounts = thell.counts(copy(dt)),
+ thell .... [TRUNCATED]
Unit: milliseconds
expr min lq mean median uq max neval
max 2126.1138 2148.3453 2207.7801 2205.3536 2241.2848 2340.1203 10
thellcounts 197.7312 202.4817 234.2949 205.4828 304.1556 309.1028 10
thelldates 261.9889 264.5597 283.9970 266.1244 267.8603 374.6406 10
thelldates2 320.6352 331.7558 374.4110 340.2668 439.1490 441.8473 10

Use `data.table` to get first of subgroup based on a variable

Consider a data set consisting of a grouping variable (here id) and an ordered variable (here date)
(df <- data.frame(
id = rep(1:2,2),
date = 4:1
))
# id date
# 1 1 4
# 2 2 3
# 3 1 2
# 4 2 1
I'm wondering what the easiest way is in data.table to do the equivalent of this dplyr code:
library(dplyr)
df %>%
group_by(id) %>%
filter(min_rank(date)==1)
# Source: local data frame [2 x 2]
# Groups: id
#
# id date
# 1 1 2
# 2 2 1
i.e. for each id get the first according to date.
Based on a similar stackoverflow question (Create an "index" for each element of a group with data.table), I came up with this
library(data.table)
dt <- data.table(df)
setkey(dt, id, date)
for(k in unique(dt$id)){
dt[id==k, index := 1:.N]
}
dt[index==1,]
But it seems like there should be a one-liner for this. Being unfamiliar with data.table I thought something like this
dt[,,mult="first", by=id]
should work, but alas! The last bit of code seems like it should group by id and then take the first (which within id would be determined by date since I've set the keys in this way.)
EDIT
Thanks to Ananda Mahto, this one-liner will now be in my data.table repertoire
dt[,.SD[1], by=id]
# id date
# 1: 1 2
# 2: 2 1
Working directly with your source data.frame, you can try:
setkey(as.data.table(df), id, date)[, .SD[1], by = id]
# id date
# 1: 1 2
# 2: 2 1
Extending your original idea, you can just do:
dt <- data.table(df)
setkey(dt, id, date)
dt[, index := sequence(.N), by = id][index == 1]
# id date index
# 1: 1 2 1
# 2: 2 1 1
It might be that at a certain scale, David is correct about head vs [1], but I'm not sure what scale that would be.
set.seed(1)
nrow <- 10000
ncol <- 20
df <- data.frame(matrix(sample(10, nrow * ncol, TRUE), nrow = nrow, ncol = ncol))
fun1 <- function() setkey(as.data.table(df), X1, X2)[, head(.SD, 1), by = X1]
fun2 <- function() setkey(as.data.table(df), X1, X2)[, .SD[1], by = X1]
library(microbenchmark)
microbenchmark(fun1(), fun2())
# Unit: milliseconds
# expr min lq mean median uq max neval
# fun1() 12.178189 12.496777 13.400905 12.808523 13.483545 30.28425 100
# fun2() 4.474345 4.554527 4.948255 4.620596 4.965912 8.17852 100
Here's another option using data.tables binary search
setkey(dt[, indx := seq_len(.N), by = id], indx)[J(1)]
# id date indx
# 1: 1 2 1
# 2: 2 1 1
Some benchmarks:
It seems that all the methods perform more or less the same, but on huge data set (1e+06*1e+2) binrary search wins
set.seed(1)
nrow <- 1e6
ncol <- 1e2
df <- data.frame(matrix(sample(10, nrow * ncol, TRUE), nrow = nrow, ncol = ncol))
library(data.table)
funAM1 <- function() setkey(as.data.table(df), X1, X2)[, .SD[1], by = X1]
funAM2 <- function() setkey(as.data.table(df), X1, X2)[, index := sequence(.N), by = X1][index == 1]
funDA1 <- function() setkey(as.data.table(df), X1, X2)[, head(.SD, 1), by = X1]
funDA2 <- function() setkey(as.data.table(df)[, indx := seq_len(.N), by = X1], X1)[J(1)]
library(microbenchmark)
Res <- microbenchmark(funAM1(), funAM2(), funDA1(), funDA2())
Res
# Unit: milliseconds
# expr min lq median uq max neval
# funAM1() 737.5690 758.3015 771.9344 794.1417 910.1019 100
# funAM2() 631.7822 693.8286 704.6912 729.6960 806.5556 100
# funDA1() 757.0327 772.4353 784.3107 810.0759 938.6344 100
# funDA2() 564.7291 578.1089 587.6470 611.7269 740.4077 100
boxplot(Res)

Flat Apportionment of values across time periods

For different values of id I have a start and end dates with a relative quantity, var.
For each records (for the same id), start date is the same then the previous end date (here it comes roll...).
These periods span across multiple months and possibly years. My need is to split the quantity in var into parts relative to the actual days in each months. e.g.
start end var
30/01/2006 20/02/2006 104
above I have 21 days, the lower limit will belong to the previous period and the upper to the current, so 1/21 of 104 will be assigned to Jan 2006 and the rest to Feb 2006
I currently have two methods, listed below with dummy data, but they are pretty slow and I was wondering if someone may help with me out to speed them up.
library(data.table)
# data
set.seed(1)
nsample <- 200L # To increase the data size just change nsample
dt <- data.table(id= 1L:nsample)
dt <- dt[, list(date=sample(seq(as.Date("2006-01-01"), as.Date("2012-01-01"), "day"), 51, F)), by=id]
setkey(dt)
dt <- dt[, {tmp <- embed(as.vector(date), 2);list(start = structure(tmp[,2], class="Date"),
end = structure(tmp[,1], class="Date"),
var = rnorm(50, 100, 5))}, by=id]
setkey(dt, id, end)
> dt[1:4]
id start end var
1: 1 2006-01-30 2006-02-20 104.41542
2: 1 2006-02-20 2006-05-15 106.89356
3: 1 2006-05-15 2006-08-21 106.71162
4: 1 2006-08-21 2006-09-30 96.21729
# Method 1
dt1 <- copy(dt)
system.time({
dt1[, id2 := 1:.N]
tmp <- dt1[, list(id = id,
date = seq(start+1, end, "day"),
var = var), by=id2]
tmp[, var := var/(.N), by=id2]
res1 <- tmp[, list(var = sum(var)), by=list(id, period = paste(year(date), month(date), sep="-"))]
})
#user system elapsed
#1.92 0.00 1.92
# Method 2
dt2 <- copy(dt)
system.time({
dt2[, Ndays := as.integer(end)-as.integer(start)]
tmp <- dt2[, list(date = seq(min(start)+1, max(end), "day")), by=id]
setkey(tmp)
res2 <- dt2[ tmp, roll=-Inf][ end >= start,list(var = sum(var/Ndays)), by=list(id, period = paste(year(end), month(end), sep="-")) ]
})
#user system elapsed
# 0.7 0.0 0.7
> sum(dt$var) == sum(res1$var)
[1] TRUE
> sum(dt$var) == sum(res2$var)
[1] TRUE
> all.equal(res1, res2)
[1] TRUE
> res2[1:4]
id period var
1: 1 2006-1 4.972163
2: 1 2006-2 109.623593
3: 1 2006-3 39.448815
4: 1 2006-4 38.176273
This will be a bit faster (it's 3x faster for me than your second version). I optimized several things in your second version, that you can see below:
# let's just divide here instead of later
dt2[, var := var/(as.integer(end)-as.integer(start))]
tmp <- dt2[, list(date = seq(min(start)+1, max(end), "day")), by=id]
# data is sorted, so no need to sort again, just set key without sort
setattr(tmp, "sorted", c("id", "date"))
res2 <- dt2[tmp, roll=-Inf][,
list(var = sum(var)),
# doing the paste in by slows it down quite a bit, so let's postpone it
by=list(id, year(end), month(end))][,
`:=`(period = paste(year, month, sep = '-'), year = NULL, month = NULL)]
Re comment about large sizes - you could do all of the above inside dt2. It'll be slower, but I it won't create a large tmp:
dt2[, var := var/(as.integer(end)-as.integer(start))][,
{tmp = data.table(date = seq(min(start)+1, max(end), "day"));
setattr(tmp, 'sorted', 'date');
setattr(.SD, 'sorted', 'end');
.SD[tmp, roll = -Inf][,
list(var = sum(var)), by = list(year(end), month(end))][,
`:=`(period = paste(year, month, sep = '-'), year = NULL, month = NULL)]
}, by = id]

Resources