0
\$\begingroup\$

I have about 977 obs in top500Stocks which contains name of 977 stocks.

head(top500Stocks,10)
    ï..Symbol
1    RELIANCE
2         TCS
3    HDFCBANK
4        INFY
5  HINDUNILVR
6        HDFC
7   ICICIBANK
8   KOTAKBANK
9        SBIN
10 BAJFINANCE

and I have Date, OHLC and Adj.Close, Vol and Ret of each stocks from the top500Stocks in stocksRetData

  head(stocksRetData[[1]],3)
          Date     Open     High      Low    Close Adj.Close    Volume   Ret
    1 20000103 28.18423 29.86935 28.18423 38.94457  29.86935  28802010 0.000
    2 20000104 30.66445 32.26056 29.82188 42.06230  32.26056  61320457 0.080
    3 20000105 30.45677 34.16522 30.45677 43.71014  33.52440 173426953 0.039

Now for a given lookbackPeriod and holdPeriod I am trying to run the below function but it takes about 1 minute. How can I make it faster? Because I have to run for multiple lookbackPeriod and holdPeriod it will take forever to complete.

CalC.MOD_MScore.Ret.High <- function(lookbackPeriod, holdPeriod, fnoStocks, 
                                     stocksRetData, totalTestPeriod) {
  
  #We go through each stock and calculate Modified mscores where we give more importance to recent data
  
  WeeklyData <- list()
  wmean <- function(x, k) mean(seq(k)/k * x)
  
  for (i in 1:nrow(fnoStocks)){
    
    out <- stocksRetData[[i]]
    out <- tail(out,totalTestPeriod)
    
    if (nrow(out)==totalTestPeriod){
      
      tempDF <- transform(out, wtMean = rollapply(Ret, lookbackPeriod, wmean, 
                                                  k = lookbackPeriod, align = "right", 
                                                  fill = NA))
      
      tempDF <- transform(tempDF, ExitVal = rollapply(lead(High, holdPeriod), 
                                                      holdPeriod, max, 
                                                      align = "right", 
                                                        fill = NA))
      
      tempDF$NWeekRet <- (tempDF$ExitVal - tempDF$Adj.Close ) / tempDF$Adj.Close
      
      tempDF <- tempDF[!is.na(tempDF$wtMean),]
      tempDF <- tempDF[!is.na(tempDF$ExitVal),]
      tempDF$StockName = fnoStocks[i,1]
      tempDF$WeekNum = c((lookbackPeriod):(nrow(tempDF)+lookbackPeriod-1))
      
      WeeklyData[[i]] <- data.frame(
        StockName = tempDF$StockName,
        WeekNum = tempDF$WeekNum,
        M_Score = tempDF$wtMean,
        NWeekRet = tempDF$NWeekRet,
        stringsAsFactors =  FALSE
      )
      
    }
  }# i ends here
  
  return(bind_rows(WeeklyData))
}

This takes more than a minute to complete.

 a <- CalC.MOD_MScore.Ret.High(4,14,fnoStocks = top500Stocks, stocksRetData = stocksRetData, 2000)
\$\endgroup\$
5
  • \$\begingroup\$ can you supply the data so the code can be tested? \$\endgroup\$
    – minem
    Jun 1 at 8:18
  • \$\begingroup\$ @minem sure but where do I upload it? \$\endgroup\$ Jun 1 at 8:20
  • \$\begingroup\$ @minem top500Stocks contains 977 unique strings in column 1. And stocksRetData contains list of 977 dataframes with data in above format. Other than that no other data is used. \$\endgroup\$ Jun 1 at 8:31
  • \$\begingroup\$ The current question title, which states your concerns about the code, applies to too many questions on this site to be useful. The site standard is for the title to simply state the task accomplished by the code. Please see How do I ask a good question?. \$\endgroup\$
    – BCdotWEB
    Jun 1 at 12:35
  • \$\begingroup\$ @Stupid_Intern updated my answer \$\endgroup\$
    – minem
    Jun 2 at 10:00
1
\$\begingroup\$

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 
\$\endgroup\$
1
  • \$\begingroup\$ Thank you for your help. It works wonderfully. :) \$\endgroup\$ Jun 2 at 13:31

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.