speeding up "for-loop" for deleting rows matching criteria

Question

I am backtesting some investment strategy using R, I have a piece of script below:

set.seed(1)
output.df <- data.frame(action=sample(c("initial_buy","sell","buy"),
          10000,replace=TRUE),stringsAsFactors=FALSE)
output.df[,"uid"] <- 1:nrow(output.df)

cutrow.fx <- function(output.df) {
  loop.del <- 2
  while (loop.del <= nrow(output.df)) {
    if ((output.df[loop.del,"action"]=="initial_buy" & 
            output.df[loop.del-1,"action"]=="initial_buy")|
          (output.df[loop.del,"action"]=="sell" & 
            output.df[loop.del-1,"action"]=="sell")|
          (output.df[loop.del,"action"]=="buy" & 
            output.df[loop.del-1,"action"]=="sell")|
          (output.df[loop.del,"action"]=="initial_buy" & 
            output.df[loop.del-1,"action"]=="buy")){
      output.df <- output.df[-loop.del,]
    } else {
      loop.del <- loop.del + 1
    }
  }
output.df<<-output.df
}

print(system.time(cutrow.fx(output.df=output.df)))

The strategy will determine: 1) when to start buying a stock; 2) when to add additional contribution to the stock; and 3) when to sell all the stock. I have a dataframe with price of a stock for the past 10 years. I wrote 3 scripts to indicate which date should I buy/sell the stock, combine the 3 results and order them.

I need to remove some of the "impossible action", e.g. I cannot sell the same stock twice without buying new units beforehand, so I used the script above to delete those impossible action. But the for loop is kind of slow.

Any suggestion for speeding it up?

Update 01

I have updated the cutrow.fx into the following but fail:

cutrow.fx <- function(output.df) {
  output.df[,"action_pre"] <- "NIL"
  output.df[2:nrow(output.df),"action_pre"] <- output.df[1:(nrow(output.df)-1),"action"]                    
  while (any(output.df[,"action_pre"]=="initial_buy" & output.df[,"action"]=="initial_buy")|
           any(output.df[,"action_pre"]=="sell" & output.df[,"action"]=="sell")|
           any(output.df[,"action_pre"]=="sell" & output.df[,"action"]=="buy")|
           any(output.df[,"action_pre"]=="buy" & output.df[,"action"]=="initial_buy")) {
    output.df <- output.df[!(output.df[,"action_pre"]=="initial_buy" & output.df[,"action"]=="initial_buy"),]
    output.df <- output.df[!(output.df[,"action_pre"]=="sell" & output.df[,"action"]=="sell"),]
    output.df <- output.df[!(output.df[,"action_pre"]=="sell" & output.df[,"action"]=="buy"),]
    output.df <- output.df[!(output.df[,"action_pre"]=="buy" & output.df[,"action"]=="initial_buy"),]
    output.df[,"action_pre"] <- "NIL"
    output.df[2:nrow(output.df),"action_pre"] <- output.df[1:(nrow(output.df)-1),"action"]                    
  }        
  output.df[,"action_pre"] <- NULL
  output.df<<-output.df
}

