d1r: d1r package

d1.backtest.addMyPredictions <- function(mydecisions, mystrategy,myaccount) {
  add.indicator(
    strategy = mystrategy,
    name = "getForecast",
    arguments = list(
      decisions = mydecisions,
      activetimestamp = quote (index(mktdata)),
      activeticker = quote(sub("\\..*", "", colnames(
        as.data.frame(mktdata)
      )[1])),
      label = "mydecisions"
    )
  )
  #)
  
  add.signal(
    strategy = mystrategy,
    name = "sigThreshold",
    arguments = list(
      column = "mydecisions.getForecast.ind",
      threshold = 0,
      relationship = "gte",
      cross = FALSE
    ),
    label = "long"
  )
  
  
  add.signal(
    strategy = mystrategy,
    name = "sigThreshold",
    arguments = list(
      column = "mydecisions.getForecast.ind",
      threshold = 0,
      relationship = "lt",
      cross = FALSE
    ),
    label = "short"
  )
  add.rule(
    strategy = mystrategy,
    name = 'myrule',
    arguments = list(
      sigcol = "long",
      sigval = TRUE,
      orderqty = mydecisions,
      ordertype = "market",
      orderside = NULL,
      #threshold = 0.0005,
      prefer = "High",
      myaccount = myaccount,
      TxnFees = 0,
      replace = FALSE
    ),
    type = "enter",
    label = "EnterLONG"
  )
  
  add.rule(
    strategy = mystrategy,
    name = 'myrule',
    arguments = list(
      sigcol = "short",
      sigval = TRUE,
      orderqty = mydecisions,
      ordertype = "market",
      orderside = NULL,
      #threshold = 0.0005,
      prefer = "High",
      myaccount = myaccount,
      TxnFees = -0,
      replace = FALSE
    ),
    type = "enter",
    label = "EnterSHORT"
  )
}

