R/empirical.R

In shill1729/KellyCriterion: Log-optimal stock allocation

#' Growth/entropy rate for repeated bets
#'
#' @param w fraction of wealth to invest
#' @param x the daily returns range
#' @param y the empirical density function of returns
#' @param rate the risk-free rate or the cost of carry, assumed to be annualized
#' @description {The growth-rate function for repeated bets.}
#' @return numeric
#' @export entropy_historical
entropy_historical <- function(w, x, y, rate)
{
  # Assumed annual rate
  mapply(function(W){
    sum((log(1+rate/252+W*(x-rate/252)))*y*c(0, diff(x)))
  }, W = w)
}

#' Growth/entropy rate derivative for repeated bets
#'
#' @param w fraction of wealth to invest
#' @param x the daily returns range
#' @param y the empirical density function of returns
#' @param rate the risk-free rate or the cost of carry, assumed to be annualized
#' @description {The growth-rate derivative for repeated bets.}
#' @return numeric
#' @export entropy_derivative
entropy_derivative <- function(w, x, y, rate)
{
  # Assumed annual rate
  mapply(function(W){
    sum(((x-rate/252)/(1+rate/252+W*(x-rate/252)))*y*c(0, diff(x)))
  }, W = w)
}


#' Quadrature Kelly computation
#'
#' @param returns the time-series of daily log-returns
#' @param rate the relevant interest rate (risk-free, cost of carry, etc) and is assumed to be annualized
#' @param plotGrowth whether to plot the growth functions
#' @param bd the precision boundary away from the interval endpoint in the bisection
#' @description {Computes the optimal Kelly fraction via numerical integration given the empirical density function}
#' @details {Solves a root equation in terms of the expectation of a function of the returns. See pdf for details.}
#' @return list
#' @export kelly_quadrature
kelly_quadrature <- function(returns, rate, plotGrowth = FALSE, bd = 0.0001) {
  # assume annual rate
  epdf <- density(returns)
  x <- epdf$x
  y <- epdf$y
  x1 <- min(x)
  xn <- max(x)
  a <- -(1+rate/252)/(xn-rate/252)
  b <- -(1+rate/252)/(x1-rate/252)-bd
  wStar <- stats::uniroot(entropy_derivative, interval = c(a, b), x = x, y = y, rate = rate)
  wS <- wStar$root
  input <- data.frame(n = length(returns), x1 = x1, xn = xn, a = a, b = b, rate = rate)
  output <- list(input = input, optimalWeight = wS)
  if(plotGrowth){
    w <- seq(a, b, length.out = 100)
    # Plotting growth function
    graphics::par(mfrow = c(2, 1))
    graphics::plot(w, entropy_derivative(w, x, y, rate), type = "l", main = "g'(w)")
    graphics::abline(h = 0)
    graphics::abline(v = wS)
    graphics::plot(w, entropy_historical(w, x, y, rate), type = "l", main ="g(w)")
    graphics::abline(v = wS)
  }
  return(output)
}


#' Rolling period quadrature Kelly criterion
#'
#' @param returns the time series of daily returns
#' @param n number of days to roll by
#' @param rate interest rate of relevance, assumes the input is annualized (deannualized inside the function)
#' @param constrain whether to constrain the capital or not
#' @param lb lower bound capital limit
#' @param ub upper bound capital limit
#' @description {Function to compute rolling quadrature Kelly criterion. Can take constant or variable rate.}
#' @details {Generic rolling function via loops. Also includes capital constraints for prohibiting leverage.}
#' @return matrix
#' @export kelly_rolling_quadrature
kelly_rolling_quadrature <- function(returns, n, rate, constrain = FALSE, lb = -0.5, ub = 0.5)
{
  # Get length of time-series of returns
  m <- length(returns)
  # The rolling will have m-n points

  rollingK <- matrix(0, nrow = m-n)
  if(length(rate)>1)
  {
    for(i in (n+1):m)
    {
      rollingK[i-n] <- kelly_quadrature(returns[(i-n):i], rate[i-n])$optimalWeight
    }
  } else if(length(rate) == 1)
  {
    for(i in (n+1):m)
    {
      rollingK[i-n] <- kelly_quadrature(returns[(i-n):i], rate)$optimalWeight
    }
  }
  if(constrain)
  {
    rollingK[rollingK<0] <- pmax(rollingK[rollingK<0], lb)
    rollingK[rollingK>0] <- pmin(rollingK[rollingK>0], ub)
  }
  return(rollingK)
}