Universal portfolio, part 10

Part 9 compared the wealth of Universal against other portfolio selection algorithms by using the experimental cumulative distribution function of the relative wealth.  This leads to a very compact representation, but it completely hides the absolute level evolution as the number of stocks in a portfolio increases.

The code below uses a slightly different approach, it uses a scatterplot where the final absolute wealth of two different algorithms are used for the x and y axes.  The main diagonal corresponds to both algorithms having an equal final wealth.  To provide more information, side graphs with the marginal probability of final wealth are included.

Finally, an other reference is added, the best CRP, using the optimization code in package logopt.

As in part 9, the code recalculates the value of Universal final wealth across all 4-tuples and thus takes one day to run if you did not have yet the results in your environment, be warned. Also, the code presentation uses Syntax Highlighter, I am still experimenting with the best way to present R code.

# Performance of Universal compared to some references

library(logopt)
x <- coredata(nyse.cover.1962.1984)
w <- logopt:::x2w(x)
nDays <- dim(x)[1]
nStocks <- dim(x)[2] 
Days <- 1:nDays
iWin <- 1 ; plot(1:10)

TupleSizes <- c(2,3,4)
EvaluateOnAllTuples <- function(ListName, TupleSizes, fFinalWealth, ...) {
 if (exists(ListName) == FALSE) {
  LocalList <- list()
  for (i in 1:length(TupleSizes)) {
   TupleSize <- TupleSizes[i]
   ws <- combn(x=(1:nStocks), m=(TupleSize), FUN=fFinalWealth, simplify=TRUE, ...)
   LocalList[[i]] <- ws
  }
  assign(ListName, LocalList, pos=parent.frame())
 }
}

UniversalFinalWealth <- function(cols, ...) {
 x <- list(...)[[1]] ; n <- list(...)[[2]]
 uc <- universal.cover(x[,cols], 20)
 return(uc[length(uc)])
}
EvaluateOnAllTuples("lUniversalFinalWealth", TupleSizes, UniversalFinalWealth, x, 20)

BestStockFinalWealth <- function(cols, ...) { 
 w <- list(...)[[1]]
 return(max(w[nDays,cols])) 
}
EvaluateOnAllTuples("lBestStockFinalWealth", TupleSizes, BestStockFinalWealth, w)

UcrpFinalWealth <- function(cols, ...) {
 x <- list(...)[[1]]
 ucrp <- crp(x[,cols])
 return(ucrp[length(ucrp)]) 
}
EvaluateOnAllTuples("lUcrpFinalWealth", TupleSizes, UcrpFinalWealth, x)

BhFinalWealth <- function(cols, ...) {
 x <- list(...)[[1]]
 ubh <- bh(x[,cols])
 return(ubh[length(ubh)]) 
}
EvaluateOnAllTuples("lBhFinalWealth", TupleSizes, BhFinalWealth, x)

BestCrpFinalWealth <- function(cols, ...) { 
 x <- list(...)[[1]]
 bopt <- bcrp.optim(x[,cols])
 bcrp <- crp(x[,cols],bopt)
 return(bcrp[length(bcrp)]) 
}
EvaluateOnAllTuples("lBestCrpFinalWealth", TupleSizes, BestCrpFinalWealth, x)

Colors <- c("blue","green","red")

CompareFinalAbsoluteWealth <- function( L0, L1, MainString, TupleSizes=TupleSizes, clip=0.01,
                           Colors=c("blue","green","red"), PlotChar = 19, PlotSize = 0.5,
                                   XLabel="Universal wealth", YLabel="Other wealth") {
 nLines <- min(length(L0),length(L1))
 if (clip > 0) { MaxUp <- quantile(c(L0[[nLines]], L1[[nLines]]), 1-clip) }
 else          { MaxUp <- max(L0, L1) }
 XLims = c(0, MaxUp)
 layout( matrix( c(0,2,2,1,3,3,1,3,3),ncol=3) )
 d.x <- density(L0[[1]])
 plot(d.x$x, d.x$y, xlim=XLims, type='l', col=Colors[1], main="Density on x axis", xlab="", ylab="")
 grid()
 for (i in 1:nLines) {
  d.x <- density(L0[[i]])
  lines(d.x$x, d.x$y, type='l', col=Colors[i])
  abline(v=mean(L0[[i]]), col=Colors[i])
 }
 d.y <- density(L1[[1]])
 plot(d.y$y, d.y$x, ylim=XLims, xlim=rev(range(d.y$y)), type='l', col=Colors[1], , main="Density on y axis", xlab="", ylab="")
 grid()
 for (i in 1:nLines) {
  d.y <- density(L1[[i]])
  lines(d.y$y, d.y$x, type='l', col=Colors[i])
  abline(h=mean(L1[[i]]), col=Colors[i])
 }
 plot(L0[[nLines]], L1[[nLines]], col=Colors[nLines], pch=PlotChar, cex=PlotSize, 
  xlab=XLabel, ylab=YLabel, xlim= XLims, ylim= XLims, type="p", main=MainString) 
 for (j in 1:nLines) {
  i <- nLines - j + 1
  points(L0[[i]], L1[[i]], col=Colors[i], pch=PlotChar, cex=PlotSize) 
  rug(L0[[i]], col=Colors[i],ticksize=0.01*i)
  rug(L1[[i]], col=Colors[i],ticksize=0.01*i, side=2)
 }
 abline(0,1,col="lightgray",lwd=2)
 legend("topright", legend=c("2 stocks","3 stocks","4 stocks"), pch=PlotChar, col=Colors, bg="white")
 grid()
}