myrule <-
  
  function (mktdata = mktdata,
            timestamp,
            sigcol,
            sigval,
            orderqty = 0,
            myaccount,
            ordertype,
            orderside = NULL,
            orderset = NULL,
            threshold = NULL,
            tmult = FALSE,
            replace = TRUE,
            delay = 1e-04,
            osFUN = "osNoOp",
            pricemethod = c("market", "opside", "active"),
            portfolio,
            symbol,
            ...,
            ruletype,
            TxnFees = 0,
            prefer = NULL,
            sethold = FALSE,
            label = "",
            order.price = NULL,
            chain.price = NULL,
            time.in.force = "")
  {
    if (!is.function(osFUN))
      osFUN <- match.fun(osFUN)
    if (hasArg(curIndex))
      curIndex <- eval(match.call(expand.dots = TRUE)$curIndex,
                       parent.frame())
    else
      curIndex <- mktdata[timestamp, which.i = TRUE]
    ##Alessandro contribution to accept pre-gen decisions
    if (!class(orderqty) == "numeric") {
      weight = orderqty[as.Date(date) == as.Date(timestamp) &
                          ticker == symbol, weight]
      trading.pl = sum(getPortfolio(portfolio)$summary$Net.Trading.PL)
      total.equity = getEndEq(myaccount,timestamp) + trading.pl
      curQty = getPosQty(Portfolio = portfolio,
                            Symbol = symbol,
                            Date = timestamp)
      openQty =  as.numeric(getOrders(portfolio,symbol))
      openQty = ifelse(length(openQty)==0,0,openQty)
      curQty = curQty + openQty
      targetSize = total.equity * weight 

      ClosePrice <- as.numeric(Cl(mktdata[timestamp, ]))
      tradeQty = targetSize/ClosePrice - curQty #TODO: add fx 
      orderqty <-  round(tradeQty)
    }
    if (curIndex > 0 && curIndex <= nrow(mktdata) && (ruletype ==
                                                      "chain" || (!is.na(mktdata[curIndex, sigcol]) && mktdata[curIndex,
                                                                                                               sigcol] == sigval))) {
      pricemethod <- pricemethod[1]
      if (hasArg(prefer))
        prefer =
          match.call(expand.dots = TRUE)$prefer
      else
        prefer = NULL
      if (!is.null(threshold)) {
        if (!is.numeric(threshold)) {
          col.idx <- grep(threshold, colnames(mktdata))
          if (length(col.idx) < 1)
            stop(
              paste(
                "no indicator column in mktdata matches threshold name \"",
                threshold,
                "\"",
                sep = ""
              )
            )
          if (length(col.idx) > 1)
            stop(
              paste(
                "more than one indicator column in mktdata matches threshold name \"",
                threshold,
                "\"",
                sep = ""
              )
            )
          threshold <- as.numeric(mktdata[curIndex, col.idx])
        }
      }
      if (is.null(orderside) & !isTRUE(orderqty == 0)) {
        curqty <- getPosQty(Portfolio = portfolio,
                            Symbol = symbol,
                            Date = timestamp)
        if (curqty > 0) {
          orderside <- "long"
        }
        else if (curqty < 0) {
          orderside <- "short"
        }
        else {
          if (orderqty > 0)
            orderside <- "long"
          else
            orderside <- "short"
        }
      }
      if (orderqty == "all") {
        if (orderside == "long") {
          tmpqty <- 1
        }
        else {
          tmpqty <- -1
        }
      }
      else {
        tmpqty <- orderqty
      }
      if (!is.null(order.price)) {
        orderprice <- order.price
      }
      else if (!is.null(chain.price)) {
        orderprice <- chain.price
      }
      else {
        switch(
          pricemethod,
          market = ,
          opside = ,
          active = {
            if (is.BBO(mktdata)) {
              if (tmpqty > 0)
                prefer = "ask"
              else
                prefer = "bid"
            }
            orderprice <- try(getPrice(x = mktdata[curIndex,], prefer = prefer)[, 1])
          },
          passive = ,
          work = ,
          join = {
            if (is.BBO(mktdata)) {
              if (tmpqty > 0)
                prefer = "bid"
              else
                prefer = "ask"
            }
            orderprice <- try(getPrice(x = mktdata[curIndex,], prefer = prefer)[, 1])
          },
          maker = {
            if (hasArg(price) & length(match.call(expand.dots = TRUE)$price) >
                1) {
              orderprice <- try(match.call(expand.dots = TRUE)$price)
            } else {
              if (!is.null(threshold)) {
                baseprice <- last(getPrice(x = mktdata[curIndex,])[, 1])
                if (hasArg(tmult) & isTRUE(match.call(expand.dots = TRUE)$tmult)) {
                  baseprice <- last(getPrice(x = mktdata[curIndex,])[, 1])
                  if (length(threshold) > 1) {
                    orderprice <- baseprice * threshold
                  } else {
                    orderprice <- c(baseprice * threshold,
                                    baseprice * (1 + 1 - threshold))
                  }
                } else {
                  if (length(threshold) > 1) {
                    orderprice <- baseprice + threshold
                  } else {
                    orderprice <- c(baseprice + threshold,
                                    baseprice + (-threshold))
                  }
                }
              } else {
                stop(
                  "maker orders without specified prices and without threholds not (yet?) supported"
                )
                if (is.BBO(mktdata)) {
                  
                } else {
                  
                }
              }
            }
            if (length(orderqty) == 1)
              orderqty <- c(orderqty,-orderqty)
          }
        )
        if (inherits(orderprice, "try-error"))
          orderprice <- NULL
        if (length(orderprice) > 1 && pricemethod != "maker")
          orderprice <- last(orderprice[timestamp])
        if (!is.null(orderprice) && !is.null(ncol(orderprice)))
          orderprice <- orderprice[, 1]
      }
      if (is.null(orderset))
        orderset = NA
      if (orderqty != "all") {
        orderqty <- osFUN(
          strategy = strategy,
          data = mktdata,
          timestamp = timestamp,
          orderqty = orderqty,
          ordertype = ordertype,
          orderside = orderside,
          portfolio = portfolio,
          symbol = symbol,
          ... = ...,
          ruletype = ruletype,
          orderprice = as.numeric(orderprice)
        )
      }
      if (!is.null(orderqty) && orderqty != 0 && length(orderprice)) {
        addOrder(
          portfolio = portfolio,
          symbol = symbol,
          timestamp = timestamp,
          qty = orderqty,
          price = as.numeric(orderprice),
          ordertype = ordertype,
          side = orderside,
          orderset = orderset,
          threshold = threshold,
          status = "open",
          replace = replace,
          delay = delay,
          tmult = tmult,
          ... = ...,
          prefer = prefer,
          TxnFees = TxnFees,
          label = label,
          time.in.force = time.in.force
        )
      }
    }
    if (sethold)
      hold <<- TRUE
  }




getForecast <- function(decisions, activetimestamp, activeticker,reactOn = 'forecast')
{
  fcst = decisions[as.Date(date) %in% as.Date(activetimestamp) &
                     ticker == unique(activeticker)]
  setkey(fcst, date)
  #fill NaN dates
  allDates = data.table(allDates = as.Date(activetimestamp))
  fcstFilled = merge(allDates,
                     fcst[,dateAsDate:=as.Date(date)],
                     by.x = 'allDates',
                     by.y = 'dateAsDate',
                     all.x = T)
  fcstFilled[is.na(predict), predict := 0]
  setkey(fcstFilled, allDates)
  #Manipulations - required by quantstrat:
  if (reactOn == 'forecast'){
    output = xts(fcstFilled$predict, fcstFilled$allDates)
  } else if (reactOn == 'decision'){
    output = xts(fcstFilled$decision, fcstFilled$allDates)
  }

  colnames(output) = 'mydecisions'
  return(output)
}


