# 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