Investment evaluation as measure of forecast success

We want to see whether certain forecasts perform better than random ones in making an investment decision on stocks.

First we define 2 functions which invest when we predict a rise and calculate the winnings.

library(forecast)
## Loading required package: RcppArmadillo
## Loading required package: Rcpp
## Loading required package: zoo
## 
## Attaching package: 'zoo'
## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric
## Loading required package: timeDate
## Loading required package: tseries
## Loading required package: quadprog
## Loading required package: fracdiff
## Loading required package: nnet
## Loading required package: colorspace
## Loading required package: parallel
## Loading required package: ggplot2
## Loading required package: digest
## Loading required package: grid
## Loading required package: gtable
## Loading required package: MASS
## Loading required package: plyr
## Loading required package: reshape2
## Loading required package: stringr
## Loading required package: stringi
## Loading required package: magrittr
## Loading required package: lattice
## Loading required package: scales
## Loading required package: RColorBrewer
## Loading required package: dichromat
## Loading required package: munsell
## 
## Attaching package: 'munsell'
## The following object is masked from 'package:colorspace':
## 
##     desaturate
## Loading required package: labeling
## Loading required package: tibble
## Loading required package: assertthat
## Loading required package: lazyeval
## 
## Attaching package: 'tibble'
## The following object is masked from 'package:assertthat':
## 
##     has_name
## This is forecast 7.2
invest_eval <- function(last, pred, actual) {
  # if forecast > last invest, calc the return (sell next period)
  if (pred > last) {
    return(actual - last)
  } else {
    return(0)
  }
}

wins <- function(x, p, idx) {
  stopifnot(max(idx) <= length(x))
  w <- sapply(idx, function(i) {
    invest_eval(x[i - 1], p[i], x[i])
  })
  return(w)
}

set.seed(100)
n <- 100

# 2 uncorrelated random series
xrand <- rnorm(n, 10, 1)
prand <- rnorm(n, 10, 1)
cor(xrand, prand)
## [1] -0.1350806
# 2 uncorrelated trended series
xtrend <- 1:n / 5 + rnorm(n, 0, 1)
ptrend <- 1:n / 5 + rnorm(n, 0, 1)
cor(xtrend, ptrend)
## [1] 0.9651826
# 2 process with same structure but not related
xar1 <- 10 + arima.sim(list(ar = .8), n)
par1 <- 10 + arima.sim(list(ar = .8), n)
cor(xar1, par1)
## [1] -0.2807578
# auto.arima forecast
par1f <- sapply(11:n, function(i) {
  # 1:10 -> 11
  forecast(auto.arima(xar1[1:(i - 1)]), 1)$mean
})
par1f <- c(rep(NA, 10), par1f)

# theta forecast
par1f2 <- sapply(11:n, function(i) {
  # 1:10 -> 11
  thetaf(xar1[1:(i - 1)], 1)$mean
})
par1f2 <- c(rep(NA, 10), par1f2)

# naive oppose the sign 
par1f3 <- sapply(11:n, function(i) {
  # oppose the last change
  xar1[i - 1] - sign(xar1[i - 1] - xar1[i - 2])
})
par1f3 <- c(rep(NA, 10), par1f3)

cor(xar1, par1, use = 'compl')
## [1] -0.2807578
cor(xar1, par1f, use = 'compl')
## [1] 0.75465
cor(xar1, par1f2, use = 'compl')
## [1] 0.7606652
cor(xar1, par1f3, use = 'compl')
## [1] 0.6945875
# calc wins
wrand <- wins(xrand, prand, 11:n)
wtrend <- wins(xtrend, ptrend, 11:n)
war1 <- wins(xar1, par1, 11:n)
war1f <- wins(xar1, par1f, 11:n)
war1f2 <- wins(xar1, par1f2, 11:n)
war1f3 <- wins(xar1, par1f3, 11:n)

matplot(cbind(xrand, prand), type = 'l', main = 'random')

matplot(cbind(xtrend, ptrend), type = 'l', main = 'trend')

matplot(cbind(xar1, par1, par1f, par1f2, par1f3), type = 'l', main = 'AR1')
legend('bottomleft', c('ar1', 'random', 'auto.arima', 'thetaf', 'opp sign'), lty = 1, col = 1:5)