Exploring Optimal f

Recently I’ve been reading Ralph Vince’s Risk Opportunity Analysis. His exploration in Optimal f and Leverage Space Model is quite fascinating and coincidently, his theory generalized the findings we’ve seen in my previous posts Monty Hall Paradox Test and Is Your Faith Fat-tailed?

In a nutshell, Ralph’s theory incorporates the factor of time into a decision-making & bet-sizing process through implementing probability-weighted median and Optimal f, as oppose to using probability-weighted mean and Kelly Criterion.

It’s a very powerful combination. In a hypothetical game with negative expected return, as well as a high chance to win small amounts and a very little chance to lose a lot (such as 90% of win 1 and 10% of loss -10), using probability-weighted median could prevent the player rejecting highly probable and small profits while Optimal f could protect the player from remotely possible disasters.

Here I’d like to mirror what he did in his book using a 2:1 fair coin tossing game to illustrate these ideas. Since the expected return is 2 * 0.5 + (-1) * 0.5 = 0.5, we are going to play this game anyway. But the expected return, which has a linear relationship with the amount you bet f, only tells half of the story. As shown below in R. With your time horizon expands, the relationship bends. (well…)

# sets up the function
HPR <- function(win = 2, loss = -1, hor = 2, lev = 1, try = 101) {	
	# hor = time horizon
	# lev = max leverage	
	f <- seq(0, lev, length.out = try)
	ghpr <- rep(0, length(f))
	
	for (i in 1:length(ghpr)) {
		win_ret <- 1 + f[i] * win
		loss_ret <- 1 + f[i] * loss
		mat <- matrix(c(win_ret, loss_ret))
		mat <- mat %*% t(mat)
		if (hor > 2) {
			for (j in 2:(hor - 1)) {
				mat <- cbind(mat * win_ret, mat * loss_ret)
			}
		}
		ghpr[i] <- sum((mat ^ (1 / hor) - 1)) / (2 ^ hor)
	}
	ghpr[ghpr<0] <- 0
	data.frame(f = f, GHPR = 1 + ghpr, HPR = (ghpr + 1) ^ hor)
}
# play 2 times
plot(HPR(hor=2)$f, HPR(hor=2)$HPR, type='l', ylim = c(1, 1.8), main =
'Time Horizon Illustration', xlab = 'f', ylab = 'HPR')
# play 1 time
lines(c(0, 1), c(1, 1.5))
# and more
lines(HPR(hor=3)$f, HPR(hor=3)$HPR)
lines(HPR(hor=4)$f, HPR(hor=4)$HPR)
lines(HPR(hor=5)$f, HPR(hor=5)$HPR)
lines(HPR(hor=6)$f, HPR(hor=6)$HPR)
lines(HPR(hor=7)$f, HPR(hor=7)$HPR)
lines(HPR(hor=8)$f, HPR(hor=8)$HPR)
text(0.8, 1.2, '2')
text(0.65, 1.18, '3')
text(0.5, 1.1, '8')
text(1, 1.55, '1')
grid()

As we continue to play (despite the time horizon), the optimal bet size f keeps approaching to 0.25, which could also be derived out from the objective function of Optimal f: .

Now we can examine the compounding effect with using Optimal f.

# this function simply implements Optimal f with 100 observations
Opt.f <- function(win = 2, loss = -1, p = .5, lev = 1, obs = 100, plays = 1) {
	f <- seq(0, lev, 1/obs)
	rets <- rep(0, length(f))

	for (i in 1:length(rets)) {
		rets[i] <- (((1 + f[i] * win / -loss) ^ p) * ((1 + f[i] * loss / -loss)
		^ (1 - p))) ^ plays
	}
	data.frame(f = f, rets = rets)
}
# the results of 40 plays
plot(Opt.f(plays=40)$f, Opt.f(plays=40)$rets, type='l', main = 'Optimal f Effect',
xlab = 'f', ylab = 'returns')
# 20 and 5 plays
lines(Opt.f(plays=20)$f, Opt.f(plays=20)$rets)
lines(Opt.f(plays=5)$f, Opt.f(plays=5)$rets)
text(.25, 9, '40')
text(.25, 3.5, '20')
text(.25, 1, '5')
grid()

Finally, instead of tossing one coin, now we have two coins for the same game and here’s the combined effect of 5 plays.

