├── README.md
├── Errata.md
├── chap6.md
└── textRcode.md


/README.md:
--------------------------------------------------------------------------------
 1 | <img src="https://github.com/nickpoison/astsa/blob/master/fun_with_astsa/figs/tsa4.jpg" alt="tsa4"  height="200" > 
 2 | 
 3 |  #### &#10024; Here is [A Road Map](https://nickpoison.github.io/) if you want a broad view of what is available.
 4 | 
 5 | &#10024; Follow this link if you are looking for the [5th Edition](https://github.com/nickpoison/tsa5/)
 6 | 
 7 |  <br/>
 8 | 
 9 | ## tsa4
10 | 
11 | - All the (updated) code used in the text  is in [textRcode.md](https://github.com/nickpoison/tsa4/blob/master/textRcode.md)
12 | 
13 | 
14 | - Edition 4 errata is here: [Errata](https://github.com/nickpoison/tsa4/blob/master/Errata.md)
15 | 
16 | 
17 | ## astsa
18 | 
19 | - The home of [astsa - the package for the text](https://github.com/nickpoison/astsa) is here too.
20 | 
21 | - See the [NEWS](https://github.com/nickpoison/astsa/blob/master/NEWS.md) for further details about the state of the package and the changelog.
22 | 
23 | - A demonstration of the capabilities of `astsa` can be found here at
24 | [**FUN WITH ASTSA**](https://github.com/nickpoison/astsa/blob/master/fun_with_astsa/fun_with_astsa.md)
25 | 
26 | 
27 | ## python
28 | 
29 | - The [code in the first 3 chapters of the text has been converted to Python here.](https://github.com/borisgarbuzov/tsa4-python/tree/master/src) 
30 | 
31 | - And a [Python package that contains datasets from `astsa` is here.](https://pypi.org/project/astsadata/)
32 | 
33 | - _Why use Python if you can use R?_ &nbsp; &nbsp; -Mr Natural
34 | 
35 | &emsp; &ensp;<img src="https://github.com/nickpoison/astsa/blob/master/fun_with_astsa/figs/tool.png" alt="mr natch">
36 | 
37 | 


--------------------------------------------------------------------------------
/Errata.md:
--------------------------------------------------------------------------------
 1 | ## Edition 4 Errata  
 2 | 
 3 | _[aides who called tRump a moron](https://www.politico.com/story/2018/09/04/trumps-insults-idiot-woodward-806455) ... now let's go_
 4 | 
 5 | <br/>
 6 | 
 7 | ### Chapter 1 
 8 | 
 9 | - it's perfect
10 | 
11 | ### Chapter 2 
12 | 
13 |  __Eq (2.38)-(2.39):__ To be more general, the time subscript should have been $t_i$ so the equations would read $$m_t = \sum_{i=1}^n  w_i(t) x_{t_i}  \tag{2.38}$$ where<br/><br/>
14 |    $$~~~~~~~~~~~~~~~~~~~~~~~~w_i(t)= K\bigl(\tfrac{t-{t_i}}{b}\bigr) \Bigm/   \sum_{j=1}^n K\bigl(\tfrac{t-{t_j}}{b}\bigr) \tag{2.39}$$
15 |  <br/><br/>
16 | ... and typically $K(z)=\exp(-z^2/2)$ is used (no need for constants because the weights are normalized).
17 | 
18 | 
19 | So these two are the same:
20 | ```r
21 | par(mfrow=c(2,1))
22 | tsplot(soi)      # monthly data; frequency=12 and t = 1/12, 2/12, ...
23 | lines(ksmooth(time(soi), soi, kernel="normal", bandwidth=1), lwd=2, col=4)
24 | # and
25 | SOI = ts(soi, frequency=1)   # change to t = 1,2,... 
26 | tsplot(SOI)   
27 | lines(ksmooth(time(SOI), SOI, kernel="normal", bandwidth=12), lwd=2, col=4)
28 | ```
29 | 
30 |  
31 | 
32 | ###  Chapter 3 
33 | 
34 | - __Eq (3.10):__ The sum should be to $k$ (and not $k-1$):  $~x_t = \phi^{-k} x_{t+k} - \sum_{j=1}^{k} \phi^{-j} w_{t+j}\,.$
35 | 
36 | 
37 | ### Chapter 4 
38 | 
39 | - as if
40 | 
41 | 
42 | ### Chapter 5 
43 | 
44 |  - __Example 5.1:__ I put this note on the R code page, but I thought I'd repeat it here. 
45 | In Example 5.1, we used <kbd>fracdiff</kbd>, but it's not a very good package. 
46 | We should have used another package such as <kbd>arfima</kbd>, but unfortunately it didn't make it into the revision. This is changed in Edition 5: 
47 | 
48 | ```r
49 | library(arfima)
50 | summary(varve.fd <- arfima(log(varve)))  # d.hat = 0.3728, se(d,hat) = 0.0273
51 | # residual stuff
52 | innov = resid(varve.fd)  
53 | plot.ts(innov[[1]])  
54 | acf(innov[[1]])
55 | ```
56 | 
57 | ### Chapter 6 
58 | 
59 |  - __Property 6.7, equation (6.137):__ Left off the conditioning arguments ... the $\pi_j(t)$  in the numerator and in the denominator  should be $\pi_j(t \mid t-1)$ . 
60 | 
61 |  - __Example 6.13:__  There is a correction in the code for this example.  The correction has been made here [textRcode](https://github.com/nickpoison/tsa4/blob/master/textRcode.md).  Under Example 6.13 code, the correction is for bootstrapping (lines 60-63) and the results are a little different (but the discussion is still correct):
62 | 
63 |    ```r
64 |     for (j in k){               # this is line 60
65 |       K  = (phi*Pp[j-1]*z[j-1])/sig[j-1]  
66 |      xp.star[j] = phi*xp.star[j-1] + Ups + K*sqrt(sig[j-1])*e.star[j-1]
67 |      } 
68 |    ```
69 | 
70 |    
71 | 
72 | 
73 | ### Chapter 7 
74 | 
75 | - not enough people read this chapter to find the bloopers ... but we're fairly certain there are a few
76 | 
77 | 
78 | ###  Elsewhere
79 | 
80 |  - FYI: In Edition 5, Appendix R has been removed and put online  here: [dsstoffer.github.io/Rtoot](https://dsstoffer.github.io/Rtoot)
81 | 
82 | 
83 | <br/><br/><br/>
84 | 


--------------------------------------------------------------------------------
/chap6.md:
--------------------------------------------------------------------------------
   1 | ## Chapter 6 - Old Kalman Filter and Smoother Details and Code
   2 | 
   3 | 
   4 | 
   5 | > __Note__ The old Kalman filter and smoother scripts and the EM scripts now are marked with an `x` ... e.g., `Kfilter1` is now `xKfilter1` etc. etc. etc. BUT, older scripts can be changed to the newer ones with only slight changes.  The gain in speed is worth the effort!!
   6 | 
   7 | > __Warning__ Eventually, the old scripts with an `x` prefix will be removed.
   8 | <br/><br/>
   9 | 
  10 | ---
  11 | 
  12 | ### &#128685; this is the OLD stuff and will NOT work in version 2.0 or later
  13 | 
  14 | The  three levels of code  `Kfilter0/Ksmooth0`,  `Kfilter1/Ksmooth1`, and `Kfilter2/Ksmooth2`
  15 | have been superseded by the newer `Kfilter` and `Ksmooth` scripts. The new scripts are faster, easier to work with, and they remove the need for 3 different scripts.  
  16 | 
  17 | This page contains a description of the old code and lists the older Chapter 6 code. What you see here does NOT apply anymore. 
  18 | 
  19 | ### StaRt Old Stuff:
  20 | 
  21 | 
  22 | + For various models, each script provides the Kalman filter/smoother, the innovations
  23 |  and the corresponding variance-covariance matrices, and the value of the innovations likelihood at the location of the parameter values passed to the script. MLE is then accomplished by calling  the script that runs the filter. _The model is specified by passing the model parameters._
  24 | 
  25 | 
  26 | + Level 0 is for the case of a fixed measurement matrix and no inputs; i.e., if  A<sub>t</sub> = A for all t, and there are no inputs,   then use the code at level 0.  
  27 |     
  28 | +  If the measurement matrices are time varying or there are inputs, use the  code at a higher level (1 or 2).   Many of the examples in the text can be done at level 0.
  29 |     
  30 |     
  31 | + Level 1 allows for time varying measurement matrices and inputs, and level 2 adds
  32 |     the possibility of correlated noise processes. 
  33 |     
  34 | The models for each case are (x is state, y is observation, and t = 1, &hellip;, n):
  35 |    
  36 | &diams; **Level 0:** &nbsp; &nbsp; x<sub>t</sub> = &Phi; x<sub>t-1</sub> + w<sub>t</sub>, &nbsp; &nbsp; y<sub>t</sub> = A x<sub>t</sub> + v<sub>t</sub>, &nbsp; &nbsp; w<sub>t</sub> ~ iid N<sub>p</sub>(0, Q) &perp;   v<sub>t</sub> ~ iid N<sub>q</sub>(0, R) &perp; x<sub>0</sub> ~ N<sub>p</sub>(&mu;<sub>0</sub>, &Sigma;<sub>0</sub>)
  37 | 
  38 | &diams; **Level 1:**  &nbsp; &nbsp;  x<sub>t</sub> = &Phi; x<sub>t-1</sub> +  &Upsilon; u<sub>t</sub> + w<sub>t</sub>,  &nbsp; &nbsp;  y<sub>t</sub> = A<sub>t</sub> x<sub>t</sub> +  &Gamma; u<sub>t</sub> + v<sub>t</sub>,  &nbsp;   u<sub>t</sub> are r-dimensional inputs, etc.<br>
  39 |      
  40 | &diams; **Level 2:** &nbsp; &nbsp; x<sub>t</sub> = &Phi; x<sub>t-1</sub> +  &Upsilon; u<sub>t</sub> + &Theta; w<sub>t-1</sub>, &nbsp;   &nbsp;   y<sub>t</sub> = A<sub>t</sub> x<sub>t</sub> +  &Gamma; u<sub>t</sub> + v<sub>t</sub>, &nbsp;  cov(w<sub>s</sub>, v<sub>t</sub>) = S &delta;<sub>s</sub><span style="position:relative; left: -.9ex; bottom: 2pt"><sup>t</sup></span>, &nbsp; &Theta; is p &times; m, and w<sub>t</sub> is m-dimensional, etc.
  41 | 
  42 | ---  
  43 |     
  44 | ### Level 0 - Fixed Measurement Matrices and No Inputs  
  45 |    
  46 |   The call to Kfilter0 is,   `Kfilter0(n,y,A,mu0,Sigma0,Phi,cQ,cR)` in fairly obvious notation   except that `cQ` and   `cR` are the Cholesky-type decompositions of 
  47 |   `Q` and `R`.  In particular `Q = t(cQ)%*%cQ` and `R = t(cR)%*%cR` is all that is required provided `Q`and `R` are valid covariance matrices (Q can be singular and there is an example in the text).   The call to `Ksmooth0` is similar. 
  48 | 
  49 |  __In all three cases, the smoother also returns the filter and the likelihood.__
  50 |   
  51 | ---
  52 |  	
  53 | ### Level 1 - Varying Measurement Matrices and Inputs
  54 |        
  55 |  The call to the filter is `Kfilter1(n,y,A,mu0,Sigma0,Phi,Ups,Gam,cQ,cR,input)` 
  56 |    where `A` is an array with `dim=c(q,p,n)`,  `Ups` is &Upsilon; [p &times; r],  `Gam`is &Gamma; [q &times; r],    and `input` is the matrix of inputs
  57 |      that has the same row dimension as y (which  is n &times; q), `input`is n &times; r; the state dimension is p).  The call to `Ksmooth1`is similar.  Set  `Ups`, `Gam`, or `input` to 0 (zero) if you  don't  use them. 
  58 |  
  59 | ---  
  60 |   		
  61 | ### Level 2 - Varying Measurement Matrices,  Inputs and Correlated Noise</h3>  
  62 |    
  63 | The call to the filter is `Kfilter2(n,y,A,mu0,Sigma0,Phi,Ups,Gam,Theta,cQ,cR,S,input)`, which is similar to `Kfilter1` but that `S` must be included.  `Kfilter2` runs the filter given in Property 6.5.  The call to `Ksmooth2` is similar. Set `Ups` or `Gam` or `input` to 0 (zero) if you don't  use them.   
  64 | 
  65 | ---
  66 | ---
  67 | 
  68 | ## OLD Chapter 6 Code
  69 | 
  70 | Example 6.1
  71 | ```r
  72 | tsplot(blood, type='o', col=c(6,4,2), lwd=2, pch=19, cex=1) 
  73 | ```
  74 | 
  75 | Example 6.2
  76 | ```r
  77 | tsplot(cbind(globtemp, globtempl), spag=TRUE, lwd=2, col=astsa.col(c(6,4),.5), ylab="Temperature Deviations")
  78 | 
  79 | # or the updated version (one is land only and the other ocean only)
  80 | tsplot(cbind(gtemp_land, gtemp_ocean), spaghetti=TRUE, lwd=2, pch=20, type="o", 
  81 |         col=astsa.col(c(4,2),.5), ylab="Temperature Deviations", main="Global Warming")
  82 | legend("topleft", legend=c("Land Surface", "Sea Surface"), lty=1, pch=20, col=c(4,2), bg="white")
  83 | ```
  84 | 
  85 | Example 6.5
  86 | ```r
  87 | # generate data 
  88 | set.seed(1)  
  89 | num = 50
  90 | w = rnorm(num+1,0,1)
  91 | v = rnorm(num,0,1)
  92 |                                
  93 | mu = cumsum(w)  # states:  mu[0], mu[1], . . ., mu[50] 
  94 | y = mu[-1] + v  # obs:  y[1], . . ., y[50]
  95 | 
  96 | # filter and smooth (Ksmooth0 does both)
  97 | mu0 = 0; sigma0 = 1;  phi = 1; cQ = 1; cR = 1   
  98 | ks = Ksmooth0(num, y, 1, mu0, sigma0, phi, cQ, cR)   
  99 | 
 100 | # pictures 
 101 | par(mfrow=c(3,1))
 102 | Time = 1:num
 103 | 
 104 | tsplot(Time, mu[-1], type='p', main="Prediction", ylim=c(-5,10))      
 105 |   lines(ks$xp)
 106 |   lines(ks$xp+2*sqrt(ks$Pp), lty="dashed", col="blue")
 107 |   lines(ks$xp-2*sqrt(ks$Pp), lty="dashed", col="blue")
 108 | 
 109 | tsplot(Time, mu[-1], type='p', main="Filter", ylim=c(-5,10))
 110 |   lines(ks$xf)
 111 |   lines(ks$xf+2*sqrt(ks$Pf), lty="dashed", col="blue")
 112 |   lines(ks$xf-2*sqrt(ks$Pf), lty="dashed", col="blue")
 113 | 
 114 | tsplot(Time, mu[-1], type='p',  main="Smoother", ylim=c(-5,10))
 115 |   lines(ks$xs)
 116 |   lines(ks$xs+2*sqrt(ks$Ps), lty="dashed", col="blue")
 117 |   lines(ks$xs-2*sqrt(ks$Ps), lty="dashed", col="blue") 
 118 | 
 119 | mu[1]; ks$x0n; sqrt(ks$P0n)   # initial value info
 120 | 
 121 | # In case you can't see the differences in the figures...
 122 | # ... either get new glasses or ... 
 123 | # ... plot them on the same graph (not shown in text)
 124 | dev.new()
 125 | tsplot(Time, mu[-1], type='o', pch=19, cex=1)
 126 | lines(ks$xp, col=4, lwd=3)
 127 | lines(ks$xf, col=3, lwd=3) 
 128 | lines(ks$xs, col=2, lwd=3)
 129 | names = c("predictor","filter","smoother")
 130 | legend("bottomright", names, col=4:2, lwd=3, lty=1, bg="white")
 131 | ```
 132 | 
 133 | 
 134 | Example 6.6
 135 | ```r
 136 | # Generate Data
 137 | set.seed(999)
 138 | num = 100
 139 | N = num+1
 140 | x = sarima.sim(n=N, ar=.8)
 141 | # below used in text
 142 | # x = arima.sim(n=N, list(ar = .8))
 143 | y = ts(x[-1] + rnorm(num,0,1))     
 144 | 
 145 | # Initial Estimates 
 146 | u = ts.intersect(y, lag(y,-1), lag(y,-2)) 
 147 | varu = var(u)
 148 | coru = cor(u) 
 149 | phi = coru[1,3]/coru[1,2]             
 150 | q = (1-phi^2)*varu[1,2]/phi   
 151 | r = varu[1,1] - q/(1-phi^2) 
 152 | (init.par = c(phi, sqrt(q), sqrt(r))) 
 153 | 
 154 | # Function to evaluate the likelihood 
 155 | Linn=function(para){
 156 |   phi = para[1]; sigw = para[2]; sigv = para[3]   
 157 |   Sigma0 = (sigw^2)/(1-phi^2); Sigma0[Sigma0<0]=0   
 158 |   kf = Kfilter0(num,y,1,mu0=0,Sigma0,phi,sigw,sigv)
 159 |   return(kf$like)   
 160 |   }
 161 | 
 162 | # Estimation  
 163 | (est = optim(init.par, Linn, gr=NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))      
 164 | SE = sqrt(diag(solve(est$hessian)))
 165 | cbind(estimate=c(phi=est$par[1],sigw=est$par[2],sigv=est$par[3]), SE)
 166 | ```
 167 | 
 168 | 
 169 | 
 170 | Example 6.7
 171 | ```r
 172 | ##- slight change from text, the data scaled -##
 173 | ##- you can remove the scales to get to the original analysis -##
 174 | # Setup 
 175 | y = cbind(globtemp/sd(globtemp), globtempl/sd(globtempl))
 176 | num = nrow(y)
 177 | input = rep(1,num)
 178 | A = array(rep(1,2), dim=c(2,1,num))
 179 | mu0 = -.35; Sigma0 = 1;  Phi = 1
 180 | 
 181 | # Function to Calculate Likelihood 
 182 | Linn=function(para){
 183 |  cQ = para[1]      # sigma_w
 184 |   cR1 = para[2]    # 11 element of chol(R)
 185 |   cR2 = para[3]    # 22 element of chol(R)
 186 |   cR12 = para[4]   # 12 element of chol(R)
 187 |  cR = matrix(c(cR1,0,cR12,cR2),2)  # put the matrix together
 188 |  drift = para[5]
 189 |  kf = Kfilter1(num,y,A,mu0,Sigma0,Phi,drift,0,cQ,cR,input)
 190 |  return(kf$like) 
 191 |  }
 192 | 
 193 | # Estimation
 194 | init.par = c(.1,.1,.1,0,.05)  # initial values of parameters
 195 | (est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1))) 
 196 | SE = sqrt(diag(solve(est$hessian))) 
 197 | 
 198 | # Summary of estimation  
 199 | estimate = est$par; u = cbind(estimate, SE)
 200 | rownames(u)=c("sigw","cR11", "cR22", "cR12", "drift"); u  
 201 | 
 202 | # Smooth (first set parameters to their final estimates)
 203 | cQ    = est$par[1]  
 204 |  cR1  = est$par[2]   
 205 |  cR2  = est$par[3]   
 206 |  cR12 = est$par[4]  
 207 | cR    = matrix(c(cR1,0,cR12,cR2), 2)
 208 | (R    = t(cR)%*%cR)    #  to view the estimated R matrix
 209 | drift = est$par[5]  
 210 | ks    = Ksmooth1(num,y,A,mu0,Sigma0,Phi,drift,0,cQ,cR,input)  
 211 | 
 212 | # Plot 
 213 | tsplot(y, spag=TRUE, margins=.5, type='o', pch=2:3, col=4:3, lty=6, ylab='Temperature Deviations')
 214 | xsm  = ts(as.vector(ks$xs), start=1880)
 215 | rmse = ts(sqrt(as.vector(ks$Ps)), start=1880)
 216 | lines(xsm, lwd=2)
 217 |   xx = c(time(xsm), rev(time(xsm)))
 218 |   yy = c(xsm-2*rmse, rev(xsm+2*rmse))
 219 | polygon(xx, yy, border=NA, col=gray(.6, alpha=.25))
 220 | ```
 221 | 
 222 | 
 223 | Example 6.8
 224 | ```r
 225 | library(nlme)   # loads package nlme (comes with R)
 226 | 
 227 | # Generate data (same as Example 6.6)
 228 | set.seed(999); num = 100; N = num+1
 229 | x = sarima.sim(ar=.8, n=N)
 230 | y = ts(x[-1] + rnorm(num,0,1))     
 231 | 
 232 | # Initial Estimates 
 233 | u = ts.intersect(y,lag(y,-1),lag(y,-2)) 
 234 | varu = var(u); coru = cor(u) 
 235 | phi = coru[1,3]/coru[1,2]             
 236 | q = (1-phi^2)*varu[1,2]/phi   
 237 | r = varu[1,1] - q/(1-phi^2) 
 238 | cr = sqrt(r); cq = sqrt(q); mu0 = 0; Sigma0 = 2.8
 239 | (em = EM0(num, y, 1, mu0, Sigma0, phi, cq, cr, 75, .00001))   
 240 | 
 241 | # Standard Errors  (this uses nlme)
 242 | phi = em$Phi; cq = chol(em$Q); cr = chol(em$R)
 243 | mu0 = em$mu0; Sigma0 = em$Sigma0
 244 | para = c(phi, cq, cr)
 245 | 
 246 | # Evaluate likelihood at estimates 
 247 | Linn=function(para){
 248 |   kf = Kfilter0(num, y, 1, mu0, Sigma0, para[1], para[2], para[3])
 249 |   return(kf$like) 
 250 |   }
 251 | emhess = fdHess(para, function(para) Linn(para))
 252 | SE = sqrt(diag(solve(emhess$Hessian)))  
 253 | 
 254 | # Display summary of estimation 
 255 | estimate = c(para, em$mu0, em$Sigma0); SE = c(SE,NA,NA)
 256 | u = cbind(estimate, SE)
 257 | rownames(u) = c("phi","sigw","sigv","mu0","Sigma0")
 258 | u 
 259 | ```
 260 | 
 261 | 
 262 | Example 6.9
 263 | ```r
 264 | y    = cbind(WBC, PLT, HCT)
 265 | num  = nrow(y)       
 266 | A    = array(0, dim=c(3,3,num))  # creates num 3x3 zero matrices
 267 | for(k in 1:num) if (y[k,1] > 0) A[,,k]= diag(1,3) 
 268 | 
 269 | # Initial values 
 270 | mu0    = matrix(0,3,1) 
 271 | Sigma0 = diag(c(.1,.1,1) ,3)
 272 | Phi    = diag(1,3)
 273 | cQ     = diag(c(.1,.1,1), 3)
 274 | cR     = diag(c(.1,.1,1), 3)  
 275 | (em = EM1(num, y, A, mu0, Sigma0, Phi, cQ, cR, 100, .001))    
 276 | 
 277 | # Graph smoother
 278 | ks  = Ksmooth1(num, y, A, em$mu0, em$Sigma0, em$Phi, 0, 0, chol(em$Q), chol(em$R), 0)
 279 | y1s = ks$xs[1,,] 
 280 | y2s = ks$xs[2,,] 
 281 | y3s = ks$xs[3,,]
 282 | p1  = 2*sqrt(ks$Ps[1,1,]) 
 283 | p2  = 2*sqrt(ks$Ps[2,2,]) 
 284 | p3  = 2*sqrt(ks$Ps[3,3,])
 285 | 
 286 | par(mfrow=c(3,1))
 287 | tsplot(WBC, type='p', pch=19, ylim=c(1,5), col=6, lwd=2, cex=1)
 288 | lines(y1s) 
 289 |   xx = c(time(WBC), rev(time(WBC)))  # same for all
 290 |   yy = c(y1s-p1, rev(y1s+p1))
 291 | polygon(xx, yy, border=8, col=astsa.col(8, alpha = .1))  
 292 | 
 293 | tsplot(PLT, type='p', ylim=c(3,6), pch=19, col=4, lwd=2, cex=1)
 294 | lines(y2s)
 295 |   yy = c(y2s-p2, rev(y2s+p2))
 296 | polygon(xx, yy, border=8, col=astsa.col(8, alpha = .1))  
 297 | 
 298 | tsplot(HCT, type='p', pch=19, ylim=c(20,40), col=2, lwd=2, cex=1)
 299 | lines(y3s)
 300 |   yy = c(y3s-p3, rev(y3s+p3))
 301 | polygon(xx, yy, border=8, col=astsa.col(8, alpha = .1))  
 302 | ```
 303 | 
 304 | 
 305 | 
 306 | Example 6.10
 307 | ```r
 308 | num = length(jj)
 309 | A = cbind(1,1,0,0) 
 310 | 
 311 | # Function to Calculate Likelihood 
 312 | Linn=function(para){
 313 |  Phi = diag(0,4) 
 314 |  Phi[1,1] = para[1] 
 315 |  Phi[2,]=c(0,-1,-1,-1); Phi[3,]=c(0,1,0,0); Phi[4,]=c(0,0,1,0)
 316 |  cQ1 = para[2]; cQ2 = para[3]     # sqrt q11 and sqrt q22
 317 |  cQ=diag(0,4); cQ[1,1]=cQ1; cQ[2,2]=cQ2
 318 |  cR = para[4]                     # sqrt r11
 319 |  kf = Kfilter0(num,jj,A,mu0,Sigma0,Phi,cQ,cR)
 320 |  return(kf$like)  
 321 |  }
 322 | 
 323 | # Initial Parameters 
 324 | mu0      = c(.7,0,0,0) 
 325 | Sigma0   = diag(.04,4)  
 326 | init.par = c(1.03, .1, .1, .5)  # Phi[1,1], the 2 Qs and R
 327 | 
 328 | # Estimation
 329 | est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1))
 330 | SE  = sqrt(diag(solve(est$hessian)))
 331 | u   = cbind(estimate=est$par,SE)
 332 | rownames(u)=c("Phi11","sigw1","sigw2","sigv"); u     
 333 | 
 334 | # Smooth
 335 | Phi      = diag(0,4) 
 336 | Phi[1,1] = est$par[1] 
 337 | Phi[2,]  = c(0,-1,-1,-1) 
 338 | Phi[3,]  = c(0,1,0,0) 
 339 | Phi[4,]  = c(0,0,1,0)
 340 | cQ1      = est$par[2]
 341 | cQ2      = est$par[3]      
 342 | cQ       = diag(0,4)
 343 | cQ[1,1]  = cQ1 
 344 | cQ[2,2]  = cQ2   
 345 | cR       = est$par[4]   
 346 | ks       = Ksmooth0(num, jj, A, mu0, Sigma0, Phi, cQ, cR)   
 347 | 
 348 | # Plots
 349 | Tsm   = ts(ks$xs[1,,], start=1960, freq=4)
 350 | Ssm   = ts(ks$xs[2,,], start=1960, freq=4)
 351 | p1    = 3*sqrt(ks$Ps[1,1,]); p2 = 3*sqrt(ks$Ps[2,2,])
 352 | par(mfrow=c(2,1))
 353 | tsplot(Tsm, main='Trend Component', ylab='Trend')
 354 |   xx  = c(time(jj), rev(time(jj)))
 355 |   yy  = c(Tsm-p1, rev(Tsm+p1))
 356 | polygon(xx, yy, border=NA, col=gray(.5, alpha = .3))
 357 | tsplot(jj, main='Data & Trend+Season', ylab='J&J QE/Share', ylim=c(-.5,17))
 358 |   xx  = c(time(jj), rev(time(jj)) )
 359 |   yy  = c((Tsm+Ssm)-(p1+p2), rev((Tsm+Ssm)+(p1+p2)) )
 360 | polygon(xx, yy, border=NA, col=gray(.5, alpha = .3))
 361 | 
 362 | # Forecast
 363 | dev.new()
 364 | n.ahead = 12
 365 | y       = ts(append(jj, rep(0,n.ahead)), start=1960, freq=4)
 366 | rmspe   = rep(0,n.ahead) 
 367 | x00     = ks$xf[,,num]
 368 | P00     = ks$Pf[,,num]
 369 | Q       = t(cQ)%*%cQ 
 370 | R       = t(cR)%*%(cR)
 371 | for (m in 1:n.ahead){
 372 |        xp = Phi%*%x00
 373 |        Pp = Phi%*%P00%*%t(Phi)+Q
 374 |       sig = A%*%Pp%*%t(A)+R
 375 |         K = Pp%*%t(A)%*%(1/sig)
 376 |       x00 = xp 
 377 |       P00 = Pp-K%*%A%*%Pp
 378 |  y[num+m] = A%*%xp
 379 |  rmspe[m] = sqrt(sig) 
 380 | }
 381 | tsplot(y, type='o', main='', ylab='J&J QE/Share', ylim=c(5,30), xlim = c(1975,1984))
 382 | upp  = ts(y[(num+1):(num+n.ahead)]+2*rmspe, start=1981, freq=4)
 383 | low  = ts(y[(num+1):(num+n.ahead)]-2*rmspe, start=1981, freq=4)
 384 |  xx  = c(time(low), rev(time(upp)))
 385 |  yy  = c(low, rev(upp))
 386 | polygon(xx, yy, border=8, col=gray(.5, alpha = .3))
 387 | abline(v=1981, lty=3)
 388 | ```
 389 | 
 390 | 
 391 | 
 392 | Example 6.12
 393 | ```r
 394 | # Preliminary analysis
 395 | fit1   = sarima(cmort, 2,0,0, xreg=time(cmort))
 396 | acf(cbind(dmort <- resid(fit1$fit), tempr, part))
 397 | lag2.plot(tempr, dmort, 8)
 398 | lag2.plot(part, dmort, 8)
 399 | 
 400 | # quick and dirty fit (detrend then fit ARMAX)
 401 | trend   = time(cmort) - mean(time(cmort))  
 402 | dcmort  = resid(fit2 <- lm(cmort~trend, na.action=NULL))  # detrended mort
 403 | u       = ts.intersect(dM=dcmort, dM1=lag(dcmort,-1), dM2=lag(dcmort,-2), T1=lag(tempr,-1), P=part, P4=lag(part,-4))
 404 | sarima(u[,1], 0,0,0, xreg=u[,2:6])  # ARMAX fit with residual analysis 
 405 | 
 406 | # all estimates at once
 407 | trend   = time(cmort) - mean(time(cmort)) # center time
 408 | const   = time(cmort)/time(cmort)         # appropriate time series of 1s
 409 | ded     = ts.intersect(M=cmort, T1=lag(tempr,-1), P=part, P4=lag(part,-4), trend, const)
 410 | y       = ded[,1]
 411 | input   = ded[,2:6]
 412 | num     = length(y)
 413 | A       = array(c(1,0), dim = c(1,2,num))
 414 | 
 415 | # Function to Calculate Likelihood
 416 | Linn=function(para){
 417 |  phi1   = para[1]; phi2 = para[2]; cR = para[3];  b1 = para[4]
 418 |  b2     = para[5];   b3 = para[6]; b4 = para[7]; alf = para[8]
 419 |  mu0    = matrix(c(0,0), 2, 1)
 420 |  Sigma0 = diag(100, 2)
 421 |  Phi    = matrix(c(phi1, phi2, 1, 0), 2)
 422 |  Theta  = matrix(c(phi1, phi2), 2)
 423 |  Ups    = matrix(c(b1, 0, b2, 0, b3, 0, 0, 0, 0, 0), 2, 5)
 424 |  Gam    = matrix(c(0, 0, 0, b4, alf), 1, 5); cQ = cR; S = cR^2
 425 |  kf     = Kfilter2(num, y, A, mu0, Sigma0, Phi, Ups, Gam, Theta, cQ, cR, S, input)
 426 | return(kf$like) 
 427 | }
 428 | 
 429 | # Estimation - prelim analysis gives good starting values
 430 | init.par = c(phi1=.3, phi2=.3, cR=5, b1=-.2, b2=.1, b3=.05, b4=-1.6, alf=mean(cmort)) 
 431 | L = c( 0,  0,  1, -1,  0,  0, -2, 70)   # lower bound on parameters
 432 | U = c(.5, .5, 10,  0, .5, .5,  0, 90)   # upper bound - used in optim
 433 | est      = optim(init.par, Linn, NULL, method='L-BFGS-B', lower=L, upper=U, 
 434 |                  hessian=TRUE, control=list(trace=1, REPORT=1, factr=10^8))
 435 | SE       = sqrt(diag(solve(est$hessian)))
 436 | round(cbind(estimate=est$par, SE), 3) # results
 437 | 
 438 | # Residual Analysis (not shown)
 439 | phi1   = est$par[1]; phi2 = est$par[2]
 440 | cR     = est$par[3]; b1   = est$par[4]
 441 | b2     = est$par[5]; b3   = est$par[6]
 442 | b4     = est$par[7]; alf  = est$par[8]
 443 | mu0    = matrix(c(0,0), 2, 1)
 444 | Sigma0 = diag(100, 2)
 445 | Phi    = matrix(c(phi1, phi2, 1, 0), 2)
 446 | Theta  = matrix(c(phi1, phi2), 2)
 447 | Ups    = matrix(c(b1, 0, b2, 0, b3, 0, 0, 0, 0, 0), 2, 5)
 448 | Gam    = matrix(c(0, 0, 0, b4, alf), 1, 5)
 449 | cQ     = cR
 450 | S      = cR^2
 451 | kf     = Kfilter2(num, y, A, mu0, Sigma0, Phi, Ups, Gam, Theta, cQ, cR, S, input)
 452 | res    = ts(as.vector(kf$innov), start=start(cmort), freq=frequency(cmort))
 453 | sarima(res, 0,0,0, no.constant=TRUE)  # gives a full residual analysis
 454 | 
 455 | # Similar fit with but with trend in the X of ARMAX
 456 | trend  = time(cmort) - mean(time(cmort))
 457 | u      = ts.intersect(M=cmort, M1=lag(cmort,-1), M2=lag(cmort,-2), T1=lag(tempr,-1), 
 458 |            P=part, P4=lag(part -4), trend)
 459 | sarima(u[,1], 0,0,0, xreg=u[,2:7])
 460 | ```
 461 | 
 462 | 
 463 | 
 464 | Example 6.13
 465 | ```r
 466 | ################################## 
 467 | # NOTE:  If this takes a long time to run on your machine, try
 468 | #         tol   = .0001   and if you need more speed
 469 | #         nboot = 250         
 470 | tol = sqrt(.Machine$double.eps)  # determines convergence of optimizer     
 471 | nboot = 500                      # number of bootstrap replicates     
 472 | ################################## 
 473 | 
 474 | pb = txtProgressBar(min = 0, max = nboot, initial = 0, style=3)  # progress bar
 475 | 
 476 | y     = window(qinfl, c(1953,1), c(1965,2))  # inflation   
 477 | z     = window(qintr, c(1953,1), c(1965,2))  # interest   
 478 | num   = length(y) 
 479 | A     = array(z, dim=c(1,1,num))
 480 | input = matrix(1,num,1)  
 481 | 
 482 | # Function to Calculate Likelihood   
 483 | Linn  = function(para, y.data){  # pass data also
 484 |    phi = para[1];  alpha = para[2]
 485 |    b   = para[3];  Ups   = (1-phi)*b
 486 |    cQ  = para[4];  cR    = para[5]  
 487 |    kf  = Kfilter2(num,y.data,A,mu0,Sigma0,phi,Ups,alpha,1,cQ,cR,0,input)
 488 |    return(kf$like)    
 489 | }
 490 | 
 491 | # Parameter Estimation   
 492 | mu0      = 1
 493 | Sigma0   = .01  
 494 | init.par = c(phi=.84, alpha=-.77, b=.85, cQ=.12, cR=1.1) # initial values   
 495 | 
 496 | est = optim(init.par,  Linn, NULL, y.data=y, method="BFGS", hessian=TRUE, 
 497 |              control=list(trace=1, REPORT=1, reltol=tol))  
 498 | SE  = sqrt(diag(solve(est$hessian)))   
 499 | 
 500 | phi   = est$par[1];  alpha = est$par[2]
 501 | b     = est$par[3];  Ups   = (1-phi)*b         
 502 | cQ    = est$par[4];  cR    = est$par[5] 
 503 | round(cbind(estimate=est$par, SE), 3)  
 504 | 
 505 | 
 506 | # BEGIN BOOTSTRAP   
 507 | # Run the filter at the estimates 
 508 | kf = Kfilter2(num,y,A,mu0,Sigma0,phi,Ups,alpha,1,cQ,cR,0,input)  
 509 | 
 510 | # Pull out necessary values from the filter and initialize  
 511 | xp      = kf$xp
 512 | innov   = kf$innov 
 513 | sig     = kf$sig 
 514 | e       = innov/sqrt(sig)
 515 | e.star  = e                      # initialize values
 516 | y.star  = y  
 517 | xp.star = xp  
 518 | k       = 4:50                   # hold first 3 observations fixed 
 519 | para.star = matrix(0, nboot, 5)  # to store estimates
 520 | init.par  =  c(.84, -.77, .85, .12, 1.1)    
 521 | 
 522 | for (i in 1:nboot){
 523 |  setTxtProgressBar(pb,i)                       
 524 |  e.star[k] = sample(e[k], replace=TRUE)   
 525 |  for (j in k){ 
 526 |     K        = (phi*Pp[j]*z[j])/sig[j]
 527 |   xp.star[j] = phi*xp.star[j-1] + Ups+K[j]*sqrt(sig[j])*e.star[j] }   
 528 |    y.star[k] = z[k]*xp.star[k] + alpha + sqrt(sig[k])*e.star[k]  
 529 |  est.star = optim(init.par, Linn, NULL, y.data=y.star, method="BFGS", control=list(reltol=tol))     
 530 |  para.star[i,] = cbind(est.star$par[1], est.star$par[2], est.star$par[3], 
 531 |                        abs(est.star$par[4]), abs(est.star$par[5]))   
 532 | }
 533 | close(pb) 
 534 | 
 535 | # Some summary statistics  
 536 | rmse = rep(NA,5)                 # SEs from the bootstrap
 537 | for(i in 1:5){rmse[i]=sqrt(sum((para.star[,i]-est$par[i])^2)/nboot)
 538 |               cat(i, rmse[i],"\n") 
 539 |              }              
 540 | # Plot phi and sigw  (scatter.hist in astsa v1.13)
 541 | phi  = para.star[,1] 
 542 | sigw = abs(para.star[,4]) 
 543 | phi  = ifelse(phi<0, NA, phi)    # any phi < 0 not plotted
 544 | scatter.hist(sigw, phi, ylab=expression(phi), xlab=expression(sigma[~w]), 
 545 |              hist.col=astsa.col(5,.4), pt.col=5, pt.size=1.5)
 546 | ```
 547 | 
 548 | Example 6.14
 549 | ```r
 550 | set.seed(123)
 551 | num   = 50
 552 | w     = rnorm(num,0,.1)
 553 | x     = cumsum(cumsum(w))
 554 | y     = x + rnorm(num,0,1)
 555 | ## State Space ##
 556 | Phi   = matrix(c(2,1,-1,0),2)
 557 | A     = matrix(c(1,0),1)
 558 | mu0   = matrix(0,2); Sigma0 = diag(1,2)
 559 | Linn  = function(para){
 560 |   sigw = para[1] 
 561 |   sigv = para[2]
 562 |   cQ   = diag(c(sigw,0))
 563 |   kf   = Kfilter0(num, y, A, mu0, Sigma0, Phi, cQ, sigv)
 564 | return(kf$like) 
 565 | }
 566 | ## Estimation ##
 567 | init.par = c(.1, 1)
 568 | (est  = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))
 569 | SE    = sqrt(diag(solve(est$hessian)))
 570 | # Summary of estimation
 571 | estimate = est$par; u = cbind(estimate, SE)
 572 | rownames(u) = c("sigw","sigv"); u
 573 | # Smooth
 574 | sigw  = est$par[1]
 575 | cQ    = diag(c(sigw,0))
 576 | sigv  = est$par[2]
 577 | ks    = Ksmooth0(num, y, A, mu0, Sigma0, Phi, cQ, sigv)
 578 | xsmoo = ts(ks$xs[1,1,]); psmoo = ts(ks$Ps[1,1,])
 579 | upp   = xsmoo+2*sqrt(psmoo)
 580 | low   = xsmoo-2*sqrt(psmoo)
 581 | #
 582 | tsplot(x, ylab="", ylim=c(-1,8), col=1)
 583 | lines(y, type='o', col=8)
 584 | lines(xsmoo, col=4, lty=2, lwd=3)
 585 | lines(upp, col=4, lty=2); lines(low, col=4, lty=2)
 586 | lines(smooth.spline(y), lty=1, col=2)
 587 | legend("topleft", c("Observations","State"), pch=c(1,-1), lty=1, lwd=c(1,2), col=c(8,1))
 588 | legend("bottomright", c("Smoother", "GCV Spline"), lty=c(2,1), lwd=c(3,1), col=c(4,2))
 589 | ```
 590 | 
 591 | Example 6.16
 592 | ```r
 593 | library(depmixS4)
 594 | model <- depmix(EQcount ~1, nstates=2, data=data.frame(EQcount), family=poisson('identity'), respstart=c(15,25))
 595 | set.seed(90210)
 596 | summary(fm <- fit(model))   # estimation results  
 597 | standardError(fm)           # with standard errors
 598 | 
 599 | ##-- A little nicer display of the parameters --##
 600 | para.mle = as.vector(getpars(fm))[3:8]  
 601 | ( mtrans = matrix(para.mle[1:4], byrow=TRUE, nrow=2) )
 602 | ( lams   = para.mle[5:6] )  
 603 | ( pi1    = mtrans[2,1]/(2 - mtrans[1,1] - mtrans[2,2]) )  
 604 | ( pi2    = 1 - pi1 )
 605 | 
 606 | #-- Graphics --##
 607 | par(mfrow=c(3,1))
 608 | # data and states
 609 | tsplot(EQcount, main="", ylab='EQcount', type='h', col=gray(.7), ylim=c(0,50))
 610 | text(EQcount, col=6*posterior(fm)[,1]-2, labels=posterior(fm)[,1])
 611 | # prob of state 2
 612 | tsplot(ts(posterior(fm)[,3], start=1900), ylab = expression(hat(pi)[~2]*'(t|n)'));  abline(h=.5, lty=2)
 613 | # histogram
 614 | hist(EQcount, breaks=30, prob=TRUE, main="")
 615 | xvals = seq(1,45)
 616 | u1 = pi1*dpois(xvals, lams[1])  
 617 | u2 = pi2*dpois(xvals, lams[2])
 618 | lines(xvals, u1, col=4)   
 619 | lines(xvals, u2, col=2)
 620 | ```
 621 | 
 622 | Example 6.17
 623 | ```r
 624 | library(depmixS4)
 625 | y = ts(sp500w, start=2003, freq=52)  # make data depmix friendly
 626 | mod3 <- depmix(y~1, nstates=3, data=data.frame(y))
 627 | set.seed(2)
 628 | summary(fm3 <- fit(mod3))   # estimation results  
 629 | 
 630 | ##-- a little nicer display --## 
 631 |  para.mle    = as.vector(getpars(fm3)[-(1:3)])
 632 |  permu       = matrix(c(0,0,1,0,1,0,1,0,0), 3,3)   # for the label switch 
 633 |  (mtrans.mle = permu%*%round(t(matrix(para.mle[1:9],3,3)),3)%*%permu)
 634 |  (norms.mle  = round(matrix(para.mle[10:15],2,3),3)%*%permu)
 635 | 
 636 | ##-- Graphics --##  
 637 | layout(matrix(c(1,2, 1,3), 2), heights=c(1,.75))
 638 | 
 639 | tsplot(y, main="", ylab='S&P500 Weekly Returns', col=gray(.7), ylim=c(-.11,.11))
 640 |  culer = 4-posterior(fm3)[,1];  culer[culer==3]=4  # switch labels 1 and 3
 641 |  text(y, col=culer, labels=4-posterior(fm3)[,1])
 642 | 
 643 | acf1(y^2, 25) 
 644 | 
 645 | hist(y, 25, prob=TRUE, main='', col=astsa.col(8,.2))
 646 | pi.hat = colSums(posterior(fm3)[-1,2:4])/length(y)
 647 | culer = c(1,2,4)
 648 | for (i in 1:3) { 
 649 |  mu = norms.mle[1,i]; sig = norms.mle[2,i]
 650 |  x = seq(-.2,.15, by=.001)
 651 | lines(x, pi.hat[4-i]*dnorm(x, mean=mu, sd=sig), col=culer[i], lwd=2)  
 652 |  }
 653 | ```
 654 | 
 655 | Example 6.18
 656 | ```r
 657 | library(MSwM)
 658 | set.seed(90210)
 659 | dflu  = diff(flu)
 660 | model = lm(dflu~ 1)
 661 | mod   = msmFit(model, k=2, p=2, sw=rep(TRUE,4)) # 2 regimes, AR(2)s
 662 | summary(mod)
 663 | plotProb(mod, which=3)
 664 | ```
 665 | 
 666 | 
 667 | 
 668 | Example 6.22
 669 | ```r
 670 | y   = flu  
 671 | num = length(y)
 672 | nstate = 4                      # state dimenstion
 673 | M1 = as.matrix(cbind(1,0,0,1))  # obs matrix normal
 674 | M2 = as.matrix(cbind(1,0,1,1))  # obs matrix flu epi
 675 | prob = matrix(0,num,1); yp = y  # to store pi2(t|t-1) & y(t|t-1)
 676 | xfilter = array(0, dim=c(nstate,1,num)) # to store x(t|t)
 677 | # Function to Calculate Likelihood
 678 | Linn = function(para){
 679 |   alpha1 = para[1]; alpha2 = para[2]; beta0 = para[3]
 680 |   sQ1 = para[4];  sQ2 = para[5];  like=0
 681 |   xf  = matrix(0, nstate, 1)  # x filter
 682 |   xp  = matrix(0, nstate, 1)  # x pred
 683 |   Pf  = diag(.1, nstate)      # filter cov
 684 |   Pp  = diag(.1, nstate)      # pred cov
 685 |   pi11 <- .75 -> pi22;  pi12 <- .25 -> pi21; pif1 <- .5 -> pif2
 686 |   phi = matrix(0,nstate,nstate)
 687 |   phi[1,1] = alpha1; phi[1,2] = alpha2; phi[2,1]=1; phi[4,4]=1
 688 |   Ups = as.matrix(rbind(0,0,beta0,0))
 689 |   Q   = matrix(0,nstate,nstate)
 690 |   Q[1,1] = sQ1^2; Q[3,3] = sQ2^2; R=0  # R=0 in final model
 691 |   # begin filtering #
 692 |     for(i in 1:num){
 693 |     xp   = phi%*%xf + Ups; Pp = phi%*%Pf%*%t(phi) + Q
 694 |     sig1 = as.numeric(M1%*%Pp%*%t(M1) + R)
 695 |     sig2 = as.numeric(M2%*%Pp%*%t(M2) + R)
 696 |     k1   = Pp%*%t(M1)/sig1; k2 = Pp%*%t(M2)/sig2
 697 |     e1   = y[i]-M1%*%xp; e2 = y[i]-M2%*%xp
 698 |     pip1 = pif1*pi11 + pif2*pi21; pip2 = pif1*pi12 + pif2*pi22
 699 |     den1 = (1/sqrt(sig1))*exp(-.5*e1^2/sig1)
 700 |     den2 = (1/sqrt(sig2))*exp(-.5*e2^2/sig2)
 701 |     denm = pip1*den1 + pip2*den2
 702 |     pif1 = pip1*den1/denm; pif2 = pip2*den2/denm
 703 |     pif1 = as.numeric(pif1); pif2 = as.numeric(pif2)
 704 |     e1   = as.numeric(e1); e2=as.numeric(e2)
 705 |     xf   = xp + pif1*k1*e1 + pif2*k2*e2
 706 |     eye  = diag(1, nstate)
 707 |     Pf   = pif1*(eye-k1%*%M1)%*%Pp + pif2*(eye-k2%*%M2)%*%Pp
 708 |     like = like - log(pip1*den1 + pip2*den2)
 709 |     prob[i]<<-pip2; xfilter[,,i]<<-xf; innov.sig<<-c(sig1,sig2)
 710 |     yp[i]<<-ifelse(pip1 > pip2, M1%*%xp, M2%*%xp)  
 711 |     }
 712 | return(like)   
 713 | }
 714 | # Estimation
 715 | alpha1 = 1.4; alpha2 = -.5; beta0 = .3; sQ1 = .1; sQ2 = .1
 716 | init.par = c(alpha1, alpha2, beta0, sQ1, sQ2)
 717 | (est = optim(init.par, Linn, NULL, method='BFGS', hessian=TRUE, control=list(trace=1,REPORT=1)))
 718 | SE   = sqrt(diag(solve(est$hessian)))
 719 | u    = cbind(estimate=est$par, SE)
 720 | rownames(u)=c('alpha1','alpha2','beta0','sQ1','sQ2'); u
 721 | 
 722 | # Graphics
 723 | predepi = ifelse(prob<.5,0,1)
 724 | FLU = window(flu, start=1968.4)
 725 | Time = window(time(flu), start=1968.4)  
 726 | k = 6:num     
 727 | par(mfrow=c(3,1))     
 728 | tsplot(FLU, col=8, ylab='flu')
 729 |  text(FLU, col= predepi[k]+1, labels=predepi[k]+1, cex=1.1) 
 730 |  legend('topright', '(a)', bty='n')
 731 | 
 732 | filters = ts(t(xfilter[c(1,3,4),,]), start=tsp(flu)[1], frequency=tsp(flu)[3])
 733 | tsplot(window(filters, start=1968.4),  spag=TRUE, col=2:4, ylab='filter')
 734 |  legend('topright', '(b)', bty='n')
 735 | 
 736 | tsplot(FLU, type='p', pch=19, ylab='flu', cex=1.2)
 737 |  prde1 = 2*sqrt(innov.sig[1]); prde2 = 2*sqrt(innov.sig[2])
 738 |  prde = ifelse(predepi[k]<.5, prde1, prde2)
 739 |    xx = c(Time, rev(Time))
 740 |    yy = c(yp[k]-prde, rev(yp[k]+prde))
 741 |  polygon(xx, yy, border=8, col=gray(.6, alpha=.3)) 
 742 |  legend('topright', '(c)', bty='n')
 743 | ```
 744 | 
 745 | 
 746 | 
 747 | 
 748 | Example 6.23
 749 | ```r
 750 | y   = log(nyse^2) 
 751 | num = length(y)
 752 | 
 753 | # Initial Parameters
 754 | phi0=0; phi1=.95; sQ=.2; alpha=mean(y); sR0=1; mu1=-3; sR1=2
 755 | init.par = c(phi0,phi1,sQ,alpha,sR0,mu1,sR1)
 756 | 
 757 | # Innovations Likelihood 
 758 | Linn = function(para){
 759 |   phi0=para[1]; phi1=para[2]; sQ=para[3]; alpha=para[4]
 760 |   sR0=para[5]; mu1=para[6]; sR1=para[7]
 761 |   sv = SVfilter(num,y,phi0,phi1,sQ,alpha,sR0,mu1,sR1)
 762 |   return(sv$like)    
 763 | }
 764 | 
 765 | # Estimation  
 766 | (est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))
 767 | SE = sqrt(diag(solve(est$hessian)))
 768 | u = cbind(estimates=est$par, SE)  
 769 | rownames(u)=c("phi0","phi1","sQ","alpha","sigv0","mu1","sigv1"); u
 770 | 
 771 | # Graphics   (need filters at the estimated parameters)
 772 | phi0=est$par[1]; phi1=est$par[2]; sQ=est$par[3]; alpha=est$par[4]
 773 | sR0=est$par[5]; mu1=est$par[6]; sR1=est$par[7]
 774 | sv = SVfilter(num,y,phi0,phi1,sQ,alpha,sR0,mu1,sR1) 
 775 | 
 776 | # densities plot (f is chi-sq, fm is fitted mixture)
 777 | x = seq(-15,6,by=.01) 
 778 | f = exp(-.5*(exp(x)-x))/(sqrt(2*pi))
 779 | f0 = exp(-.5*(x^2)/sR0^2)/(sR0*sqrt(2*pi))
 780 | f1 = exp(-.5*(x-mu1)^2/sR1^2)/(sR1*sqrt(2*pi))
 781 | fm = (f0+f1)/2
 782 | tsplot(x, f, xlab='x')
 783 | lines(x, fm, lty=2, lwd=2)
 784 | legend('topleft', legend=c('log chi-square', 'normal mixture'), lty=1:2)
 785 | 
 786 | dev.new()
 787 | Time = 701:1100
 788 | tsplot(Time, nyse[Time], type='l', col=4, lwd=2, ylab='', xlab='', ylim=c(-.18,.12))
 789 | lines(Time, sv$xp[Time]/10, lwd=2, col=6)
 790 | ```
 791 | 
 792 | 
 793 | 
 794 | Example 6.24
 795 | ```r
 796 | n.boot = 500        # number of bootstrap replicates
 797 | tol = sqrt(.Machine$double.eps)  # convergence limit 
 798 | 
 799 | gnpgr = diff(log(gnp))
 800 | fit = arima(gnpgr, order=c(1,0,0))
 801 | y = as.matrix(log(resid(fit)^2))
 802 | num = length(y) 
 803 | tsplot(y, ylab="")
 804 | 
 805 | # Initial Parameters
 806 | phi1 = .9; sQ = .5; alpha = mean(y); sR0 = 1; mu1 = -3; sR1 = 2.5
 807 | init.par = c(phi1, sQ, alpha, sR0, mu1, sR1)
 808 | 
 809 | # Innovations Likelihood 
 810 | Linn=function(para){
 811 |   phi1 = para[1]; sQ = para[2]; alpha = para[3]
 812 |   sR0 = para[4]; mu1 = para[5]; sR1 = para[6]
 813 |   sv = SVfilter(num, y, 0, phi1, sQ, alpha, sR0, mu1, sR1)
 814 |   return(sv$like)    
 815 |   }
 816 | 
 817 | # Estimation  
 818 | (est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))
 819 | SE = sqrt(diag(solve(est$hessian)))
 820 | u = cbind(estimates=est$par, SE)  
 821 | rownames(u)=c("phi1","sQ","alpha","sig0","mu1","sig1"); u
 822 | 
 823 | # Bootstrap 
 824 | para.star = matrix(0, n.boot, 6)  # to store parameter estimates
 825 | Linn2 = function(para){   
 826 |   phi1 = para[1]; sQ = para[2]; alpha = para[3]
 827 |   sR0 = para[4]; mu1 = para[5]; sR1 = para[6]
 828 |   sv = SVfilter(num, y.star, 0, phi1, sQ, alpha, sR0, mu1, sR1)
 829 |   return(sv$like)    
 830 |   }
 831 | 
 832 | for (jb in 1:n.boot){  cat("iteration:", jb, "\n")
 833 |  phi1 = est$par[1]; sQ = est$par[2]; alpha = est$par[3]    
 834 |  sR0 = est$par[4]; mu1 = est$par[5]; sR1 = est$par[6] 
 835 |  Q = sQ^2; R0 = sR0^2; R1 = sR1^2
 836 |  sv = SVfilter(num, y, 0, phi1, sQ, alpha, sR0, mu1, sR1)
 837 |  
 838 |  sig0 = sv$Pp+R0 
 839 |  sig1 = sv$Pp+R1 
 840 |  K0   = sv$Pp/sig0 
 841 |  K1   = sv$Pp/sig1
 842 |  inn0 = y-sv$xp-alpha; inn1 = y-sv$xp-mu1-alpha
 843 |  den1 = (1/sqrt(sig1))*exp(-.5*inn1^2/sig1)
 844 |  den0 = (1/sqrt(sig0))*exp(-.5*inn0^2/sig0)
 845 |  fpi1 = den1/(den0+den1)
 846 |  
 847 |  # (start resampling at t=4)
 848 |  e0   = inn0/sqrt(sig0)
 849 |  e1   = inn1/sqrt(sig1)  
 850 |  indx = sample(4:num, replace=TRUE)
 851 |  sinn = cbind(c(e0[1:3], e0[indx]), c(e1[1:3], e1[indx]))
 852 |  eF   = matrix(c(phi1, 1, 0, 0), 2, 2)
 853 |  xi   = cbind(sv$xp,y)    # initialize
 854 |    
 855 |    for (i in 4:num){    # generate boot sample
 856 |    G   = matrix(c(0, alpha+fpi1[i]*mu1), 2, 1)
 857 |    h21 = (1-fpi1[i])*sqrt(sig0[i]); h11 = h21*K0[i]
 858 |    h22 = fpi1[i]*sqrt(sig1[i]); h12 = h22*K1[i]
 859 |    H   = matrix(c(h11,h21,h12,h22),2,2)
 860 |    xi[i,] = t(eF%*%as.matrix(xi[i-1,],2) + G + H%*%as.matrix(sinn[i,],2))
 861 |    }
 862 |    
 863 |  # Estimates from boot data 
 864 |  y.star = xi[,2]
 865 |  phi1 = .9; sQ = .5; alpha = mean(y.star); sR0 = 1; mu1 = -3; sR1 = 2.5
 866 |  init.par = c(phi1, sQ, alpha, sR0, mu1, sR1)   #  same as for data
 867 |  est.star = optim(init.par, Linn2, NULL, method="BFGS", control=list(reltol=tol)) 
 868 |  para.star[jb,] = cbind(est.star$par[1], abs(est.star$par[2]), est.star$par[3], abs(est.star$par[4]), 
 869 |                         est.star$par[5], abs(est.star$par[6])) 
 870 | }
 871 | 
 872 | # Some summary statistics and graphics  
 873 | rmse = rep(NA, 6)  # SEs from the bootstrap
 874 | for(i in 1:6){rmse[i] = sqrt(sum((para.star[,i]-est$par[i])^2)/n.boot)
 875 |                 cat(i, rmse[i],"\n") 
 876 |              }  
 877 | dev.new()
 878 | phi = para.star[,1]
 879 | hist(phi, 15, prob=TRUE, main="", xlim=c(0,2), xlab="", col=astsa.col(4,.3))
 880 | abline(v=mean(phi), col=4)
 881 | curve(dnorm(x, mean=u[1,1], sd=u[2,1]), 0, 2, add=TRUE)
 882 | abline(v=u[1,1])
 883 | ```
 884 | 
 885 | 
 886 | Example 6.26 
 887 | 
 888 | &emsp; Adapted from code by: [Hedibert Freitas Lopes](http://hedibert.org/)
 889 | 
 890 | ```r
 891 | ##-- Notation --##
 892 | #           y(t) = x(t) + v(t);    v(t) ~ iid N(0,V)                     
 893 | #           x(t) = x(t-1) + w(t);  w(t) ~ iid N(0,W)                        
 894 | #  priors:  x(0) ~ N(m0,C0);  V ~ IG(a,b);  W ~ IG(c,d)
 895 | #    FFBS:  x(t|t) ~ N(m,C);  x(t|n) ~ N(mm,CC);  x(t|t+1) ~ N(a,R)  
 896 | ##-- 
 897 | ffbs = function(y,V,W,m0,C0){
 898 |   n  = length(y);  a  = rep(0,n);  R  = rep(0,n)
 899 |   m  = rep(0,n);   C  = rep(0,n);  B  = rep(0,n-1)     
 900 |   H  = rep(0,n-1); mm = rep(0,n);  CC = rep(0,n)
 901 |   x  = rep(0,n); llike = 0.0
 902 |   for (t in 1:n){
 903 |     if(t==1){a[1] = m0; R[1] = C0 + W
 904 |       }else{ a[t] = m[t-1]; R[t] = C[t-1] + W }
 905 |     f      = a[t]
 906 |     Q      = R[t] + V
 907 |     A      = R[t]/Q
 908 |     m[t]   = a[t]+A*(y[t]-f)
 909 |     C[t]   = R[t]-Q*A**2
 910 |     B[t-1] = C[t-1]/R[t]
 911 |     H[t-1] = C[t-1]-R[t]*B[t-1]**2
 912 |     llike  = llike + dnorm(y[t],f,sqrt(Q),log=TRUE) }
 913 |   mm[n] = m[n]; CC[n] = C[n]
 914 |   x[n]  = rnorm(1,m[n],sqrt(C[n]))
 915 |   for (t in (n-1):1){
 916 |     mm[t] = m[t] + C[t]/R[t+1]*(mm[t+1]-a[t+1])
 917 |     CC[t] = C[t] - (C[t]^2)/(R[t+1]^2)*(R[t+1]-CC[t+1])
 918 |     x[t]  = rnorm(1,m[t]+B[t]*(x[t+1]-a[t+1]),sqrt(H[t]))  }
 919 | return(list(x=x,m=m,C=C,mm=mm,CC=CC,llike=llike))   }
 920 | 
 921 | # Simulate states and data
 922 | set.seed(1); W = 0.5; V = 1.0
 923 | n  = 100; m0 = 0.0; C0 = 10.0; x0 = 0
 924 | w  = rnorm(n,0,sqrt(W))
 925 | v  = rnorm(n,0,sqrt(V))
 926 | x  = y = rep(0,n)
 927 | x[1] = x0   + w[1]
 928 | y[1] = x[1] + v[1]
 929 | for (t in 2:n){
 930 |   x[t] = x[t-1] + w[t]
 931 |   y[t] = x[t] + v[t]   }
 932 | 
 933 | # actual smoother (for plotting)
 934 | ks = Ksmooth0(num=n, y, A=1, m0, C0, Phi=1, cQ=sqrt(W), cR=sqrt(V))
 935 | xsmooth = as.vector(ks$xs)
 936 | 
 937 | # run it
 938 | run = ffbs(y,V,W,m0,C0)
 939 | m   = run$m; C = run$C; mm = run$mm
 940 | CC  = run$CC; L1 = m-2*C; U1  = m+2*C
 941 | L2  = mm-2*CC; U2 = mm+2*CC
 942 | N   = 50
 943 | Vs  = seq(0.1,2,length=N)
 944 | Ws  = seq(0.1,2,length=N)
 945 | likes = matrix(0,N,N)
 946 | for (i in 1:N){
 947 |  for (j in 1:N){
 948 |    V   = Vs[i]
 949 |    W   = Ws[j]
 950 |    run = ffbs(y,V,W,m0,C0)    
 951 |   likes[i,j] = run$llike  }  }  
 952 | # Hyperparameters
 953 | a = 0.01; b = 0.01; c = 0.01; d = 0.01
 954 | # MCMC step
 955 | set.seed(90210)
 956 | burn  = 10;  M = 1000
 957 | niter = burn + M
 958 | V1    = V;  W1 = W
 959 | draws = NULL
 960 | all_draws = NULL
 961 | for (iter in 1:niter){
 962 |   run   = ffbs(y,V1,W1,m0,C0)
 963 |   x     = run$x
 964 |   V1    = 1/rgamma(1,a+n/2,b+sum((y-x)^2)/2)
 965 |   W1    = 1/rgamma(1,c+(n-1)/2,d+sum(diff(x)^2)/2)
 966 |   draws = rbind(draws,c(V1,W1,x))    }
 967 | all_draws = draws[,1:2]
 968 | q025  = function(x){quantile(x,0.025)}
 969 | q975  = function(x){quantile(x,0.975)}
 970 | draws = draws[(burn+1):(niter),]
 971 | xs    = draws[,3:(n+2)]
 972 | lx    = apply(xs,2,q025)
 973 | mx    = apply(xs,2,mean)
 974 | ux    = apply(xs,2,q975)
 975 | 
 976 | ##  plot data
 977 | par(mfrow=c(2,2))
 978 | tsplot(cbind(x,y), spag=TRUE,  ylab='', col=c(1,8), lwd=2)
 979 | points(y)
 980 | legend(0, 11, legend=c("x(t)","y(t)"), lty=1, col=c(1,8), lwd=2, bty="n", pch=c(-1,1))
 981 | contour(Vs, Ws, exp(likes), xlab=expression(sigma[v]^2), ylab=expression(sigma[w]^2), 
 982 |          drawlabels=FALSE, ylim=c(0,1.2))
 983 | points(draws[,1:2], pch=16, col=rgb(.9,0,0,0.3), cex=.7)
 984 | hist(draws[,1], ylab="Density",main="", xlab=expression(sigma[v]^2))
 985 | abline(v=mean(draws[,1]), col=3, lwd=3)
 986 | hist(draws[,2],main="", ylab="Density", xlab=expression(sigma[w]^2))
 987 | abline(v=mean(draws[,2]), col=3, lwd=3)
 988 | 
 989 | ## plot states
 990 | dev.new()
 991 | tsplot(y, ylab='', type='o', col=8)
 992 | lines(xsmooth, lwd=4, col=rgb(1,0,1,alpha=.4))
 993 | lines(mx, col= 4) 
 994 |  xx=c(1:100, 100:1)
 995 |  yy=c(lx, rev(ux))
 996 | polygon(xx, yy, border=NA, col= gray(.6,alpha=.2))
 997 | legend('topleft', c('true smoother', 'data', 'posterior mean', '95% of draws'), lty=1, 
 998 |          lwd=c(3,1,1,10), pch=c(-1,1,-1,-1), col=c(6, gray(.4), 4, gray(.6, alpha=.5)), 
 999 |          bg='white' )  
1000 | ```
1001 | 
1002 | Example 6.27
1003 | 
1004 | ```r
1005 | y = jj
1006 | ### setup - model and initial parameters
1007 | set.seed(90210)
1008 | n = length(y)
1009 | F = c(1,1,0,0)      # this is A 
1010 | G = diag(0,4)       # G is Phi 
1011 |   G[1,1] = 1.03 
1012 |   G[2,]  = c(0,-1,-1,-1); G[3,]=c(0,1,0,0); G[4,]=c(0,0,1,0)
1013 | a1 = rbind(.7,0,0,0)  # this is mu0
1014 | R1 = diag(.04,4)      # this is Sigma0
1015 | V = .1
1016 | W11 = .1
1017 | W22 = .1
1018 | 
1019 | ##-- FFBS --##  
1020 | ffbs = function(y,F,G,V,W11,W22,a1,R1){
1021 |   n  = length(y)
1022 |   Ws = diag(c(W11,W22,1,1))  # this is Q with 1s as a device only
1023 |   iW = diag(1/diag(Ws),4)    
1024 |   a  = matrix(0,n,4)         # this is m_t
1025 |   R  = array(0,c(n,4,4))     # this is V_t
1026 |   m  = matrix(0,n,4)
1027 |   C  = array(0,c(n,4,4))
1028 |   a[1,]  = a1[,1]
1029 |   R[1,,] = R1
1030 |   f      = t(F)%*%a[1,]
1031 |   Q      = t(F)%*%R[1,,]%*%F + V
1032 |   A      = R[1,,]%*%F/Q[1,1]
1033 |   m[1,]  = a[1,]+A%*%(y[1]-f)
1034 |   C[1,,] = R[1,,]-A%*%t(A)*Q[1,1]
1035 |   for (t in 2:n){
1036 |     a[t,]  = G%*%m[t-1,]
1037 |     R[t,,] = G%*%C[t-1,,]%*%t(G) + Ws
1038 |     f      = t(F)%*%a[t,]
1039 |     Q      = t(F)%*%R[t,,]%*%F + V
1040 |     A      = R[t,,]%*%F/Q[1,1]
1041 |     m[t,]  = a[t,] + A%*%(y[t]-f)
1042 |     C[t,,] = R[t,,] - A%*%t(A)*Q[1,1]      }
1043 |   xb       = matrix(0,n,4)
1044 |   xb[n,]  = m[n,] + t(chol(C[n,,]))%*%rnorm(4)
1045 |   for (t in (n-1):1){
1046 |     iC  = solve(C[t,,])
1047 |     CCC = solve(t(G)%*%iW%*%G + iC)
1048 |     mmm = CCC%*%(t(G)%*%iW%*%xb[t+1,] + iC%*%m[t,])
1049 |     xb[t,] = mmm + t(chol(CCC))%*%rnorm(4)  }
1050 |   return(xb)                                
1051 | }
1052 | 
1053 | ##-- Prior hyperparameters --##
1054 | # b0 = 0     # mean for beta = phi -1
1055 | # B0 = Inf   # var for  beta  (non-informative => use OLS for sampling beta)
1056 | n0 = 10      # use same for all- the prior is 1/Gamma(n0/2, n0*s20_/2)
1057 | s20v = .001  # for V
1058 | s20w =.05    # for Ws
1059 | 
1060 | ##-- MCMC scheme --##
1061 | set.seed(90210)
1062 | burnin  = 100 
1063 | step    = 10   
1064 | M       = 1000  
1065 | niter   = burnin+step*M
1066 | pars    = matrix(0,niter,4)
1067 | xbs     = array(0,c(niter,n,4))
1068 | pb      = txtProgressBar(min=0, max=niter, initial=0, style=3)  # progress bar
1069 |             
1070 | for (iter in 1:niter){
1071 |     setTxtProgressBar(pb,iter)  
1072 |     xb = ffbs(y,F,G,V,W11,W22,a1,R1)
1073 |      u = xb[,1] 
1074 |     yu = diff(u); xu = u[-n]    # for phihat and se(phihat)
1075 |   regu = lm(yu~0+xu)                # est of beta = phi-1
1076 |  phies = as.vector(coef(summary(regu)))[1:2] + c(1,0) # phi estimate and SE
1077 |    dft = df.residual(regu)   
1078 | G[1,1] = phies[1] + rt(1,dft)*phies[2]  # use a t
1079 |     V  = 1/rgamma(1, (n0+n)/2, (n0*s20v/2) + sum((y-xb[,1]-xb[,2])^2)/2)
1080 |    W11 = 1/rgamma(1, (n0+n-1)/2, (n0*s20w/2) + sum((xb[-1,1]-phies[1]*xb[-n,1])^2)/2)
1081 |    W22 = 1/rgamma(1, (n0+ n-3)/2, (n0*s20w/2) + sum((xb[4:n,2] + xb[3:(n-1),2] + 
1082 |                   xb[2:(n-2),2] +xb[1:(n-3),2])^2)/2)
1083 |    xbs[iter,,] = xb
1084 |    pars[iter,] = c(G[1,1], sqrt(V), sqrt(W11), sqrt(W22))           
1085 | }
1086 | close(pb) 
1087 | 
1088 | # Plot results
1089 | ind = seq(burnin+1, niter, by=step)
1090 | names= c(expression(phi), expression(sigma[v]), expression(sigma[w~11]), expression(sigma[w~22]))
1091 | par(mfcol=c(3,4))
1092 | for (i in 1:4){
1093 |  tsplot(pars[ind,i],xlab="iterations", ylab="trace", main="")
1094 |  mtext(names[i], side=3, line=.5, cex=1) 
1095 |  acf(pars[ind,i],main="", lag.max=25, xlim=c(1,25), ylim=c(-.4,.4))
1096 |  hist(pars[ind,i],main="",xlab="")
1097 |  abline(v=mean(pars[ind,i]), lwd=2, col=3) 
1098 | }
1099 | 
1100 | dev.new()
1101 | par(mfrow=c(2,1))
1102 |   mxb = cbind(apply(xbs[ind,,1],2,mean), apply(xbs[,,2],2,mean))
1103 |   lxb = cbind(apply(xbs[ind,,1],2,quantile,0.005), apply(xbs[ind,,2],2,quantile,0.005))
1104 |   uxb = cbind(apply(xbs[ind,,1],2,quantile,0.995), apply(xbs[ind,,2],2,quantile,0.995))   
1105 |   mxb = ts(cbind(mxb,rowSums(mxb)), start = tsp(jj)[1], freq=4) 
1106 |   lxb = ts(cbind(lxb,rowSums(lxb)), start = tsp(jj)[1], freq=4)
1107 |   uxb = ts(cbind(uxb,rowSums(uxb)), start = tsp(jj)[1], freq=4)
1108 |   names=c('Trend', 'Season', 'Trend + Season')
1109 |   L = min(lxb[,1])-.01; U = max(uxb[,1]) +.01
1110 | tsplot(mxb[,1],  ylab=names[1], ylim=c(L,U))
1111 |   xx=c(time(jj), rev(time(jj)))
1112 |   yy=c(lxb[,1], rev(uxb[,1]))
1113 |   polygon(xx, yy, border=NA, col=gray(.4, alpha = .2)) 
1114 |   L = min(lxb[,3])-.01; U = max(uxb[,3]) +.01
1115 | tsplot(mxb[,3],  ylab=names[3], ylim=c(L,U))
1116 |   xx=c(time(jj), rev(time(jj)))
1117 |   yy=c(lxb[,3], rev(uxb[,3]))
1118 |   polygon(xx, yy, border=NA, col=gray(.4, alpha = .2))            
1119 | ```
1120 | 
1121 | 


--------------------------------------------------------------------------------
/textRcode.md:
--------------------------------------------------------------------------------
   1 | 
   2 | ## R Code Used in the Examples - tsa4 
   3 | 
   4 | <img align="left" src="https://github.com/nickpoison/astsa/blob/master/fun_with_astsa/figs/tsa4.jpg" alt="&nbsp; tsa4 &nbsp;"  height="200" />  This is the site for the 4th edition.  The site for the 5th edition is here: [Time Series Analysis and Its Applications, 5th Edition](https://github.com/nickpoison/tsa5/blob/master/textRcode.md) 
   5 | 
   6 | 
   7 | #### &#x2728; See the [NEWS](https://github.com/nickpoison/astsa/blob/master/NEWS.md) for further details about the state of the package and the changelog.
   8 | 
   9 | 
  10 | #### &#10024; An intro to `astsa` capabilities can be found at  [FUN WITH ASTSA](https://github.com/nickpoison/astsa/blob/master/fun_with_astsa/fun_with_astsa.md)
  11 | 
  12 | #### &#10024; Here is [A Road Map](https://nickpoison.github.io/) if you want a broad view of what is available.
  13 | 
  14 | <br/><br/>
  15 | 
  16 | <br/>
  17 | 
  18 | &#9940; &#9940;  __WARNING:__   If loaded, the package `dplyr` may (and most likely will) corrupt the base scripts  `filter` 
  19 | and  `lag`  that we use often. In this case, to avoid problems when analyzing time series, you have a few options:
  20 | 
  21 | ```r
  22 | # (1) either detach the problem package
  23 | detach(package:dplyr)  
  24 | 
  25 | # (2) or fix it yourself if you want dplyr 
  26 | # this is a great idea from  https://stackoverflow.com/a/65186251
  27 | library(dplyr, exclude = c("filter", "lag"))  # remove the culprits on load
  28 | Lag <- dplyr::lag            # and do what the dplyr ... 
  29 | Filter <- dplyr::filter      # ... maintainers refuse to do
  30 | # then use `Lag` and `Filter` for dplyr's scripts
  31 | # `lag` and `filter` will remain uncorrupted as originally intended
  32 | 
  33 | # (3) or just take back the commands
  34 | filter = stats::filter
  35 | lag = stats::lag
  36 | 
  37 | # in this case, you can still use these for dplyr
  38 | Lag <- dplyr::lag     
  39 | Filter <- dplyr::filter 
  40 | ```
  41 | 
  42 |  &#128534; If you are wondering how it is possible to corrupt a base package, you are not alone. 
  43 | 
  44 | <br/>
  45 | 
  46 | ---
  47 | ---
  48 | 
  49 | >  __Note__ when you are in a code block below, you can copy the contents of the block by moving your mouse to the upper right corner and clicking on the copy icon ( &#128203; ).
  50 | 
  51 | ---
  52 | ---
  53 | 
  54 | ### Table of Contents
  55 | 
  56 |   * [Chapter 1 - Characteristics of Time Series](#chapter-1)
  57 |   * [Chapter 2 - Time Series Regression and Exploratory Data Analysis](#chapter-2)
  58 |   * [Chapter 3 - ARIMA Models](#chapter-3)
  59 |   * [Chapter 4 - Spectral Analysis and Filtering](#chapter-4)
  60 |   * [Chapter 5 - Additional Time Domain Topics](#chapter-5)
  61 |   * [Chapter 6 - State Space Models](#chapter-6)
  62 |   * [Chapter 7 - Statistical Methods in the Frequency Domain](#chapter-7)
  63 | 
  64 | ---
  65 | 
  66 | ## Chapter 1
  67 | 
  68 | 
  69 | Example 1.1 
  70 | 
  71 | ```r
  72 | tsplot(jj, col=4, type="o", ylab="Quarterly Earnings per Share")
  73 | ```
  74 | 
  75 | Example 1.2  
  76 | 
  77 | ```r
  78 | tsplot(globtemp, col=4, type="o", ylab="Global Temperature Deviations")
  79 | 
  80 | # or with the updated values
  81 | tsplot(gtemp_land, col=4, type="o", ylab="Global Temperature Deviations")
  82 | ```
  83 | 
  84 | Example 1.3  
  85 | 
  86 | ```r
  87 | tsplot(speech)  
  88 | ```
  89 | 
  90 | Example 1.4  
  91 | 
  92 | ```r
  93 | library(xts)         # install it if you don't have it
  94 | djiar = diff(log(djia$Close))[-1]        
  95 | plot(djiar, col=4, main="DJIA Returns") 
  96 | ```
  97 | 
  98 | Example 1.5  
  99 | 
 100 | ```r
 101 | par(mfrow = c(2,1))  # set up the graphics
 102 | tsplot(soi, col=4, ylab="", main="Southern Oscillation Index")
 103 | tsplot(rec, col=4, ylab="", main="Recruitment") 
 104 | ```
 105 | 
 106 | Example 1.6
 107 | 
 108 | ```r
 109 | par(mfrow=c(2,1))  
 110 | tsplot(fmri1[,2:5], col=1:4, ylab="BOLD", main="Cortex", spaghetti=TRUE)
 111 | tsplot(fmri1[,6:9], col=1:4, ylab="BOLD", main="Thalamus & Cerebellum", spaghetti=TRUE)
 112 | 
 113 | # each separately (not in text)
 114 | tsplot(fmri1[,2:9], col=1:8, lwd=2, ncol=2, ylim=c(-.6,.6))
 115 | 
 116 | # and another view (not in text)
 117 | x     = ts(fmri1[,4:9], start=0, freq=32)         
 118 | names = c("Cortex","Thalamus","Cerebellum")
 119 | u     = ts(rep(c(rep(.6,16), rep(-.6,16)), 4), start=0, freq=32) # stimulus signal
 120 | par(mfrow=c(3,1))
 121 | for (i in 1:3){ 
 122 |   j = 2*i - 1
 123 |   tsplot(x[,j:(j+1)], ylab="BOLD", xlab="", main=names[i], col=5:6, ylim=c(-.6,.6), 
 124 |          lwd=2, xaxt="n", spaghetti=TRUE)
 125 |   axis(seq(0,256,64), side=1, at=0:4)
 126 |   lines(u, type="s", col=gray(.3)) 
 127 | }
 128 | mtext("seconds", side=1, line=1.75, cex=.9)
 129 | ```
 130 | 
 131 | Example 1.7
 132 | 
 133 | ```r
 134 | par(mfrow=2:1)
 135 | tsplot(EQ5,  col=4, main="Earthquake")
 136 | tsplot(EXP6, col=4, main="Explosion")
 137 | 
 138 | # or try (not in text)
 139 | tsplot(cbind(EQ5,EXP6), col=4)
 140 | ```
 141 | 
 142 | Example 1.9
 143 | 
 144 | ```r
 145 | w = rnorm(500,0,1)                  # 500 N(0,1) variates
 146 | v = filter(w, sides=2, rep(1/3,3))  # moving average
 147 | par(mfrow=c(2,1))
 148 | tsplot(w, col=4, main="white noise")
 149 | tsplot(v, col=4, ylim=c(-3,3), main="moving average")
 150 | ```
 151 | 
 152 | Example 1.10
 153 | 
 154 | ```r
 155 | w = rnorm(550,0,1)  # 50 extra to avoid startup problems
 156 | x = filter(w, filter=c(1,-.9), method="recursive")[-(1:50)]
 157 | tsplot(x, col=4, main="autoregression")
 158 | ```
 159 | 
 160 | Example 1.11
 161 | 
 162 | ```r
 163 | set.seed(154) # so you can reproduce the results
 164 | w = rnorm(200); x = cumsum(w) # two commands in one line
 165 | wd = w +.2;    xd = cumsum(wd)
 166 | tsplot(xd, ylim=c(-5,55), main="random walk", ylab='')
 167 | lines(x, col=4) 
 168 | clip(0,200,0,50)
 169 | abline(h=0, col=4, lty=2)
 170 | abline(a=0, b=.2, lty=2)
 171 | ```
 172 | 
 173 | Example 1.12
 174 | 
 175 | ```r
 176 | cs = 2*cos(2*pi*(1:500)/50 + .6*pi)
 177 | w = rnorm(500,0,1)
 178 | par(mfrow=c(3,1))
 179 | tsplot(cs, ylab="", main = expression(x[t]==2*cos(2*pi*t/50+.6*pi)))
 180 | tsplot(cs + w, ylab="", main = expression(x[t]==2*cos(2*pi*t/50+.6*pi)+N(0,1)))
 181 | tsplot(cs + 5*w, ylab="", main = expression(x[t]==2*cos(2*pi*t/50+.6*pi)+N(0,25)))
 182 | ```
 183 | 
 184 | Example 1.24
 185 | 
 186 | ```r
 187 | set.seed(2)
 188 | x = rnorm(100)
 189 | y = lag(x, -5) + rnorm(100)
 190 | ccf2(y, x, ylab='CCovF', type='covariance')
 191 | text( 9, 1.1, 'x leads')
 192 | text(-8, 1.1, 'y leads')
 193 | ```
 194 | 
 195 | Example 1.25
 196 | 
 197 | ```r
 198 | (r = round( acf1(soi, 6, plot=FALSE), 2)) # sample acf values
 199 | par(mfrow=c(1,2))
 200 | tsplot(lag(soi,-1), soi, col=4, type='p', xlab='lag(soi,-1)')
 201 |  legend("topleft", legend=r[1], bg="white", adj=.45, cex = 0.85)
 202 | tsplot(lag(soi,-6), soi, col=4, type='p', xlab='lag(soi,-6)')
 203 |  legend("topleft", legend=r[6], bg="white", adj=.25, cex = 0.8)
 204 | ```
 205 | 
 206 | Example 1.26
 207 | 
 208 | ```r
 209 | set.seed(666)
 210 | x1 = sample(c(-1,1), 11, replace=TRUE)  # simulated sequence of coin tosses
 211 | x2 = sample(c(-1,1), 101, replace=TRUE)
 212 | y1 = 5 + filter(x1, sides=1, filter=c(1,-.7))[-1]
 213 | y2 = 5 + filter(x2, sides=1, filter=c(1,-.7))[-1]
 214 | tsplot(y1, type='s')   # plot 1st series
 215 |  points(y1, pch=19)
 216 | c(mean(y1), mean(y2))  # the sample means
 217 | acf(y1, lag.max=4, plot=FALSE) 
 218 | acf(y2, lag.max=4, plot=FALSE) 
 219 | 
 220 | #########################################
 221 | # here's the version from the other text -
 222 | # same idea but the y values are 2-4-6-8
 223 | # like the children's cheer
 224 | 
 225 | set.seed(101011)
 226 | x1 = sample(c(-2,2), 11, replace=TRUE)   # simulated coin tosses
 227 | x2 = sample(c(-2,2), 101, replace=TRUE)
 228 | y1 = 5 + filter(x1, sides=1, filter=c(1,-.5))[-1]
 229 | y2 = 5 + filter(x2, sides=1, filter=c(1,-.5))[-1]
 230 | tsplot(y1, type="s", col=4, xaxt="n", yaxt="n")  # y2 not shown
 231 |  axis(1, 1:10); axis(2, seq(2,8,2), las=1)
 232 |  points(y1, pch=21, cex=1.1, bg=6)
 233 | acf(y1, lag.max=4, plot=FALSE) 
 234 | acf(y2, lag.max=4, plot=FALSE) 
 235 | ```
 236 | 
 237 | Example 1.27
 238 | 
 239 | ```r
 240 | acf1(speech, 250)
 241 | ```
 242 | 
 243 | Example 1.28
 244 | 
 245 | ```r
 246 | par(mfrow=c(3,1))
 247 | acf1(soi, main="Southern Oscillation Index")
 248 | acf1(rec, main="Recruitment")
 249 | ccf2(soi, rec, main="SOI vs Recruitment")
 250 | ```
 251 | 
 252 | Example 1.29
 253 | 
 254 | ```r
 255 | set.seed(1492)
 256 | num = 120 
 257 | t   = 1:num
 258 | X   = ts(2*cos(2*pi*t/12) + rnorm(num), freq=12)
 259 | Y   = ts(2*cos(2*pi*(t+5)/12) + rnorm(num), freq=12)
 260 | Yw  = resid( lm(Y~ cos(2*pi*t/12) + sin(2*pi*t/12), na.action=NULL) )
 261 | par(mfrow=c(3,2) )
 262 | tsplot(X)
 263 | tsplot(Y)
 264 | acf1(X, 48, ylab='ACF(X)')
 265 | acf1(Y, 48, ylab='ACF(Y)')
 266 | ccf2(X, Y, 24)
 267 | ccf2(X, Yw, 24, ylim=c(-.6,.6))
 268 | ################################################
 269 | 
 270 | #  here's another example that's simpler
 271 | #  the series are trend stationary with 
 272 | #  just a hint of trend - but same result
 273 | 
 274 | set.seed(90210)
 275 | num = 250  
 276 | t   = 1:num
 277 | X   = .01*t + rnorm(num,0,2)
 278 | Y   = .01*t + rnorm(num)
 279 | par(mfrow=c(3,1))
 280 | tsplot(cbind(X,Y), spag=TRUE, col=astsa.col(c(4,2),.7), lwd=2, ylab='data')  
 281 | ccf2(X, Y,  ylim=c(-.3,.3), col=4, lwd=2)
 282 | Yw = detrend(Y)  # whiten Y by removing trend
 283 | ccf2(X, Yw, ylim=c(-.3,.3), col=4, lwd=2)
 284 | ```
 285 | 
 286 | Example 1.30
 287 | 
 288 | ```r
 289 | par(mar=rep(1,4))
 290 | persp(1:64, 1:36, soiltemp, phi=30, theta=30, scale=FALSE, expand=4, 
 291 |        ticktype="detailed", xlab="rows", ylab="cols", zlab="temperature")
 292 | dev.new()          
 293 | tsplot(rowMeans(soiltemp), xlab="row", ylab="Average Temperature")
 294 | ```
 295 | 
 296 | Example 1.31
 297 | 
 298 | ```r
 299 | fs = abs(fft(soiltemp-mean(soiltemp)))^2/(64*36) # see Ch 4 for info on FFT
 300 | cs = Re(fft(fs, inverse=TRUE)/sqrt(64*36))  # ACovF
 301 | rs = cs/cs[1,1]                             # ACF
 302 | 
 303 | rs2 = cbind(rs[1:41,21:2], rs[1:41,1:21])   #  these lines are just to center
 304 | rs3 = rbind(rs2[41:2,], rs2)                #  the 0 lag  
 305 | 
 306 | par(mar = c(1,2.5,0,0)+.1)
 307 | persp(-40:40, -20:20, rs3, phi=30, theta=30, expand=30, scale="FALSE",  
 308 |        ticktype="detailed", xlab="row lags", ylab="column lags", zlab="ACF")
 309 | ```
 310 | 
 311 | [<sub>top</sub>](#table-of-contents)
 312 | 
 313 | ---
 314 | 
 315 | 
 316 | 
 317 | ## Chapter 2
 318 | 
 319 | 
 320 | Example 2.1
 321 | 
 322 | ```r
 323 | # astsa now has a trend script, so Figure 2.1 can be done in one line
 324 | trend(chicken, lwd=2)    # includes a 95% CI
 325 | 
 326 | # in the text
 327 | summary(fit <- lm(chicken~time(chicken))) # regress price on time
 328 | tsplot(chicken, ylab="cents per pound", col=4, lwd=2)
 329 | abline(fit)      # add the fitted regression line to the plot            
 330 | ```
 331 | 
 332 | Example 2.2
 333 | 
 334 | ```r
 335 | ##-- separate
 336 | par(mfrow=c(3,1))
 337 | tsplot(cmort, main="Cardiovascular Mortality", col=6, type="o", pch=19, ylab="")
 338 | tsplot(tempr, main="Temperature", col=4, type="o", pch=19, ylab="")
 339 | tsplot(part, main="Particulates", col=2, type="o", pch=19, ylab="")
 340 | 
 341 | ##-- together 
 342 | dev.new()
 343 | tsplot(cbind(cmort, tempr, part), spag=TRUE, ylab="", col=c(6,4,2))
 344 | legend("topright", legend=c("Mortality", "Temperature", "Pollution"), lty=1, lwd=2, col=c(6,4,2), bg="white")
 345 | 
 346 | ##-- scatterplot matrix
 347 | dev.new()  
 348 | panel.cor <- function(x, y, ...){
 349 | usr <- par("usr")
 350 | par(usr = c(0, 1, 0, 1))
 351 | r <- round(cor(x, y), 2)
 352 | text(0.5, 0.5, r, cex = 1.75)
 353 | }
 354 | pairs(cbind(Mortality=cmort, Temperature=tempr, Particulates=part), col=4, lower.panel=panel.cor)
 355 | 
 356 | #  Regression
 357 | temp  = tempr-mean(tempr)  # center temperature    
 358 | temp2 = temp^2             # square it  
 359 | trend = time(cmort)        # time
 360 | 
 361 | fit = lm(cmort~ trend + temp + temp2 + part, na.action=NULL)
 362 |             
 363 | summary(fit)       # regression results
 364 | summary(aov(fit))  # ANOVA table   (compare to next line)
 365 | summary(aov(lm(cmort~cbind(trend, temp, temp2, part)))) # Table 2.1
 366 | 
 367 | num = length(cmort)                                     # sample size
 368 | AIC(fit)/num - log(2*pi)                                # AIC 
 369 | BIC(fit)/num - log(2*pi)                                # BIC   
 370 | (AICc = log(sum(resid(fit)^2)/num) + (num+5)/(num-5-2)) # AICc
 371 | ```
 372 | 
 373 | Examples 2.3
 374 | 
 375 | ```r
 376 | fish = ts.intersect(rec, soiL6=lag(soi,-6), dframe=TRUE)   
 377 | summary(fit <- lm(rec~soiL6, data=fish, na.action=NULL))
 378 | ## not shown in text but resids are not white
 379 | par(mfrow=2:1)
 380 | tsplot(resid(fit))
 381 | acf1(resid(fit))
 382 | ```
 383 | 
 384 | 
 385 | 
 386 | Examples 2.4 and 2.5
 387 | 
 388 | ```r
 389 | # astsa now has a detrend script, so Figure 2.4 can be done as
 390 | par(mfrow=2:1)
 391 | tsplot( detrend(chicken), main="detrended" )
 392 | tsplot( diff(chicken), main="first difference" )
 393 | 
 394 | # and Figure 2.5 as
 395 | dev.new()
 396 | par(mfrow=c(3,1))     # plot ACFs
 397 | acf1(chicken, 48, main="chicken")
 398 | acf1(detrend(chicken), 48, main="detrended")
 399 | acf1(diff(chicken), 48, main="first difference")
 400 | ```
 401 | 
 402 | 
 403 | Example 2.6
 404 | 
 405 | ```r
 406 | par(mfrow=c(2,1))
 407 | tsplot(diff(globtemp), type="o")
 408 |  mean(diff(globtemp))     # drift estimate = .008
 409 | acf1(diff(gtemp), 48, main="")
 410 | ```
 411 | 
 412 | Example 2.7
 413 | 
 414 | ```r
 415 | layout(matrix(1:4,2), widths=c(2.5,1))
 416 | tsplot(varve, main="", ylab="", col=4)
 417 |  mtext("varve", side=3, line=.5, cex=1.2, font=2, adj=0)
 418 | tsplot(log(varve), main="", ylab="", col=4)
 419 |  mtext("log(varve)", side=3, line=.5, cex=1.2, font=2, adj=0)
 420 | qqnorm(varve, main="", col=4)
 421 |  qqline(varve, col=2, lwd=2)
 422 | qqnorm(log(varve), main="", col=4)
 423 |  qqline(log(varve), col=2, lwd=2)
 424 | ```
 425 | 
 426 | Example 2.8  
 427 | 
 428 | ```r
 429 | lag1.plot(soi, 12, col=astsa.col(4, .3), cex=1.5, pch=20)
 430 | dev.new()
 431 | lag2.plot(soi, rec, 8, col=astsa.col(4, .3), cex=1.5, pch=20)
 432 | ```
 433 | 
 434 | Example 2.9
 435 | 
 436 | ```r
 437 | dummy = ifelse(soi<0, 0, 1)
 438 | fish  = ts.intersect(rec, soiL6=lag(soi,-6), dL6=lag(dummy,-6), dframe=TRUE)
 439 | summary(fit <- lm(rec~ soiL6*dL6, data=fish, na.action=NULL))
 440 | tsplot(fish$soiL6, fish$rec, type='p', col=4, ylab='rec', xlab='soiL6')
 441 | lines(lowess(fish$soiL6, fish$rec), col=4, lwd=2)
 442 | points(fish$soiL6, fitted(fit), pch='+', col=6)
 443 | 
 444 | dev.new()
 445 | par(mfrow=2:1)
 446 | tsplot(resid(fit)) # not shown ...
 447 | acf1(resid(fit))   # ... but obviously not noise
 448 | ```
 449 | 
 450 | 
 451 | Example 2.10
 452 | 
 453 | ```r
 454 | set.seed(1000)  # so you can reproduce these results
 455 | x  = 2*cos(2*pi*1:500/50 + .6*pi) + rnorm(500,0,5)
 456 | z1 = cos(2*pi*1:500/50)  
 457 | z2 = sin(2*pi*1:500/50)
 458 | summary(fit <- lm(x~0+z1+z2))  # zero to exclude the intercept
 459 | par(mfrow=c(2,1))
 460 | tsplot(x, col=4)
 461 | tsplot(x, col=astsa.col(4,.7), ylab=expression(hat(x)))
 462 | lines(fitted(fit), col=2, lwd=2)
 463 | ```
 464 | 
 465 | 
 466 | Example 2.11
 467 | 
 468 | ```r
 469 | wgts = c(.5, rep(1,11), .5)/12
 470 | soif = filter(soi, sides=2, filter=wgts)
 471 | tsplot(soi, col=4)
 472 | lines(soif, lwd=2, col=6)
 473 | par(fig = c(.75, 1, .75, 1), new = TRUE) # the insert
 474 | nwgts = c(rep(0,20), wgts, rep(0,20))
 475 | plot(nwgts, type="l", ylim = c(-.02,.1), xaxt='n', yaxt='n', ann=FALSE)
 476 | ```
 477 | 
 478 | 
 479 | Example 2.12 
 480 | 
 481 | ```r
 482 | tsplot(soi, col=4)
 483 | lines(ksmooth(time(soi), soi, "normal", bandwidth=1), lwd=2, col=6)
 484 | par(fig = c(.75, 1, .75, 1), new = TRUE) # the insert
 485 | curve(dnorm, -3, 3,  xaxt='n', yaxt='n', ann=FALSE)
 486 | ```
 487 | 
 488 | 
 489 | Example 2.13
 490 | 
 491 | ```r
 492 | # Figure 2.14 using the trend script
 493 | trend(soi, lowess=TRUE)
 494 | lines(lowess(soi, f=.05), lwd=2, col=6) # El Niño cycle
 495 | ```
 496 | 
 497 | 
 498 | 
 499 | Example 2.14
 500 | 
 501 | ```r
 502 | tsplot(soi)
 503 | lines(smooth.spline(time(soi), soi, spar=.5), lwd=2, col=4)
 504 | lines(smooth.spline(time(soi), soi, spar= 1), lty=2, lwd=2, col=2)
 505 | ```
 506 | 
 507 | Example 2.15
 508 | 
 509 | ```r
 510 | tsplot(tempr, cmort, type="p", xlab="Temperature", ylab="Mortality", pch=20, col=4)
 511 | lines(lowess(tempr, cmort), col=6, lwd=2)
 512 | ```
 513 | 
 514 | [<sub>top</sub>](#table-of-contents)
 515 | 
 516 | ---
 517 | 
 518 | 
 519 | 
 520 | ## Chapter 3
 521 | 
 522 | > The way AIC, AICc, and BIC are calculated in `sarima` changed a few versions ago. The values in the text will be different than the current values, but the results of any data analysis in the text are the same.
 523 | 
 524 | <br/>
 525 | 
 526 | 
 527 | 
 528 | 
 529 | Example 3.2
 530 | 
 531 | ```r
 532 | par(mfrow=c(2,1))                         
 533 | # in the expressions below, ~ is a space and == is equal
 534 | tsplot(sarima.sim(ar= .9, n=100), col=4, ylab="", main=(expression(AR(1)~~~phi==+.9))) 
 535 | tsplot(sarima.sim(ar=-.9, n=100), col=4, ylab="", main=(expression(AR(1)~~~phi==-.9))) 
 536 | ```
 537 | 
 538 | Example 3.5
 539 | 
 540 | ```r
 541 | par(mfrow=c(2,1))                                   
 542 | tsplot(sarima.sim(ma= .9, n=100), col=4, ylab="", main=(expression(MA(1)~~~theta==+.9)))    
 543 | tsplot(sarima.sim(ma=-.9, n=100), col=4, ylab="", main=(expression(MA(1)~~~theta==-.9)))    
 544 | ```
 545 | 
 546 | Example 3.7
 547 | 
 548 | ```r
 549 | set.seed(8675309)         # Jenny, I got your number
 550 | x = rnorm(150, mean=5)    # Jenerate iid N(5,1)s
 551 | arima(x, order=c(1,0,1))  # Jenstimation
 552 | ```
 553 | 
 554 | Example 3.8
 555 | 
 556 | ```r
 557 | ARMAtoMA(ar = .9, ma = .5, 10)   # first 10 psi-weights
 558 | ARMAtoAR(ar = .9, ma = .5, 10)   # first 10 pi-weights
 559 | ```
 560 | 
 561 | Example 3.9
 562 | ```r
 563 | # this is how Figure 3.3 was generated
 564 | seg1   =  seq( 0, 2,  by=0.1)
 565 | seg2   =  seq(-2, 2,  by=0.1)
 566 | name1  =  expression(phi[1])
 567 | name2  =  expression(phi[2])
 568 | tsplot(seg1, (1-seg1), ylim=c(-1,1), xlim=c(-2,2), ylab=name2, xlab=name1,
 569 |         main='Causal Region of an AR(2)')
 570 |  lines(-seg1, (1-seg1), ylim=c(-1,1), xlim=c(-2,2)) 
 571 |  abline(h=0, v=0, lty=2, col=8)
 572 |  lines(seg2, -(seg2^2 /4), ylim=c(-1,1))
 573 |  lines( x=c(-2,2), y=c(-1,-1), ylim=c(-1,1))
 574 |  text(0, .35, 'real roots')
 575 |  text(0, -.5, 'complex roots')
 576 | ```
 577 | 
 578 | 
 579 | Example 3.11
 580 | 
 581 | ```r
 582 | z = c(1,-1.5,.75)    # coefficients of the polynomial
 583 | (a = polyroot(z)[1]) # = 1+0.57735i,  print one root which is 1 + i 1/sqrt(3)
 584 | arg = Arg(a)/(2*pi)  # arg in cycles/pt  
 585 | 1/arg                # = 12,  the period
 586 | 
 587 | par(mfrow=c(3,1))
 588 | set.seed(8675309)    # Jenny, it's me again
 589 | ar2 = sarima.sim(ar=c(1.5,-.75), n=144, S=12)
 590 | tsplot(ar2, xlab="Year")
 591 | 
 592 | ACF = ARMAacf(ar=c(1.5,-.75), ma=0, 50)[-1]
 593 | tsplot(ACF, type="h", xlab="lag")
 594 | abline(h=0, col=8)
 595 | 
 596 | # alternately - not in text
 597 | ACF = ARMAacf(ar=c(1.5,-.75), ma=0, 50)
 598 | tsplot(0:50, ACF, type="h", xlab="lag")
 599 | abline(h=0, col=8)
 600 | 
 601 | 
 602 | # psi-weights - not in text
 603 | psi = ts(ARMAtoMA(ar=c(1.5,-.75), ma=0, 50), start=0, freq=12)
 604 | tsplot(psi, type='o', cex=1.1, ylab=expression(psi-weights), xaxt='n', xlab='Index')
 605 | axis(1, at=0:4, labels=c('0','12','24','36','48'))
 606 | 
 607 | # you can play the same game with the ACF - not in text
 608 | ACF = ts(ARMAacf(ar=c(1.5,-.75), ma=0, 50), start=0, frequency=12)
 609 | tsplot(ACF, type='h', xaxt='n', xlab='LAG')
 610 | abline(h=0, col=8)
 611 | axis(1, at=0:4, labels=c('0','12','24','36','48'))
 612 | 
 613 | ```
 614 | 
 615 | Example 3.12
 616 | 
 617 | ```r
 618 | psi = ARMAtoMA(ar=.9, ma=.5, 50)       #  for a list        
 619 | tsplot(psi, type='h', ylab=expression(psi-weights), xlab='Index')    # for a graph
 620 | ```
 621 | 
 622 | 
 623 | Example 3.16
 624 | 
 625 | ```r
 626 | ar2.acf  = ARMAacf(ar=c(1.5,-.75), ma=0, 24)[-1]
 627 | ar2.pacf = ARMAacf(ar=c(1.5,-.75), ma=0, 24, pacf=TRUE)
 628 | par(mfrow=1:2)
 629 | tsplot(ar2.acf,  type="h", xlab="lag", lwd=3, nxm=5, col=c(rep(4,11), 6))
 630 | tsplot(ar2.pacf, type="h", xlab="lag", lwd=3, nxm=5, col=4)
 631 | ```
 632 | 
 633 | Example 3.18   
 634 | 
 635 | ```r
 636 | acf2(rec, 48)     # will produce values and a graphic 
 637 | (regr = ar.ols(rec, order=2, demean=FALSE, intercept=TRUE))  # regression
 638 | regr$asy.se.coef  # standard errors                             
 639 | ```
 640 | 
 641 | 
 642 | Example 3.25  
 643 | 
 644 | ```r
 645 | regr = ar.ols(rec, order=2, demean=FALSE, intercept=TRUE)
 646 | fore = predict(regr, n.ahead=24)
 647 | tsplot(cbind(rec, fore$pred), spag=TRUE, col=1:2, xlim=c(1980,1990), ylab="Recruitment")
 648 | lines(fore$pred, type="p", col=2)
 649 | lines(fore$pred+fore$se, lty="dashed", col=4)
 650 | lines(fore$pred-fore$se, lty="dashed", col=4)
 651 | ```
 652 | 
 653 | Example 3.26
 654 | 
 655 | ```r
 656 | set.seed(666)
 657 | x     = sarima.sim(ar=.9, ma=.5, n=100)
 658 | xr    = rev(x) # xr is the reversed data
 659 | pxr   = predict(arima(xr, order=c(1,0,1)), 10) # predict the reversed data
 660 | pxrp  = rev(pxr$pred) # reorder the predictors (for plotting)
 661 | pxrse = rev(pxr$se) # reorder the SEs
 662 | nx    = ts(c(pxrp, x), start=-9) # attach the backcasts to the data
 663 | tsplot(nx, ylab=expression(X[~t]), main='Backcasting', ylim=c(-7,4))
 664 |  U  = nx[1:10] + pxrse
 665 |  L  = nx[1:10] - pxrse
 666 |  xx = c(-9:0, 0:-9) 
 667 |  yy = c(L, rev(U))
 668 | polygon(xx, yy, border = 8, col = gray(0.6, alpha = 0.2))
 669 | lines(-9:0, nx[1:10], col=2, type='o')
 670 | ```
 671 | 
 672 | 
 673 | Example 3.28
 674 | 
 675 | ```r
 676 | rec.yw = ar.yw(rec, order=2)
 677 | rec.yw$x.mean    # = 62.26278 (mean estimate)
 678 | rec.yw$ar        # = 1.3315874, -.4445447  (parameter estimates)
 679 | sqrt(diag(rec.yw$asy.var.coef))  # = .04222637, .04222637  (standard errors)
 680 | rec.yw$var.pred  # = 94.79912 (error variance estimate)
 681 | 
 682 | rec.pr = predict(rec.yw, n.ahead=24)
 683 |  U = rec.pr$pred + rec.pr$se
 684 |  L = rec.pr$pred - rec.pr$se
 685 | tsplot(cbind(rec, rec.pr$pred), spag=TRUE, xlim=c(1980,1990),  ylab="Recruitment") 
 686 | lines(rec.pr$pred, col=2, type="o")
 687 | lines(U, col=4, lty=2)
 688 | lines(L, col=4, lty=2)
 689 | ```
 690 | 
 691 | Example 3.29
 692 | 
 693 | ```r
 694 | set.seed(1)
 695 | ma1 = sarima.sim(ma=.9, n=50)
 696 | acf1(ma1, 1, plot=FALSE)  # [1] .536 (lag 1 sample ACF)
 697 | ```
 698 | 
 699 | Example 3.31
 700 | 
 701 | ```r
 702 | rec.mle = ar.mle(rec, order=2)
 703 | rec.mle$x.mean
 704 | rec.mle$ar
 705 | sqrt(diag(rec.mle$asy.var.coef))
 706 | rec.mle$var.pred
 707 | ```
 708 | 
 709 | 
 710 | 
 711 | Example 3.33
 712 | 
 713 | ```r
 714 | x = diff(log(varve))       # data
 715 | r = acf1(x, 1, plot=FALSE) # acf(1)
 716 | c(0) -> z -> Sc -> Sz -> Szw -> para # initialize .. 
 717 | c(x[1]) -> w                         # .. all variables
 718 | num = length(x)            # 633
 719 | 
 720 | ## Gauss-Newton Estimation
 721 | para[1] = (1-sqrt(1-4*(r^2)))/(2*r)  # MME to start (not very good)
 722 | niter   = 12             
 723 | for (j in 1:niter){  
 724 |  for (t in 2:num){ w[t] = x[t]   - para[j]*w[t-1]
 725 |                    z[t] = w[t-1] - para[j]*z[t-1]
 726 |  }
 727 |  Sc[j]  = sum(w^2)
 728 |  Sz[j]  = sum(z^2)
 729 |  Szw[j] = sum(z*w)
 730 | para[j+1] = para[j] + Szw[j]/Sz[j]
 731 | }
 732 | ## Results
 733 | cbind(iteration=1:niter-1, thetahat=para[1:niter], Sc, Sz)
 734 | 
 735 | ## Plot conditional SS and results
 736 | c(0) -> cSS
 737 | th = -seq(.3, .94, .01)
 738 | for (p in 1:length(th)){   
 739 |  for (t in 2:num){ w[t] = x[t] - th[p]*w[t-1] 
 740 |  }
 741 | cSS[p] = sum(w^2)
 742 | }
 743 | tsplot(th, cSS, ylab=expression(S[c](theta)), xlab=expression(theta))
 744 | abline(v=para[1:12], lty=2, col=4) # add previous results to plot
 745 | points(para[1:12], Sc[1:12], pch=16, col=4)
 746 | ```
 747 | 
 748 | 
 749 | 
 750 | Example 3.36
 751 | 
 752 | ```r
 753 | # generate data
 754 | set.seed(101010)   
 755 | e   = rexp(150, rate=.5) 
 756 | u   = runif(150,-1,1) 
 757 | de  = e*sign(u)
 758 | dex = 50 + sarima.sim(n=100, ar=.95, innov=de, burnin=50) 
 759 | tsplot(dex, ylab=expression(X[~t]))
 760 | 
 761 | # Bootstrap
 762 | set.seed(666)                 # not that 666
 763 | fit     = ar.yw(dex, order=1) # assumes the data were retained
 764 | m       = fit$x.mean          # estimate of mean
 765 | phi     = fit$ar              # estimate of phi
 766 | nboot   = 250                 # number of bootstrap replicates
 767 | resids  = fit$resid[-1]       # the 99 innovations
 768 | x.star  = dex                 # initialize x*
 769 | phi.star.yw = c()             # initialize phi* 
 770 | 
 771 | for (i in 1:nboot) {
 772 |   resid.star = sample(resids, replace=TRUE)
 773 |   x.star     = sarima.sim(n=99, ar=phi, innov=resid.star, burnin=0) + m 
 774 |  phi.star.yw[i] = ar.yw(x.star, order=1)$ar
 775 | }
 776 | 
 777 | # small sample distn
 778 | set.seed(111)
 779 | phi.yw = rep(NA, 1000)
 780 | for (i in 1:1000){
 781 |  e = rexp(150, rate=.5); u = runif(150,-1,1); de = e*sign(u)
 782 |  x = 50 + arima.sim(n=100,list(ar=.95), innov=de, n.start=50)
 783 |  phi.yw[i] = ar.yw(x, order=1)$ar 
 784 | }
 785 | 
 786 | # Picture
 787 | hist(phi.star.yw, 15, main="", prob=TRUE, xlim=c(.65,1.05), ylim=c(0,14), 
 788 |       col=astsa.col(4,.3), xlab=expression(hat(phi)))
 789 | lines(density(phi.yw, bw=.02), lwd=2)  
 790 | curve(dnorm(x, mean=.96, sd=.03), .75,1.1, lty=2, lwd=2, add=TRUE)
 791 | legend(.65, 14, bty='n', lty=c(1,0,2), lwd=c(2,0,2), col=1, pch=c(NA,22,NA), 
 792 |       pt.bg=c(NA,astsa.col(4,.3),NA), pt.cex=2.5, 
 793 |       legend=c('true distribution', 'bootstrap distribution', 'normal approximation'))
 794 | ```
 795 | 
 796 | 
 797 | Example 3.38
 798 | 
 799 | ```r
 800 | set.seed(666)    
 801 | x = sarima.sim(ma = -0.8, d=1, n = 100)
 802 | (x.ima = HoltWinters(x, beta=FALSE, gamma=FALSE))  # &alpha; is 1-&lambda; here
 803 | plot(x.ima)
 804 | ```
 805 | 
 806 | Example 3.39, 3.40, and 3.43
 807 | 
 808 | ```r
 809 | tsplot(gnp, col=4)
 810 | 
 811 | dev.new()
 812 | acf2(gnp, 50)               # compare to acf2(1:250, 50)       
 813 | gnpgr = diff(log(gnp))      # growth rate
 814 | 
 815 | dev.new()
 816 | tsplot(gnpgr, col=4)
 817 | 
 818 | dev.new()
 819 | acf2(gnpgr, 24)  
 820 | sarima(gnpgr, 1, 0, 0)      # AR(1)
 821 | sarima(gnpgr, 0, 0, 2)      # MA(2) 
 822 | ARMAtoMA(ar=.35, ma=0, 10)  # prints psi-weights
 823 | ```
 824 | 
 825 | Example 3.41
 826 | 
 827 | ```r
 828 | sarima(log(varve), 0,1,1, no.constant=TRUE, gg=TRUE, col=4)   # ARIMA(0,1,1)
 829 | 
 830 | dev.new()
 831 | sarima(log(varve), 1,1,1, no.constant=TRUE, gg=TRUE, col=4)   # ARIMA(1,1,1)
 832 | ```
 833 | 
 834 | Example 3.44
 835 | 
 836 | ```r
 837 | trend  = time(cmort) 
 838 | temp   = tempr - mean(tempr)
 839 | temp2  = temp^2
 840 | summary(fit <- lm(cmort~trend + temp + temp2 + part, na.action=NULL))
 841 | acf2(resid(fit), 52) # implies AR2
 842 | sarima(cmort, 2,0,0, xreg=cbind(trend,temp,temp2,part) )
 843 | ```
 844 | 
 845 | Example 3.45
 846 | 
 847 | ```r
 848 | # Note: this could benefit from a seasonal model fit, but it hasn't
 849 | #  been talked about yet - you could come back to this after the next section
 850 | dummy = ifelse(soi<0, 0, 1)
 851 | fish = ts.intersect(rec, soiL6=lag(soi,-6), dL6=lag(dummy,-6), dframe=TRUE)
 852 | summary(fit <- lm(rec ~soiL6*dL6, data=fish, na.action=NULL))
 853 | plot(resid(fit))
 854 | acf2(resid(fit))     # indicates AR(2)
 855 | intract = fish$soiL6*fish$dL6  # interaction term
 856 | sarima(fish$rec, 2,0,0, xreg = cbind(fish$soiL6, fish$dL6, intract))
 857 | ```
 858 | 
 859 | 
 860 | 
 861 | Example 3.46
 862 | 
 863 | ```r
 864 | set.seed(666)
 865 | SAR = sarima.sim(sar=.9, S=12, n=37) + 50
 866 | layout(matrix(c(1,2, 1,3), nc=2), heights=c(1.5,1))
 867 | tsplot(SAR, type="c", xlab="Year")
 868 |  abline(v=1:3, col=4, lty=2)
 869 |  points(SAR, pch=Months, cex=1.35, font=4, col=1:6)
 870 | 
 871 | phi  = c(rep(0,11),.9)
 872 | ACF  = ARMAacf(ar=phi, ma=0, 100)[-1] # [-1] removes 0 lag
 873 | PACF = ARMAacf(ar=phi, ma=0, 100, pacf=TRUE)
 874 |  LAG = 1:100/12
 875 | tsplot(LAG, ACF, type="h", xlab="LAG", ylim=c(-.04,1))
 876 |  abline(h=0, col=8)
 877 | tsplot(LAG, PACF, type="h", xlab="LAG", ylim=c(-.04,1))
 878 |  abline(h=0, col=8)
 879 | ```
 880 | 
 881 | 
 882 | Example 3.47
 883 | 
 884 | ```r
 885 | par(mfrow=1:2)
 886 | phi  = c(rep(0,11),.8)
 887 | ACF  = ARMAacf(ar=phi, ma=-.5, 50)[-1]
 888 | PACF = ARMAacf(ar=phi, ma=-.5, 50, pacf=TRUE)
 889 |  LAG = 1:50/12
 890 | tsplot(LAG, ACF, type="h", xlab="LAG", ylim=c(-.4,.8), col=4, lwd=2)
 891 |  abline(h=0, col=8)
 892 | tsplot(LAG, PACF, type="h", xlab="LAG", ylim=c(-.4,.8), col=4, lwd=2)
 893 |  abline(h=0, col=8)
 894 | ```
 895 | 
 896 | 
 897 | Example 3.49
 898 | 
 899 | ```r
 900 | x     = AirPassengers
 901 | lx    = log(x) 
 902 | dlx   = diff(lx) 
 903 | ddlx  = diff(dlx, 12)
 904 | tsplot(cbind(x, lx, dlx, ddlx), main="")
 905 | 
 906 | # below of interest for showing seasonal persistence (not shown here):
 907 | par(mfrow=c(2,1))
 908 | monthplot(dlx)
 909 | monthplot(ddlx)
 910 | 
 911 | sarima(lx, 1,1,1, 0,1,1, 12)   # model 1
 912 | sarima(lx, 0,1,1, 0,1,1, 12)   # model 2 (the winner)
 913 | sarima(lx, 1,1,0, 0,1,1, 12)   # model 3
 914 | 
 915 | dev.new()
 916 | sarima.for(lx, 12, 0,1,1, 0,1,1,12)  # forecasts
 917 | ```
 918 | 
 919 | [<sub>top</sub>](#table-of-contents)
 920 | 
 921 | ---
 922 | 
 923 | ## Chapter 4
 924 | 
 925 | 
 926 | Example 4.1
 927 | ```r
 928 | x1 = 2*cos(2*pi*1:100*6/100)  + 3*sin(2*pi*1:100*6/100)
 929 | x2 = 4*cos(2*pi*1:100*10/100) + 5*sin(2*pi*1:100*10/100)
 930 | x3 = 6*cos(2*pi*1:100*40/100) + 7*sin(2*pi*1:100*40/100)
 931 | x = x1 + x2 + x3 
 932 | 
 933 | par(mfrow=c(2,2))
 934 | tsplot(x1, ylim=c(-10,10), main = expression(omega==6/100~~~A^2==13))
 935 | tsplot(x2, ylim=c(-10,10), main = expression(omega==10/100~~~A^2==41))
 936 | tsplot(x3, ylim=c(-10,10), main = expression(omega==40/100~~~A^2==85))
 937 | tsplot(x, ylim=c(-16,16), main="sum")
 938 | ```
 939 | 
 940 | Example 4.2
 941 | ```r
 942 | # x from Example 4.1 is used here
 943 | dev.new()
 944 | P = abs(2*fft(x)/100)^2
 945 | Fr = 0:99/100                    
 946 | tsplot(Fr, P, type="o", xlab="frequency", ylab="periodogram")
 947 | abline(v=.5, lty=2)
 948 | ```
 949 | 
 950 | Example 4.3
 951 | ```r
 952 | # modulation
 953 | t = 1:200
 954 | tsplot(x <- 2*cos(2*pi*.2*t)*cos(2*pi*.01*t))     
 955 | lines(cos(2*pi*.19*t)+cos(2*pi*.21*t), col=2)     # the same
 956 | Px = Mod(fft(x))^2 
 957 | tsplot(0:199/200, Px, type='o')                   # the periodogram
 958 | 
 959 | # star mag analysis
 960 | n    = length(star)
 961 | par(mfrow=c(2,1))
 962 | tsplot(star, ylab="star magnitude", xlab="day")
 963 | Per   = Mod(fft(star-mean(star)))^2/n
 964 | Freq  = (1:n -1)/n
 965 | tsplot(Freq[1:50], Per[1:50], type='h', lwd=3, ylab="Periodogram", xlab="Frequency")
 966 | text(.05,  7000, "24 day cycle") 
 967 | text(.027, 9000, "29 day cycle")
 968 | #- a list to help find the peaks
 969 | round( cbind(1/Freq[1:30], Per[1:30]), 3)
 970 | ```
 971 | 
 972 | 
 973 | 
 974 | 
 975 | Examples 4.5, 4.6, 4.7
 976 | ```r
 977 | # default is to not plot on log scale 
 978 | # add log='y' otherwise  
 979 | par(mfrow=c(3,1))
 980 | arma.spec(main="White Noise", col=4)
 981 | arma.spec(ma=.5, main="Moving Average", col=4)
 982 | arma.spec(ar=c(1,-.9), main="Autoregression", col=4)
 983 | ```
 984 | 
 985 | 
 986 | Example 4.10
 987 | ```r
 988 | x      = c(1,2,3,2,1)        
 989 | c1     = cos(2*pi*1:5*1/5)
 990 | s1     = sin(2*pi*1:5*1/5) 
 991 | c2     = cos(2*pi*1:5*2/5)
 992 | s2     = sin(2*pi*1:5*2/5)
 993 | omega1 = cbind(c1, s1)
 994 | omega2 = cbind(c2, s2)
 995 | anova(lm(x~ omega1+omega2) )  # ANOVA Table
 996 | Mod(fft(x))^2/5               # the periodogram (as a check)
 997 | ```
 998 | 
 999 | Example 4.13
1000 | ```r
1001 | par(mfrow=c(2,1))      
1002 | soi.per = mvspec(soi)             
1003 |  abline(v=1/4, lty="dotted")
1004 | rec.per = mvspec(rec) 
1005 |  abline(v=1/4, lty="dotted")
1006 | 
1007 | soi.per$details[1:50,] 
1008 |   #       frequency  period spectrum
1009 |   #  [9,]     0.225  4.4444   0.0309
1010 |   # [10,]     0.250  4.0000   0.0537
1011 |   # [11,]     0.275  3.6364   0.0754
1012 |   # [12,]     0.300  3.3333   0.0567
1013 |   # 
1014 |   # [39,]     0.975  1.0256   0.0167
1015 |   # [40,]     1.000  1.0000   0.9722
1016 |   # [41,]     1.025  0.9756   0.0054
1017 | 
1018 | # conf intervals -  returned value:
1019 | U = qchisq(.025,2)    # 0.05063  
1020 | L = qchisq(.975,2)    # 7.37775
1021 | 2*soi.per$spec[10]/L  # 0.01456
1022 | 2*soi.per$spec[10]/U  # 2.12220
1023 | 2*soi.per$spec[40]/L  # 0.26355
1024 | 2*soi.per$spec[40]/U  # 38.40108
1025 | 
1026 | # Repeat lines above using rec in place of soi
1027 | ```
1028 | 
1029 | Example 4.14
1030 | ```r
1031 | soi.ave = mvspec(soi, kernel('daniell',4))
1032 | abline(v = c(.25,1,2,3), lty=2)
1033 | soi.ave$bandwidth      # = 0.225
1034 | df  = soi.ave$df       # df = 16.9875  
1035 | U   = qchisq(.025, df) # U = 7.555916
1036 | L   = qchisq(.975, df) # L = 30.17425
1037 | soi.ave$spec[10]       # 0.0495202
1038 | soi.ave$spec[40]       # 0.1190800
1039 | # intervals
1040 | df*soi.ave$spec[10]/L  # 0.0278789
1041 | df*soi.ave$spec[10]/U  # 0.1113333
1042 | df*soi.ave$spec[40]/L  # 0.0670396
1043 | df*soi.ave$spec[40]/U  # 0.2677201
1044 | 
1045 | # Repeat above commands with soi replaced by rec, for example:
1046 | rec.ave = mvspec(rec, k)
1047 | abline(v=c(.25,1,2,3), lty=2)
1048 | # and so on.
1049 | ```
1050 | 
1051 | Example 4.15
1052 | ```r
1053 | t = seq(0, 1, by=1/200) 
1054 | amps = c(1, .5, .4, .3, .2, .1)
1055 | x = matrix(0, 201, 6)
1056 | for (j in 1:6) x[,j] = amps[j]*sin(2*pi*t*2*j)
1057 | x = ts(cbind(x, rowSums(x)), start=0, deltat=1/200)               
1058 | tsplot(x, lty=c(1:6, 1), lwd=c(rep(1,6), 2), ylab="Sinusoids", col=1:6, spaghetti=TRUE)
1059 | names = c("Fundamental","2nd Harmonic","3rd Harmonic","4th Harmonic","5th Harmonic", 
1060 |           "6th Harmonic","Formed Signal")
1061 | legend("topright", names, lty=c(1:6, 1), lwd=c(rep(1,6), 2), col=1:6)
1062 | rm(t)                    #Redemption
1063 | 
1064 | ##########################################################################
1065 | # another view of the idea, sawtooth signal periodic but not sinusoidal  #
1066 | ##########################################################################
1067 | y = ts(rev(1:100 %% 20), freq=20)         # sawtooth signal
1068 | par(mfrow=2:1)
1069 | tsplot(1:100, y, ylab="sawtooth signal", col=4)
1070 | mvspec(y, main="", ylab="periodogram", col=5, xlim=c(0,7))  
1071 | ```
1072 | 
1073 | 
1074 | 
1075 | Example 4.16
1076 | ```r
1077 | kernel("modified.daniell", c(3,3))          # for a list
1078 | plot(kernel("modified.daniell", c(3,3)))    # for a graph
1079 | 
1080 | k        = kernel("modified.daniell", c(3,3))
1081 | soi.smo  = mvspec(soi, kernel=k, taper=.1)
1082 | abline(v = c(.25,1), lty=2)
1083 | ## Repeat above lines with rec replacing soi 
1084 | soi.smo$df           # df = 17.42618
1085 | soi.smo$bandwidth    # B  = 0.2308103
1086 | 
1087 | # An easier way to obtain soi.smo:
1088 | soi.smo = mvspec(soi, spans=c(7,7), taper=.1, nxm=4)
1089 | 
1090 | # hightlight El Nino cycle
1091 | rect(1/7, -1e5, 1/3, 1e5, density=NA, col=gray(.5,.2))
1092 | mtext("1/4", side=1, line=0, at=.25, cex=.75)     
1093 | ```
1094 | 
1095 | 
1096 | 
1097 | Example 4.17
1098 | ```r
1099 | s0 = mvspec(soi, spans=c(7,7), plot=FALSE)             # no taper
1100 | s50 = mvspec(soi, spans=c(7,7), taper=.5, plot=FALSE)  # full taper
1101 | tsplot(s50$freq, s50$spec, log="y", type="l", ylab="spectrum", xlab="frequency") 
1102 | lines(s0$freq, s0$spec, lty=2) 
1103 | abline(v=.25, lty=2, col=8)
1104 | mtext('1/4',side=1, line=0, at=.25, cex=.9)
1105 | legend(5,.04, legend=c('full taper', 'no taper'), lty=1:2)
1106 | 
1107 | text(1.42, 0.04, 'leakage', cex=.8)
1108 | arrows(1.4, .035, .75, .009, length=0.05,angle=30)   
1109 | arrows(1.4, .035, 1.21, .0075, length=0.05,angle=30)
1110 | par(fig = c(.65, 1, .65, 1),  new = TRUE, cex=.5,  mgp=c(0,-.1,0), tcl=-.2)
1111 | taper <- function(x) { .5*(1+cos(2*pi*x))  }
1112 |  x <- seq(from = -.5, to = .5, by = 0.001)
1113 | plot(x, taper(x), type = "l",  lty = 1,  yaxt='n', ann=FALSE)
1114 | ```
1115 | 
1116 | 
1117 | Example 4.18
1118 | ```r
1119 | # AR spectrum - AIC picks order=15
1120 | u <- spec.ic(soi,  detrend=TRUE, col=4, lwd=2, nxm=4)  
1121 | # plot AIC and BIC
1122 | dev.new()
1123 | tsplot(0:30, u[[1]][,2:3], type='o', col=2:3, xlab='ORDER', nxm=5, lwd=2, gg=TRUE)  
1124 | ```
1125 | 
1126 | 
1127 | Example 4.21
1128 | ```r
1129 | sr = mvspec(cbind(soi,rec), kernel("daniell",9), plot.type="coh")
1130 | sr$df                     # df = 35.8625
1131 | f = qf(.999, 2, sr$df-2)  # f = 8.529792
1132 | C = f/(18+f)              # C = 0.3188779
1133 | abline(h = C)
1134 | ```
1135 | 
1136 | 
1137 | Example 4.22
1138 | ```r
1139 | par(mfrow=c(3,1))
1140 | tsplot(soi, col=4)                         # plot data
1141 | tsplot(diff(soi), col=4)                   # plot first difference
1142 | k = kernel("modified.daniell", 6)          # filter weights
1143 | tsplot(soif <- kernapply(soi, k), col=4)   # plot 12 month filter
1144 | dev.new()
1145 | mvspec(soif, spans=9, lwd=2, col=5, nxm=4, taper=.1) # spectral analysis (not shown)
1146 | rect(1/7, -1e5, 1/3, 1e5, density=NA, col=gray(.5,.2))
1147 | mtext("1/4", side=1, line=0, at=.25, cex=.75)
1148 | dev.new()
1149 | ##-- frequency responses --##
1150 | par(mfrow=c(2,1))
1151 | w = seq(0, .5, by=.01)
1152 | FRdiff = abs(1-exp(2i*pi*w))^2
1153 | tsplot(w, FRdiff, xlab='frequency')
1154 | u = cos(2*pi*w)+cos(4*pi*w)+cos(6*pi*w)+cos(8*pi*w)+cos(10*pi*w)
1155 | FRma = ((1 + cos(12*pi*w) + 2*u)/12)^2
1156 | tsplot(w, FRma, xlab='frequency')
1157 | ```
1158 | 
1159 | 
1160 | Example 4.24
1161 | ```r
1162 | LagReg(soi, rec, L=15, M=32, threshold=6)
1163 |  dev.new()
1164 | LagReg(rec, soi, L=15, M=32, inverse=TRUE, threshold=.01)
1165 |  dev.new()
1166 | fish = ts.intersect(R=rec, RL1=lag(rec,-1), SL5=lag(soi,-5))
1167 | (u = lm(fish[,1]~fish[,2:3], na.action=NULL))
1168 | acf2(resid(u))       # suggests ar1
1169 | sarima(fish[,1], 1, 0, 0, xreg=fish[,2:3], details=FALSE) 
1170 | ```
1171 | 
1172 | Example 4.25
1173 | ```r
1174 | SigExtract(soi, L=9, M=64, max.freq=.05) 
1175 | ```
1176 | 
1177 | Example 4.26
1178 | ```r
1179 | per = abs(fft(soiltemp-mean(soiltemp))/sqrt(64*36))^2       
1180 | per2 = cbind(per[1:32,18:2], per[1:32,1:18])   # this and line below is just rearranging
1181 | per3 = rbind(per2[32:2,], per2)                # results to get 0 frequency in the middle
1182 | 
1183 | par(mar=c(1,2.5,0,0)+.1)
1184 | persp(-31:31/64, -17:17/36, per3, phi=30, theta=30, expand=.6, ticktype="detailed", xlab="cycles/row", 
1185 |        ylab="cycles/column", zlab="Periodogram Ordinate")
1186 | ```
1187 | 
1188 | [<sub>top</sub>](#table-of-contents)
1189 | 
1190 | ---
1191 | 
1192 | ## Chapter 5
1193 | 
1194 | 
1195 | Example 5.1
1196 | 
1197 | ```r
1198 | # NOTE: The example in the text uses the package 'fracdiff', 
1199 | #       which is a dinosaur and gave questionable results - 
1200 | #       this uses 'arfima' but it didn't make it into the text.
1201 | library(arfima)
1202 | summary(varve.fd <- arfima(log(varve)))  # d.hat = 0.3728, se(d,hat) = 0.0273
1203 | # residual stuff
1204 | innov = resid(varve.fd)  
1205 | par(mfrow=2:1)
1206 | tsplot(innov[[1]])  
1207 | acf1(innov[[1]])  
1208 | 
1209 | # plot pi wgts
1210 | dev.new()
1211 | p = rep(1,31)
1212 | for (k in 1:30){ p[k+1] = (k-coef(varve.fd)[1])*p[k]/(k+1) }
1213 | tsplot(p[-1], ylab=expression(pi[j](d)), xlab="Index (j)", type="h", lwd=4, col=2:7, nxm=5)
1214 | ```
1215 | 
1216 | 
1217 | Example 5.2
1218 | ```r
1219 | series = log(varve)  # specify series to be analyzed
1220 | d0 = .1              # initial value of d
1221 | n.per = nextn(length(series))
1222 | m = (n.per)/2  - 1
1223 | per = abs(fft(series-mean(series))[-1])^2  # remove 0 freq
1224 | per = per/n.per      # R doesn't scale fft by sqrt(n)
1225 | g = 4*(sin(pi*((1:m)/n.per))^2)
1226 | 
1227 | # Function to calculate -log.likelihood
1228 | whit.like = function(d){  
1229 |  g.d=g^d
1230 |  sig2 = (sum(g.d*per[1:m])/m)
1231 |  log.like = m*log(sig2) - d*sum(log(g)) + m
1232 |  return(log.like)   
1233 | }
1234 | 
1235 | # Estimation (?optim for details - output not shown)
1236 | (est = optim(d0, whit.like, gr=NULL, method="L-BFGS-B", 
1237 |      hessian=TRUE, lower=-.5, upper=.5, control=list(trace=1,REPORT=1)))
1238 | 
1239 | # Results  [d.hat = .380, se(dhat) = .028]  
1240 | cat("d.hat =", est$par, "se(dhat) = ",1/sqrt(est$hessian),"\n")  
1241 | g.dhat = g^est$par
1242 | sig2 = sum(g.dhat*per[1:m])/m
1243 | cat("sig2hat =",sig2,"\n")  # sig2hat = .229 
1244 | 
1245 | # compart AR spectrum to long memory spectrum
1246 | u = spec.ic(log(varve), log='y', lty=2, xlim=c(0,.25), ylim=c(.2,20), col=4)        
1247 | g = 4*(sin(pi*((1:500)/2000))^2)
1248 | fhat = sig2*g^{-est$par}             # long memory spectral estimate          
1249 | lines(1:500/2000, fhat, col=6)
1250 | ar.mle(log(varve))                   # to get AR(8) estimates 
1251 | 
1252 | # 'fracdiff' has a GPH method, but I don't trust the pacakge
1253 | # library(fracdiff)
1254 | # fdGPH(log(varve), bandw=.9)   # m = n^bandw- it's supposed to be small- this is way too big 
1255 | ```
1256 | 
1257 | 
1258 | Example 5.3
1259 | ```r
1260 | library(tseries)
1261 | adf.test(log(varve), k=0)  # DF test
1262 | adf.test(log(varve))       # ADF test
1263 | pp.test(log(varve))        # PP test
1264 | ```
1265 | 
1266 | Example 5.4
1267 | ```r
1268 | gnpgr = diff(log(gnp))          # get the returns
1269 | u     = sarima(gnpgr, 1, 0, 0)  # fit an AR(1)
1270 | acf2(resid(u$fit), 20)          # get (p)acf of the squared residuals
1271 |  
1272 | library(fGarch)
1273 | summary(garchFit(~arma(1,0)+garch(1,0), gnpgr))
1274 | ```
1275 | 
1276 | 
1277 | 
1278 | Example 5.5 and 5.6 
1279 | ```r
1280 | library(xts)   # needed to handle djia
1281 | djiar = diff(log(djia$Close))[-1]
1282 | acf2(djiar)    # exhibits some autocorrelation (not shown)
1283 | acf2(djiar^2)  # oozes autocorrelation (not shown)
1284 | library(fGarch)
1285 | # GARCH fit
1286 | summary(djia.g <- garchFit(~arma(1,0)+garch(1,1), data=djiar, cond.dist='std'))
1287 | plot(djia.g)    # to see all plot options
1288 | # APARCH fit
1289 | summary(djia.ap <- garchFit(~arma(1,0)+aparch(1,1), data=djiar, cond.dist='std'))
1290 | plot(djia.ap)
1291 | ```
1292 | 
1293 | Example 5.7
1294 | ```r
1295 | tsplot(flu, type="c")
1296 | Months = c("J","F","M","A","M","J","J","A","S","O","N","D")
1297 | points(flu, pch=Months, cex=.8, font=2)
1298 | # Start analysis
1299 | dflu = diff(flu)
1300 | dev.new()
1301 | lag1.plot(dflu, corr=FALSE) # scatterplot with lowess fit
1302 | thrsh = .05 # threshold
1303 | Z = ts.intersect(dflu, lag(dflu,-1), lag(dflu,-2), lag(dflu,-3),
1304 | lag(dflu,-4) )
1305 | ind1 = ifelse(Z[,2] < thrsh, 1, NA) # indicator < thrsh
1306 | ind2 = ifelse(Z[,2] < thrsh, NA, 1) # indicator >= thrsh
1307 | X1 = Z[,1]*ind1
1308 | X2 = Z[,1]*ind2
1309 | summary(fit1 <- lm(X1~ Z[,2:5]) ) # case 1
1310 | summary(fit2 <- lm(X2~ Z[,2:5]) ) # case 2
1311 | D = cbind(rep(1, nrow(Z)), Z[,2:5]) # design matrix
1312 | p1 = D %*% coef(fit1) # get predictions
1313 | p2 = D %*% coef(fit2)
1314 | prd = ifelse(Z[,2] < thrsh, p1, p2)
1315 | dev.new()
1316 | tsplot(dflu, ylim=c(-.5,.5), type='p', pch=3)
1317 | lines(prd)
1318 | prde1 = sqrt(sum(resid(fit1)^2)/df.residual(fit1) )
1319 | prde2 = sqrt(sum(resid(fit2)^2)/df.residual(fit2) )
1320 | prde = ifelse(Z[,2] < thrsh, prde1, prde2)
1321 | tx = time(dflu)[-(1:4)]
1322 | xx = c(tx, rev(tx))
1323 | yy = c(prd-2*prde, rev(prd+2*prde))
1324 | polygon(xx, yy, border=8, col=gray(.6, alpha=.25) )
1325 | abline(h=.05, col=4, lty=6)
1326 | 
1327 | # Using tsDyn (not in text)
1328 | library(tsDyn)        
1329 | # vignette("tsDyn")   # for package details (it's quirky, so you'll need this)
1330 | dflu = diff(flu)
1331 | (u = setar(dflu, m=4, thDelay=0))  # fit model and view results (thDelay=0 is lag 1 delay)
1332 | BIC(u); AIC(u)                     # if you want to try other models ... m=3 works well too
1333 | plot(u)                            # graphics -  ?plot.setar for information
1334 | ```
1335 | 
1336 | Example 5.8 and 5.9 
1337 | ```r
1338 | soi.d   = resid(lm(soi~time(soi), na.action=NULL)) # detrended SOI
1339 | acf2(soi.d)
1340 | fit     = arima(soi.d, order=c(1,0,0))
1341 | ar1     = as.numeric(coef(fit)[1]) # = 0.5875
1342 | soi.pw  = resid(fit)
1343 | rec.fil = filter(rec, filter=c(1, -ar1), sides=1)
1344 | dev.new()
1345 | ccf2(soi.pw, rec.fil) 
1346 | 
1347 | fish  = ts.intersect(rec, RL1=lag(rec,-1), SL5=lag(soi.d,-5))
1348 | (u    = lm(fish[,1]~fish[,2:3], na.action=NULL))
1349 | dev.new()
1350 | acf2(resid(u)) # suggests ar1
1351 | (arx  = sarima(fish[,1], 1, 0, 0, xreg=fish[,2:3])) # final model
1352 | pred  = rec + resid(arx$fit) # 1-step-ahead predictions
1353 | dev.new()
1354 | tsplot(pred, col=astsa.col(8,.3), lwd=7, ylab='rec & prediction')
1355 | lines(rec)
1356 | ```
1357 | 
1358 | Example 5.10 and 5.11 
1359 | ```r
1360 | library(vars)
1361 | x = cbind(cmort, tempr, part)
1362 | summary(VAR(x, p=1, type="both"))  # "both" fits constant + trend
1363 | 
1364 | VARselect(x, lag.max=10, type="both")
1365 | summary(fit <- VAR(x, p=2, type="both"))
1366 | acf(resid(fit), 52)
1367 | serial.test(fit, lags.pt=12, type="PT.adjusted")
1368 | 
1369 | (fit.pr = predict(fit, n.ahead = 24, ci = 0.95))  # 4 weeks ahead
1370 | dev.new()
1371 | fanchart(fit.pr)  # plot prediction + error
1372 | ```
1373 | 
1374 | Example 5.12 
1375 | ```r
1376 | library(marima)
1377 | model   = define.model(kvar=3, ar=c(1,2), ma=c(1))
1378 | arp     = model$ar.pattern 
1379 | map     = model$ma.pattern
1380 | cmort.d = resid(detr <- lm(cmort~ time(cmort), na.action=NULL))
1381 | xdata   = matrix(cbind(cmort.d, tempr, part), ncol=3)  # strip ts attributes
1382 | fit     = marima(xdata, ar.pattern=arp, ma.pattern=map, means=c(0,1,1), penalty=1)
1383 | # resid analysis (not displayed)
1384 | innov   = t(resid(fit))
1385 | tsplot(innov) 
1386 | acfm(innov)    # since astsa v1.13.2
1387 | # acf(innov, na.action = na.pass)  # or use this
1388 | 
1389 | # fitted values for cmort
1390 | pred    = ts(t(fitted(fit))[,1], start=start(cmort), freq=frequency(cmort)) +
1391 | detr$coef[1] + detr$coef[2]*time(cmort)
1392 | plot(pred, ylab="Cardiovascular Mortality", lwd=2, col=4)
1393 | points(cmort)
1394 | # print estimates and corresponding t^2-statistic
1395 | short.form(fit$ar.estimates, leading=FALSE)
1396 | short.form(fit$ar.fvalues,   leading=FALSE)
1397 | short.form(fit$ma.estimates, leading=FALSE)
1398 | short.form(fit$ma.fvalues,   leading=FALSE)
1399 | fit$resid.cov # estimate of noise cov matrix
1400 | ```
1401 | 
1402 | [<sub>top</sub>](#table-of-contents)
1403 | 
1404 | ---
1405 | 
1406 | ## Chapter 6
1407 | 
1408 | > __Warning__ The code here uses the updated scripts in `astsa` _version 2.0._   Details of the updates are in the help files of `Kfilter`, `Ksmooth`, and `EM`.  Original code (prior to version 2.0) may be found here: [Original Chapter 6 Info and Code](https://github.com/nickpoison/tsa4/blob/master/chap6.md)
1409 | 
1410 | 
1411 | 
1412 | 
1413 | Example 6.1
1414 | ```r
1415 | tsplot(blood, type='o', col=c(6,4,2), lwd=2, pch=19, cex=1) 
1416 | ```
1417 | 
1418 | Example 6.2
1419 | ```r
1420 | tsplot(cbind(gtemp_land, gtemp_ocean), spaghetti=TRUE, lwd=2, pch=20, type="o", 
1421 |         col=astsa.col(c(4,2),.5), ylab="Temperature Deviations", main="Global Warming")
1422 | legend("topleft", legend=c("Land Surface", "Sea Surface"), lty=1, pch=20, col=c(4,2), bg="white")
1423 | ```
1424 | 
1425 | Example 6.5
1426 | ```r
1427 | # generate data 
1428 | set.seed(1)  
1429 | num = 50
1430 | w   = rnorm(num+1,0,1)
1431 | v   = rnorm(num,0,1)
1432 | mu  = cumsum(w)     # states:  mu[0], mu[1], . . ., mu[50] 
1433 | y   = mu[-1] + v    # obs:  y[1], . . ., y[50]
1434 | 
1435 | # filter and smooth (Ksmooth does both)
1436 | mu0 = 0;  sigma0 = 1;  phi = 1;  sQ = 1;  sR = 1   
1437 | ks = Ksmooth(y, A=1, mu0, sigma0, phi, sQ, sR)   
1438 | 
1439 | # pictures 
1440 | par(mfrow=c(3,1))
1441 | 
1442 | tsplot(mu[-1], type='p', col=4, pch=19, ylab=expression(mu[~t]), main="Prediction", ylim=c(-5,10)) 
1443 |   lines(ks$Xp, col=6)
1444 |   lines(ks$Xp+2*sqrt(ks$Pp), lty=6, col=6)
1445 |   lines(ks$Xp-2*sqrt(ks$Pp), lty=6, col=6)
1446 | 
1447 | tsplot(mu[-1], type='p', col=4, pch=19, ylab=expression(mu[~t]), main="Filter", ylim=c(-5,10)) 
1448 |   lines(ks$Xf, col=6)
1449 |   lines(ks$Xf+2*sqrt(ks$Pf), lty=6, col=6)
1450 |   lines(ks$Xf-2*sqrt(ks$Pf), lty=6, col=6)
1451 | 
1452 | tsplot(mu[-1], type='p', col=4, pch=19, ylab=expression(mu[~t]), main="Smoother", ylim=c(-5,10)) 
1453 |   lines(ks$Xs, col=6)
1454 |   lines(ks$Xs+2*sqrt(ks$Ps), lty=6, col=6)
1455 |   lines(ks$Xs-2*sqrt(ks$Ps), lty=6, col=6)
1456 | 
1457 | mu[1]; ks$X0n; sqrt(ks$P0n)   # initial value info
1458 | ```
1459 | 
1460 | 
1461 | Example 6.6 
1462 | ```r
1463 | # Generate Data
1464 | set.seed(999)
1465 | num = 100
1466 | N = num+1
1467 | x = sarima.sim(n=N, ar=.8)
1468 | y = ts(x[-1] + rnorm(num,0,1))     
1469 | 
1470 | # Initial Estimates 
1471 | u = ts.intersect(y, lag(y,-1), lag(y,-2)) 
1472 | varu = var(u)
1473 | coru = cor(u) 
1474 | phi = coru[1,3]/coru[1,2] 
1475 | q = (1-phi^2)*varu[1,2]/phi 
1476 | r = varu[1,1] - q/(1-phi^2) 
1477 | (init.par = c(phi, sqrt(q), sqrt(r))) 
1478 | 
1479 | # Function to evaluate the likelihood 
1480 | Linn=function(para){
1481 |   phi = para[1]; sigw = para[2]; sigv = para[3] 
1482 |   Sigma0 = (sigw^2)/(1-phi^2); Sigma0[Sigma0<0]=0 
1483 |   kf = Kfilter(y,A=1,mu0=0,Sigma0,phi,sigw,sigv)
1484 |   return(kf$like)   
1485 |   }
1486 | 
1487 | # Estimation
1488 | (est = optim(init.par, Linn, gr=NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))      
1489 | SE = sqrt(diag(solve(est$hessian)))
1490 | cbind(estimate=c(phi=est$par[1],sigw=est$par[2],sigv=est$par[3]), SE)
1491 | ```
1492 | 
1493 | 
1494 | 
1495 | Example 6.7
1496 | ```r
1497 | ##- slight change from text, the data scaled -##
1498 | ##- you can remove the scales to get to the original analysis -##
1499 | 
1500 | ##- ALSO note that regression parameters not used are set to NULL (the default) instead of 0 now. 
1501 | 
1502 | # Setup 
1503 | y = cbind(globtemp/sd(globtemp), globtempl/sd(globtempl))
1504 | num = nrow(y)
1505 | input = rep(1,num)
1506 | A = matrix(c(1,1), nrow=2)
1507 | mu0 = -.35; Sigma0 = 1;  Phi = 1
1508 | 
1509 | # Function to Calculate Likelihood 
1510 | Linn=function(para){
1511 |  sQ = para[1]      # sigma_w
1512 |   sR1 = para[2]    # 11 element of  sR
1513 |   sR2 = para[3]    # 22 element of sR
1514 |   sR21 = para[4]   # 21 element of sR
1515 |  sR = matrix(c(sR1,sR21,0,sR2), 2)  # put the matrix together
1516 |  drift = para[5]
1517 |  kf = Kfilter(y,A,mu0,Sigma0,Phi,sQ,sR,Ups=drift,Gam=NULL,input)  # NOTE Gamma is set to NULL now (instead of 0)
1518 |  return(kf$like) 
1519 |  }
1520 | 
1521 | # Estimation
1522 | init.par = c(.1,.1,.1,0,.05)  # initial values of parameters
1523 | (est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1))) 
1524 | SE = sqrt(diag(solve(est$hessian))) 
1525 | 
1526 | # Summary of estimation  
1527 | estimate = est$par; u = cbind(estimate, SE)
1528 | rownames(u)=c("sigw","sR11", "sR22", "sR21", "drift"); u  
1529 | 
1530 | # Smooth (first set parameters to their final estimates)
1531 | sQ    = est$par[1]  
1532 |  sR1  = est$par[2]   
1533 |  sR2  = est$par[3]   
1534 |  sR21 = est$par[4]  
1535 | sR    = matrix(c(sR1,sR21,0,sR2), 2)
1536 | (R    = sR%*%t(sR))   #  to view the estimated R matrix
1537 | drift = est$par[5]  
1538 | ks    = Ksmooth(y,A,mu0,Sigma0,Phi,sQ,sR,Ups=drift,Gam=NULL,input)  # NOTE Gamma is set to NULL now (instead of 0)
1539 | 
1540 | # Plot 
1541 | tsplot(y, spag=TRUE, margins=.5, type='o', pch=2:3, col=4:3, lty=6, ylab='Temperature Deviations')
1542 | xsm  = ts(as.vector(ks$Xs), start=1880)
1543 | rmse = ts(sqrt(as.vector(ks$Ps)), start=1880)
1544 | lines(xsm, lwd=2, col=6)
1545 |   xx = c(time(xsm), rev(time(xsm)))
1546 |   yy = c(xsm-2*rmse, rev(xsm+2*rmse))
1547 | polygon(xx, yy, border=NA, col=gray(.6, alpha=.25))
1548 | ```
1549 | 
1550 | 
1551 | Example 6.8
1552 | 
1553 | 
1554 | ```r
1555 | library(nlme)   # loads package nlme (comes with R)
1556 | 
1557 | # Generate data (same as Example 6.6)
1558 | set.seed(999); num = 100; N = num+1
1559 | x = sarima.sim(ar=.8, n=N)
1560 | y = ts(x[-1] + rnorm(num,0,1))     
1561 | 
1562 | # Initial Estimates 
1563 | u = ts.intersect(y,lag(y,-1),lag(y,-2)) 
1564 | varu = var(u); coru = cor(u) 
1565 | phi = coru[1,3]/coru[1,2]             
1566 | q = (1-phi^2)*varu[1,2]/phi   
1567 | r = varu[1,1] - q/(1-phi^2) 
1568 | mu0 = 0; Sigma0 = 2.8
1569 | ( em = EM(y, 1, mu0, Sigma0, phi, q, r) )   
1570 | 
1571 | # Standard Errors  (this uses nlme)
1572 | phi = em$Phi; sq = sqrt(em$Q); sr = sqrt(em$R)
1573 | mu0 = em$mu0; Sigma0 = em$Sigma0
1574 | para = c(phi, sq, sr)
1575 |  # evaluate likelihood at estimates 
1576 | Linn=function(para){
1577 |   kf = Kfilter(y, A=1, mu0, Sigma0, para[1], para[2], para[3])
1578 |   return(kf$like) 
1579 |   }
1580 | emhess = fdHess(para, function(para) Linn(para))
1581 | SE = sqrt(diag(solve(emhess$Hessian)))  
1582 | 
1583 | # Display summary of estimation 
1584 | estimate = c(para, em$mu0, em$Sigma0); SE = c(SE,NA,NA)
1585 | u = cbind(estimate, SE)
1586 | rownames(u) = c("phi","sigw","sigv","mu0","Sigma0")
1587 | u 
1588 | ```
1589 | 
1590 | 
1591 | Example 6.9
1592 | 
1593 | 
1594 | ```r
1595 | y    = blood
1596 | num  = nrow(y)       
1597 | A    = array(0, dim=c(3,3,num))   
1598 | for(k in 1:num) if (!is.na(y[k,1])) A[,,k]= diag(1,3) 
1599 | 
1600 | # Initial values 
1601 | mu0    = matrix(0,3,1) 
1602 | Sigma0 = diag(c(.1,.1,1) ,3)
1603 | Phi    = diag(1,3)
1604 | Q      = diag(c(.1,.1,1), 3)
1605 | R     = diag(c(.1,.1,1), 3)  
1606 | ( em = EM(y, A, mu0, Sigma0, Phi, Q, R) ) 
1607 | 
1608 | # Graph smoother
1609 | sQ = em$Q %^% .5
1610 | sR = sqrt(em$R)
1611 | ks  = Ksmooth(y, A, em$mu0, em$Sigma0, em$Phi, sQ , sR)
1612 | y1s = ks$Xs[1,,] 
1613 | y2s = ks$Xs[2,,] 
1614 | y3s = ks$Xs[3,,]
1615 | p1  = 2*sqrt(ks$Ps[1,1,]) 
1616 | p2  = 2*sqrt(ks$Ps[2,2,]) 
1617 | p3  = 2*sqrt(ks$Ps[3,3,])
1618 | 
1619 | par(mfrow=c(3,1))
1620 | tsplot(WBC, type='p', pch=19, ylim=c(1,5), col=6, lwd=2, cex=1)
1621 | lines(y1s) 
1622 |   xx = c(time(WBC), rev(time(WBC)))  # same for all
1623 |   yy = c(y1s-p1, rev(y1s+p1))
1624 | polygon(xx, yy, border=8, col=astsa.col(8, alpha = .1))  
1625 | 
1626 | tsplot(PLT, type='p', ylim=c(3,6), pch=19, col=4, lwd=2, cex=1)
1627 | lines(y2s)
1628 |   yy = c(y2s-p2, rev(y2s+p2))
1629 | polygon(xx, yy, border=8, col=astsa.col(8, alpha = .1))  
1630 | 
1631 | tsplot(HCT, type='p', pch=19, ylim=c(20,40), col=2, lwd=2, cex=1)
1632 | lines(y3s)
1633 |   yy = c(y3s-p3, rev(y3s+p3))
1634 | polygon(xx, yy, border=8, col=astsa.col(8, alpha = .1))  
1635 | ```
1636 | 
1637 | 
1638 | 
1639 | Example 6.10
1640 | ```r
1641 | num = length(jj)
1642 | A   = cbind(1,1,0,0) 
1643 | 
1644 | # Function to Calculate Likelihood 
1645 | Linn = function(para){
1646 |  Phi = diag(0,4) 
1647 |  Phi[1,1] = para[1] 
1648 |  Phi[2,]=c(0,-1,-1,-1); Phi[3,]=c(0,1,0,0); Phi[4,]=c(0,0,1,0)
1649 |  sQ1 = para[2]; sQ2 = para[3]     # sqrt q11 and sqrt q22
1650 |  sQ  = diag(0,4); sQ[1,1]=sQ1; sQ[2,2]=sQ2
1651 |  sR = para[4]                     # sqrt r11
1652 |  kf = Kfilter(jj, A, mu0, Sigma0, Phi, sQ, sR)
1653 |  return(kf$like)  
1654 |  }
1655 | 
1656 | # Initial Parameters 
1657 | mu0      = c(.7,0,0,0) 
1658 | Sigma0   = diag(.04, 4)  
1659 | init.par = c(1.03, .1, .1, .5)   # Phi[1,1], the 2 Qs and R
1660 | 
1661 | # Estimation
1662 | est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1))
1663 | SE  = sqrt(diag(solve(est$hessian)))
1664 | u   = cbind(estimate=est$par,SE)
1665 | rownames(u)=c("Phi11","sigw1","sigw2","sigv"); u 
1666 | 
1667 | # Smooth
1668 | Phi      = diag(0,4) 
1669 | Phi[1,1] = est$par[1]; Phi[2,]  = c(0,-1,-1,-1) 
1670 | Phi[3,]  = c(0,1,0,0); Phi[4,]  = c(0,0,1,0)
1671 | sQ       = diag(0,4)
1672 | sQ[1,1]  = est$par[2]
1673 | sQ[2,2]  = est$par[3]   
1674 | sR       = est$par[4]   
1675 | ks       = Ksmooth(jj, A, mu0, Sigma0, Phi, sQ, sR)   
1676 | 
1677 | # Plots
1678 | Tsm   = ts(ks$Xs[1,,], start=1960, freq=4)
1679 | Ssm   = ts(ks$Xs[2,,], start=1960, freq=4)
1680 | p1    = 3*sqrt(ks$Ps[1,1,]); p2 = 3*sqrt(ks$Ps[2,2,])
1681 | par(mfrow=c(2,1))
1682 | tsplot(Tsm, main='Trend Component', ylab='Trend')
1683 |   xx  = c(time(jj), rev(time(jj)))
1684 |   yy  = c(Tsm-p1, rev(Tsm+p1))
1685 | polygon(xx, yy, border=NA, col=gray(.5, alpha = .3))
1686 | tsplot(jj, main='Data & Trend+Season', ylab='J&J QE/Share', ylim=c(-.5,17))
1687 |   xx  = c(time(jj), rev(time(jj)) )
1688 |   yy  = c((Tsm+Ssm)-(p1+p2), rev((Tsm+Ssm)+(p1+p2)) )
1689 | polygon(xx, yy, border=NA, col=gray(.5, alpha = .3))
1690 | 
1691 | # Forecast
1692 | dev.new()
1693 | n.ahead = 12
1694 | y       = ts(append(jj, rep(0,n.ahead)), start=1960, freq=4)
1695 | rmspe   = rep(0,n.ahead) 
1696 | x00     = ks$Xf[,,num]
1697 | P00     = ks$Pf[,,num]
1698 | Q       = sQ%*%t(sQ) 
1699 | R       = sR%*%t(sR)
1700 | for (m in 1:n.ahead){
1701 |        xp = Phi%*%x00
1702 |        Pp = Phi%*%P00%*%t(Phi)+Q
1703 |       sig = A%*%Pp%*%t(A)+R
1704 |         K = Pp%*%t(A)%*%(1/sig)
1705 |       x00 = xp 
1706 |       P00 = Pp-K%*%A%*%Pp
1707 |  y[num+m] = A%*%xp
1708 |  rmspe[m] = sqrt(sig) 
1709 | }
1710 | tsplot(y, type='o', main='', ylab='J&J QE/Share', ylim=c(5,30), xlim = c(1975,1984))
1711 | upp  = ts(y[(num+1):(num+n.ahead)]+2*rmspe, start=1981, freq=4)
1712 | low  = ts(y[(num+1):(num+n.ahead)]-2*rmspe, start=1981, freq=4)
1713 |  xx  = c(time(low), rev(time(upp)))
1714 |  yy  = c(low, rev(upp))
1715 | polygon(xx, yy, border=8, col=gray(.5, alpha = .3))
1716 | abline(v=1981, lty=3)
1717 | ```
1718 | 
1719 | 
1720 | Example 6.12
1721 | ```r
1722 | # Preliminary analysis
1723 | fit1   = sarima(cmort, 2,0,0, xreg=time(cmort))
1724 | acf(cbind(dmort <- resid(fit1$fit), tempr, part))
1725 | lag2.plot(tempr, dmort, 8)
1726 | lag2.plot(part, dmort, 8)
1727 | 
1728 | # quick and dirty fit (detrend then fit ARMAX)
1729 | trend   = time(cmort) - mean(time(cmort))  
1730 | dcmort  = resid(fit2 <- lm(cmort~trend, na.action=NULL))  # detrended mort
1731 | u       = ts.intersect(dM=dcmort, dM1=lag(dcmort,-1), dM2=lag(dcmort,-2), T1=lag(tempr,-1), P=part, P4=lag(part,-4))
1732 | sarima(u[,1], 0,0,0, xreg=u[,2:6])  # ARMAX fit with residual analysis 
1733 | 
1734 | #################################################
1735 | ##  All estimates at once                      ##
1736 | #################################################
1737 | trend   = time(cmort) - mean(time(cmort)) # center time
1738 | const   = time(cmort)/time(cmort)         # appropriate time series of 1s
1739 | ded     = ts.intersect(M=cmort, T1=lag(tempr,-1), P=part, P4=lag(part,-4), trend, const)
1740 | y       = ded[,1]
1741 | input   = ded[,2:6]
1742 | num     = length(y)
1743 | A       = matrix(c(1,0), 1, 2)  
1744 | 
1745 | # Function to Calculate Likelihood
1746 | Linn=function(para){
1747 |  phi1   = para[1]; phi2 = para[2]; sR = para[3];  b1 = para[4]
1748 |  b2     = para[5];   b3 = para[6]; b4 = para[7]; alf = para[8]
1749 |  mu0    = matrix(c(0,0), 2, 1)
1750 |  Sigma0 = diag(100, 2)
1751 |  Phi    = matrix(c(phi1, phi2, 1, 0), 2)
1752 |  S      = 1
1753 |  Ups    = matrix(c(b1, 0, b2, 0, b3, 0, 0, 0, 0, 0), 2, 5)
1754 |  Gam    = matrix(c(0, 0, 0, b4, alf), 1, 5) 
1755 |  sQ     = matrix(c(phi1, phi2), 2)*sR
1756 | # S      = sR^2
1757 |  kf     = Kfilter(y, A, mu0, Sigma0, Phi, sQ, sR, Ups=Ups, Gam=Gam, input=input, S=S, version=2)
1758 | return(kf$like) 
1759 | }
1760 | 
1761 | # Estimation - prelim analysis gives good starting values
1762 | init.par = c(phi1=.3, phi2=.3, sR=4, b1=-.1, b2=.1, b3=.04, b4=-1.3, alf=mean(cmort)) 
1763 | L = c( 0,  0,  1, -1,  0,  0, -2, 70)   # lower bound on parameters
1764 | U = c(.5, .5, 10,  0, .5, .5,  0, 90)   # upper bound - used in optim
1765 | est      = optim(init.par, Linn, NULL, method='L-BFGS-B', lower=L, upper=U, 
1766 |                  hessian=TRUE, control=list(trace=1, REPORT=1, factr=10^8))
1767 | SE       = sqrt(diag(solve(est$hessian)))
1768 | round(cbind(estimate=est$par, SE), 3) # results
1769 | #################################################
1770 | 
1771 | # Residual Analysis (not shown)
1772 | phi1   = est$par[1]; phi2 = est$par[2]
1773 | sR     = est$par[3]; b1   = est$par[4]
1774 | b2     = est$par[5]; b3   = est$par[6]
1775 | b4     = est$par[7]; alf  = est$par[8]
1776 | mu0    = matrix(c(0,0), 2, 1)
1777 | Sigma0 = diag(100, 2)
1778 | Phi    = matrix(c(phi1, phi2, 1, 0), 2)
1779 | S      = 1
1780 | Ups    = matrix(c(b1, 0, b2, 0, b3, 0, 0, 0, 0, 0), 2, 5)
1781 | Gam    = matrix(c(0, 0, 0, b4, alf), 1, 5) 
1782 | sQ     = matrix(c(phi1, phi2), 2)*sR
1783 | kf     = Kfilter(y, A, mu0, Sigma0, Phi, sQ, sR, Ups=Ups, Gam=Gam, input=input, S=S, version=2)
1784 | res    = ts(drop(kf$innov), start=start(cmort), freq=frequency(cmort))
1785 | sarima(res, 0,0,0, no.constant=TRUE)  # gives a full residual analysis
1786 | 
1787 | # Similar fit with but with trend in the X of ARMAX
1788 | trend  = time(cmort) - mean(time(cmort))
1789 | u      = ts.intersect(M=cmort, M1=lag(cmort,-1), M2=lag(cmort,-2), T1=lag(tempr,-1), 
1790 |            P=part, P4=lag(part -4), trend)
1791 | sarima(u[,1], 0,0,0, xreg=u[,2:7])
1792 | ```
1793 | 
1794 | 
1795 | 
1796 | Example 6.13
1797 | ```r
1798 | ################################## 
1799 | # NOTE:  If this takes a long time on your machine, 
1800 | #        increase `tol` and/or decrease `nboot`
1801 | tol   = .0001    # determines convergence of optimizer     
1802 | nboot = 500      # number of bootstrap replicates     
1803 | ################################## 
1804 | 
1805 | y     = window(qinfl, c(1953,1), c(1965,2))  # inflation   
1806 | z     = window(qintr, c(1953,1), c(1965,2))  # interest   
1807 | num   = length(y) 
1808 | A     = array(z, dim=c(1,1,num))
1809 | input = matrix(1,num,1)  
1810 | 
1811 | # Function to Calculate Likelihood   
1812 | Linn  = function(para, y.data){  # pass data also
1813 |    phi = para[1];  alpha = para[2]
1814 |    b   = para[3];  Ups   = (1-phi)*b
1815 |    sQ  = para[4];  sR    = para[5]  
1816 |    kf  = Kfilter(y.data,A,mu0,Sigma0,phi,sQ ,sR ,Ups ,Gam=alpha,input)
1817 |    return(kf$like)    
1818 | }
1819 | 
1820 | # Parameter Estimation   
1821 | mu0      = 1
1822 | Sigma0   = .01  
1823 | init.par = c(phi=.84, alpha=-.77, b=.85, sQ=.12, sR=1.1)  # initial values   
1824 | 
1825 | est = optim(init.par,  Linn, NULL, y.data=y, method="BFGS", hessian=TRUE, 
1826 |              control=list(trace=1, REPORT=1, reltol=tol))  
1827 | SE  = sqrt(diag(solve(est$hessian)))   
1828 | 
1829 | phi   = est$par[1];  alpha = est$par[2]
1830 | b     = est$par[3];  Ups   = (1-phi)*b         
1831 | sQ    = est$par[4];  sR    = est$par[5] 
1832 | round(cbind(estimate=est$par, SE), 3)  
1833 | 
1834 | 
1835 | # BEGIN BOOTSTRAP   
1836 | # Run the filter at the estimates 
1837 | kf  = Kfilter(y, A, mu0, Sigma0, phi, sQ, sR, Ups, Gam=alpha, input) 
1838 | 
1839 | # Pull out necessary values from the filter and initialize  
1840 | xp      = kf$Xp
1841 | Pp      = kf$Pp
1842 | innov   = kf$innov 
1843 | sig     = kf$sig 
1844 | e       = innov/sqrt(sig)
1845 | e.star  = e                      # initialize values
1846 | y.star  = y  
1847 | xp.star = xp  
1848 | k       = 4:50                   # hold first 3 observations fixed 
1849 | para.star = matrix(0, nboot, 5)  # to store estimates
1850 | init.par  =  c(.84, -.77, .85, .12, 1.1)    
1851 | 
1852 | pb = txtProgressBar(min = 0, max = nboot, initial = 0, style=3)  # progress bar
1853 | 
1854 | for (i in 1:nboot){
1855 |  setTxtProgressBar(pb,i)                       
1856 |  e.star[k] = sample(e[k], replace=TRUE)   
1857 |  for (j in k){ 
1858 |    K  = (phi*Pp[j-1]*z[j-1])/sig[j-1]  
1859 |   xp.star[j] = phi*xp.star[j-1] + Ups +   K*sqrt(sig[j-1])*e.star[j-1]
1860 |   } 
1861 |    y.star[k] = z[k]*xp.star[k] + alpha + sqrt(sig[k])*e.star[k]  
1862 |  est.star  = optim(init.par, Linn, NULL, y.data=y.star, method='BFGS', control=list(reltol=tol))     
1863 |  para.star[i,] = cbind(est.star$par[1], est.star$par[2], est.star$par[3], 
1864 |                        abs(est.star$par[4]), abs(est.star$par[5]))   
1865 | }
1866 | close(pb) 
1867 | 
1868 | # Some summary statistics  
1869 | rmse = rep(NA,5)                 # SEs from the bootstrap
1870 | for(i in 1:5){rmse[i]=sqrt(sum((para.star[,i]-est$par[i])^2)/nboot)
1871 |               cat(i, rmse[i],"\n") 
1872 |              }              
1873 | # Plot phi and sigw  (scatter.hist in astsa v1.13)
1874 | phi  = para.star[,1] 
1875 | sigw = abs(para.star[,4]) 
1876 | scatter.hist(sigw, phi, ylab=expression(phi), xlab=expression(sigma[~w]), 
1877 |              hist.col=astsa.col(5,.4), pt.col=5, pt.size=1.5)
1878 | ```
1879 | 
1880 | 
1881 | Example 6.14
1882 | 
1883 | ```r
1884 | set.seed(123)
1885 | num   = 50
1886 | w     = rnorm(num,0,.1)
1887 | x     = cumsum(cumsum(w))
1888 | y     = x + rnorm(num,0,1)
1889 | ## State Space ##
1890 | Phi   = matrix(c(2,1,-1,0),2)
1891 | A     = matrix(c(1,0),1)
1892 | mu0   = matrix(0,2); Sigma0 = diag(1,2)
1893 | Linn  = function(para){
1894 |   sigw = para[1] 
1895 |   sigv = para[2]
1896 |   sQ   = diag(c(sigw,0))
1897 |   kf   = Kfilter(y, A, mu0, Sigma0, Phi, sQ, sigv)
1898 | return(kf$like) 
1899 | }
1900 | 
1901 | ## Estimation ##
1902 | init.par = c(.1, 1)
1903 | (est  = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))
1904 | SE    = sqrt(diag(solve(est$hessian)))
1905 | # Summary of estimation
1906 | estimate = est$par; u = cbind(estimate, SE)
1907 | rownames(u) = c("sigw","sigv"); u
1908 | 
1909 | # Smooth
1910 | sigw  = est$par[1]
1911 | sQ    = diag(c(sigw,0))
1912 | sigv  = est$par[2]
1913 | ks    = Ksmooth(y, A, mu0, Sigma0, Phi, sQ, sigv)
1914 | xsmoo = ts(ks$Xs[1,1,])
1915 | psmoo = ts(ks$Ps[1,1,])
1916 | upp   = xsmoo + 2*sqrt(psmoo)
1917 | low   = xsmoo - 2*sqrt(psmoo)
1918 | 
1919 | 
1920 | tsplot(x, ylab="", ylim=c(-1,8), col=1)
1921 | lines(y, type='o', col=8)
1922 | lines(xsmoo, col=4, lty=2, lwd=3)
1923 | lines(upp, col=4, lty=2); lines(low, col=4, lty=2)
1924 | lines(smooth.spline(y), lty=1, col=2)
1925 | legend("topleft", c("Observations","State"), pch=c(1,-1), lty=1, lwd=c(1,2), col=c(8,1))
1926 | legend("bottomright", c("Smoother", "GCV Spline"), lty=c(2,1), lwd=c(3,1), col=c(4,2))
1927 | ```
1928 | 
1929 | Example 6.16
1930 | 
1931 | ```r
1932 | library(depmixS4)
1933 | model <- depmix(EQcount ~1, nstates=2, data=data.frame(EQcount), family=poisson('identity'), respstart=c(15,25))
1934 | set.seed(90210)
1935 | summary(fm <- fit(model))   # estimation results  
1936 | standardError(fm)           # with standard errors
1937 | 
1938 | ##-- A little nicer display of the parameters --##
1939 | para.mle = as.vector(getpars(fm))[3:8]  
1940 | ( mtrans = matrix(para.mle[1:4], byrow=TRUE, nrow=2) )
1941 | ( lams   = para.mle[5:6] )  
1942 | ( pi1    = mtrans[2,1]/(2 - mtrans[1,1] - mtrans[2,2]) )  
1943 | ( pi2    = 1 - pi1 )
1944 | 
1945 | #-- Graphics --##
1946 | par(mfrow=c(3,1))
1947 | # data and states
1948 | tsplot(EQcount, main="", ylab='EQcount', type='h', col=gray(.7), ylim=c(0,50))
1949 | text(EQcount, col=6*posterior(fm)[,1]-2, labels=posterior(fm)[,1])
1950 | # prob of state 2
1951 | tsplot(ts(posterior(fm)[,3], start=1900), ylab = expression(hat(pi)[~2]*'(t|n)'));  abline(h=.5, lty=2)
1952 | # histogram
1953 | hist(EQcount, breaks=30, prob=TRUE, main="")
1954 | xvals = seq(1,45)
1955 | u1 = pi1*dpois(xvals, lams[1])  
1956 | u2 = pi2*dpois(xvals, lams[2])
1957 | lines(xvals, u1, col=4)   
1958 | lines(xvals, u2, col=2)
1959 | ```
1960 | 
1961 | Example 6.17
1962 | ```r
1963 | library(depmixS4)
1964 | y = ts(sp500w, start=2003, freq=52)  # make data depmix friendly
1965 | mod3 <- depmix(y~1, nstates=3, data=data.frame(y))
1966 | set.seed(2)
1967 | summary(fm3 <- fit(mod3))   # estimation results  
1968 | 
1969 | ##-- a little nicer display --## 
1970 |  para.mle    = as.vector(getpars(fm3)[-(1:3)])
1971 |  permu       = matrix(c(0,0,1,0,1,0,1,0,0), 3,3)   # for the label switch 
1972 |  (mtrans.mle = permu%*%round(t(matrix(para.mle[1:9],3,3)),3)%*%permu)
1973 |  (norms.mle  = round(matrix(para.mle[10:15],2,3),3)%*%permu)
1974 | 
1975 | ##-- Graphics --##  
1976 | layout(matrix(c(1,2, 1,3), 2), heights=c(1,.75))
1977 | 
1978 | tsplot(y, main="", ylab='S&P500 Weekly Returns', col=gray(.7), ylim=c(-.11,.11))
1979 |  culer = 4-posterior(fm3)[,1];  culer[culer==3]=4  # switch labels 1 and 3
1980 |  text(y, col=culer, labels=4-posterior(fm3)[,1])
1981 | 
1982 | acf1(y^2, 25) 
1983 | 
1984 | hist(y, 25, prob=TRUE, main='', col=astsa.col(8,.2))
1985 | pi.hat = colSums(posterior(fm3)[-1,2:4])/length(y)
1986 | culer = c(1,2,4)
1987 | for (i in 1:3) { 
1988 |  mu = norms.mle[1,i]; sig = norms.mle[2,i]
1989 |  x = seq(-.2,.15, by=.001)
1990 | lines(x, pi.hat[4-i]*dnorm(x, mean=mu, sd=sig), col=culer[i], lwd=2)  
1991 |  }
1992 | ```
1993 | 
1994 | Example 6.18
1995 | ```r
1996 | library(MSwM)
1997 | set.seed(90210)
1998 | dflu  = diff(flu)
1999 | model = lm(dflu~ 1)
2000 | mod   = msmFit(model, k=2, p=2, sw=rep(TRUE,4)) # 2 regimes, AR(2)s
2001 | summary(mod)
2002 | plotProb(mod, which=3)
2003 | ```
2004 | 
2005 | 
2006 | 
2007 | Example 6.22
2008 | ```r
2009 | y   = flu  
2010 | num = length(y)
2011 | nstate = 4                      # state dimenstion
2012 | M1 = as.matrix(cbind(1,0,0,1))  # obs matrix normal
2013 | M2 = as.matrix(cbind(1,0,1,1))  # obs matrix flu epi
2014 | prob = matrix(0,num,1); yp = y  # to store pi2(t|t-1) & y(t|t-1)
2015 | xfilter = array(0, dim=c(nstate,1,num)) # to store x(t|t)
2016 | # Function to Calculate Likelihood
2017 | Linn = function(para){
2018 |   alpha1 = para[1]; alpha2 = para[2]; beta0 = para[3]
2019 |   sQ1 = para[4];  sQ2 = para[5];  like=0
2020 |   xf  = matrix(0, nstate, 1)  # x filter
2021 |   xp  = matrix(0, nstate, 1)  # x pred
2022 |   Pf  = diag(.1, nstate)      # filter cov
2023 |   Pp  = diag(.1, nstate)      # pred cov
2024 |   pi11 <- .75 -> pi22;  pi12 <- .25 -> pi21; pif1 <- .5 -> pif2
2025 |   phi = matrix(0,nstate,nstate)
2026 |   phi[1,1] = alpha1; phi[1,2] = alpha2; phi[2,1]=1; phi[4,4]=1
2027 |   Ups = as.matrix(rbind(0,0,beta0,0))
2028 |   Q   = matrix(0,nstate,nstate)
2029 |   Q[1,1] = sQ1^2; Q[3,3] = sQ2^2; R=0  # R=0 in final model
2030 |   # begin filtering #
2031 |     for(i in 1:num){
2032 |     xp   = phi%*%xf + Ups; Pp = phi%*%Pf%*%t(phi) + Q
2033 |     sig1 = as.numeric(M1%*%Pp%*%t(M1) + R)
2034 |     sig2 = as.numeric(M2%*%Pp%*%t(M2) + R)
2035 |     k1   = Pp%*%t(M1)/sig1; k2 = Pp%*%t(M2)/sig2
2036 |     e1   = y[i]-M1%*%xp; e2 = y[i]-M2%*%xp
2037 |     pip1 = pif1*pi11 + pif2*pi21; pip2 = pif1*pi12 + pif2*pi22
2038 |     den1 = (1/sqrt(sig1))*exp(-.5*e1^2/sig1)
2039 |     den2 = (1/sqrt(sig2))*exp(-.5*e2^2/sig2)
2040 |     denm = pip1*den1 + pip2*den2
2041 |     pif1 = pip1*den1/denm; pif2 = pip2*den2/denm
2042 |     pif1 = as.numeric(pif1); pif2 = as.numeric(pif2)
2043 |     e1   = as.numeric(e1); e2=as.numeric(e2)
2044 |     xf   = xp + pif1*k1*e1 + pif2*k2*e2
2045 |     eye  = diag(1, nstate)
2046 |     Pf   = pif1*(eye-k1%*%M1)%*%Pp + pif2*(eye-k2%*%M2)%*%Pp
2047 |     like = like - log(pip1*den1 + pip2*den2)
2048 |     prob[i]<<-pip2; xfilter[,,i]<<-xf; innov.sig<<-c(sig1,sig2)
2049 |     yp[i]<<-ifelse(pip1 > pip2, M1%*%xp, M2%*%xp)  
2050 |     }
2051 | return(like)   
2052 | }
2053 | # Estimation
2054 | alpha1 = 1.4; alpha2 = -.5; beta0 = .3; sQ1 = .1; sQ2 = .1
2055 | init.par = c(alpha1, alpha2, beta0, sQ1, sQ2)
2056 | (est = optim(init.par, Linn, NULL, method='BFGS', hessian=TRUE, control=list(trace=1,REPORT=1)))
2057 | SE   = sqrt(diag(solve(est$hessian)))
2058 | u    = cbind(estimate=est$par, SE)
2059 | rownames(u)=c('alpha1','alpha2','beta0','sQ1','sQ2'); u
2060 | 
2061 | # Graphics
2062 | predepi = ifelse(prob<.5,0,1)
2063 | FLU = window(flu, start=1968.4)
2064 | Time = window(time(flu), start=1968.4)  
2065 | k = 6:num     
2066 | par(mfrow=c(3,1))     
2067 | tsplot(FLU, col=8, ylab='flu')
2068 |  text(FLU, col= predepi[k]+1, labels=predepi[k]+1, cex=1.1) 
2069 |  legend('topright', '(a)', bty='n')
2070 | 
2071 | filters = ts(t(xfilter[c(1,3,4),,]), start=tsp(flu)[1], frequency=tsp(flu)[3])
2072 | tsplot(window(filters, start=1968.4),  spag=TRUE, col=2:4, ylab='filter')
2073 |  legend('topright', '(b)', bty='n')
2074 | 
2075 | tsplot(FLU, type='p', pch=19, ylab='flu', cex=1.2)
2076 |  prde1 = 2*sqrt(innov.sig[1]); prde2 = 2*sqrt(innov.sig[2])
2077 |  prde = ifelse(predepi[k]<.5, prde1, prde2)
2078 |    xx = c(Time, rev(Time))
2079 |    yy = c(yp[k]-prde, rev(yp[k]+prde))
2080 |  polygon(xx, yy, border=8, col=gray(.6, alpha=.3)) 
2081 |  legend('topright', '(c)', bty='n')
2082 | ```
2083 | 
2084 | 
2085 | 
2086 | <a name="6.23"></a>
2087 | Example 6.23
2088 | ```r
2089 | y   = log(nyse^2) 
2090 | num = length(y)
2091 | 
2092 | # Initial Parameters
2093 | phi0=0; phi1=.95; sQ=.2; alpha=mean(y); sR0=1; mu1=-3; sR1=2
2094 | init.par = c(phi0,phi1,sQ,alpha,sR0,mu1,sR1)
2095 | 
2096 | # Innovations Likelihood 
2097 | Linn = function(para){
2098 |   phi0=para[1]; phi1=para[2]; sQ=para[3]; alpha=para[4]
2099 |   sR0=para[5]; mu1=para[6]; sR1=para[7]
2100 |   sv = SVfilter(num,y,phi0,phi1,sQ,alpha,sR0,mu1,sR1)
2101 |   return(sv$like)    
2102 | }
2103 | 
2104 | # Estimation  
2105 | (est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))
2106 | SE = sqrt(diag(solve(est$hessian)))
2107 | u = cbind(estimates=est$par, SE)  
2108 | rownames(u)=c("phi0","phi1","sQ","alpha","sigv0","mu1","sigv1"); u
2109 | 
2110 | # Graphics   (need filters at the estimated parameters)
2111 | phi0=est$par[1]; phi1=est$par[2]; sQ=est$par[3]; alpha=est$par[4]
2112 | sR0=est$par[5]; mu1=est$par[6]; sR1=est$par[7]
2113 | sv = SVfilter(num,y,phi0,phi1,sQ,alpha,sR0,mu1,sR1) 
2114 | 
2115 | # densities plot (f is chi-sq, fm is fitted mixture)
2116 | x = seq(-15,6,by=.01) 
2117 | f = exp(-.5*(exp(x)-x))/(sqrt(2*pi))
2118 | f0 = exp(-.5*(x^2)/sR0^2)/(sR0*sqrt(2*pi))
2119 | f1 = exp(-.5*(x-mu1)^2/sR1^2)/(sR1*sqrt(2*pi))
2120 | fm = (f0+f1)/2
2121 | tsplot(x, f, xlab='x')
2122 | lines(x, fm, lty=2, lwd=2)
2123 | legend('topleft', legend=c('log chi-square', 'normal mixture'), lty=1:2)
2124 | 
2125 | dev.new()
2126 | Time = 701:1100
2127 | tsplot(Time, nyse[Time], type='l', col=4, lwd=2, ylab='', xlab='', ylim=c(-.18,.12))
2128 | lines(Time, sv$xp[Time]/10, lwd=2, col=6)
2129 | ```
2130 | 
2131 | 
2132 | 
2133 | Example 6.24
2134 | ```r
2135 | n.boot = 500        # number of bootstrap replicates
2136 | tol = sqrt(.Machine$double.eps)  # convergence limit 
2137 | 
2138 | gnpgr = diff(log(gnp))
2139 | fit = arima(gnpgr, order=c(1,0,0))
2140 | y = as.matrix(log(resid(fit)^2))
2141 | num = length(y) 
2142 | tsplot(y, ylab="")
2143 | 
2144 | # Initial Parameters
2145 | phi1 = .9; sQ = .5; alpha = mean(y); sR0 = 1; mu1 = -3; sR1 = 2.5
2146 | init.par = c(phi1, sQ, alpha, sR0, mu1, sR1)
2147 | 
2148 | # Innovations Likelihood 
2149 | Linn=function(para){
2150 |   phi1 = para[1]; sQ = para[2]; alpha = para[3]
2151 |   sR0 = para[4]; mu1 = para[5]; sR1 = para[6]
2152 |   sv = SVfilter(num, y, 0, phi1, sQ, alpha, sR0, mu1, sR1)
2153 |   return(sv$like)    
2154 |   }
2155 | 
2156 | # Estimation  
2157 | (est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE, control=list(trace=1,REPORT=1)))
2158 | SE = sqrt(diag(solve(est$hessian)))
2159 | u = cbind(estimates=est$par, SE)  
2160 | rownames(u)=c("phi1","sQ","alpha","sig0","mu1","sig1"); u
2161 | 
2162 | # Bootstrap 
2163 | para.star = matrix(0, n.boot, 6)  # to store parameter estimates
2164 | Linn2 = function(para){   
2165 |   phi1 = para[1]; sQ = para[2]; alpha = para[3]
2166 |   sR0 = para[4]; mu1 = para[5]; sR1 = para[6]
2167 |   sv = SVfilter(num, y.star, 0, phi1, sQ, alpha, sR0, mu1, sR1)
2168 |   return(sv$like)    
2169 |   }
2170 | 
2171 | for (jb in 1:n.boot){  cat("iteration:", jb, "\n")
2172 |  phi1 = est$par[1]; sQ = est$par[2]; alpha = est$par[3]    
2173 |  sR0 = est$par[4]; mu1 = est$par[5]; sR1 = est$par[6] 
2174 |  Q = sQ^2; R0 = sR0^2; R1 = sR1^2
2175 |  sv = SVfilter(num, y, 0, phi1, sQ, alpha, sR0, mu1, sR1)
2176 |  
2177 |  sig0 = sv$Pp+R0 
2178 |  sig1 = sv$Pp+R1 
2179 |  K0   = sv$Pp/sig0 
2180 |  K1   = sv$Pp/sig1
2181 |  inn0 = y-sv$xp-alpha; inn1 = y-sv$xp-mu1-alpha
2182 |  den1 = (1/sqrt(sig1))*exp(-.5*inn1^2/sig1)
2183 |  den0 = (1/sqrt(sig0))*exp(-.5*inn0^2/sig0)
2184 |  fpi1 = den1/(den0+den1)
2185 |  
2186 |  # (start resampling at t=4)
2187 |  e0   = inn0/sqrt(sig0)
2188 |  e1   = inn1/sqrt(sig1)  
2189 |  indx = sample(4:num, replace=TRUE)
2190 |  sinn = cbind(c(e0[1:3], e0[indx]), c(e1[1:3], e1[indx]))
2191 |  eF   = matrix(c(phi1, 1, 0, 0), 2, 2)
2192 |  xi   = cbind(sv$xp,y)    # initialize
2193 |    
2194 |    for (i in 4:num){    # generate boot sample
2195 |    G   = matrix(c(0, alpha+fpi1[i]*mu1), 2, 1)
2196 |    h21 = (1-fpi1[i])*sqrt(sig0[i]); h11 = h21*K0[i]
2197 |    h22 = fpi1[i]*sqrt(sig1[i]); h12 = h22*K1[i]
2198 |    H   = matrix(c(h11,h21,h12,h22),2,2)
2199 |    xi[i,] = t(eF%*%as.matrix(xi[i-1,],2) + G + H%*%as.matrix(sinn[i,],2))
2200 |    }
2201 |    
2202 |  # Estimates from boot data 
2203 |  y.star = xi[,2]
2204 |  phi1 = .9; sQ = .5; alpha = mean(y.star); sR0 = 1; mu1 = -3; sR1 = 2.5
2205 |  init.par = c(phi1, sQ, alpha, sR0, mu1, sR1)   #  same as for data
2206 |  est.star = optim(init.par, Linn2, NULL, method="BFGS", control=list(reltol=tol)) 
2207 |  para.star[jb,] = cbind(est.star$par[1], abs(est.star$par[2]), est.star$par[3], abs(est.star$par[4]), 
2208 |                         est.star$par[5], abs(est.star$par[6])) 
2209 | }
2210 | 
2211 | # Some summary statistics and graphics  
2212 | rmse = rep(NA, 6)  # SEs from the bootstrap
2213 | for(i in 1:6){rmse[i] = sqrt(sum((para.star[,i]-est$par[i])^2)/n.boot)
2214 |                 cat(i, rmse[i],"\n") 
2215 |              }  
2216 | dev.new()
2217 | phi = para.star[,1]
2218 | hist(phi, 15, prob=TRUE, main="", xlim=c(0,2), xlab="", col=astsa.col(4,.3))
2219 | abline(v=mean(phi), col=4)
2220 | curve(dnorm(x, mean=u[1,1], sd=u[2,1]), 0, 2, add=TRUE)
2221 | abline(v=u[1,1])
2222 | ```
2223 | 
2224 | 
2225 | Example 6.26 
2226 | 
2227 | ```r
2228 | # generate some data from the model - 2 parameters
2229 | set.seed(1)
2230 | sQ = 1; sR = 3; n  = 100
2231 | mu0 = 0; Sigma0=10; x0=rnorm(1,mu0,Sigma0)
2232 | w  = rnorm(n); v  = rnorm(n)
2233 | x = c(x0   + sQ*w[1])  # initialize states
2234 | y = c(x[1] + sR*v[1])  # initialize obs
2235 | for (t in 2:n){ 
2236 |   x[t] = x[t-1] + sQ*w[t]
2237 |   y[t] = x[t] + sR*v[t]
2238 |   }
2239 | 
2240 | # set up the Gibbs sampler
2241 | burn   = 50;  n.iter = 1000
2242 | niter  = burn + n.iter
2243 | draws  = c()
2244 | # priors for R (a,b) and Q (c,d) IG distributions
2245 | a = 2; b = 2; c = 2; d = 1  
2246 | # (1) initialize - sample sQ and sR  
2247 | sR = sqrt(1/rgamma(1,a,b)); sQ =  sqrt(1/rgamma(1,c,d))
2248 | 
2249 | # progress bar
2250 | pb = txtProgressBar(min = 0, max = niter, initial = 0, style=3)  
2251 | 
2252 | # run it
2253 | for (iter in 1:niter){
2254 | ## (2)  sample the states  
2255 |  run   = ffbs(y,1,0,10,1,sQ,sR)  # ffbs(y,A,mu0,Sigma0,Phi,Ups,Gam,sQ,sR,input)
2256 | ## (1)  sample the parameters    
2257 |   Xs   = as.matrix(run$Xs)
2258 |   R    = 1/rgamma(1,a+n/2,b+sum((y-Xs)^2)/2)
2259 |  sR    = sqrt(R)
2260 |   Q    = 1/rgamma(1,c+(n-1)/2,d+sum(diff(Xs)^2)/2)
2261 |  sQ    = sqrt(Q)
2262 | ## store everything 
2263 |  draws = rbind(draws,c(sQ,sR,Xs))
2264 |  setTxtProgressBar(pb,iter)  
2265 | }
2266 | close(pb)
2267 | 
2268 | # pull out the results for easy plotting
2269 | draws  = draws[(burn+1):(niter),]
2270 |  q025  = function(x){quantile(x,0.025)}
2271 |  q975  = function(x){quantile(x,0.975)}
2272 | xs     = draws[,3:(n+2)]
2273 | lx     = apply(xs,2,q025)
2274 | mx     = apply(xs,2,mean)
2275 | ux     = apply(xs,2,q975)
2276 | 
2277 | # some graphics 
2278 | tsplot(cbind(x,y,mx), spag=TRUE,  ylab='', col=c(6,8,4), lwd=c(1,1,1.5), type='o', pch=c(NA,1,NA))
2279 | legend('topleft', legend=c("x(t)","y(t)","xs(t)"), lty=1, col=c(6,8,4), lwd=1.5, bty="n", pch=c(NA,1,NA))
2280 | points(y)
2281 |  xx=c(1:100, 100:1)
2282 |  yy=c(lx, rev(ux))
2283 | polygon(xx, yy, border=NA, col=astsa.col(4,.1))
2284 | ```
2285 | 
2286 | 
2287 | 
2288 | Example 6.27
2289 | 
2290 | ```r
2291 | y = jj    # the data
2292 | 
2293 | ### setup - model and initial parameters
2294 | set.seed(90210)
2295 | n   = length(y)
2296 | A   = matrix(c(1,1,0,0), 1, 4)
2297 | Phi = diag(0,4)
2298 |   Phi[1,1] = 1.03 
2299 |   Phi[2,]  = c(0,-1,-1,-1); Phi[3,]=c(0,1,0,0); Phi[4,]=c(0,0,1,0)
2300 | mu0 = rbind(.7,0,0,0)
2301 | Sigma0 = diag(.04, 4)
2302 | sR = 1                    # observation noise standard deviation
2303 | sQ = diag(c(.1,.1,0,0))   # state noise standard deviations on the diagonal
2304 | 
2305 | ### initializing and hyperparameters
2306 | burn   = 50
2307 | n.iter = 1000
2308 | niter  = burn + n.iter
2309 | draws  = NULL
2310 | a = 2; b = 2; c = 2; d = 1   # hypers (c and d for both Qs)
2311 | 
2312 | pb = txtProgressBar(min = 0, max = niter, initial = 0, style=3)  # progress bar
2313 | 
2314 | ### start Gibbs
2315 | for (iter in 1:niter){
2316 | # draw states 
2317 |   run  = ffbs(y,A,mu0,Sigma0,Phi,sQ,sR)   # initial values are given above
2318 |   xs   = run$Xs
2319 | # obs variance
2320 |   R    = 1/rgamma(1,a+n/2,b+sum((as.vector(y)-as.vector(A%*%xs[,,]))^2))
2321 |  sR    = sqrt(R)
2322 | # beta where phi = 1+beta  
2323 |  Y     = diff(xs[1,,])
2324 |  D     = as.vector(lag(xs[1,,],-1))[-1]
2325 |  regu  = lm(Y~0+D)  # est beta = phi-1
2326 |  phies = as.vector(coef(summary(regu)))[1:2] + c(1,0) # phi estimate and SE
2327 |  dft   = df.residual(regu)
2328 |  Phi[1,1]  = phies[1] + rt(1,dft)*phies[2]  # use a t to sample phi
2329 | # state variances
2330 |   u   = xs[,,2:n] - Phi%*%xs[,,1:(n-1)]
2331 |   uu  = u%*%t(u)/(n-2)
2332 |   Q1  = 1/rgamma(1,c+(n-1)/2,d+uu[1,1]/2)
2333 |   sQ1 = sqrt(Q1)
2334 |   Q2  = 1/rgamma(1,c+(n-1)/2,d+uu[2,2]/2)
2335 |   sQ2 = sqrt(Q2) 
2336 |   sQ  = diag(c(sQ1, sQ2, 0,0))
2337 | # store results
2338 |  trend = xs[1,,]
2339 |  season= xs[2,,] 
2340 |  draws = rbind(draws,c(Phi[1,1],sQ1,sQ2,sR,trend,season))
2341 |  setTxtProgressBar(pb,iter)  
2342 | }
2343 | close(pb)
2344 | 
2345 | ##- display results -##
2346 | 
2347 | # set up
2348 | u     = draws[(burn+1):(niter),]
2349 | parms = u[,1:4]
2350 | q025  = function(x){quantile(x,0.025)}
2351 | q975  = function(x){quantile(x,0.975)}
2352 | 
2353 | ##  plot parameters (display at end)
2354 | names= c(expression(phi), expression(sigma[w1]), expression(sigma[w2]), expression(sigma[v]))
2355 | par(mfrow=c(4,1), mar=c(2,1,2,1)+1)
2356 | for (i in 1:4){
2357 | hist(parms[,i], col=astsa.col(5,.4), main=names[i], xlab='', cex.main=2)
2358 |  u1 = apply(parms,2,q025); u2 = apply(parms,2,mean); u3 = apply(parms,2,q975);
2359 | abline(v=c(u1[i],u2[i],u3[i]), lwd=2, col=c(3,6,3))
2360 | }
2361 | 
2362 | ###  plot states  (display at end)
2363 | # trend
2364 | dev.new()
2365 | par(mfrow=2:1)
2366 | tr    = ts(u[,5:(n+4)], start=1960, frequency=4)
2367 | ltr   = ts(apply(tr,2,q025), start=1960, frequency=4)
2368 | mtr   = ts(apply(tr,2,mean), start=1960, frequency=4)
2369 | utr   = ts(apply(tr,2,q975), start=1960, frequency=4)
2370 | 
2371 | tsplot(mtr, ylab='', col=4, main='trend')
2372 |  xx=c(time(mtr), rev(time(mtr)))
2373 |  yy=c(ltr, rev(utr))
2374 | polygon(xx, yy, border=NA, col=astsa.col(4,.1)) 
2375 | 
2376 | # trend + season
2377 | sea    = ts(u[,(n+5):(2*n)], start=1960, frequency=4)
2378 | lsea   = ts(apply(sea,2,q025), start=1960, frequency=4)
2379 | msea   = ts(apply(sea,2,mean), start=1960, frequency=4)
2380 | usea   = ts(apply(sea,2,q975), start=1960, frequency=4)
2381 | tsplot(msea+mtr, ylab='', col=4, main='trend + season')
2382 |  xx=c(time(msea), rev(time(msea)))
2383 |  yy=c(lsea+ltr, rev(usea+utr))
2384 | polygon(xx, yy, border=NA, col=astsa.col(4,.1)) 
2385 | ```
2386 | 
2387 | 
2388 | [<sub>top</sub>](#table-of-contents)
2389 | 
2390 | ---
2391 | 
2392 | ## Chapter 7
2393 | 
2394 | Code in Introduction
2395 | 
2396 | ```r
2397 | x = matrix(0, 128, 6)
2398 | for (i in 1:6) x[,i] = rowMeans(fmri[[i]])
2399 | colnames(x)=c("Brush", "Heat", "Shock", "Brush", "Heat", "Shock")
2400 | tsplot(x, ncol=2, byrow=FALSE, main='')
2401 | mtext('Awake', outer=T, adj=.25)
2402 | mtext('Sedated', outer=T, adj=.75)
2403 | ```
2404 | 
2405 | ```r
2406 | attach(eqexp)  # to use the names
2407 | 
2408 | P = 1:1024; S = P+1024
2409 | x = cbind(EQ5[P], EQ6[P], EX5[P], EX6[P], NZ[P], EQ5[S], EQ6[S], 
2410 |           EX5[S], EX6[S], NZ[S])
2411 | x.name = c("EQ5","EQ6","EX5","EX6","NZ")
2412 | colnames(x) = c(x.name, x.name)
2413 | tsplot(x, ncol=2, byrow=FALSE, main='')
2414 | mtext('P waves', outer=T, adj=.25)
2415 | mtext('S waves', outer=T, adj=.75)
2416 | 
2417 | detach(eqexp)  # Redemption 
2418 | ```
2419 | 
2420 | 
2421 | Example 7.1
2422 | ```r
2423 | tsplot(climhyd, ncol=2, col=2:7, lwd=2)    # figure 7.3
2424 | Y = climhyd         # Y to hold transformed series
2425 | Y[,6] = log(Y[,6])  # log inflow
2426 | Y[,5] = sqrt(Y[,5]) # sqrt precipitation 
2427 |                               
2428 | L = 25              # setup 
2429 | M = 100 
2430 | alpha = .001
2431 | fdr = .001
2432 | nq = 2              # number of inputs  (Temp and Precip)
2433 | 
2434 | # Spectral Matrix 
2435 | Yspec = mvspec(Y, spans=L, kernel="daniell", taper=.1, plot=FALSE)
2436 | n = Yspec$n.used          # effective sample size
2437 | Fr = Yspec$freq           # fundamental freqs 
2438 | n.freq = length(Fr)       # number of frequencies
2439 | Yspec$bandwidth           # = 0.05 
2440 |  
2441 | # Coherencies (see section 4.7 also)
2442 | Fq = qf(1-alpha, 2, L-2); cn = Fq/(L-1+Fq)
2443 | plt.name = c("(a)","(b)","(c)","(d)","(e)","(f)")
2444 | dev.new()
2445 | par(mfrow=c(2,3), cex.lab=1.2) 
2446 | # The coherencies are listed as 1,2,...,15=choose(6,2) 
2447 | for (i in 11:15){
2448 |  tsplot(Fr,Yspec$coh[,i], ylab="Sq Coherence", xlab="Frequency", ylim=c(0,1),
2449 |       main=paste("Inflow with", names(climhyd[i-10]), sep=' '))
2450 |  abline(h = cn); text(.45,.98, plt.name[i-10], cex=1.2)  
2451 | } 
2452 | 
2453 |  # Multiple Coherency 
2454 | coh.15 = stoch.reg(Y, cols.full = c(1,5), cols.red = NULL, alpha, L, M, plot.which = "coh", 
2455 |                      main="Inflow with Temp & Precip")  
2456 | text(.45,.98, plt.name[6], cex=1.2) 
2457 | 
2458 | # Partial F (note F-stat is called eF in the code)
2459 | numer.df = 2*nq
2460 | denom.df = Yspec$df-2*nq
2461 | 
2462 | dev.new()
2463 | par(mfrow=c(3,1), mar=c(3,3,2,1)+.5, mgp = c(1.5,0.4,0), cex.lab=1.2)  
2464 | out.15 = stoch.reg(Y, cols.full = c(1,5), cols.red = 5, alpha, L, M, plot.which = "F.stat")
2465 |  eF = out.15$eF 
2466 |  pvals = pf(eF, numer.df, denom.df, lower.tail = FALSE)
2467 |  pID = FDR(pvals, fdr)
2468 | abline(h=c(eF[pID]), lty=2)
2469 | title(main = "Partial F Statistic")
2470 | 
2471 | # Regression Coefficients
2472 | S = seq(from = -M/2+1, to = M/2 - 1, length = M-1)
2473 | 
2474 | tsplot(S, coh.15$Betahat[,1], type = "h", xlab = "", ylab =names(climhyd[1]), 
2475 |         ylim = c(-.025, .055), lwd=2)
2476 | abline(h=0)
2477 | title(main = "Impulse Response Functions")
2478 | 
2479 | tsplot(S, coh.15$Betahat[,2], type = "h", xlab = "Index", ylab = names(climhyd[5]), 
2480 |         ylim = c(-.015, .055), lwd=2)
2481 | abline(h=0)
2482 | ```
2483 | 
2484 | 
2485 | Example 7.2
2486 | ```r
2487 | attach(beamd)
2488 | 
2489 | tau    = rep(0,3) 
2490 |      u = ccf(sensor1, sensor2, plot=FALSE)
2491 | tau[1] = u$lag[which.max(u$acf)]    #  17
2492 |      u = ccf(sensor3, sensor2, plot=FALSE)
2493 | tau[3] = u$lag[which.max(u$acf)]    # -22
2494 | 
2495 | Y = ts.union(sensor1=lag(sensor1,tau[1]), lag(sensor2, tau[2]), lag(sensor3, tau[3]))
2496 | Y = ts.union(Y, rowMeans(Y))
2497 | colnames(Y) = c('sensor1', 'sensor2', 'sensor3', 'beam')
2498 | tsplot(Y, main="Infrasonic Signals and Beam")
2499 | 
2500 | 
2501 | detach(beamd)
2502 | ```
2503 | 
2504 | 
2505 | 
2506 | Example 7.4
2507 | ```r
2508 | attach(beamd)
2509 | 
2510 | L = 9
2511 | fdr = .001 
2512 | N = 3
2513 | Y = cbind(beamd, beam=rowMeans(beamd))
2514 | n = nextn(nrow(Y))
2515 | 
2516 | Y.fft = mvfft(as.ts(Y))/sqrt(n)
2517 | Df = Y.fft[,1:3]   # fft of the data
2518 | Bf = Y.fft[,4]     # beam fft 
2519 | 
2520 | ssr = N*Re(Bf*Conj(Bf))               # raw signal spectrum
2521 | sse = Re(rowSums(Df*Conj(Df))) - ssr  # raw error spectrum
2522 | 
2523 | # Smooth
2524 | SSE = filter(sse, sides=2, filter=rep(1/L,L), circular=TRUE)
2525 | SSR = filter(ssr, sides=2, filter=rep(1/L,L), circular=TRUE)
2526 | SST = SSE + SSR
2527 | 
2528 | par(mfrow=c(2,1))
2529 | Fr  = 0:(n-1)/n
2530 | nFr = 1:200   # freqs to plot
2531 | 
2532 | tsplot( Fr[nFr], SST[nFr], type="l", ylab="log Power", xlab="", main="Sum of Squares",log="y")
2533 | lines(Fr[nFr], SSE[nFr], type="l", lty=2)
2534 | 
2535 | eF = (N-1)*SSR/SSE; df1 = 2*L;  df2 = 2*L*(N-1)
2536 | pvals = pf(eF, df1, df2, lower=FALSE)  # p values for FDR
2537 | pID = FDR(pvals, fdr); Fq = qf(1-fdr, df1, df2)  
2538 | 
2539 | tsplot(Fr[nFr], eF[nFr], type="l", ylab="F-statistic", xlab="Frequency",  main="F Statistic")
2540 | abline(h=c(Fq, eF[pID]), lty=1:2)
2541 | 
2542 | 
2543 | detach(beamd)
2544 | ```
2545 | 
2546 | 
2547 | Example 7.5
2548 | ```r
2549 | attach(beamd)
2550 | 
2551 | L  = 9
2552 | M  = 100 
2553 | M2 = M/2
2554 | N  = 3   
2555 | Y  = cbind(beamd, beam <- rowMeans(beamd))
2556 | n  = nextn(nrow(Y))
2557 | n.freq = n/2
2558 |  
2559 | Y[,1:3] = Y[,1:3]-Y[,4]  # center each series  
2560 | 
2561 | Y.fft = mvfft(as.ts(Y))/sqrt(n)
2562 | Ef    = Y.fft[,1:3]              # fft of the error
2563 | Bf    = Y.fft[,4]                # beam fft
2564 | ssr   = N*Re(Bf*Conj(Bf))        # Raw Signal Spectrum 
2565 | sse   = Re(rowSums(Ef*Conj(Ef))) # Raw Error Spectrum
2566 | 
2567 | # Smooth
2568 | SSE = filter(sse, sides=2, filter=rep(1/L,L), circular=TRUE)
2569 | SSR = filter(ssr, sides=2, filter=rep(1/L,L), circular=TRUE)
2570 | 
2571 | # Estimate Signal and Noise Spectra
2572 | fv = SSE/(L*(N-1))          # Equation (7.77)
2573 | fb = (SSR-SSE/(N-1))/(L*N)  # Equation (7.78)
2574 | fb[fb<0] = 0 
2575 | 
2576 | H0 = N*fb/(fv+N*fb)     
2577 | H0[ceiling(.04*n):n] = 0    # zero out H0 beyond frequency .04
2578 | 
2579 | # Extend components to make it a valid transform
2580 | H0 = c(H0[1:n.freq], rev(H0[2:(n.freq+1)]))  
2581 | h0 = Re(fft(H0, inverse = TRUE))            # Impulse Response 
2582 | h0 = c(rev(h0[2:(M2+1)]), h0[1:(M2+1)])     # center it
2583 | h1 = spec.taper(h0, p = .5)                 # taper it
2584 | k1 = h1/sum(h1)                             # normalize it
2585 | f.beam = filter(Y$beam, filter=k1, sides=2) # filter it
2586 | 
2587 | # Graphics  
2588 | nFr = 1:50      # freqs to display
2589 | Fr = (nFr-1)/n  # frequencies 
2590 | 
2591 | layout(matrix(c(1, 2, 4, 1, 3, 4), nc=2))
2592 | tsplot(10*Fr, fb[nFr], type="l", ylab="Power", xlab="Frequency (Hz)")
2593 |  lines(10*Fr, fv[nFr], lty=2); text(.24, 5, "(a)", cex=1.2)
2594 | tsplot(10*Fr, H0[nFr], type="l", ylab="Frequency Response", xlab="Frequency(Hz)")
2595 |  text(.23, .84, "(b)", cex=1.2)
2596 | tsplot(-M2:M2, k1, type="l", ylab="Impulse Response", xlab="Index", lwd=1.5)
2597 |  text(45, .022, "(c)", cex=1.2)
2598 | tsplot(cbind(f.beam,beam), spag=TRUE, lty=1:2, ylab="beam")
2599 |  text(2040, 2, "(d)", cex=1.2)
2600 | 
2601 | detach(beamd) 
2602 | ```
2603 | 
2604 | Example 7.6
2605 | ```r
2606 | n          = 128               # length of series
2607 | n.freq     = 1 + n/2           # number of frequencies
2608 | Fr         = (0:(n.freq-1))/n  # the frequencies 
2609 | N          = c(5,4,5,3,5,4)    # number of series for each cell
2610 | n.subject  = sum(N)            # number of subjects (26)
2611 | n.trt      = 6                 # number of treatments
2612 | L          = 3                 # for smoothing
2613 | num.df     = 2*L*(n.trt-1)     # dfs for F test
2614 | den.df     = 2*L*(n.subject-n.trt)
2615 | 
2616 | 
2617 | # Design Matrix (Z): 
2618 | Z1 = outer(rep(1,N[1]), c(1,1,0,0,0,0))
2619 | Z2 = outer(rep(1,N[2]), c(1,0,1,0,0,0))
2620 | Z3 = outer(rep(1,N[3]), c(1,0,0,1,0,0))
2621 | Z4 = outer(rep(1,N[4]), c(1,0,0,0,1,0)) 
2622 | Z5 = outer(rep(1,N[5]), c(1,0,0,0,0,1)) 
2623 | Z6 = outer(rep(1,N[6]), c(1,-1,-1,-1,-1,-1)) 
2624 | 
2625 | Z  = rbind(Z1, Z2, Z3, Z4, Z5, Z6)
2626 | ZZ = t(Z)%*%Z 
2627 | 
2628 | SSEF <- rep(NA, n) -> SSER   
2629 | 
2630 | HatF = Z%*%solve(ZZ, t(Z))
2631 | HatR = Z[,1]%*%t(Z[,1])/ZZ[1,1]
2632 | 
2633 | par(mfrow=c(3,3))
2634 | loc.name = c("Cortex 1","Cortex 2","Cortex 3","Cortex 4","Caudate","Thalamus 1",
2635 |               "Thalamus 2", "Cerebellum 1","Cerebellum 2")
2636 | 
2637 | for(Loc in 1:9) {   
2638 |  i = n.trt*(Loc-1)   
2639 |  Y = cbind(fmri[[i+1]], fmri[[i+2]], fmri[[i+3]], fmri[[i+4]], fmri[[i+5]], fmri[[i+6]])
2640 |  Y = mvfft(spec.taper(Y, p=.5))/sqrt(n)	
2641 |  Y = t(Y)      # Y is now 26 x 128 FFTs
2642 | 
2643 |  # Calculation of Error Spectra 
2644 |  for (k in 1:n) {   
2645 |   SSY = Re(Conj(t(Y[,k]))%*%Y[,k])
2646 |   SSReg = Re(Conj(t(Y[,k]))%*%HatF%*%Y[,k])
2647 |  SSEF[k] = SSY - SSReg
2648 |   SSReg = Re(Conj(t(Y[,k]))%*%HatR%*%Y[,k])
2649 |  SSER[k] = SSY - SSReg  
2650 |  }
2651 | 
2652 | # Smooth 
2653 | sSSEF = filter(SSEF, rep(1/L, L), circular = TRUE)
2654 | sSSER = filter(SSER, rep(1/L, L), circular = TRUE)
2655 | 
2656 | eF =(den.df/num.df)*(sSSER-sSSEF)/sSSEF
2657 | 
2658 | tsplot(Fr, eF[1:n.freq], xlab="Frequency", ylab="F Statistic", ylim=c(0,7), main=loc.name[Loc])
2659 | abline(h=qf(.999, num.df, den.df),lty=2) 
2660 | }
2661 | ```
2662 | 
2663 | Example 7.7
2664 | ```r
2665 | n      = 128
2666 | n.freq = 1 + n/2  
2667 | Fr     = (0:(n.freq-1))/n  
2668 | nFr    = 1:(n.freq/2) 
2669 | N      = c(5,4,5,3,5,4)  
2670 | n.para = 6          # number of parameters
2671 | n.subject = sum(N)  # total number of subjects
2672 | 
2673 | L = 3   
2674 | df.stm = 2*L*(3-1)              # stimulus (3 levels: Brush,Heat,Shock)
2675 | df.con = 2*L*(2-1)              # conscious (2 levels: Awake,Sedated)  
2676 | df.int = 2*L*(3-1)*(2-1)        # interaction 
2677 | den.df = 2*L*(n.subject-n.para) # df for full model 
2678 | 
2679 | # Design Matrix:          mu  a1  a2   b  g1  g2   
2680 |  Z1 = outer(rep(1,N[1]), c(1,  1,  0,  1,  1,  0)) 
2681 |  Z2 = outer(rep(1,N[2]), c(1,  0,  1,  1,  0,  1)) 
2682 |  Z3 = outer(rep(1,N[3]), c(1, -1, -1,  1, -1, -1)) 
2683 |  Z4 = outer(rep(1,N[4]), c(1,  1,  0, -1, -1,  0)) 
2684 |  Z5 = outer(rep(1,N[5]), c(1,  0,  1, -1,  0, -1)) 
2685 |  Z6 = outer(rep(1,N[6]), c(1, -1, -1, -1,  1,  1))
2686 |  
2687 |  Z = rbind(Z1, Z2, Z3, Z4, Z5, Z6)  
2688 |  ZZ = t(Z)%*%Z
2689 | 
2690 | rep(NA, n)-> SSEF -> SSE.stm -> SSE.con -> SSE.int              
2691 | HatF    = Z%*%solve(ZZ,t(Z))     
2692 | Hat.stm = Z[,-(2:3)]%*%solve(ZZ[-(2:3),-(2:3)], t(Z[,-(2:3)]))  
2693 | Hat.con = Z[,-4]%*%solve(ZZ[-4,-4], t(Z[,-4]))   
2694 | Hat.int = Z[,-(5:6)]%*%solve(ZZ[-(5:6),-(5:6)], t(Z[,-(5:6)]))                                                           
2695 | 
2696 | par(mfrow=c(5,3), oma=c(0,2,0,0))
2697 | loc.name = c("Cortex 1","Cortex 2","Cortex 3","Cortex 4","Caudate", "Thalamus 1",
2698 |               "Thalamus 2", "Cerebellum 1","Cerebellum 2")
2699 | for(Loc in c(1:4,9)) {   # only Loc 1 to 4 and 9 used                
2700 |   i = 6*(Loc-1)                                                                 
2701 |   Y = cbind(fmri[[i+1]], fmri[[i+2]], fmri[[i+3]], fmri[[i+4]], fmri[[i+5]], fmri[[i+6]])                     
2702 |   Y = mvfft(spec.taper(Y, p=.5))/sqrt(n)  
2703 |   Y = t(Y)  
2704 |   for (k in 1:n) {    
2705 |     SSY=Re(Conj(t(Y[,k]))%*%Y[,k])
2706 |     SSReg= Re(Conj(t(Y[,k]))%*%HatF%*%Y[,k])
2707 |   SSEF[k]=SSY-SSReg 
2708 |     SSReg=Re(Conj(t(Y[,k]))%*%Hat.stm%*%Y[,k])
2709 |   SSE.stm[k] = SSY-SSReg
2710 |     SSReg=Re(Conj(t(Y[,k]))%*%Hat.con%*%Y[,k])
2711 |   SSE.con[k]=SSY-SSReg  
2712 |     SSReg=Re(Conj(t(Y[,k]))%*%Hat.int%*%Y[,k])
2713 |   SSE.int[k]=SSY-SSReg   
2714 |   }
2715 |  # Smooth    
2716 |   sSSEF    = filter(SSEF, rep(1/L, L), circular = TRUE)
2717 |   sSSE.stm = filter(SSE.stm, rep(1/L, L), circular = TRUE)
2718 |   sSSE.con = filter(SSE.con, rep(1/L, L), circular = TRUE)
2719 |   sSSE.int = filter(SSE.int, rep(1/L, L), circular = TRUE)  
2720 |   eF.stm   = (den.df/df.stm)*(sSSE.stm-sSSEF)/sSSEF
2721 |   eF.con   = (den.df/df.con)*(sSSE.con-sSSEF)/sSSEF
2722 |   eF.int   = (den.df/df.int)*(sSSE.int-sSSEF)/sSSEF
2723 | 
2724 | tsplot(Fr[nFr],eF.stm[nFr],xlab="Frequency", ylab="F Statistic", ylim=c(0,12))
2725 |    abline(h=qf(.999, df.stm, den.df),lty=2)       
2726 |   if(Loc==1) mtext("Stimulus", side=3, line=.3, cex=.8)
2727 |   mtext(loc.name[Loc], side=2, line=3, cex=.8)
2728 |  tsplot(Fr[nFr],eF.con[nFr], xlab="Frequency", ylab="F Statistic", ylim=c(0,12))
2729 |   abline(h=qf(.999, df.con, den.df),lty=2)
2730 |   if(Loc==1)  mtext("Consciousness", side=3, line=.3, cex=.8)   
2731 |  tsplot(Fr[nFr],eF.int[nFr], xlab="Frequency",ylab="F Statistic", ylim=c(0,12))
2732 |   abline(h=qf(.999, df.int, den.df),lty=2)
2733 |   if(Loc==1) mtext("Interaction", side=3, line= .3, cex=.8)   
2734 | } 
2735 | ```
2736 | 
2737 | 
2738 | 
2739 | Example 7.8
2740 | ```r
2741 | n      = 128
2742 | n.freq = 1 + n/2  
2743 | Fr     = (0:(n.freq-1))/n
2744 | nFr    = 1:(n.freq/2) 
2745 | N      = c(5,4,5,3,5,4)
2746 | L      = 3
2747 | n.subject = sum(N)
2748 |    
2749 | # Design Matrix            
2750 | Z1 = outer(rep(1,N[1]), c(1,0,0,0,0,0)) 
2751 | Z2 = outer(rep(1,N[2]), c(0,1,0,0,0,0)) 
2752 | Z3 = outer(rep(1,N[3]), c(0,0,1,0,0,0)) 
2753 | Z4 = outer(rep(1,N[4]), c(0,0,0,1,0,0)) 
2754 | Z5 = outer(rep(1,N[5]), c(0,0,0,0,1,0)) 
2755 | Z6 = outer(rep(1,N[6]), c(0,0,0,0,0,1))
2756 | Z  = rbind(Z1, Z2, Z3, Z4, Z5, Z6)
2757 | ZZ = t(Z)%*%Z 
2758 | 
2759 | A      = rbind(diag(1,3), diag(1,3))   # Contrasts:  6 x 3 
2760 | nq     = nrow(A)
2761 | num.df = 2*L*nq
2762 | den.df = 2*L*(n.subject-nq)                   
2763 | HatF   = Z%*%solve(ZZ, t(Z))           # full model hat matrix   
2764 | 
2765 | rep(NA, n)-> SSEF -> SSER 
2766 | eF = matrix(0,n,3)
2767 | 
2768 | par(mfrow=c(5,3), oma=c(0,2,0,0)) 
2769 | 
2770 | loc.name = c("Cortex 1","Cortex 2","Cortex 3","Cortex 4","Caudate","Thalamus 1","Thalamus 2",
2771 |              "Cerebellum 1","Cerebellum 2")
2772 | cond.name = c("Brush", "Heat", "Shock")             
2773 | 
2774 | for(Loc in c(1:4,9)) {
2775 |  i = 6*(Loc-1)                                                                 
2776 |  Y = cbind(fmri[[i+1]],fmri[[i+2]],fmri[[i+3]],fmri[[i+4]], fmri[[i+5]],fmri[[i+6]])                       
2777 |  Y = mvfft(spec.taper(Y, p=.5))/sqrt(n); Y = t(Y)  
2778 |  for (cond in 1:3){
2779 |   Q = t(A[,cond])%*%solve(ZZ, A[,cond])
2780 |   HR = A[,cond]%*%solve(ZZ, t(Z))      
2781 |   for (k in 1:n){   
2782 |     SSY = Re(Conj(t(Y[,k]))%*%Y[,k])
2783 |     SSReg= Re(Conj(t(Y[,k]))%*%HatF%*%Y[,k])
2784 |    SSEF[k]= (SSY-SSReg)*Q 
2785 |     SSReg= HR%*%Y[,k]
2786 |    SSER[k] = Re(SSReg*Conj(SSReg))  
2787 |   }     
2788 | 
2789 | # Smooth      
2790 |  sSSEF = filter(SSEF, rep(1/L, L), circular = TRUE)
2791 |  sSSER = filter(SSER, rep(1/L, L), circular = TRUE)       
2792 |  eF[,cond]= (den.df/num.df)*(sSSER/sSSEF)   }                                    
2793 |  tsplot(Fr[nFr], eF[nFr,1], xlab="Frequency", ylab="F Statistic", ylim=c(0,5), main='')
2794 |   abline(h=qf(.999, num.df, den.df),lty=2)       
2795 |   if(Loc==1) mtext("Brush", side=3, line=.3, cex=1)
2796 |   mtext(loc.name[Loc], side=2, line=3, cex=.9)
2797 |  tsplot(Fr[nFr], eF[nFr,2], xlab="Frequency", ylab="F Statistic", ylim=c(0,5), main='')
2798 |   abline(h=qf(.999, num.df, den.df),lty=2)
2799 |   if(Loc==1)  mtext("Heat", side=3, line=.3, cex=1)   
2800 |  tsplot(Fr[nFr], eF[nFr,3], xlab="Frequency", ylab="F Statistic", ylim=c(0,5), main='')
2801 |   abline(h = qf(.999, num.df, den.df) ,lty=2)
2802 |   if(Loc==1) mtext("Shock", side=3, line=.3, cex=1)  
2803 | }  
2804 | ```
2805 | 
2806 | 
2807 | Example 7.9
2808 | ```r
2809 | P = 1:1024 
2810 | S = P+1024
2811 | N = 8
2812 | n = 1024
2813 | p.dim = 2
2814 | m = 10
2815 | L = 2*m+1
2816 | 
2817 | eq.P   = as.ts(eqexp[P,1:8])
2818 | eq.S   = as.ts(eqexp[S,1:8]) 
2819 | eq.m   = cbind(rowMeans(eq.P), rowMeans(eq.S))
2820 | ex.P   = as.ts(eqexp[P,9:16])
2821 | ex.S   = as.ts(eqexp[S,9:16]) 
2822 | ex.m   = cbind(rowMeans(ex.P), rowMeans(ex.S)) 
2823 | m.diff = mvfft(eq.m - ex.m)/sqrt(n)
2824 | 
2825 | eq.Pf = mvfft(eq.P-eq.m[,1])/sqrt(n)
2826 | eq.Sf = mvfft(eq.S-eq.m[,2])/sqrt(n)
2827 | ex.Pf = mvfft(ex.P-ex.m[,1])/sqrt(n)
2828 | ex.Sf = mvfft(ex.S-ex.m[,2])/sqrt(n) 
2829 | 
2830 | fv11 = rowSums(eq.Pf*Conj(eq.Pf)) + rowSums(ex.Pf*Conj(ex.Pf))/(2*(N-1))
2831 | fv12 = rowSums(eq.Pf*Conj(eq.Sf)) + rowSums(ex.Pf*Conj(ex.Sf))/(2*(N-1))
2832 | fv22 = rowSums(eq.Sf*Conj(eq.Sf)) + rowSums(ex.Sf*Conj(ex.Sf))/(2*(N-1))
2833 | fv21 = Conj(fv12)
2834 | 
2835 | # Equal Means  
2836 | T2 = rep(NA, 512)
2837 | for (k  in 1:512){
2838 |  fvk = matrix(c(fv11[k], fv21[k], fv12[k], fv22[k]), 2, 2)
2839 |  dk = as.matrix(m.diff[k,])
2840 |  T2[k] = Re((N/2)*Conj(t(dk))%*%solve(fvk,dk))  }
2841 | eF = T2*(2*p.dim*(N-1))/(2*N-p.dim-1)
2842 | 
2843 | par(mfrow=c(2,2))
2844 | 
2845 | freq = 40*(0:511)/n  # in Hz (cycles per second)  
2846 | tsplot(freq, eF, xlab="Frequency (Hz)", ylab="F Statistic", main="Equal Means")
2847 | abline(h=qf(.999, 2*p.dim, 2*(2*N-p.dim-1)))
2848 | 
2849 | # Equal P   
2850 | kd    = kernel("daniell",m);  
2851 | u     = Re(rowSums(eq.Pf*Conj(eq.Pf))/(N-1))
2852 | feq.P = kernapply(u, kd, circular=TRUE)
2853 | u     = Re(rowSums(ex.Pf*Conj(ex.Pf))/(N-1))
2854 | fex.P =	kernapply(u, kd, circular=TRUE)
2855 | 
2856 | tsplot(freq, feq.P[1:512]/fex.P[1:512], xlab="Frequency (Hz)", ylab="F Statistic", 
2857 |       main="Equal P-Spectra")
2858 | abline(h = qf(.999, 2*L*(N-1),  2*L*(N-1))) 
2859 | 
2860 | # Equal S   
2861 | u     = Re(rowSums(eq.Sf*Conj(eq.Sf))/(N-1))
2862 | feq.S = kernapply(u, kd, circular=TRUE)
2863 | u     = Re(rowSums(ex.Sf*Conj(ex.Sf))/(N-1))
2864 | fex.S =	kernapply(u, kd, circular=TRUE)
2865 | 
2866 | tsplot(freq, feq.S[1:512]/fex.S[1:512], xlab="Frequency (Hz)", ylab="F Statistic", 
2867 |       main="Equal S-Spectra")
2868 | abline(h=qf(.999, 2*L*(N-1),  2*L*(N-1))) 
2869 | 
2870 | # Equal Spectra  
2871 | u      = rowSums(eq.Pf*Conj(eq.Sf))/(N-1)
2872 | feq.PS = kernapply(u, kd, circular=TRUE)
2873 | u      = rowSums(ex.Pf*Conj(ex.Sf)/(N-1))
2874 | fex.PS = kernapply(u, kd, circular=TRUE)
2875 | fv11   = kernapply(fv11, kd, circular=TRUE)
2876 | fv22   = kernapply(fv22, kd, circular=TRUE)
2877 | fv12  = kernapply(fv12, kd, circular=TRUE)
2878 | 
2879 | Mi = L*(N-1) 
2880 | M  = 2*Mi
2881 | TS = rep(NA,512)
2882 | 
2883 | for (k  in 1:512){
2884 |  det.feq.k = Re(feq.P[k]*feq.S[k] - feq.PS[k]*Conj(feq.PS[k]))
2885 |  det.fex.k = Re(fex.P[k]*fex.S[k] - fex.PS[k]*Conj(fex.PS[k]))
2886 |  det.fv.k  = Re(fv11[k]*fv22[k] - fv12[k]*Conj(fv12[k]))
2887 |  
2888 |  log.n1 = log(M)*(M*p.dim)
2889 |  log.d1 = log(Mi)*(2*Mi*p.dim)
2890 |  log.n2 = log(Mi)*2 +log(det.feq.k)*Mi + log(det.fex.k)*Mi  
2891 |  log.d2 = (log(M)+log(det.fv.k))*M
2892 |  r = 1 - ((p.dim+1)*(p.dim-1)/6*p.dim*(2-1))*(2/Mi - 1/M)
2893 |  TS[k] = -2*r*(log.n1+log.n2-log.d1-log.d2)   
2894 | }
2895 | 
2896 | tsplot(freq, TS, xlab="Frequency (Hz)", ylab="Chi-Sq Statistic", main="Equal Spectral Matrices")
2897 | abline(h = qchisq(.9999, p.dim^2))   # about 23.5, so not on the plot
2898 | ```
2899 | 
2900 | 
2901 | 
2902 | 
2903 | Example 7.10
2904 | ```r
2905 | P     = 1:1024
2906 | S     = P+1024
2907 | mag.P = log10(apply(eqexp[P,],2,max) - apply(eqexp[P,],2,min))
2908 | mag.S = log10(apply(eqexp[S,],2,max) - apply(eqexp[S,],2,min))
2909 | eq.P  = mag.P[1:8]
2910 | eq.S  = mag.S[1:8]
2911 | ex.P  = mag.P[9:16]
2912 | ex.S =  mag.S[9:16]
2913 | NZ.P  = mag.P[17]
2914 | NZ.S  = mag.S[17] 
2915 | 
2916 | # Compute linear discriminant function 
2917 | cov.eq     = var(cbind(eq.P, eq.S))
2918 | cov.ex     = var(cbind(ex.P, ex.S))
2919 | cov.pooled = (cov.ex + cov.eq)/2
2920 | 
2921 | means.eq   =  colMeans(cbind(eq.P,eq.S)); 
2922 | means.ex   =  colMeans(cbind(ex.P,ex.S))
2923 | slopes.eq  = solve(cov.pooled, means.eq)
2924 | inter.eq   = -sum(slopes.eq*means.eq)/2
2925 | slopes.ex  = solve(cov.pooled, means.ex)
2926 | inter.ex   = -sum(slopes.ex*means.ex)/2
2927 | d.slopes   = slopes.eq - slopes.ex
2928 | d.inter    = inter.eq - inter.ex
2929 | 
2930 | # Classify new observation 
2931 | new.data = cbind(NZ.P, NZ.S)
2932 | 
2933 | d = sum(d.slopes*new.data) + d.inter
2934 | post.eq = exp(d)/(1+exp(d))
2935 | 
2936 | # Print (disc function, posteriors) and plot results  
2937 | cat(d.slopes[1], "mag.P +" , d.slopes[2], "mag.S +" , d.inter,"\n")  
2938 | cat("P(EQ|data) =", post.eq,  "  P(EX|data) =", 1-post.eq, "\n" )    
2939 | 
2940 | tsplot(eq.P, eq.S, type='p', xlim=c(0,1.5), ylim=c(.75,1.25), 
2941 |         xlab="log mag(P)", ylab ="log mag(S)", pch = 8, cex=1.1, lwd=2, 
2942 |         main="Classification Based on Magnitude Features", col=4)
2943 |  points(ex.P, ex.S, pch = 6, cex=1.1, lwd=2, col=6)
2944 |  points(new.data, pch = 3, cex=1.1, lwd=2, col=3)
2945 |  abline(a = -d.inter/d.slopes[2], b = -d.slopes[1]/d.slopes[2])
2946 |  text(eq.P-.07,eq.S+.005, label=names(eqexp[1:8]), cex=.8)
2947 |  text(ex.P+.07,ex.S+.003, label=names(eqexp[9:16]), cex=.8)
2948 |  text(NZ.P+.05,NZ.S+.003, label=names(eqexp[17]), cex=.8)
2949 |  legend("topright",c("EQ","EX","NZ"),pch=c(8,6,3),pt.lwd=2,cex=1.1, col=c(4,6,3))
2950 | 
2951 | # Cross-validation 
2952 | all.data = rbind(cbind(eq.P,eq.S), cbind(ex.P,ex.S))
2953 | post.eq <- rep(NA, 8) -> post.ex 
2954 | 
2955 | for(j in 1:16) {
2956 |  if (j <= 8) {samp.eq = all.data[-c(j, 9:16),];  samp.ex = all.data[9:16,]}
2957 |  if (j > 8)  {samp.eq = all.data[1:8,];    samp.ex = all.data[-c(j, 1:8),]}
2958 |  
2959 |  df.eq      = nrow(samp.eq)-1;  df.ex = nrow(samp.ex)-1
2960 |  mean.eq    = colMeans(samp.eq);  mean.ex = colMeans(samp.ex)
2961 |  cov.eq     = var(samp.eq);  cov.ex = var(samp.ex)
2962 |  cov.pooled = (df.eq*cov.eq + df.ex*cov.ex)/(df.eq + df.ex)
2963 |  slopes.eq  = solve(cov.pooled, mean.eq)
2964 |  inter.eq   = -sum(slopes.eq*mean.eq)/2
2965 |  slopes.ex  = solve(cov.pooled, mean.ex)
2966 |  inter.ex   = -sum(slopes.ex*mean.ex)/2
2967 |  d.slopes   = slopes.eq - slopes.ex
2968 |  d.inter    = inter.eq - inter.ex
2969 |  
2970 |  d = sum(d.slopes*all.data[j,]) + d.inter
2971 |  if (j <= 8) post.eq[j] = exp(d)/(1+exp(d))
2972 |  if (j > 8) post.ex[j-8] = 1/(1+exp(d))  
2973 | }
2974 | 
2975 | Posterior = cbind(1:8, post.eq, 1:8, post.ex)
2976 | colnames(Posterior) = c("EQ","P(EQ|data)","EX","P(EX|data)")
2977 | # results from cross-validation 
2978 | round(Posterior, 3)   
2979 | ```
2980 | 
2981 | 
2982 | 
2983 | Example 7.11
2984 | 
2985 | ```r
2986 | P = 1:1024
2987 | S = P+1024
2988 | p.dim = 2
2989 | n =1024
2990 | 
2991 | eq = as.ts(eqexp[,1:8])
2992 | ex = as.ts(eqexp[,9:16])
2993 | nz = as.ts(eqexp[,17])
2994 | f.eq <- array(dim=c(8,2,2,512)) -> f.ex 
2995 | f.NZ = array(dim=c(2,2,512))
2996 | 
2997 | # determinant for 2x2 complex matrix 
2998 | det.c = function(mat){return(Re(mat[1,1]*mat[2,2]-mat[1,2]*mat[2,1]))}
2999 | L = c(15,13,5)  # for smoothing 
3000 | for (i in 1:8){     # compute spectral matrices
3001 |  f.eq[i,,,] = mvspec(cbind(eq[P,i],eq[S,i]), spans=L, taper=.5, plot=FALSE)$fxx
3002 |  f.ex[i,,,] = mvspec(cbind(ex[P,i],ex[S,i]), spans=L, taper=.5, plot=FALSE)$fxx
3003 | }
3004 | u = mvspec(cbind(nz[P],nz[S]), spans=L, taper=.5) 
3005 | f.NZ = u$fxx	 
3006 | bndwidth = u$bandwidth*40  # about .75 Hz
3007 | fhat.eq = apply(f.eq, 2:4, mean)  # average spectra
3008 | fhat.ex = apply(f.ex, 2:4, mean)
3009 | 
3010 | # plot the average spectra
3011 | par(mfrow=c(2,2))
3012 | Fr = 40*(1:512)/n
3013 | tsplot(Fr, Re(fhat.eq[1,1,]), main="", xlab="Frequency (Hz)", ylab="")
3014 | tsplot(Fr, Re(fhat.eq[2,2,]), main="", xlab="Frequency (Hz)", ylab="")
3015 | tsplot(Fr, Re(fhat.ex[1,1,]), xlab="Frequency (Hz)", ylab="")
3016 | tsplot(Fr, Re(fhat.ex[2,2,]), xlab="Frequency (Hz)", ylab="")
3017 | mtext("Average P-spectra", side=3, line=-1.5, adj=.2, outer=TRUE)
3018 | mtext("Earthquakes", side=2, line=-1, adj=.8,  outer=TRUE)
3019 | mtext("Average S-spectra", side=3, line=-1.5, adj=.82, outer=TRUE)
3020 | mtext("Explosions", side=2, line=-1, adj=.2, outer=TRUE)
3021 | par(fig = c(.75, .995, .75, .98), new = TRUE)
3022 | ker = kernel("modified.daniell", L)$coef; ker = c(rev(ker),ker[-1])
3023 | plot((-33:33)/40,ker,type="l",ylab="",xlab="",cex.axis=.7,yaxp=c(0,.04,2))
3024 | 
3025 | # choose alpha
3026 | Balpha = rep(0,19) 
3027 | for (i in 1:19){  alf=i/20
3028 | for (k in 1:256) {  	
3029 | Balpha[i]= Balpha[i] + Re(log(det.c(alf*fhat.ex[,,k] + (1-alf)*fhat.eq[,,k])/ det.c(fhat.eq[,,k]))- 
3030 |                            alf*log(det.c(fhat.ex[,,k])/det.c(fhat.eq[,,k])))} }
3031 | alf = which.max(Balpha)/20   # = .4  
3032 | 
3033 | # calculate information criteria          
3034 | rep(0,17) -> KLDiff -> BDiff -> KLeq -> KLex -> Beq -> Bex
3035 | for (i in 1:17){
3036 |  if (i <= 8) f0 = f.eq[i,,,]
3037 |  if (i > 8 & i <= 16) f0 = f.ex[i-8,,,]
3038 |  if (i == 17) f0 = f.NZ
3039 |  for (k in 1:256) {    # only use freqs out to .25
3040 |   tr = Re(sum(diag(solve(fhat.eq[,,k],f0[,,k]))))
3041 |   KLeq[i] = KLeq[i] + tr + log(det.c(fhat.eq[,,k])) - log(det.c(f0[,,k]))
3042 |   Beq[i] =  Beq[i] + Re(log(det.c(alf*f0[,,k]+(1-alf)*fhat.eq[,,k])/det.c(fhat.eq[,,k])) - 
3043 |                          alf*log(det.c(f0[,,k])/det.c(fhat.eq[,,k])))
3044 |   tr = Re(sum(diag(solve(fhat.ex[,,k],f0[,,k]))))
3045 |   KLex[i] = KLex[i] + tr +  log(det.c(fhat.ex[,,k])) - log(det.c(f0[,,k]))
3046 |   Bex[i] = Bex[i] + Re(log(det.c(alf*f0[,,k]+(1-alf)*fhat.ex[,,k])/det.c(fhat.ex[,,k])) - 
3047 |                        alf*log(det.c(f0[,,k])/det.c(fhat.ex[,,k]))) 
3048 |   }
3049 | KLDiff[i] = (KLeq[i] - KLex[i])/n 
3050 | BDiff[i] =  (Beq[i] - Bex[i])/(2*n) 
3051 | }
3052 | 
3053 | x.b = max(KLDiff)+.1; x.a = min(KLDiff)-.1
3054 | y.b = max(BDiff)+.01; y.a = min(BDiff)-.01
3055 | 
3056 | dev.new()                                 
3057 | tsplot(KLDiff[9:16], BDiff[9:16], type="p", xlim=c(x.a,x.b), ylim=c(y.a,y.b), cex=1.1, lwd=2, 
3058 |       xlab="Kullback-Leibler Difference",ylab="Chernoff Difference", col=6,
3059 |       main="Classification Based on Chernoff and K-L Distances", pch=6)
3060 | points(KLDiff[1:8], BDiff[1:8], pch=8, cex=1.1, lwd=2, col=4)
3061 | points(KLDiff[17], BDiff[17],  pch=3, cex=1.1, lwd=2, col=3)
3062 | legend("topleft", legend=c("EQ", "EX", "NZ"), pch=c(8,6,3), pt.lwd=2, col=c(4,6,3))
3063 | abline(h=0, v=0, lty=2, col=8)
3064 | text(KLDiff[-c(1,2,3,7,14)]-.075, BDiff[-c(1,2,3,7,14)], label=names(eqexp[-c(1,2,3,7,14)]), cex=.7)
3065 | text(KLDiff[c(1,2,3,7,14)]+.075, BDiff[c(1,2,3,7,14)], label=names(eqexp[c(1,2,3,7,14)]), cex=.7)
3066 | ```
3067 | 
3068 | 
3069 | Example 7.12
3070 | 
3071 | ```r
3072 | library(cluster)
3073 | P = 1:1024
3074 | S = P+1024
3075 | p.dim = 2
3076 | n =1024
3077 | 
3078 | eq = as.ts(eqexp[,1:8])
3079 | ex = as.ts(eqexp[,9:16])
3080 | nz = as.ts(eqexp[,17])
3081 | 
3082 | f = array(dim=c(17,2,2,512))  
3083 | L = c(15,15)   # for smoothing 
3084 | for (i in 1:8){     # compute spectral matrices
3085 |  f[i,,,] = mvspec(cbind(eq[P,i],eq[S,i]), spans=L, taper=.5, plot=FALSE)$fxx
3086 |  f[i+8,,,] = mvspec(cbind(ex[P,i],ex[S,i]), spans=L, taper=.5, plot=FALSE)$fxx 
3087 | }
3088 | f[17,,,] = mvspec(cbind(nz[P],nz[S]), spans=L, taper=.5, plot=FALSE)$fxx	
3089 | 
3090 | # calculate symmetric information criteria 
3091 | JD = matrix(0,17,17) 
3092 | for (i in 1:16){
3093 |  for (j in (i+1):17){	
3094 |   for (k in 1:256) {    # only use freqs out to .25
3095 |     tr1 = Re(sum(diag(solve(f[i,,,k],f[j,,,k]))))
3096 |     tr2 = Re(sum(diag(solve(f[j,,,k], f[i,,,k]))))
3097 |     JD[i,j] = JD[i,j] + (tr1 + tr2 - 2*p.dim)
3098 |   }
3099 |  }
3100 | }
3101 |  
3102 | JD = (JD + t(JD))/n
3103 | colnames(JD) = c(colnames(eq), colnames(ex), "NZ") 
3104 | rownames(JD) = colnames(JD)
3105 | cluster.2 = pam(JD, k = 2, diss = TRUE)  
3106 | 
3107 | summary(cluster.2)  # print results
3108 | par(mar=c(2,2,1,.5)+2, cex=3/4, cex.lab=4/3, cex.main=4/3)
3109 | clusplot(JD, cluster.2$cluster, col.clus=gray(.5), labels=3, lines=0, 
3110 |          col.p = c(rep(4,8), rep(6,8), 3),  
3111 |          main="Clustering Results for Explosions and Earthquakes")
3112 | text(-3.5,-1.5, "Group I", cex=1.1, font=2) 
3113 | text(1.5,5,"Group II", cex=1.1, font=2)
3114 | ```
3115 | 
3116 | 
3117 | Example 7.13
3118 | 
3119 | ```r
3120 | n = 128
3121 | Per = abs(mvfft(fmri1[,-1]))^2/n
3122 | 
3123 | par(mfrow=c(2,4), mar=c(3,2,2,1),  mgp = c(1.6,.6,0), oma=c(0,1,0,0))
3124 | for (i in 1:8){
3125 |  plot(0:20, Per[1:21,i], type="n", xaxt='n', ylim=c(0,8), main=colnames(fmri1)[i+1], xlab="Cycles", ylab="")
3126 |  axis(1, seq(0,20,by=4))
3127 |  Grid(nx=NA, ny=NULL, minor=FALSE)
3128 |  abline(v=seq(0,60,by=4), col='lightgray', lty=1)
3129 |  lines(0:20, Per[1:21,i]) }
3130 | mtext("Periodogram", side=2, line=-.3, outer=TRUE, adj=c(.2,.8))
3131 | 
3132 | fxx = mvspec(fmri1[,-1], kernel("daniell", c(1,1)), taper=.5, plot=FALSE)$fxx
3133 | l.val = rep(NA,64)
3134 | for (k in 1:64) {
3135 |  u = eigen(fxx[,,k], symmetric=TRUE, only.values=TRUE)
3136 |  l.val[k] = u$values[1]
3137 | }
3138 | 
3139 | dev.new()
3140 | par(mar=c(2.25,2,.5,.5)+.5,  mgp = c(1.6,.6,0))  
3141 | plot(l.val, type="n", xaxt='n',xlab="Cycles (Frequency x 128)", ylab="First Principal Component")
3142 | axis(1, seq(4,60,by=8))
3143 | Grid(nx=NA, ny=NULL, minor=FALSE)
3144 | abline(v=seq(4,60,by=8), col='lightgray', lty=1)
3145 | lines(l.val)
3146 | 
3147 | # at freq k=4
3148 | u = eigen(fxx[,,4], symmetric=TRUE)
3149 | lam = u$values 
3150 | evec = u$vectors
3151 | lam[1]/sum(lam) # % of variance explained
3152 | sig.e1 = matrix(0,8,8)
3153 | for (l in 2:5){  # last 3 evs are 0
3154 |  sig.e1 = sig.e1 + lam[l]*evec[,l]%*%Conj(t(evec[,l]))/(lam[1]-lam[l])^2
3155 | }
3156 | sig.e1 = Re(sig.e1)*lam[1]*sum(kernel("daniell", c(1,1))$coef^2)
3157 | p.val = round(pchisq(2*abs(evec[,1])^2/diag(sig.e1), 2, lower.tail=FALSE), 3)
3158 | cbind(colnames(fmri1)[-1], abs(evec[,1]), p.val) # print table values
3159 | ```
3160 | 
3161 | 
3162 | Example 7.14
3163 | ```r
3164 | bhat = sqrt(lam[1])*evec[,1]
3165 | Dhat = Re(diag(fxx[,,4] - bhat%*%Conj(t(bhat))))
3166 | res = Mod(fxx[,,4] - Dhat - bhat%*%Conj(t(bhat)))
3167 | ```
3168 | 
3169 | Example 7.15
3170 | ```r
3171 | gr = diff(log(ts(econ5, start=1948, frequency=4))) # growth rate
3172 | tsplot(100*gr, col=2:6, lwd=2, ncol=2, main="Growth Rates (%)")
3173 | 
3174 | 
3175 | # scale each series to have variance 1
3176 | gr = ts(apply(gr,2,scale), freq=4)   # scaling strips ts attributes
3177 | dev.new()
3178 | gr.spec = mvspec(gr, spans=c(7,7), detrend=FALSE, taper=.25, col=2:6, lwd=2)
3179 | legend("topright", colnames(econ5), lty=1:5, lwd=2, col=2:6)
3180 | 
3181 | dev.new()
3182 | plot.spec.coherency(gr.spec, ci=NA,  main="Squared Coherencies")
3183 | 
3184 | # PCs
3185 | n.freq = length(gr.spec$freq)
3186 | lam = matrix(0,n.freq,5)
3187 | for (k in 1:n.freq) lam[k,] = eigen(gr.spec$fxx[,,k], symmetric=TRUE, only.values=TRUE)$values 
3188 | 
3189 | dev.new()
3190 | par(mfrow=c(2,1))
3191 | tsplot(gr.spec$freq, lam[,1], ylab="", xlab="Frequency", main="First Eigenvalue")
3192 |  abline(v=.25, lty=2)
3193 | tsplot(gr.spec$freq, lam[,2], ylab="", xlab="Frequency", main="Second Eigenvalue")
3194 |  abline(v=.125, lty=2)
3195 | 
3196 | e.vec1 = eigen(gr.spec$fxx[,,10], symmetric=TRUE)$vectors[,1] 
3197 | e.vec2 =  eigen(gr.spec$fxx[,,5], symmetric=TRUE)$vectors[,2]
3198 | round(Mod(e.vec1), 2);  round(Mod(e.vec2), 3) 
3199 | ```
3200 | 
3201 | 
3202 | Example 7.17  (there is now a script for the spectral envelope)
3203 | 
3204 | ```r
3205 | xdata = dna2vector(bnrf1ebv)
3206 | u     = specenv(xdata, spans=c(7,7))  
3207 | 
3208 | # details near the peak (coefs are for A, C, G, and T)
3209 | round(u,4)[1330:1336,]
3210 | ```
3211 | 
3212 | Example 7.18
3213 | 
3214 | ```r
3215 | x = astsa::nyse    
3216 | # possible transformations include absolute value and squared value
3217 | xdata = cbind(x, abs(x), x^2)  
3218 | par(mfrow=2:1)
3219 | u = specenv(xdata, real=TRUE,  spans=c(3,3))
3220 | # peak at freq = .001 so let's
3221 | # plot the optimal transform 
3222 | beta = u[2, 3:5]  # scalings
3223 | b = beta/beta[2]  # makes abs(x) coef=1
3224 | gopt = function(x) { b[1]*x+b[2]*abs(x)+b[3]*x^2 }
3225 |  curve(gopt, -.2, .2, col=4, lwd=2, panel.first=Grid(nym=0))
3226 | gabs = function(x) { b[2]*abs(x) } # corresponding to |x|
3227 |  curve(gabs, -.2, .2, add=TRUE, col=6)
3228 | legend('bottomright', lty=1, col=c(4,6), legend=c('optimal', 'absolute value'), bg='white') 
3229 | ```
3230 | 
3231 | [<sub>top</sub>](#table-of-contents)
3232 | 
3233 | ---
3234 | 


--------------------------------------------------------------------------------