################################################################################
# Simulations of Feller processes - B. Boettcher
################################################################################
# Code by B. Boettcher (bjoern.boettcher {at} tu-dresden.de) for the paper:
# Feller processes: The Next Generation in Modeling. Brownian Motion, Levy
# processes and beyond.
#
# Code executed within R (http://www.r-project.org/), version 2.11.1
#
# Note: We opted for clarity, rather than for the most efficient code. The 
# functions are written for an educated user, i.e. the functions do in general
# not check if the entered parameters have appropriate values.
#
# If you want to use this code to simulate Feller processes - instead of just
# reproducing the figures of the paper - please note:
#
# rfellerprocess(maxtime, timestepsize, startpoint, r1dstep) generates the 
# sample path and r1dstep is one of
# rlevymixture      - for a process given by the mixture approach 
# rstablefamily     - for a stable-like process
# rnigfamily        - for a normal inverse Gaussian-like process
# rmeixnerfamily    - for a Meixner-like process
# 
# The components of the mixture can be modified at the beginning of the section 
# "the Levy mixture approach".
# The families can be modified in the functions rstablefamily, rnigfamily and 
# rmeixnerfamily, respectively.
# 
# Examples:
# plot(rfellerprocess(10,0.001,0,rlevymixture))
# plot(rfellerprocess(10,0.001,0,rstablefamily))
# plot(rfellerprocess(1000,0.1,0,rnigfamily))
# plot(rfellerprocess(1000,0.1,0,rmeixnerfamily))
#
################################################################################

rfellerprocess <- function(maxtime,timestepsize,startpoint,r1dstep){
# generates the approximation to the path of the Feller process
#
# maxtime = time up to which the path will be simulated
# timestepsize = time-step size of the increments
# startpoint = starting point of the process
# r1dstep = a one dimensional function for one step generation 
#           (the function should accept two parameters: 
#            the time-step size and the current position)
#
# returns a list containing the time and position of the process as xy.coords

  n = ceiling(maxtime/timestepsize)
  v = numeric(n+1)
  v[1] = startpoint
  for ( i in 1:n) {
    v[i+1] = r1dstep(timestepsize,v[i]) + v[i]
  }
  invisible(xy.coords((0:n)* timestepsize,v,xlab="time",ylab="space"))
}


################################################################################
# the Levy mixture approach
################################################################################
# (here we work with global variables for convenience)
#

n = 3                                           # Number of processes to mix
rlevy = list(n)                                 # the processes
a = list(n)                                     # the coefficients
rlevy[[1]] = function(t) rnorm(1,sd=sqrt(t))    # L^1 = Brownian motion
rlevy[[2]] = function(t) rpois(1,lambda=t)      # L^2 = Poisson process
rlevy[[3]] = function(t) rcauchy(1,scale=t)     # L^3 = Cauchy process

# Now one could define just the functions directly (and the process exists
# always if the functions are non-negative, bounded and Lipschitz continuous)
# a[[1]] = 
# a[[2]] = 
#
# Instead, we define regions and generate the functions by linear interpolation

regions = c( 
-6,         # right endpoint of the region where the process is just L^1
-4,4,       # left & right endpoint of the region where the process is just L^2
6           # left endpoint of the region where the process is just L^3
)

# The following yields functions 'a' such that they are =1 on their region and 
# =0 on the others. Constructed by linear interpolation.
 
a[[1]] = approxfun(c(regions[1],regions[2]),c(1,0), method="linear",1,0)
for(i in 2:(n-1)) {
   a[[i]]=approxfun(c(regions[i*2-3],regions[i*2-2],regions[i*2-1],regions[i*2])
                    ,c(0,1,1,0),method="linear",0,0)
}
a[[n]] = approxfun(c(regions[n*2-3],regions[n*2-2]),c(0,1), method="linear",0,1)

rlevymixture = function(t,x) {
# generates an increment of the Levy family constructed as mixture with the 
# above defined processes and coefficients
#
# t = time-step size
# x = current position

  y = 0
  for(i in 1:n)
   y = y + a[[i]](x)*rlevy[[i]](t)
  return(y)
}


################################################################################
# the symmetric-alpha-stable family 
################################################################################

rstable = function(n,t,alpha=1) {
# generation of increments of an alpha stable process
#
# n = number of increments
# t = time-step size
# alpha = index of stability
#
# We use 
# * the algorithm form Chambers, J. M.; Mallows, C. L. & Stuck, B. W. 
#   A Method for Simulating Stable Random Variables, Journal of the American 
#   Statistical Association, 1976, 71, 340-344
# * the stability, i.e.: 
#   X has char.exp. |xi|^alpha ==> t^(1/alpha) X has char.exp. t |xi|^alpha

   W = rexp(n)
   Theta = runif(n,-pi/2,pi/2)
   return(t^(1/alpha)*(sin(alpha*Theta)/cos(Theta)^(1/alpha) 
           * (cos((1-alpha)*Theta)/W)^((1-alpha)/alpha)))
}

