Kelly Criterion

The Kelly Criterion

“In probability theory, the Kelly criterion (or Kelly strategy or Kelly bet), is a formula that determines the optimal theoretical size for a bet. It is valid when the expected returns are known. The Kelly bet size is found by maximizing the expected value of the logarithm of wealth, which is equivalent to maximizing the expected geometric growth rate. It was described by J. L. Kelly Jr, a researcher at Bell Labs, in 1956.[1] The criterion is also known as the scientific gambling method, as it leads to higher wealth compared to any other strategy in the long run (i.e. the theoretical maximum return as the number of bets goes to infinity). The practical use of the formula has been demonstrated for gambling and the same idea was used to explain diversification in investment management. In the 2000s, Kelly-style analysis became a part of mainstream investment theory and the claim has been made that well-known successful investors including Warren Buffett and Bill Gross use Kelly methods. William Poundstone wrote an extensive popular account of the history of Kelly betting. Also see Intertemporal portfolio choice.”

Wikipedia https://en.wikipedia.org/wiki/Kelly_criterion

Required Packages

knitr::opts_chunk$set(echo = TRUE)
col_aq2<-as.character(c("#04103b","#3b5171","#5777a7","#969696","#dd0400"))

library(dplyr)

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(ecm)
library(plotly)

## Loading required package: ggplot2

## 
## Attaching package: 'plotly'

## The following object is masked from 'package:ggplot2':
## 
##     last_plot

## The following object is masked from 'package:stats':
## 
##     filter

## The following object is masked from 'package:graphics':
## 
##     layout

library(dplyr)
library(ecm)
library(plotly)
library(data.table)

## 
## Attaching package: 'data.table'

## The following objects are masked from 'package:dplyr':
## 
##     between, first, last

library(grDevices)

Financial Data

Total return data for the S&P 500 Index and an Index of 0-1 Year US Treasury Bonds has been obtained from Bloomberg and a hardcopy can be accesses through Google Drive.

id <- "1sJ3XN1uoIaWiOmWn9agEuDD5ftIN0WJH" # google file ID
ds<-read.csv(sprintf("https://docs.google.com/uc?id=%s&export=download", id))

plot_ly(ds,x=~as.Date(Dates),y=~Asset,type="scatter",mode="lines",line=list(color=col_aq2[1]))%>%
   layout(title="S&P 500 Indexed Total Return",xaxis = list(title=""), yaxis = list(title=""),legend = list(orientation = "h",xanchor = "center",x = 0.5))

The Investopedia Formula

The original Kelly Criterion is useful for binary bets where each bet can result in a 100% loss such as in Roulette, Coin-Toss or Horse Racing. It’s application to single stock investing as suggested in the Investopedia article makes little sense.

#Kelly Criterion Investopedia
f<-0.6-0.4/(0.2/0.2)
print(paste0("Investopedia example: ", round(f,2)))

## [1] "Investopedia example: 0.2"

f<-p-q/(b/a)
print(paste0("S&P 500 example: ", round(f,2)))

## [1] "S&P 500 example: 0.02"

The Entrepreneurial Investor

The shortcoming of the Investopedia formula has correctly been called out in a 2018 article on the website of the CFA institute. This article suggests an amended version of the formula that takes into account that investments in the stock market are not all or nothing bets. Instead, the relative size of gains and losses needs to be considered. The respective formula for partial losses can also be found on Wikipedia: f*=p/a-q/a The results look fine when applied to the stylized example used in the article but suggest a dangerous level of leverage when applied to the S&P 500.

#Kelly % = W/A – (1 – W)/B
#https://blogs.cfainstitute.org/investor/2018/06/14/the-kelly-criterion-you-dont-know-the-half-of-it/
#Given example
f<-0.6/0.2-0.4/0.2
print(paste0("CFA Institute Website example: ", round(f,2)))

## [1] "CFA Institute Website example: 1"

f<-p/(a)-q/(b)
print(paste0("S&P 500 example: ", round(f,2)))

## [1] "S&P 500 example: 2.64"

fig<-plot_ly(ds,x=~as.Date(Dates),y=~idx,type="scatter",mode="lines",name="Asset",line=list(color=col_aq2[1])) %>%
  add_trace(x=~as.Date(Dates),y=~cumprod(1+ret)*f-(f-1),name="Portfolio Kelly Criterion",line=list(color=col_aq2[5]))%>%
   layout(title="S&P 500 Indexed Total Return",xaxis = list(title=""), yaxis = list(title=""),legend = list(orientation = "h",xanchor = "center",x = 0.5))
fig<-fig %>%layout(plot_bgcolor  = "rgba(0, 0, 0, 0)",paper_bgcolor = "rgba(0, 0, 0, 0)", fig_bgcolor   = "rgba(0, 0, 0, 0)")
fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "spx_index_kelly_optimum",width = 600,height = 400)) 
fig

