Fixing Interpolation über Volatilität Oberflächendiagramm in R Programmierung

Question

Dieses Skript unten zieht Yahoo Daten über eine Funktion in Quantmod, dann massiert die Daten um forumalate ein 3D-Diagramm mit RGL-Bibliothek, angefügt ist ein GGplot, um die Daten zu zeigen, die ich versuche um eine Oberfläche mit getrennten Geometrien zu erzeugen. Das Problem ist, dass das 3D-Diagramm sehr hässlich aussieht und aufgrund der begrenzten Anzahl von Punkten auf den vorderen Monatsabläufen zerschneidet. Kann mir jemand sagen, was hier los ist, was ich tun kann, um das zu beheben ... muss ich glätten Jede Linie der Exspiration interpoliert dann ... ?? 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

Das akima Paket ist genau das, was Sie brauchen, aber ich glaube, Sie die Anzahl der Interpolationspunkte in der y-Achse, die delta Variable Abnahme benötigen. Die Art und Weise, wie Sie es jetzt eingestellt haben, verwendet das Standard-Raster mit 40 Punkten.

# 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)) 

Sie mit der Länge variabel in der seq Funktion spielen können unterschiedliche Ebenen der Glätte zu erhalten.

---

ich immer noch nicht ganz verstehen, was Sie wollen, aber vielleicht wollen Sie von maturity glätten? Hier ist, was das aussehen würde:

# 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'))