Improvement in performance - r

Question

I am trying to get function application based on lagging/forwarding. I use extensively data.table and I even have working code, but knowing power of data.table I think there must be a simpler way to achieve the same with possibly improving the performance (I do a lot of creation of variables inside the functions). Below is working code of functions (available in https://gist.github.com/tomaskrehlik/5262087#file-gistfile1-r )
# Lag-function lags the given variable by the date_variable
lag_variable <- function(data, variable, lags, date_variable = c("Date")) {
if (lags == 0) {
return(data)
}
if (lags>0) {
name <- "lag"
} else {
name <- "forward"
}
require(data.table)
setkeyv(data, date_variable)
if (lags>0) {
data[,index:=seq(1:.N)]
} else {
data[,index:=rev(seq(1:.N))]
}
setkeyv(data, "index")
lags <- abs(lags)
position <- which(names(data)==variable)
for ( j in 1:lags ) {
lagname <- paste(variable,"_",name,j,sep="")
lag <- paste("data[, ",lagname,":=data[list(index-",j,"), ",variable,", roll=TRUE][[",position,"L]]]", sep = "")
eval(parse( text = lag ))
}
setkeyv(data, date_variable)
data[,index:=NULL]
}
# window_func applies the function to the lagged or forwarded variables created by lag_variable
window_func <- function(data, func.name, variable, direction = "window", steps, date_variable = c("Date"), clean = TRUE) {
require(data.table)
require(stringr)
transform <- match.fun(func.name)
l <- length(names(data))
if (direction == "forward") {
lag_variable(data, variable, -steps, date_variable)
cols <- which((!(is.na(str_match(names(a), paste(variable,"_forward(",paste(1:steps,collapse="|"),")",sep=""))[,1])))*1==1)
} else {
if (direction == "backward") {
lag_variable(data, variable, steps, date_variable)
cols <- which((!(is.na(str_match(names(a), paste(variable,"_lag(",paste(1:steps,collapse="|"),")",sep=""))[,1])))*1==1)
} else {
if (direction == "window") {
lag_variable(data, variable, -steps, date_variable)
lag_variable(data, variable, steps, date_variable)
cols <- which((!(is.na(str_match(names(a), paste(variable,"_lag(",paste(1:steps,collapse="|"),")",sep=""))[,1])))*1==1)
cols <- c(cols,which((!(is.na(str_match(names(a), paste(variable,"_forward(",paste(1:steps,collapse="|"),")",sep=""))[,1])))*1==1))
} else {
stop("The direction must be either backward, forward or window.")
}
}
}
data[,transf := apply(data[,cols, with=FALSE], 1, transform)]
if (clean) {
data[,cols:=NULL,with=FALSE]
}
return(data)
}
# Typical use:
# I have a data.table DT with variables Date (class IDate), value1, value2
# I want to get cumulative sum of next five days
# window_func(DT, "sum", "value1", direction = "forward", steps = 5)
Edit: Sample data can be created by:
a <- data.table(Date = 1:1000, value = rnorm(1000))
For each Date (which, here, are integers just for an example, does not matter much), I want to create the sum of next ten observations. To run the code and get output, do:
window_func(data = a, func.name = "sum", variable = "value",
direction = "forward", steps = 10, date_variable = "Date", clean = TRUE)
The function first takes the variable and creates ten lagged variables (using function lag_variable) and then applies function column-wise and cleans after itself. Code is bloated because I sometimes need to use functions only on lag observations, sometimes on forward observations and sometimes on both, which is called window.
Any suggestions how to implement this better? My code seems to be somehow too big.

Answer 1

I'm not sure about the rest of your function, but you can get your lagged sum rather efficiently as follows:
a[ , lagSum :=
a[, list(sum=sum(value)), by=list(grp=(Date+lag-i) %/% lag)] [grp!=0, sum]
, by=list(i=Date %% lag)]
eg:
set.seed(1)
a[ , lagSum :=
a[, list(sum=sum(value)), by=list(grp=(Date+lag-i) %/% lag)] [grp!=0, sum]
, by=list(i=Date %% lag)]
> a
Date value lagSum
1: 1 -0.6264538 1.32202781
2: 2 0.1836433 3.46026279
3: 3 -0.8356286 3.66646270
4: 4 1.5952808 3.88085074
5: 5 0.3295078 0.07087005
---
996: 996 -0.3132929 -3.79332038
997: 997 -0.8806707 -3.48002750
998: 998 -0.4192869 -2.59935677
999: 999 -1.4827517 -2.18006988
1000: 1000 -0.6973182 -1.88854602
Confirming correct values:
# first n values
n <- 5
for (i in seq(n))
a[seq(i, length.out=10), print(sum(value))]
# [1] 1.322028
# [1] 3.460263
# [1] 3.666463
# [1] 3.880851
# [1] 0.07087005
BENCHMARKS (against for loop, so not quite fair)
set.seed(1)
a <- data.table(Date = 1:1000, value = rnorm(1000))
system.time({ a[ , lagSum :=
a[, list(sum=sum(value)), by=list(grp=(Date+lag-i) %/% lag)] [grp!=0, sum]
, by=list(i=Date %% lag)]
})
# user system elapsed
# 0.049 0.001 0.056
set.seed(1)
a <- data.table(Date = 1:1000, value = rnorm(1000))
system.time({ for (i in seq(nrow(a)-lag+1))
a[seq(i, length.out=10), lagSum := sum(value)]})
# user system elapsed
# 1.526 0.019 2.220