## Warning: 'layout' objects don't have these attributes: 'fig_bgcolor'
## Valid attributes include:
## '_deprecated', 'activeshape', 'annotations', 'autosize', 'autotypenumbers', 'calendar', 'clickmode', 'coloraxis', 'colorscale', 'colorway', 'computed', 'datarevision', 'dragmode', 'editrevision', 'editType', 'font', 'geo', 'grid', 'height', 'hidesources', 'hoverdistance', 'hoverlabel', 'hovermode', 'images', 'legend', 'mapbox', 'margin', 'meta', 'metasrc', 'modebar', 'newshape', 'paper_bgcolor', 'plot_bgcolor', 'polar', 'scene', 'selectdirection', 'selectionrevision', 'separators', 'shapes', 'showlegend', 'sliders', 'spikedistance', 'template', 'ternary', 'title', 'transition', 'uirevision', 'uniformtext', 'updatemenus', 'width', 'xaxis', 'yaxis', 'barmode', 'bargap', 'mapType'

frontiers in Applied Mathematics and Statistics

An October 2020 article in frontiers proposes another formula using volatility instead of odds and again illustrates it with a stylized example assuming an expected excess return of 11% and a volatility of 40%. The example suggests an optimal allocation of 68% to the risky asset. Once the formula is applied to the S&P 500 data, this ratio increases to 180%.

years<-as.numeric(as.Date(tail(ds$Dates,1))-as.Date((head(ds$Dates,1))))/365.25
geo_ret_idx<-((tail(ds$idx,1)/(head(ds$idx,1)))^(1/years)-1)
geo_ret_bond<-((tail(ds$rf,1)/(head(ds$rf,1)))^(1/years)-1)

#Formula https://www.frontiersin.org/articles/10.3389/fams.2020.577050/full
#Example:
u<-0.12/252
r<-0.01/252
s<-0.4/252^0.5
f<-(u-r)/s^2
f

## [1] 0.6875

u<-mean(ds$ret,na.rm=T)
#u<-geo_ret_idx/252
r<-mean(ds$ret_rf,na.rm=T)
#r<-geo_ret_bond/252
s<-sd(ds$ret)
f<-(u-r)/s^2
f

## [1] 1.836411

ua<-(u-r)*252
sa<-s*(252^0.5)
ua/sa

## [1] 0.3456875

fig<-
plot_ly(ds,x=~as.Date(Dates),y=~idx,type="scatter",mode="lines",name="Asset",line=list(color=col_aq2[1])) %>%
  add_trace(x=~as.Date(Dates),y=~cumprod(1+ret)*f-(f-1),name="Portfolio Kelly Criterion",line=list(color=col_aq2[5]))%>%
   layout(title="S&P 500 Indexed Total Return",xaxis = list(title=""), yaxis = list(title=""),legend = list(orientation = "h",xanchor = "center",x = 0.5))
fig<-fig %>%layout(plot_bgcolor  = "rgba(0, 0, 0, 0)",paper_bgcolor = "rgba(0, 0, 0, 0)", fig_bgcolor   = "rgba(0, 0, 0, 0)")
fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "spx_index_kelly_optimum",width = 600,height = 400)) 
fig

fig<-
plot_ly(ds,x=~as.Date(Dates),y=~idx/cummax(idx),type="scatter",mode="lines",name="Asset",line=list(color=col_aq2[1])) %>%
  add_trace(x=~as.Date(Dates),y=~(cumprod(1+ret)*f-(f-1))/cummax(cumprod(1+ret)*f-(f-1)),name="Portfolio Kelly Criterion",line=list(color=col_aq2[5]))%>%
   layout(title="S&P 500 Maximum Drawdown",xaxis = list(title=""), yaxis = list(title=""),legend = list(orientation = "h",xanchor = "center",x = 0.5))
fig<-fig %>%layout(plot_bgcolor  = "rgba(0, 0, 0, 0)",paper_bgcolor = "rgba(0, 0, 0, 0)", fig_bgcolor   = "rgba(0, 0, 0, 0)")
fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "spx_index_kelly_optimum",width = 600,height = 400)) 
fig

Sensitivity Analysis

With the formula in Carta and Conversano 2020, the Kelly strategy becomes a function of the Sharpe Ratio. The chart below illustrates the sensitivity for an asset with 20% volatility for different Sharpe Ratios.

#Kelly Criterion vs Sharpe Ratio
f_sensi<-
as.data.frame(cbind(
c(0.1,0.2,0.3,0.4,0.5),
c(
(0.1*0.2)/0.2^2,
(0.2*0.2)/0.2^2,
(0.3*0.2)/0.2^2,
(0.4*0.2)/0.2^2,
(0.5*0.2)/0.2^2
)))
names(f_sensi)<-c("sr","f")

