inst/doc/Change_in_Mean.R

In memochange: Testing for Structural Breaks under Long Memory and Testing for Changes in Persistence

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

## ---- echo = TRUE, fig.height = 4, fig.width = 7, fig.align = "center"--------
utils::data(nhtemp)
graphics::plot(nhtemp)

## ---- echo = TRUE-------------------------------------------------------------
strucchange::sctest(strucchange::efp(nhtemp ~ 1, type = "OLS-CUSUM"))

## ---- echo = TRUE, fig.height = 4, fig.width = 7, fig.align = "center"--------
T            <- 1000
series_short <- fracdiff::fracdiff.sim(n=T,d=0)$series
series_long  <- fracdiff::fracdiff.sim(n=T,d=0.45)$series

graphics::par(mfrow=c(1,2))
stats::acf(series_short,main="short memory")
stats::acf(series_long,main="long memory")

## ---- echo = TRUE-------------------------------------------------------------
set.seed(410)
T                  <- 500
N                  <- 500
results_short      <- vector("numeric",N)
results_long       <- vector("numeric",N)
for(i in 1:N)
{
  series_short     <- fracdiff::fracdiff.sim(n=T,d=0)$series
  series_long      <- fracdiff::fracdiff.sim(n=T,d=0.45)$series
  results_short[i] <- strucchange::sctest(strucchange::efp(series_short ~ 1, type = "OLS-CUSUM"))$p.value<0.05
  results_long[i]  <- strucchange::sctest(strucchange::efp(series_long ~ 1, type = "OLS-CUSUM"))$p.value<0.05
}
mean(results_short)
mean(results_long)

## ---- echo = TRUE-------------------------------------------------------------
nasdaq=data.table::fread("https://fred.stlouisfed.org/graph/fredgraph.csv?bgcolor=%23e1e9f0&chart_type=line&drp=0&fo=open%20sans&graph_bgcolor=%23ffffff&height=450&mode=fred&recession_bars=on&txtcolor=%23444444&ts=12&tts=12&width=1168&nt=0&thu=0&trc=0&show_legend=yes&show_axis_titles=yes&show_tooltip=yes&id=NASDAQCOM&scale=left&cosd=2006-01-01&coed=2009-01-01&line_color=%234572a7&link_values=false&line_style=solid&mark_type=none&mw=3&lw=2&ost=-99999&oet=99999&mma=0&fml=a&fq=Daily&fam=avg&fgst=lin&fgsnd=2009-06-01&line_index=1&transformation=lin&vintage_date=2019-11-04&revision_date=2019-11-04&nd=1971-02-05")

## ---- echo = TRUE, fig.height = 4, fig.width = 7, fig.align = "center"--------
nasdaq[NASDAQCOM==".", NASDAQCOM := NA]
nasdaq              <- as.data.frame(nasdaq)
nasdaq              <- stats::na.omit(nasdaq)
nasdaq$NASDAQCOM    <- as.numeric(nasdaq$NASDAQCOM)
nasdaq$DATE=zoo::as.Date(nasdaq$DATE)
nasdaq_xts=xts::xts(nasdaq[,-1],order.by = nasdaq$DATE)
nasdaq_xts          <- log(diff(nasdaq_xts)^2)[-1]
graphics::par(mfrow=c(1,1))
zoo::plot.zoo(nasdaq_xts, xlab="", ylab="Log squared returns", main="Log squared returns of the NASDAQ")

## ---- echo = TRUE-------------------------------------------------------------
T           <- length(nasdaq_xts)
x           <- as.numeric(nasdaq_xts)
d_est       <- LongMemoryTS::local.W(x, m=floor(1+T^0.65))$d
round(d_est,3)

## ---- echo = TRUE-------------------------------------------------------------
library(memochange)
CUSUMfixed(x,d=d_est,procedure="CUSUMfixedm_typeA",bandw=10)

## ---- echo = TRUE-------------------------------------------------------------
BP       <- strucchange::breakpoints(x~1)$breakpoints
BP_index <- zoo::index(nasdaq_xts[BP])
BP_index