rstablefamily = function (t,x){
# generates an increment of the symmetric alpha stable process family
# 
# t = time-step size of the increment
# x = current position

  exponent = function(x) 1+19/10*pmin((x/4-floor(x/4)),(ceiling(x/4)-x/4))
                                                       # 0 < exponent < 2

  rstable(1,t,exponent(x))
}


################################################################################
# the normal inverse Gaussian family 
################################################################################

rinversegaussian = function(t,a,b) {
# generates an increment of the inverse Gaussian process 
#
# t = time-step size
# a,b = parameters of the inverse Gaussian process
#
# Algorithm from: V. Seshadri, The inverse Gaussian distribution: a case study 
# in exponential families, Oxford University Press, 1993 (page 203)

  y = rnorm(1)^2
  u = runif(1)
  m = t*a
  
  xtemp = m+m^2*y/(2*b)- m*sqrt(4*m*b*y+m^2*y^2)/(2*b)
  if (u <= m/(m+xtemp)) return(xtemp)
  else return(m^2/xtemp) 
}

rnormalinversegaussian = function(t,alpha,beta,delta) {
# generates an increment of the normal inverse Gaussian process
#
# t = time-step size
# alpha,beta,delta = parameters of the normal inverse Gaussian process
#
# Simulation based on subordination of Brownian motion by an inverse Gaussian
# process

  y = rinversegaussian(t,delta,sqrt(alpha^2-beta^2))
  return(beta*y+rnorm(1,sd=sqrt(y)))
}

rnigfamily = function(t,x) {
# generates an increment of the normal inverse Gaussian family
#
# t = time-step size
# x = current position

  alpha = function(x) 1                                #  alpha > 0
  beta = function(x) -1/pi*atan(x)                     # -alpha < beta < alpha
  delta = function(x) 1                                #  delta > 0
  mu = function(x) 0                                   # mu is a real number

  return(mu(x)*t+rnormalinversegaussian(t,alpha(x),beta(x),delta(x)))
}


################################################################################
# the Meixner family
################################################################################
# we use the package cxxPack for an implementation of the complex valued 
# Gamma function "cgamma()"
# to install the package use:
# install.packages("cxxPack")
#
# Please note, that we have no relation to the author of that package.
library("cxxPack") 

rmeixner = function(t,a,b=0,m,r) {
# generates an increment of the Meixner process
#
# t = time-step size
# a,b,m,r = parameters of the Meixner process
#
# The code is based on the method proposed in the preprint:
# Reiichiro Kawai, Parameter Sensitivity Estimation for Meixner Distribution and
# Levy Processes, University of Leicester
#
# We only implemented the method for b=0 and checked the results of the proposed
# method by an optical comparison of the resulting histogram with the known 
# density function for various parameters:
#
# dmeixner = function(t,a,b,m,r,x) {
#   density function of the increments of the Meixner process
#
#   r=r*t
#   m=m*t
#   return((2*cos(b/2))^(2*r)/(2*a*pi*gamma(2*r))
#           *exp(b*(x-m)/a)*abs(cgamma(r+1i*(x-m)/a))^2)
# } 
# 
# t =
# a =
# m =
# r =
#
# x=replicate(10000,rmeixner(t,a,0,m,r))
# hist(x,freq=F)
# f = function(x) dmeixner(t,a,0,m,r,x)
# curve(f,col="red",add=T)
# 

  if (b!=0) {
   print("Error: Only the case b=0 is implemented")
   return("Error")
  }
  r=t*r
  m=t*m
  repeat {
    Q = runif(1,min=-1,max=1)/runif(1,min=-1,max=1)
    V = a/2*max(sqrt(2*r),2*r)*Q
    U = runif(1)
    if (abs(Q) < 1) {
      if (gamma(r)^2*U < abs(cgamma(r+1i*V/a))^2) { 
        break
      }  
    } 
    else {
      if (!is.na(cgamma(r+1i*V/a))) 
     # Note: if abs(V) is to large then cgamma yields NaN (but in fact the value 
     # is very small, so also the following inequality would be false. So we 
     # just treated the NaN exception separately.) 
        if (max(1,2*r)*a^2*gamma(r+1)^2*U/(2*r) < abs(cgamma(r+1i*V/a))^2 *V^2){ 
             break
           }
    }     
  }
  return(V+m)
}