fig<-
plot_ly(f_sensi,x=~sr,y=~f,type="scatter",mode="lines+markers",name="Asset",line=list(color=col_aq2[1]),marker=list(color=col_aq2[1]))%>%
   layout(title="Kelly Criterion vs Simple Sharpe Ratio",xaxis = list(title="Sharpe Ratio"), yaxis = list(title="Kelly Criterion"),legend = list(orientation = "h",xanchor = "center",x = 0.5))
fig<-fig %>%layout(plot_bgcolor  = "rgba(0, 0, 0, 0)",paper_bgcolor = "rgba(0, 0, 0, 0)", fig_bgcolor   = "rgba(0, 0, 0, 0)")
fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "spx_index_kelly_optimum",width = 600,height = 400)) 
fig

Simulation

The following functions allow users to apply the Kelly Criterion and simulate bets under various assumptions.

kelly_criterion<-function(p,gain,loss)
{
  #Kelly Criterion
  f<-p/loss-(1-p)/gain
  #b<-gain/loss
  #f_all_or_nothing<-p-((1-p)/(gain/loss))
  #Minimum Odds Required
  pmin<-loss/(loss+gain)
  
  res_list<-list("f"=f,"pmin"=pmin)
  return(res_list)
}


kelly_simulation_function<-function(number_bets,number_simulations,p,gain,loss,size_bet)
{

  res_list<-setNames(replicate(number_simulations,data.frame()),seq(1,number_simulations))
  
  
  for(j in 1:number_simulations)
  {
    #j<-1
    
    x2 <- runif(number_bets, 0, 1)
    x3 <- ifelse(x2<=(1-p),-loss,gain)
    
    x4<-as.data.frame(x3)
    x4$bet<-NA
    x4$wealth<-NA
    x4$wealth[1]<-25
    x4$index<-as.numeric(row.names(x4))
    f<-0.1
    for(i in 2:nrow(x4))
    {
      #i<-2
      x4$bet[i]<-x4$wealth[i-1]*size_bet
      x4$wealth[i]<-x4$wealth[i-1]+x4$bet[i]*x4$x3[i]
    }
    
    res_list[[j]]<-x4
    #print(j)
  }

  res_table<-rbindlist(res_list,id="id")
  
  agg_res<-
    res_table %>%
    group_by(index) %>%
    dplyr::summarize(wealth_mean = mean(wealth, na.rm=TRUE),
                     wealth_median = median(wealth, na.rm=TRUE),
                     wealth_min = min(wealth, na.rm=TRUE),
                     wealth_max = max(wealth, na.rm=TRUE)
                     
    )
  

  col_aq2<-as.character(c("#04103b","#3b5171","#5777a7","#969696","#dd0400"))
  cols = colorRampPalette(col_aq2)(6)
  fig_mean<-
    plot_ly(agg_res,x=~index,y=~wealth_mean,type="scatter",mode="lines",name="40%",line=list(color=cols[1]))%>%
    layout(title="Mean Wealth",xaxis = list(title=""), yaxis = list(title="Wealth in $"),legend = list(orientation = "h",xanchor = "center",x = 0.5))
  fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "one_simulation",width = 600,height = 400)) 


  col_aq2<-as.character(c("#04103b","#3b5171","#5777a7","#969696","#dd0400"))
  cols = colorRampPalette(col_aq2)(6)
  fig_median<-
    plot_ly(agg_res,x=~index,y=~wealth_median,type="scatter",mode="lines",name="40%",line=list(color=cols[1]))%>%
    layout(title="Median Wealth",xaxis = list(title=""), yaxis = list(title="Wealth in $"),legend = list(orientation = "h",xanchor = "center",x = 0.5))
  fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "one_simulation",width = 600,height = 400)) 

  
  col_aq2<-as.character(c("#04103b","#3b5171","#5777a7","#969696","#dd0400"))
  cols = colorRampPalette(col_aq2)(6)
  fig_min<-
    plot_ly(agg_res,x=~index,y=~wealth_min,type="scatter",mode="lines",name="40%",line=list(color=cols[1]))%>%
    layout(title="Minimum Wealth",xaxis = list(title=""), yaxis = list(title="Wealth in $"),legend = list(orientation = "h",xanchor = "center",x = 0.5))
  fig<-fig %>% config(toImageButtonOptions = list( format = "svg",filename = "one_simulation",width = 600,height = 400)) 

  
  res_list<-list("agg_res"=agg_res,"fig_mean"=fig_mean,"fig_median"=fig_median,"fig_min"=fig_min)
  return(res_list)
}

number_bets=300
number_simulations=500
gain=0.2
loss=0.20
size_bet=0.2
p=0.6

res_list<-kelly_criterion(p,gain,loss)
res_list$f

## [1] 1

#The odds required to break-even
res_list$pmin

## [1] 0.5

res_list<-kelly_simulation_function(number_bets,number_simulations,p,gain,loss,res_list$f)
res_list$fig_mean

res_list$fig_median

res_list$fig_min