if(length(dev.list()) < iWin) { x11() } ; iWin <- iWin + 1 ; dev.set(iWin) ;
CompareFinalAbsoluteWealth(lUniversalFinalWealth, lBestStockFinalWealth, "Universal relative to best stock final wealth", TupleSizes) 

if(length(dev.list()) < iWin) { x11() } ; iWin <- iWin + 1 ; dev.set(iWin) ;
CompareFinalAbsoluteWealth(lUniversalFinalWealth, lBhFinalWealth, "Universal relative to uniform buy and hold final wealth", TupleSizes) 

if(length(dev.list()) < iWin) { x11() } ; iWin <- iWin + 1 ; dev.set(iWin) ;
CompareFinalAbsoluteWealth(lUniversalFinalWealth, lUcrpFinalWealth, "Universal relative to uniform CRP final wealth", TupleSizes) 

if(length(dev.list()) < iWin) { x11() } ; iWin <- iWin + 1 ; dev.set(iWin) ;
CompareFinalAbsoluteWealth(lUniversalFinalWealth, lBestCrpFinalWealth, "Universal relative to best CRP final wealth", TupleSizes) 

# a function to compare the ECDF of two lists of final wealths
CompareFinalRelativeWealth <- function( L0, L1, MainString, TupleSizes=TupleSizes, 
                              Colors=c("blue","green","red"), PlotChar = ".",
                                   XLabel="Ratio of final wealths", YLabel="Cumulative probability") {
 nLines <- min(length(L0),length(L1))
 LR <- list() ; XLims = c()
 for(i in 1:nLines) { LR[[i]] <- L0[[i]]/L1[[i]] ; XLims <- range(XLims, LR[[i]]) }
 plot(ecdf(L0[[1]]/L1[[1]]), pch=PlotChar, col=Colors[1], main=MainString,
  xlab=XLabel, ylab=YLabel, xlim= XLims)
 abline(v=1,col="gray",lwd=2)
 for (i in 1:nLines) {
  lines(ecdf(L0[[i]]/L1[[i]]), pch=PlotChar, col=Colors[i])
 }
 legend("bottomright", legend=c("2 stocks","3 stocks","4 stocks"), fill=Colors)
 grid()
 # show best relative wealth and its composition
 for (i in 1:length(TupleSizes)) {
  TupleSize <- TupleSizes[i]
  BestTuple <- which.max(LR[[i]])
  BestStocks <- combn(1:nStocks, TupleSize)[,BestTuple]
  cat(sprintf("Max final relative wealth %.4f for stocks: ", LR[[i]][BestTuple]))
  cat(colnames(x)[BestStocks]) ; cat("\n")
 }
}

if(length(dev.list()) < iWin) { x11() } ; iWin <- iWin + 1 ; dev.set(iWin) ;
CompareFinalRelativeWealth(lUniversalFinalWealth, lBestCrpFinalWealth, "Universal relative to best CRP final wealth", TupleSizes) 

The first graph compares Universal to the best stock in the portfolio.  It also shows that the density function is not an ideal solution when the set of possible outcomes is discrete.  The ecdf function would be a better choice in this case.  The plot is also slightly misleading when compared to the equivalent plot of relative wealth in part 9.  The problem is that points overlap and so the 2D density cannot be assessed except for the set of blue points.

The next graph shows a comparison of Universal and Uniform CRP.  The graph works reasonably well in this case because both axes have smooth marginal distributions.  As for the corresponding graph of relative wealth, we can clearly see that UCRP is simply better, but now we can also see that this is especially true for the best performing portfolios.

The comparison between Universal and Uniform Buy and Hold below also works well.  And this time also we can see that the ratio gets better for better performing portfolios, but now with Universal the better algorithm

Finally the comparison between the Best CRP (in hindsight) and Universal shows that BCRP is always better.  Because the probability density function of the best CRP is less smooth, the comparison is not perfect, but it seems that the ratio degrades as the number of stocks in the portfolio increases.  This is expected given that the performance bound of Universal decreases as the number of stocks increase.

Plotting the ECDF of the relative wealth shows this effect much more vividly, clearly illustrating the advantage of looking at the same data in different fashions.