rmeixnerfamily = function(t,x) {
# generates an increment of the Meixner family
#
# t = time-step size
# x = current position

  a = function(x) if (abs(x)>=5) return(1) else return(1+10*exp(-1/(25-x^2)))
  # a>0
  b = function(x) 0                 # -pi < b < pi (implemented only for b=0 !!)
  m = function(x) 0                 # m is a real number
  r = function(x) 1                 # b>0
 
  return(rmeixner(t,a(x),b(x),m(x),r(x)))
}


################################################################################
################################################################################
# Generation of the Figures
################################################################################

# initialization of the random number generator and some graphic parameters
set.seed(1034)

par(oma = c(0,0,0,0), mar=c(4,3.2,2,0.8))
layout(matrix(c(1,2,3,4),nrow=2,byrow=TRUE),respect=TRUE)

plottype = "s"
plotpch = 19

figplot = function(xy,...) {
  plot(xy,xlab="",ylab="",pty=plottype,pch=plotpch,...)
  title(xlab="time",ylab="space",line=2.2)
}

# the levy mixture
figplot(rfellerprocess(20,0.01,0,rlevymixture),main=expression(x[0] == 0))
figplot(rfellerprocess(20,0.01,0,rlevymixture),main=expression(x[0] == 0))
figplot(rfellerprocess(20,0.01,-10,rlevymixture),main=expression(x[0] == -10))
figplot(rfellerprocess(20,0.01,10,rlevymixture),main=expression(x[0] == 10))
dev.copy2eps(file="Brownian-Poisson-Cauchy-mixture.eps",width = 4.8, height = 4.8)

# the stable-like process
layout(matrix(c(1,2,3,4,5,5),nrow=3,byrow=TRUE),heights=c(1,1,0.4), respect=TRUE)
par(oma = c(0,0,0,0), mar=c(4,3.2,2,0.8),cex=0.83)
colorexponent = function(x) pmin((x/4-floor(x/4)),(ceiling(x/4)-x/4))
cols = heat.colors(100)

path=rfellerprocess(20,0.01,0,rstablefamily)
figplot(path,main=expression(x[0] == 0)
  ,col=cols[1+ceiling(colorexponent(path$y)*150)])
path=rfellerprocess(20,0.01,0,rstablefamily)
figplot(path,main=expression(x[0] == 0)
  ,col=cols[1+ceiling(colorexponent(path$y)*150)])
path=rfellerprocess(20,0.01,-2,rstablefamily)
figplot(path,main=expression(x[0] == -2)
  ,col=cols[1+ceiling(colorexponent(path$y)*150)])
path=rfellerprocess(20,0.01,2,rstablefamily)
figplot(path,main=expression(x[0] == 2)
  ,col=cols[1+ceiling(colorexponent(path$y)*150)])

# legend for the index of the stable-like process
plotlegend = function() {
  par(mar=c(3,0,2,0))
  plot(c(1,2),c(0,1),type="n",axes=0,xlab="",ylab="")
  title(expression(paste("color coding of the values of ", alpha, "(",x,")")))
  axis(1)
  n=80
  xr = seq(1,n)/n+1
  xl = xr-1/n
  yb = rep(0,n)
  yt = rep(1,n)
  rect(xl,yb,xr,yt,col=cols[1:n],border= NA) 
}
plotlegend()
dev.copy2eps(file="stable-like.eps",width = 4.8, height = 5.76)

# the normal inverse Gaussian-like process
par(oma = c(0,0,0,0), mar=c(4,3.2,2,0.8))
layout(matrix(c(1,2,3,4),nrow=2,byrow=TRUE),respect=TRUE)

figplot(rfellerprocess(1000,0.1,0,rnigfamily),main=expression(x[0] == 0))
figplot(rfellerprocess(1000,0.1,0,rnigfamily),main=expression(x[0] == 0))
figplot(rfellerprocess(1000,0.1,-100,rnigfamily),main=expression(x[0] == -100))
figplot(rfellerprocess(1000,0.1,100,rnigfamily),main=expression(x[0] == 100))
dev.copy2eps(file="normal-inverse-gaussian-like.eps",width = 4.8, height = 4.8)

# the Meixner-like process
figplot(rfellerprocess(100,0.1,0,rmeixnerfamily),main=expression(x[0] == 0))
figplot(rfellerprocess(100,0.1,0,rmeixnerfamily),main=expression(x[0] == 0))
figplot(rfellerprocess(100,0.1,-10,rmeixnerfamily),main=expression(x[0] == -10))
figplot(rfellerprocess(100,0.1,10,rmeixnerfamily),main=expression(x[0] == 10))
dev.copy2eps(file="meixner-like.eps",width = 4.8, height = 4.8)