R code optimization

Fake data:

set.seed(1)
n1 <- 977
top500Stocks <- data.frame(a = sample(letters, n1, replace = T))
n <- 2000
df <- data.frame(High = rnorm(n),
                 Adj.Close = rnorm(n),
                 Ret = rnorm(n))
stocksRetData <- lapply(1:n1, function(x) df)

new function:

require(data.table)
minem <- function(lookbackPeriod, holdPeriod, fnoStocks, stocksRetData, totalTestPeriod) {
  
  WeeklyData <- list()
  k <- lookbackPeriod
  y <- seq(k)/k/k
  wmean2 <- function(x) sum(y * x)
  
  for (i in 1:nrow(fnoStocks)) {
    
    out <- tail(stocksRetData[[i]], totalTestPeriod)
    
    if (nrow(out) == totalTestPeriod) {
      
      wtMean <- frollapply(out$Ret, k, wmean2, align = "right", fill = NA)
      ExitVal <- frollapply(lead(out$High, holdPeriod), 
                            holdPeriod, max, align = "right", fill = NA)
      tempDF <- out
      tempDF$wtMean <- wtMean
      tempDF$ExitVal <- ExitVal
      tempDF$NWeekRet <- (ExitVal / tempDF$Adj.Close - 1)
      
      tempDF <- tempDF[!is.na(wtMean),]
      tempDF <- tempDF[!is.na(tempDF$ExitVal),]
      tempDF$StockName = fnoStocks[i, 1]
      tempDF$WeekNum = c(k:(nrow(tempDF) + k - 1))
      
      WeeklyData[[i]] <- tempDF[, c('StockName', 'WeekNum', 'wtMean', 'NWeekRet')]
      colnames(WeeklyData[[i]])[3] <- 'M_Score'
    }
  }# i ends here
  return(bind_rows(WeeklyData))
}

speed:

system.time(a2 <- minem(4, 14, top500Stocks, stocksRetData, 2000))
# user  system elapsed 
# 2.36    0.00    2.36

(versus 31.75 seconds for original on my machine)

some comments:

1. from code profiling we see that wmean was the slowest part(called thousands of times). As we know k(lookbackPeriod) beforehand we can simplify/speedup this function.

2. rollapply was quite slow. replacing it with data.tables frollapply we gain performance

3. creating new data.frame in loop isn't efficient, we can reuse tempDF (but this isn't as significant as first two points)

4. other minor changes

update

we can go faster:

minem2 <- function(lookbackPeriod, holdPeriod, fnoStocks, 
                  stocksRetData, totalTestPeriod) {
  
  k <- lookbackPeriod
  y <- seq(k)/k/k
  
  # create stock name data.table
  sn <- data.table(sname = fnoStocks[[1]], id = 1:nrow(fnoStocks), key = 'id')
  dt <- rbindlist(stocksRetData[1:nrow(fnoStocks)], idcol = 'id') # bind together data
  setkey(dt, id)
  dt <- dt[, tail(.SD, totalTestPeriod), by = id] # select last n rows by group
  dt[sn, StockName := sname] # merge stock names
  
  # calculate wtMean using tcrossprod:
  v <- shift(dt$Ret, (k:1) - 1L) # create list of lagged values
  v <- do.call(cbind, v) # bind together
  dt[, wtMean := tcrossprod(y, v)[1, ]]
  dt[1:(k - 1), wtMean := NA, by = id] # delete first (k-1) as they aren't correct
  # maybe not needed
  
  # the same approach for ExitVal as it was sufficiently fast
  dt[, ExitVal := frollapply(lead(High, holdPeriod), holdPeriod, max,
                             align = "right", fill = NA), by = id]
  
  dt[, NWeekRet := (ExitVal / Adj.Close - 1)]
  dt <- dt[!is.na(wtMean) & !is.na(ExitVal)]
  dt[, WeekNum := c(k:(.N + k - 1)), by = id]
  res <- dt[, .(StockName, WeekNum, M_Score = wtMean, NWeekRet)]
  return(res[])
}

system.time(a3 <- minem2(4, 14, top500Stocks, stocksRetData, 2000))
# user  system elapsed 
# 0.91    0.01    0.78