# Two components function
TCOpt.f <- function(win = 2, loss = -1, outcome = 4, lev = 1, obs = 100, plays = 1) {
	f1 <- seq(0, lev, 1/obs)
	f2 <- seq(0, lev, 1/obs)
	rets <- matrix(0, length(f1), length(f2))

	for (i in 1:length(f1)) {
		for (j in 1:length(f2)) {
			s1 <- (1 + (f1[i] * win + f2[j] * loss) / -loss) ^ (1 / outcome)
			s2 <- (1 + (f1[i] * win + f2[j] * win) / -loss ) ^ (1 / outcome)
			s3 <- (1 + (f1[i] * loss + f2[j] * win) / -loss ) ^ (1 / outcome)
			s4 <- (1 + (f1[i] * loss + f2[j] * loss) / -loss ) ^ (1 / outcome)
			rets[i, j] <- (s1 * s2 * s3 * s4) ^ plays
		}
	}
	rets[is.na(rets)] <- 0
	mat <- matrix(f1, nrow = length(f1), ncol=length(f1))
	list(xmat = mat, ymat = t(mat), 'rets' = rets)
}

require(rgl)
plays5 <- TCOpt.f(plays=5)
x <- plays5$xmat
y <- plays5$ymat
z <- plays5$rets
col <- c('white','blue')[ z+1 ]
persp3d(x, y, z, color=col, alpha=.6, xlab = 'coin 1', ylab = 'coin 2', zlab = 'returns')
grid3d(c('x', 'y', 'z'))
title3d("Two Components Coin Tossing", line=5)

There are a lot of other interesting properties of this system but I believe I’ve covered the gist of it. And apparently more works need to be done until we can fully utilize it in trading or investment.

roy

Testing Kelly Criterion and Optimal f in R

Kelly Criterion and Optimal f are very similar models for geometric growth optimization. Ralph Vince’s article Optimal f and the Kelly Criterion  has explained their differences in detail and here are main takeaways.

  1. Kelly Criterion does not yield the optimal fraction to risk in trading, Optimal f does
  2. Kelly Criterion only generates a leverage factor which could go infinitely large; Optimal f is bounded between 0 and 1
  3. The reconciliation between two models could be written as Optimal f = Kelly * (-W/Px), where W is the possible maximum loss on each trade, Px is the price per share. Both are in dollar amount

Inspired by Ralph’s article, I did a test in R to compare these two models. Considering a 50/50 coin flipping game that pays $2 on heads and -$0.5 on tails for every $1 you bet. Through optimizing Kelly’s objective function \sum_{i=1}^{n}(\ln(1+R_i*f)*P_i)  we should get optimal f = 0.75. While Optimal f, with objective function \prod_{i=1}^{n}(1+f*(Px_i/-W))^{P_i} , will give a different optimal f = 0.375. Let’s see if they can be consistent with observations in R.

# kelly formula test
kelly.opt <- function(win, loss, p, obs, lev) {
	# win = payout for a win
	# loss = payout for a loss
	# p = probability of winning
	# obs = number of observations
	# lev = maximum leverage allowed

	# set up different bet sizes for test
	f <- seq(0, lev, 1 / (obs - 1))
	# generate trading results according to given win, loss and p
	ret <- rep(win, length(f))
	ret[which(rbinom(length(f), 1, 1 - p) == 1)] <- loss
	#calculate accumulative pnl for different bet sizes respectively
	pnl <- f
	for (i in 1:length(f)) {
		pnl[i] <- sum(log(1 + ret * f[i]))
	}
	# find the optimal point of f
	results <- cbind(f, pnl)
	opt.kelly <- results[which(results[, 2] == max(results[, 2])), 1]
	# wrap up
	output <- list()
	output$opt.kelly <- opt.kelly
	output$results <- results
	output
}
# optimal f test
opt.f <- function(win, loss, p, obs, lev) {
	# similar as Kelly except using a different objective function
	f <- seq(0, lev, 1 / (obs - 1))

	ret <- rep(win, length(f))
	ret[which(rbinom(length(f), 1, 1 - p) == 1)] <- loss

	pnl <- f
	for (i in 1:length(f)) {
		pnl[i] <- prod(1 + ret / (-loss / f[i]))
	}

	results <- cbind(f, pnl)
	opt.f <- results[(which(results[, 2] == max(results[, 2]))), 1]

	output <- list()
	output$opt.f <- opt.f
	output$results <- results
	output
}

# get statistics for kelly
compare <- data.frame(kelly=1:5000, opt.f=1:5000)
for (i in 1:5000) {
	compare$kelly[i] <- kelly.opt(2, -.5, .5, 500, 1)$opt.kelly
}

# get statistics for optimal f
for (i in 1:5000) {
	compare$opt.f[i] <- opt.f(2, -.5, .5, 500, 1)$opt.f
}

# generate graph
require(ggplot)
m <- ggplot(compare, aes(colour=compare)) + xlim(c(0, 1)) + xlab('distribution')
m + stat_density(aes(x=kelly, colour='kelly'), adjust = 2, fill=NA) +
stat_density(aes(x=opt.f, colour='opt.f'), adjust = 2, fill=NA)

It’s always a beauty to see test results and mathematical models showing consistency. And here we are happy to see two distributions nice and tightly surrounding their means: 0.75068 for Kelly Criterion, and 0.37558 for Optimal f. To wrap things up.

roy