fixing interpolation over volatility surface graph in R programming

Question

This script below pulls yahoo data via a function in quantmod, then massages the data around to forumalate a 3D graph with RGL library, attached is a ggplot to show the data i'm trying to create a surface with in separate line geoms . the issue is that the 3D graph looks very ugly and cut up because of the limited quantities of points on the front month expirations.. can anyone tell me whats going on here , what i can do to fix this.. do i need to smooth each expiration's line then interpolate.... ?? volsurface http://img15.imageshack.us/img15/7338/surface.png ggplot2_smile http://img402.imageshack.us/img402/1272/volatilitysmilegoog.png

library(RQuantLib)
library(quantmod)
library(rgl)
library(akima)
library(ggplot2)
library(plyr)

GetIV <- function(type, value,
                  underlying, strike,dividendYield, riskFreeRate, maturity, volatility,
                  timeSteps=150, gridPoints=151) {

    AmericanOptionImpliedVolatility(type, value,
                                    underlying, strike,dividendYield, riskFreeRate, maturity, volatility,
                                    timeSteps=150, gridPoints=151)$impliedVol
}


GetDelta <- function(type, underlying, strike,
                     dividendYield, riskFreeRate, maturity, volatility, 
                     timeSteps=150, gridPoints=149, engine="CrankNicolson") {

    AmericanOption(type,underlying, strike, dividendYield, riskFreeRate, maturity, volatility,
                   timeSteps=150, gridPoints=149, engine="CrankNicolson")$delta
}
# set what symbol you want vol surface for
underlying <- 'GOOG'
# set what your volatility forcast or assumption is
volforcast <- .25
# Get symbols current price
underlying.price <- getQuote(underlying,what=yahooQF("Last Trade (Price Only)"))$Last

OC <- getOptionChain(underlying, NULL)
#check data
head(OC)
lputs <- lapply(OC, FUN = function(x) x$puts[grep("[A-Z]\\d{6}[CP]\\d{8}$", rownames(x$puts)), ])
head(lputs) #check for NA values, yahoo returns all NA values sometimes
puts <- do.call('rbind', lputs )
#check data
head(puts,5)

symbols <- as.vector(unlist(lapply(lputs, rownames)))
expiries <- unlist(lapply(symbols, FUN = function(x) regmatches(x=x, regexpr('[0-9]{6}', x) )))
puts$maturity <- as.numeric((as.Date(expiries, "%y%m%d") - Sys.Date())/365)

puts$IV <- mapply(GetIV, value = puts$Ask, strike = puts$Strike, maturity = puts$maturity,
                  MoreArgs= list(type='put', underlying= underlying.price,
                                 dividendYield=0, riskFreeRate = 0.01,  
                                 volatility = volforcast), SIMPLIFY=TRUE)

puts$delta <- mapply(GetDelta, strike =  puts$Strike, volatility = puts$IV,
                     maturity = puts$maturity, MoreArgs= list(type='put', 
                                                              underlying=underlying.price, dividendYield=0, 
                                                              riskFreeRate = 0.01 ), SIMPLIFY=TRUE)

# subset out itm puts
puts <- subset(puts, delta < -.09 & delta > -.5 )

expiries.formated <- format(as.Date(levels(factor(expiries)), format = '%y%m%d'), "%B %d, %Y")

fractionofyear.levels <- levels(factor(puts$maturity))

xyz <- with(puts, interp(x=maturity, y=delta*100, z=IV*100, 
                         xo=sort(unique(maturity)), extrap=FALSE ))

with(xyz, persp3d(x,y,z, col=heat.colors(length(z))[rank(z)], xlab='maturity', 
                  ylab='delta', zlab='IV', main='IV Surface'))

putsplot <- ggplot(puts, aes(delta, IV, group = factor(maturity), color = factor(maturity))) +
    labs(x = "Delta", y = "Implied Volatilty", title="Volatility Smile", color = "GooG \nExpiration") +
    scale_colour_discrete( breaks=c(fractionofyear.levels),
                           labels=c(expiries.formated)) + 
    geom_line() +
    geom_point()

putsplot

Answer 1

The akima package is exactly what you need, but I think you need to decrease the number of interpolated points in your y-axis, the delta variable. The way you have it set right now uses the default 40-point grid.

# No interpolation on x-axis, but uses the default 40 point grid on the y-axis
xyz <- with(puts, interp(x=maturity, y=delta*100, z=IV*100, 
            xo=sort(unique(maturity)), extrap=FALSE ))
# By setting to use less points, it will "stretch" the surface over those points.
xyz <- with(puts, interp(x=maturity, y=delta*100, z=IV*100, 
            xo=sort(unique(maturity)), 
            yo=seq(min(delta*100), max(delta*100), length = 15), extrap=FALSE ))

You can play with the length variable in the seq function to get differing levels of smoothness.

---

I still don't completely understand what you want, but maybe you want to smooth by maturity? Here is what that would look like:

# This smooths just by x.
xyz <- with(puts, interp(x=maturity, y=delta*100, z=IV*100, 
            xo=seq(min(maturity), max(maturity), length = 5), 
            , extrap=FALSE ))

with(xyz, persp3d(x,y,z, col=heat.colors(length(z))[rank(z)], xlab='maturity', 
                  ylab='delta', zlab='IV', main='IV Surface'))