###
# In my code, the IBapplyRules function will be called like this. Note that
# the Dates argument is not NULL but contains a single timestamp.
#
# IBapplyRules(portfolio = 'PF1', 
#      symbol = 'ES', strategy = currentStrategy, mktdata = mktdata, 
#      Dates = as.character(currentTimestamp), indicators = sret$indicators, 
#      signals = sret$signals, parameters = currentParameters, path.dep = TRUE)
#


IBapplyRules<-function (portfolio, symbol, strategy, mktdata, Dates = NULL, 
    indicators = NULL, signals = NULL, parameters = NULL, ..., 
    path.dep = TRUE) 
{
    .Data <- new.env()
    get.dindex <- function() get("dindex", pos = .Data)
    assign.dindex <- function(dindex) {
        dindex <- sort(unique(dindex))
        assign("dindex", dindex, .Data)
    }
    if (!is.strategy(strategy)) {
        strategy <- try(getStrategy(strategy))
        if (inherits(strategy, "try-error")) 
            stop("You must supply an object of type 'strategy'.")
    }
    ret <- NULL
    nargs <- list(...)
    if (length(nargs) == 0) 
        nargs = NULL
    if (length("...") == 0 | is.null("...")) {
        rm("...")
        nargs = NULL
    }
### #Dates = unique(index(mktdata))
### #Soren: introduced modification to handle Dates subsetting properly ???
    Dates = unique(index(mktdata[Dates]))
    ruleProc <- function(ruletypelist, timestamp = NULL, path.dep, 
        ruletype, ...) {
        for (rule in ruletypelist) {
            if (!rule$path.dep == path.dep) 
                next()
            if (!is.function(rule$name)) {
                if (!is.function(get(rule$name))) {
                  if (!is.function(get(paste("sig", rule$name, 
                    sep = ".")))) {
                    message(paste("Skipping rule", rule$name, 
                      "because there is no function by that name to call"))
                    next()
                  }
                  else {
                    rule$name <- paste("sig", rule$name, sep = ".")
                  }
                }
            }
            if (!isTRUE(rule$enabled)) 
                next()
            if (!is.null(rule$timespan) & nrow(mktdata[rule$timespan] == 
                0)) 
                next()
            if (is.function(rule$name)) 
                fun <- rule$name
            else fun <- match.fun(rule$name)
            nargs <- list(...)
            if (length(nargs) == 0) 
                nargs = NULL
            if (length("...") == 0 | is.null("...")) {
                rm("...")
                nargs = NULL
            }
            .formals <- formals(fun)
            if (hasArg(prefer)) 
                .formals$prefer = match.call(expand.dots = TRUE)$prefer
            onames <- names(.formals)
            rule$arguments$timestamp = timestamp
            rule$arguments$ruletype = ruletype
            pm <- pmatch(names(rule$arguments), onames, nomatch = 0L)
            names(rule$arguments[pm > 0L]) <- onames[pm]
            .formals[pm] <- rule$arguments[pm > 0L]
            if (length(parameters)) {
                pm <- pmatch(names(parameters), onames, nomatch = 0L)
                names(parameters[pm > 0L]) <- onames[pm]
                .formals[pm] <- parameters[pm > 0L]
            }
            if (length(nargs)) {
                pm <- pmatch(names(nargs), onames, nomatch = 0L)
                names(nargs[pm > 0L]) <- onames[pm]
                .formals[pm] <- nargs[pm > 0L]
            }
            .formals$... <- NULL
            tmp_val <- do.call(fun, .formals)
            mktdata <<- mktdata
            ret <<- ret
            hold <<- hold
        }
    }
    if (isTRUE(path.dep)) {
        dindex <- c(1, length(Dates))
        assign.dindex(dindex)
        for (type in names(strategy$rules)) {
            if (length(strategy$rules[[type]]) >= 1) {
                for (rule in strategy$rules[[type]]) {
                  if (isTRUE(rule$path.dep)) {
                    if (is.null(rule$arguments$sigcol) | is.null(rule$arguments$sigval)) {
                      assign.dindex(1:length(Dates))
                    }
                    else {
                      assign.dindex(sort(unique(c(get.dindex(), 
                        which(mktdata[, rule$arguments$sigcol] == 
                          rule$arguments$sigval)))))                      
                    }
                  }
                }
            }
        }
        dindex <- get.dindex()
        if (length(dindex) == 0) 
            dindex = 1
    }
    else {
        Dates = ""
        dindex = 1
    }
    nextIndex <- function(curIndex, ...) {
        if (!isTRUE(path.dep)) {
            curIndex = FALSE
            return(curIndex)
        }
        dindex <- get.dindex()
        nidx = FALSE
        neworders = NULL
        orderbook <- getOrderBook(portfolio)
        ordersubset <- orderbook[[portfolio]][[symbol]]
        oo.idx <- getOrders(portfolio = portfolio, symbol = symbol, 
            status = "open", which.i = TRUE)
        if (length(oo.idx) == 0) {
            nidx = FALSE
        }
        else {
            isOHLCmktdata <- is.OHLC(mktdata)
            isBBOmktdata <- is.BBO(mktdata)
            timespan <- paste(timestamp, "::", sep = "")
            if (nrow(ordersubset[oo.idx, ][timespan]) == 0) {
                nidx = FALSE
            }
            else {
                if (!length(grep("market", ordersubset[oo.idx, 
                  "Order.Type"])) == 0 || hasArg("prefer")) {
                  curIndex <- curIndex + 1
                  if (is.na(curIndex) || curIndex > length(index(mktdata))) 
                    curIndex = FALSE
                  return(curIndex)
                }
                if (!length(grep("limit", ordersubset[oo.idx, 
                  "Order.Type"])) == 0) {
                  limitorders <- grep("limit", ordersubset[oo.idx, 
                    "Order.Type"])
                  for (lorder in limitorders) {
                    dindex <- get.dindex()
                    tmpqty <- as.numeric(ordersubset[oo.idx[lorder], 
                      "Order.Qty"])
                    tmpprice <- as.numeric(ordersubset[oo.idx[lorder], 
                      "Order.Price"])
                    if (tmpqty > 0) {
                      relationship = "gte"
                      if (isBBOmktdata) {
                        col <- first(colnames(mktdata)[has.Ask(mktdata, 
                          which = TRUE)])
                      }
                      else if (isOHLCmktdata) {
                        col <- first(colnames(mktdata)[has.Lo(mktdata, 
                          which = TRUE)])
                      }
                      else {
                        stop("no price discernable in applyRules")
                      }
                    }
                    else {
                      relationship = "lte"
                      if (isBBOmktdata) {
                        col <- first(colnames(mktdata)[has.Bid(mktdata, 
                          which = TRUE)])
                      }
                      else if (isOHLCmktdata) {
                        col <- first(colnames(mktdata)[has.Hi(mktdata, 
                          which = TRUE)])
                      }
                      else {
                        stop("no price discernable in applyRules")
                      }
                    }
                    cross <- sigThreshold(label = "tmplimit", 
                      column = col, threshold = tmpprice, relationship = relationship)
                    if (any(cross[timespan])) {
                      newidx <- curIndex + which(cross[timespan])[1] - 
                        1
                      assign.dindex(c(get.dindex(), newidx))
                    }
                    else {
                      nidx = TRUE
                    }
                  }
                }
                if (!length(grep("trailing", ordersubset[oo.idx, 
                  "Order.Type"])) == 0) {
                  trailorders <- grep("trailing", ordersubset[oo.idx, 
                    "Order.Type"])
                  for (torder in trailorders) {
                    dindex <- get.dindex()
                    firsttime <- NULL
                    neworders <- NULL
                    onum <- oo.idx[torder]
                    orderThreshold <- as.numeric(ordersubset[onum, 
                      "Order.Threshold"])
                    tmpqty <- as.numeric(ordersubset[onum, "Order.Qty"])
                    tmpprice <- as.numeric(ordersubset[onum, 
                      "Order.Price"])
                    tmpidx <- as.character(index(ordersubset[onum, 
                      ]))
                    if (isBBOmktdata) {
                      if (tmpqty > 0) {
                        prefer = "offer"
                      }
                      else {
                        prefer = "bid"
                      }
                    }
                    else if (isOHLCmktdata) {
                      prefer = "close"
                    }
                    dindex <- get.dindex()
                    if (is.null(firsttime)) 
                      firsttime <- timestamp
                    nextidx <- min(dindex[dindex > curIndex])
                    if (length(nextidx)) {
                      nextstamp <- (as.character(index(mktdata[nextidx, 
                        ])))
                      timespan <- paste(firsttime, "::", nextstamp, 
                        sep = "")
                      mkt_price_series <- getPrice(mktdata[timespan], 
                        prefer = prefer)
                      col <- first(colnames(mkt_price_series))
                      orderloop <- TRUE
                    }
                    else {
                      orderloop <- FALSE
                    }
                    if (tmpqty > 0) {
                      move_order <- ifelse((mkt_price_series + 
                        orderThreshold) < tmpprice, TRUE, FALSE)
                      relationship = "gte"
                    }
                    else {
                      move_order <- ifelse((mkt_price_series + 
                        orderThreshold) > tmpprice, TRUE, FALSE)
                      relationship = "lte"
                    }
                    tmpidx <- NULL
                    if (any(move_order)) {
                      dindex <- get.dindex()
                      orderidx <- first(which(move_order))
                      if (is.null(tmpidx)) 
                        tmpidx <- as.character(index(move_order[orderidx, 
                          ]))
                      trailspan <- paste(firsttime, "::", tmpidx, 
                        sep = "")
                      cross <- sigThreshold(data = mkt_price_series, 
                        label = "tmptrail", column = col, threshold = tmpprice, 
                        relationship = relationship)
                      if (any(cross[trailspan])) {
                        newidx <- curIndex + which(cross[trailspan])[1] - 
                          1
                        newidx <- index(mktdata[index(which(cross[trailspan])[1]), 
                          which.i = TRUE])
                        assign.dindex(c(get.dindex(), newidx))
                      }
                      else {
                        moveidx <- index(mktdata[index(move_order[orderidx, 
                          ]), which.i = TRUE])
                        assign.dindex(c(get.dindex(), moveidx))
                      }
                    }
                  }
                }
            }
        }
        if (nidx) {
            curIndex <- curIndex + 1
            dindex <- get.dindex()
        }
        else {
            dindex <- get.dindex()
            curIndex <- min(dindex[dindex > curIndex])
        }
        if (is.na(curIndex) || curIndex > length(index(mktdata))) 
            curIndex = FALSE
        return(curIndex)
    }
    hold = FALSE
    holdtill = first(time(Dates)) - 1
    mktinstr <- getInstrument(symbol)
    curIndex <- 1
    while (curIndex) {
        timestamp = Dates[curIndex]
        if (isTRUE(hold) & holdtill < timestamp) {
            hold = FALSE
            holdtill = NULL
        }
        types <- sort(factor(names(strategy$rules), levels = c("pre", 
            "risk", "order", "rebalance", "exit", "enter", "entry", 
            "post")))
        for (type in types) {
            switch(type, pre = {
                if (length(strategy$rules[[type]]) >= 1) {
                  ruleProc(strategy$rules$pre, timestamp = timestamp, 
                    path.dep = path.dep, mktdata = mktdata, portfolio = portfolio, 
                    symbol = symbol, ruletype = type, mktinstr = mktinstr, 
                    ...)
                }
            }, risk = {
                if (length(strategy$rules$risk) >= 1) {
                  ruleProc(strategy$rules$risk, timestamp = timestamp, 
                    path.dep = path.dep, mktdata = mktdata, portfolio = portfolio, 
                    symbol = symbol, ruletype = type, mktinstr = mktinstr, 
                    ...)
                }
            }, order = {
                if (isTRUE(hold)) next()
                if (length(strategy$rules[[type]]) >= 1) {
                  ruleProc(strategy$rules[[type]], timestamp = timestamp, 
                    path.dep = path.dep, mktdata = mktdata, portfolio = portfolio, 
                    symbol = symbol, ruletype = type, mktinstr = mktinstr, 
                    ...)
                } else {
                  if (isTRUE(path.dep)) {
                    timespan <- paste("::", timestamp, sep = "")
                  } else timespan = NULL
                  ruleOrderProc(portfolio = portfolio, symbol = symbol, 
                    mktdata = mktdata, timespan = timespan, ...)
                }
            }, rebalance = , exit = , enter = , entry = {
                if (isTRUE(hold)) next()
                if (type == "exit") {
                  if (getPosQty(Portfolio = portfolio, Symbol = symbol, 
                    Date = timestamp) == 0) next()
                }
                if (length(strategy$rules[[type]]) >= 1) {
                  ruleProc(strategy$rules[[type]], timestamp = timestamp, 
                    path.dep = path.dep, mktdata = mktdata, portfolio = portfolio, 
                    symbol = symbol, ruletype = type, mktinstr = mktinstr, 
                    ...)
                }
            }, post = {
                if (length(strategy$rules$post) >= 1) {
                  ruleProc(strategy$rules$post, timestamp = timestamp, 
                    path.dep = path.dep, mktdata = mktdata, portfolio = portfolio, 
                    symbol = symbol, ruletype = type, mktinstr = mktinstr, 
                    ...)
                }
            })
        }
        if (isTRUE(path.dep)) 
            curIndex <- nextIndex(curIndex, ...)
        else curIndex = FALSE
###     # Soren Override: force "curIndex = FALSE" , so we only go through the while loop once
###     # The whole dindex thing only seems to be needed if we have to process MORE THAN ONE mktdata timestamp. But this is not the case in a "daily" set-up
###     # or even a >15minute setup
        curIndex = FALSE
###     # Soren Override - end
    }
    mktdata <<- mktdata
    if (is.null(ret)) {
        return(mktdata)
    }
    else return(ret)
}