I used the vector comparison as somehow inspired (I used somehow as I'm not sure if I get exact what he means in the answer) by John, use a while-loop to repeat. But the output is not the same.

Is the for-loop here inevitable?

Answer 1

I tried to do something clever with vectorization, but failed because previous iterations of the loop can change the data relationships for later iterations through. So I couldn't lag the data by a set amount and compare lagged to real results.

What I can do is minimize the copying operation involved. R is assign-by-copy, so when you write a statement like output.df <- output.df[-loop.del,], you are copying the entire data structure for each row that is deleted. Instead of changing (and copying) the data frame, I made changes to a logical vector. Some other attempts at speed-up include using logical and (&&) instead of bitwise and (&), using %in% to make fewer comparisons, and minimizing accesses on output.df.

To compare the two functions I slightly modified OP solution such that the original data frame was not overwritten. It looks like this can improve speeds by a factor of 10, but it still takes a noticeable about of time (>0.5 sec). I'd love to see any faster solutions.

OP's solution (slightly modified in return value and without global assign)

cutrow.fx <- function(output.df) {
  loop.del <- 2
  while (loop.del <= nrow(output.df)) {
    if ((output.df[loop.del,"action"]=="initial_buy" & 
            output.df[loop.del-1,"action"]=="initial_buy")|
          (output.df[loop.del,"action"]=="sell" & 
            output.df[loop.del-1,"action"]=="sell")|
          (output.df[loop.del,"action"]=="buy" & 
            output.df[loop.del-1,"action"]=="sell")|
          (output.df[loop.del,"action"]=="initial_buy" & 
            output.df[loop.del-1,"action"]=="buy")){
      output.df <- output.df[-loop.del,]
    } else {
      loop.del <- loop.del + 1
    }
  }
return(output.df)
}
ans1 <- cutrow.fx(output.df)

my solution

cutrow.fx2 <- function(output.df) {
    ##edge case if output.df has too few rows
    if (nrow(output.df) < 2) return(output.df)
    ##logical vector of indices of rows to keep
    idx <- c(TRUE,logical(nrow(output.df)-1))
    ##keeps track of the previous row
    prev.row <- 1
    prev.act <- output.df[prev.row,"action"]
    for (current.row in seq_len(nrow(output.df))[-1]) {
        ##access output.df only once per iteration
        current.act <- output.df[current.row,"action"]
        ##checks to see if current row is bad
        ##if so, continue to next row and leave previous row as is
        if ( (prev.act %in% c("initial_buy","buy")) && 
             (current.act == "initial_buy") ) {
            next
        } else if ( (prev.act == "sell") &&
            (current.act %in% c("buy","sell")) ) {
            next
        }
        ##if current row is good, mark it in idx and update previous row
        idx[current.row] <- TRUE
        prev.row <- current.row
        prev.act <- current.act
    }
    return(output.df[idx,])
}
ans2 <- cutrow.fx2(output.df)

checks that answers are the same

identical(ans1,ans2)
## [1] TRUE

#benchmarking
require(microbenchmark)
mb <- microbenchmark(
  ans1=cutrow.fx(output.df)
  ,ans2=cutrow.fx2(output.df),times=50)
print(mb)
# Unit: milliseconds
  # expr       min        lq    median         uq        max
# 1 ans1 9630.1671 9743.1102 9967.6442 10264.7000 12396.5822
# 2 ans2  481.8821  491.6699  500.6126   544.4222   645.9658

plot(mb)
require(ggplot2)
ggplot2::qplot(y=time, data=mb, colour=expr) + ggplot2::scale_y_log10()

Answer 2

Here is some code that is a bit simpler and much faster. It does not loop over all elements, but only loops between matches. It matches forward rather than backward.

First, modify your cutrow.fx function. Remove the <<-output.df on the last line, and simply return the result. Then you can run two functions and compare the results.

cutrow.fx1 <- function(d) {
  len <- length(d[,1])
  o <- logical(len)
  f <- function(a) {
    switch(a,
           initial_buy=c('buy', 'sell'), 
           buy=c('buy', 'sell'),
           sell='initial_buy'
           )
  }
  cur <- 1
  o[cur] <- TRUE
  while (cur < len) {
    nxt <- match(f(d[cur,1]), d[(cur+1):len,1])
    if (all(is.na(nxt))) {
      break
    } else {
      cur <- cur + min(nxt, na.rm=TRUE);
      o[cur] <- TRUE
    }
  }
  d[o,]
}

Show that the results are correct:

identical(cutrow.fx1(output.df), cutrow.fx(output.df))
## [1] TRUE

And it is quite a bit faster. This is due to the partial vectorization of the problem, using match to find the next row to keep, rather than iterating to discard rows.

print(system.time(cutrow.fx(output.df)))
##   user  system elapsed 
##  5.688   0.000   5.720 

print(system.time(cutrow.fx1(output.df)))
##   user  system elapsed 
##  1.050   0.000   1.056 

Answer 3

It looks like all you're doing is checking the last action. This doesn't require a loop at all. All you have to do is shift the vector and do straight vector comparisons. Here's an artificial example.

x <- sample(1:11)
buysell <- sample(c('buy', 'sell'), 11, replace = TRUE)

So, I have 11 samples, x, and whether I've bought or sold them. I want to make a boolean that shows whether I bought or sold the last sample.

bought <- c(NA, buysell[1:10])
which( bought == 'buy' )

Examine the x and buysell variables and you'll see the results here are the index of the x items where a buy was made on the prior item.

Also, you might want to check out he function %in%.