## ---- echo = TRUE, fig.height = 4, fig.width = 7, fig.align = "center"--------
T_index  <- zoo::index(nasdaq_xts[T])
m1       <- mean(nasdaq_xts[1:BP])
m2       <- mean(nasdaq_xts[(BP+1):T])
zoo::plot.zoo(nasdaq_xts, xlab="", ylab="Log squared returns", main="Log squared returns of the NASDAQ")
graphics::segments(0,m1,BP_index,m1,col=2,lwd=2)
graphics::segments((BP_index+1),m2,T_index,m2,col=2,lwd=2)

## ---- echo = TRUE, eval=FALSE-------------------------------------------------
#  
#  test_func<-function(T,d)
#  {
#    # Simulate a fractionally integrated (long-memory) time series of
#    # length T with memory d that is not subject to a shift.
#    tseries     <- fracdiff::fracdiff.sim(n=T,d=d)$series
#  
#    # Simulate a fractionally integrated (long-memory) time series of
#    # length T with memory d that is subject to a shift in the middle of
#    # the sample of magnitude 2.
#    changep     <- c(rep(0,T/2),rep(2,T/2))
#    tseries2    <- tseries+changep
#  
#    # Estimate the long-memory parameter of both series using the suggested bandwidth.
#    d_est       <- LongMemoryTS::local.W(tseries, m=floor(1+T^0.65))$d
#    d_est2      <- LongMemoryTS::local.W(tseries2, m=floor(1+T^0.65))$d
#  
#    # Apply both functions on both time series. Arguments are chosen according to
#    # Wenger, Leschinski (2019) who propose these tests.
#    typeAsize   <- CUSUMfixed(tseries,d=d_est,procedure="CUSUMfixedm_typeA",bandw=10)
#    typeBsize   <- CUSUMfixed(tseries,d=d_est,procedure="CUSUMfixedm_typeB",bandw=10)
#    typeApower  <- CUSUMfixed(tseries2,d=d_est2,procedure="CUSUMfixedm_typeA",bandw=10)
#    typeBpower  <- CUSUMfixed(tseries2,d=d_est2,procedure="CUSUMfixedm_typeB",bandw=10)
#  
#    # Save if the tests reject at the 5% significance level.
#    decAsize    <- typeAsize["Teststatistic"] > typeAsize["95%"]
#    decBsize    <- typeBsize["Teststatistic"] > typeBsize["95%"]
#    decApower   <- typeApower["Teststatistic"] > typeApower["95%"]
#    decBpower   <- typeBpower["Teststatistic"] > typeBpower["95%"]
#  
#    return(c(decAsize,decBsize,decApower,decBpower))
#  }

## ---- echo = TRUE, eval=FALSE-------------------------------------------------
#  set.seed(410)
#  # Parameter setting considered
#  T_grid              <- c(50,100)
#  d_grid              <- c(0.1,0.2)
#  N                   <- 500
#  
#  # Generate array to save the results
#  resultmat           <- array(NA, dim=c(length(T_grid),length(d_grid),4))
#  dimnames(resultmat) <- list(paste("T=",T_grid,sep=""),paste("d=",d_grid,sep=""),
#                              paste(rep(c("type-A","type-B"),2),c("size","size","power","power"),sep=" "))
#  
#  # Monte Carlo simulation
#  for(TTT in 1:length(T_grid))
#  {
#    T <- T_grid[TTT]
#    for(ddd in 1:length(d_grid))
#    {
#      d                 <- d_grid[ddd]
#      result_vec        <- 0
#      for(i in 1:N)
#      {
#      result_vec        <- result_vec+test_func(T,d)
#      }
#    resultmat[TTT,ddd,] <- result_vec/N
#    }
#  }
#  # Results
#  resultmat
#  #> , , type-A size
#  #>
#  #>       d=0.1 d=0.2
#  #> T=50  0.020 0.032
#  #> T=100 0.026 0.046
#  #>
#  #> , , type-B size
#  #>
#  #>       d=0.1 d=0.2
#  #> T=50  0.016 0.028
#  #> T=100 0.036 0.046
#  #>
#  #> , , type-A power
#  #>
#  #>       d=0.1 d=0.2
#  #> T=50   0.86 0.824
#  #> T=100  1.00 0.960
#  #>
#  #> , , type-B power
#  #>
#  #>       d=0.1 d=0.2
#  #> T=50  0.830 0.770
#  #> T=100 0.998 0.938