d1.backtest.backtestBy <- function(DT,method,nameBasket="mybasket"){
  # Description 
  # ------------------------------------------
  # Backtest a strategy according to the allocation strategy specified in 'method'
  
  # Inputs
  # -----------------------------------------
  # @param DT: data.table, must contain a "predict" column 
  # @param method: choose among: 'quintile'
  
  DT[,predict_q:=d1.stat.quantile(predict),by=date]
  DT[,weight:=0]
  switch(method,
         quintile = 
           DT[predict_q==5,
              weight:=1/length(weight),by=date][predict_q==1,
                                                weight:=-1/length(weight),by=date] 
  )
  d1.backtest.run(DT)
  
  
  
}

d1.backtest.run <- function(DT){


  # DESCRIPTION -------------------------------
  # Use quantstrat to backtest. This runs once a day, for every day
  # contained in the input table DT

  # INPUTS ------------------------------------
  # DT with a column of 'weight', date
 
  init_eq=1e6
  d1.debug.info("Init basket...")
  DT[,dateAsDate:=as.Date(date)]
  start_date = DT[,min(dateAsDate)]
  mybasket = "mybasket"
  mystrategy = "mystrategy"
  myaccount = "myaccount"
  rm.strat(mybasket)
  rm.strat(myaccount)
  initPortf(name = mybasket,
            symbols = securities,
            initDate = start_date)
  initAcct(
    name = myaccount,
    portfolios = mybasket,
    initDate = start_date,
    initEq = init_eq
  )
  initOrders(portfolio = mybasket,
             symbols = securities,
             initDate = start_date)
  strategy(mystrategy, store = TRUE)
  d1.backtest.addMyPredictions(DT, mystrategy,myaccount)

  # run day by day( (otherwise equity is not properly updated)
  for (d in DT[,unique(dateAsDate)][-1]){
    
    d = as.Date(d)
    d1.debug.info("Backtesting day",d)
    end_date = d
    
    # Uses cached data (=cached during d1.md.buildUniverse)
    getSymbols(Symbols = securities, src = "cached", index.class = "POSIXct",
               from = d, to = d, adjust = T, env=.GlobalEnv,warnings=F)

    results = applyStrategy(mystrategy, portfolios = mybasket)
    updatePortf(mybasket)
    updateAcct(myaccount)
    updateEndEq(myaccount)
    acc = getAccount(myaccount)
    d1.debug.info("Equity Value on date",d,":",last(acc$summary$End.Eq))
    d1.debug.info("Return thus far:",last(acc$summary$End.Eq)/init_eq*100-100,"%")

  }

    rets <- PortfReturns(Account=myaccount)
    acc = getAccount(myaccount)
    xyplot(acc$summary, type = "h", col = 4) 
    charts.PerformanceSummary(rets, colorset = bluefocus)
    summaryP <- getPortfolio("mybasket")
}





d1.backtest.cacheSymbols <- function(securities,pattern=".cached"){
# Description ---------------------------------
# Cache Symbols loaded from quantstrat::getSymbols

# Inputs --------------------------------------
# @param securities | list(character) |
    
    for (p in securities){
        assign(paste(p,pattern,sep=""),get(p),.GlobalEnv)
    }
}








 getSymbols.cached <- 
function (Symbols, env, return.class = "xts", index.class = "Date",
    from = "2007-01-01", to = Sys.Date(), ...)
{
    importDefaults("getSymbols.yahoo")
    this.env <- environment()
    for (var in names(list(...))) {
        assign(var, list(...)[[var]], this.env)
    }
    if (!hasArg(adjust))
        adjust <- FALSE
    default.return.class <- return.class
    default.from <- from
    default.to <- to
    if (!hasArg(verbose))
        verbose <- FALSE
    if (!hasArg(auto.assign))
        auto.assign <- TRUE
    tmp <- tempfile()

    on.exit(unlink(tmp))
    for (i in 1:length(Symbols)) {
      active = Symbols[[i]]
      active.ch = paste(active,".cached",sep="")
      dt = get(active.ch)[paste(from,'/',to,sep="")]
        if (auto.assign)
            assign(Symbols[[i]], dt  , env)
    }
    if (auto.assign)
        return(Symbols)
    return(dt)
}