Question

我试图重复一些关于适用于泡沫预测的股票指数的LPPL的研究，并且我在将模型拟合到数据方面遇到了麻烦。我一直在使用以下论文来深入了解这个项目：http://arxiv.org/pdf/1002.1010v2.pdf他们已经对HSI进行了一些测试，http://arxiv.org/pdf/0905.0220v1.pdf我最初得到了我的想法。

我还尝试重现此stackoverflow帖子的结果但没有成功（遇到多个类似的问题，即已达到最大迭代器，再次出现奇异的梯度矩阵错误）：NLS And Log-Periodic Power Law (LPPL) in R

使用每日价格以适应模型没有取得多大成功，我根据HSI LPPL文件结论中的建议使用了S＆amp; P的每周价格，数据应该是平滑的＆＃34;在某种程度上。

以下是我正在使用的代码。关于如何解决我的问题的建议将不胜感激！

library(zoom)
library(minpack.lm)
library(tseries)
library(zoo)

#grab S&P500 historical
ts <- get.hist.quote(instrument="^GSPC", 
                     start="2003-02-15", end="2007-10-31", 
                     quote="Close", provider="yahoo", origin="1970-01-01",
                     compression="w", retclass="zoo")
df <- data.frame(ts)
df <- data.frame(Date=as.Date(rownames(df)),Y=df$Close)
df <- df[!is.na(df$Y),]
df$days <- as.numeric(df$Date - df[1,]$Date)
ts <- get.hist.quote(instrument="^GSPC", 
                     start="1997-10-04", end="2011-10-12", 
                     quote="Close", provider="yahoo", origin="1970-01-01",
                     compression="w", retclass="zoo")
df2 <- data.frame(ts)
df2 <- data.frame(Date=as.Date(rownames(df2)),Y=df2$Close)
df2 <- df2[!is.na(df2$Y),]
df2$days <- as.numeric(df2$Date - df2[1,]$Date)



f <- function(pars, xx) 
  with(pars,(a + ((tc - xx)^m) *b + c *(tc - xx)^m* cos(omega*log(tc - xx))+d *(tc - xx)^m* cos(omega*log(tc - xx))))
# residual function
resids <- function(p, observed, xx) {df$Y - f(p,xx)}

plot(df2$Date,df2$Y,type="l")
lines(df$Date,df$Y,type="l")
points(df$Date,df$Y,type="p")


pp = list(a=1662.239,b=-0.483332,tc=2050, m=0.97, omega=5, c=566, d=-566)
lines(df$Date,f(pars=pp,df$days),type="l")


nls.out <- nls.lm(par=pp, fn = resids, observed = df$Y, xx = df$days, control=nls.lm.control(maxiter=1000),lower = c(a = -Inf, b = -Inf, tc = 2008, m = 0.1, omega = 0.1, c = -Inf, d = -Inf), upper = c(a = Inf, b = -0.01, tc = 2050, m = 0.97, omega = 15, c = 3000, d = 3000))
par <- nls.out$par
par
lines(df$Date,f(par,df$days), col ="blue")
nls.out <- nls.lm(par=nls.out$par, fn = resids, observed = df$Y, xx = df$days, control=nls.lm.control(maxiter=1000),lower = c(a = -Inf, b = -Inf, tc = 2008, m = 0.1, omega = 3, c = -Inf, d = -Inf), upper = c(a = Inf, b = -0.01, tc = 2025, m = 0.999, omega = 10, c = Inf, d = Inf))


lines(df$Date,f(nls.out$par,df$days), col ="purple")
ppp = nls.out$par

lines(df$Date,f(ppp,df$days), col ="purple")

nls.final <- nls(Y~(a + ((tc - df$days)^m) * (b + c * cos(omega*log(tc - df$days))+d * cos(omega*log(tc - df$days)))), data=df, start=ppp, algorithm="port", control=nls.control(maxiter=1000, minFactor=1e-8), lower = c(a = -Inf, b = -Inf, tc = 2007, m = 0.01, omega = 6, c = -Inf, d = -Inf), upper = c(a = Inf, b = 0, tc = 2010, m = 0.999, omega = 10, c = Inf, d = Inf))
summary(nls.final) # display statistics of the fit
lines(df$Date,fitted(nls.final), col = "red")

# append fitted values to df

df$pred <- predict(nls.final, interval = "confidence")


summ = coef(summary(nls.final))

R LPPL研究再现奇异梯度矩阵

0 个答案: