int forkal(int ip,int iq,int id,double *phi,double*theta,double *delta,int N,double *W,double *resid,int il,double *Y,double *AMSE) { int ifault,ir,np,k,nrbar,ird,irz; double *A,*P,*V,*store,*xrow; double zero, one, two,AA,del,sumlog,ssq,sigma,A1,dt,phij,phijdt,phii,AMS; int i, j, ll, nt, nj, idk, iid,iupd,nit,iter,ind,irj; int ir2, ir1, id2r, id2r1, id1,idd1,idd2,i45,idrr1,iddr,jkl,jkl1,id2r2,ibc,l,iri1,jj; int lk, lk1,jklj,iri,kk1,k1,kk,kkk,ind1,ind2,jrj,j1,jrk; /* C C Translation of Fortran routine C ALGORITHM AS 182 APPL. STATIST. (1982) VOL.31, NO.2 C C Finite sample prediction from ARIMA processes. C C Auxiliary routines required: KARMA & STARMA from AS 154 and C routines called by them: INCLU2 from ASR 17 (a slight variant on C AS 75, and REGRES from AS 75. C*/ ir = iq + 1; if (ir < ip) { ir = ip; } np = (ir * (ir + 1)) / 2; nrbar = (np * (np - 1)) / 2; ird = ir + id; irz = (ird * (ird + 1)) / 2; zero = 0.0; one = 1.0; two = 2.0; ifault = 0; if (ip < 0) { ifault = 1; } if (iq < 0) { ifault = ifault + 2; } if (ip*ip + iq*iq == 0) { ifault = 4; } if (id < 0) { ifault = 8; } if (il < 1) { ifault = 11; } if (ifault != 0) { return ifault; } A = (double*)malloc(sizeof(double)* ird); P = (double*)malloc(sizeof(double)* irz); V = (double*)malloc(sizeof(double)* np); store = (double*)malloc(sizeof(double)* ird); xrow = (double*)malloc(sizeof(double)* np); //Initial Conditions for Kalman Filter for (i = 0; i < ird; ++i) { A[i] = zero; store[i] = zero; } for (i = 0; i < irz; ++i) { P[i] = zero; } for (i = 0; i < np; ++i) { V[i] = zero; xrow[i] = zero; } A[0] = zero; V[0] = one; /* if (np != 1) { for (i = 2; i <= np; ++i) { V[i-1] = zero; } if (iq != 0) { iq1 = iq + 1; for (i = 2; i <= iq1; ++i) { V[i-1] = theta[i - 2]; } for (j = 1; j <= iq; ++j) { ll = j * (2 * ir + 1 - j) / 2; for (i = j; i <= iq; ++i) { lli = ll + i; V[lli-1] = theta[i-1] * theta[j-1]; // Error } } } }//130 */ //Find initial likelihood conditions. if (ir == 1) { *P = 1.0 / (1.0 - phi[0] * phi[0]); } else { starma(ip, iq, phi, theta,A, P, V); } //Calculate Data Transformations nt = N - id; if (id != 0) { for (j = 1; j <= id; ++j) { nj = N - j; store[j-1] = W[nj-1]; } for (i = 1; i <= nt; ++i) { AA = zero; for (k = 1; k <= id; ++k) { idk = id + i - k; AA -= delta[k - 1] * W[idk - 1]; } iid = i + id; W[i - 1] = W[iid - 1] + AA; } }//170 //Evaluate likelihood to obtain final KF conditions sumlog = ssq = zero; del = -1.0; iupd = 1; nit = 0; iter = 0; karma(ip, iq, phi, theta, A, P, V, nt, W, resid, &sumlog, &ssq, iupd, del,&iter, &nit); //Calculate M.L.E. of sigma squared sigma = zero; for (j = 0; j < nt; ++j) { sigma += resid[j] * resid[j]; } sigma = sigma / nt; //mdisplay(resid, 1, N); //Reset the initial A and P when differencing occurs if (id != 0) { for (i = 1; i <= np; ++i) { xrow[i-1] = P[i-1]; } for (i = 1; i <= irz; ++i) { P[i-1] = zero; } ind = 0; for (j = 1; j <= ir; ++j) { k = (j - 1) * (id + ir + 1) - (j - 1) * j / 2; for (i = j; i <= ir; ++i) { ind++; k++; P[k - 1] = xrow[ind-1]; } } for (j = 1; j <= id; ++j) { irj = ir + j; A[irj-1] = store[j-1]; } }//250 //Set up constants ir2 = ir + 1; ir1 = ir - 1; id1 = id - 1; id2r = 2 * ird; id2r1 = id2r - 1; idd1 = 2 * id + 1; idd2 = idd1 + 1; i45 = id2r + 1; idrr1 = ird + 1; iddr = 2 * id + ir; jkl = ir * (iddr + 1) / 2; jkl1 = jkl + 1; id2r2 = id2r + 2; ibc = ir * (i45 - ir) / 2; for (l = 1; l <= il; ++l) { //Predict A A1 = A[0]; if (ir != 1) { for (i = 1; i <= ir1; ++i) { A[i-1] = A[i]; } }//310 A[ir-1] = zero; if (ip != 0) { for (j = 1; j <= ip; ++j) { A[j-1] += phi[j-1] * A1; } }//330 if (id != 0) { for (j = 1; j <= id; ++j) { irj = ir + j; A1 += delta[j-1] * A[irj-1]; }//340 if (id >= 2) { for (i = 1; i <= id1; ++i) { iri1 = ird - i; A[iri1] = A[iri1-1]; } }//360 A[ir2 - 1] = A1; }//360 //A[ir2-1] = A1; //Predict P if (id != 0) { for (i = 1; i <= id; ++i) { store[i-1] = zero; for (j = 1; j <= id; ++j) { ll = imax(i, j); k = imin(i, j); jj = jkl + (ll - k) + 1 + (k - 1) * (idd2 - k) / 2; store[i-1] += delta[j-1] * P[jj-1]; } }//370 if (id != 1) { for (j = 1; j <= id1; ++j) { jj = id - j; lk = (jj - 1) * (idd2 - jj) / 2 + jkl; lk1 = jj * (idd1 - jj) / 2 + jkl; for (i = 1; i <= j; ++i) { lk = lk + 1; lk1 = lk1 + 1; P[lk1-1] = P[lk-1]; } }//380 for (j = 1; j <= id1; ++j) { jklj = jkl1 + j; irj = ir + j; P[jklj - 1] = store[j - 1] + P[irj-1]; } }//400 P[jkl1 - 1] = P[0]; for (i = 1; i <= id; ++i) { iri = ir + i; P[jkl1 - 1] += delta[i - 1] * (store[i - 1] + two * P[iri - 1]); } for (i = 1; i <= id; ++i) { iri = ir + i; store[i - 1] = P[iri - 1]; } for (j = 1; j <= ir; ++j) { kk1 = j * (id2r1 - j) / 2 + ir; k1 = (j - 1) * (id2r - j) / 2 + ir; for (i = 1; i <= id; ++i) { kk = kk1 + i; k = k1 + i; P[k - 1] = phi[j - 1] * store[i - 1]; if (j != ir) { P[k - 1] += P[kk - 1]; } } } for (j = 1; j <= ir; ++j) { store[j - 1] = zero; kkk = j * (i45 - j) / 2 - id; for (i = 1; i <= id; ++i) { kkk++; store[j - 1] += delta[i - 1] * P[kkk - 1]; } }//440 if (id != 1) { for (j = 1; j <= ir; ++j) { k = j * idrr1 - j * (j + 1) / 2 + 1; for (i = 1; i <= id1; ++i) { k--; P[k - 1] = P[k - 2]; } } }//460 for (j = 1; j <= ir; ++j) { k = (j - 1) * (id2r - j) / 2 + ir + 1; P[k - 1] = store[j - 1] + phi[j - 1] * P[0]; if (j < ir) { P[k - 1] += P[j]; } } }//480 for (i = 0; i < ir; ++i) { store[i] = P[i]; } ind = 0; dt = P[0]; for (j = 1; j <= ir; ++j) { phij = phi[j - 1]; phijdt = phij * dt; ind2 = (j - 1) * (id2r2 - j) / 2; ind1 = j * (i45 - j) / 2; for (i = j; i <= ir; ++i) { ind++; ind2++; phii = phi[i - 1]; P[ind2 - 1] = V[ind - 1] + phii * phijdt; if (j < ir) { P[ind2 - 1] += store[j] * phii; } if (i != ir) { ind1++; P[ind2 - 1] += store[i] * phij + P[ind1 - 1]; }//500 } }//500 //Predict Y Y[l - 1] = A[0]; if (id != 0) { for (j = 1; j <= id; ++j) { irj = ir + j; Y[l - 1] += A[irj - 1] * delta[j - 1]; } //Calculate MSE of Y }//520 AMS = P[0]; if (id != 0) { for (j = 1; j <= id; ++j) { jrj = ibc + (j - 1) * (idd2 - j) / 2; irj = ir + j; AMS += (two * delta[j - 1] * P[irj - 1] + P[jrj] * delta[j - 1] * delta[j - 1]); } if (id != 1) { for (j = 1; j <= id1; ++j) { j1 = j + 1; jrk = ibc + 1 + (j - 1) * (idd2 - j) / 2; for (i = j1; i <= id; ++i) { jrk++; AMS += two * delta[i-1] * delta[j-1] * P[jrk-1]; } } }//550 }//550 AMSE[l - 1] = AMS * sigma; }//560 /* mdisplay(A, 1, ird); mdisplay(P, 1, irz); mdisplay(V, 1, np); mdisplay(store, 1, ird); mdisplay(xrow, 1, np); */ free(A); free(P); free(V); free(store); free(xrow); return ifault; }
double fas154_seas(double *b, int pq, void *params) { double value, ssq, sumlog, delta; int p, q, ps, qs,s,offset; int ip, iq, ir, i,j, np, ifault, N, iupd, nit, iter; double *phi, *theta, *A, *P, *V; alik_seas_object obj = (alik_seas_object)params; value = ssq = sumlog = 0.0; ip = obj->p + (obj->s * obj->P); iq = obj->q + (obj->s * obj->Q); ir = obj->r; N = obj->N; p = obj->p; ps = obj->P; q = obj->q; qs = obj->Q; s = obj->s; offset = obj->offset; np = (ir * (ir + 1)) / 2; phi = (double*)malloc(sizeof(double)* ir); theta = (double*)malloc(sizeof(double)* ir); A = (double*)malloc(sizeof(double)* ir); P = (double*)malloc(sizeof(double)* np); V = (double*)malloc(sizeof(double)* np); for (i = 0; i < ir; ++i) { phi[i] = 0.0; theta[i] = 0.0; } for (i = 0; i < p; ++i) { phi[i] = b[i]; } for (i = 0; i < q; ++i) { theta[i] = b[i + p]; } /* for (i = p; i < ip; ++i) { phi[i] = 0.0; } for (i = q; i < iq; ++i) { theta[i] = 0.0; } */ for (j = 0; j < ps; ++j) { phi[(j + 1)*s - 1] += b[p + q + j]; for (i = 0; i < p; ++i) { phi[(j + 1)*s + i] -= b[i] * b[p + q + j]; } } for (j = 0; j < qs; ++j) { theta[(j + 1)*s - 1] += b[p + q + ps + j]; for (i = 0; i < q; ++i) { theta[(j + 1)*s + i] += b[i + p] * b[p + q + ps + j]; } } if (obj->M == 1) { for (i = 0; i < N; ++i) { obj->x[offset + i] = obj->x[offset + 2 * N + i] - b[p + q + ps + qs]; } } //mdisplay(phi, 1, ir); //mdisplay(theta, 1, ir); iupd = 0; //mdisplay(b, 1, pq); if (ip == 1 && iq == 0) { *V = 1.0; *A = 0.0; *P = 1.0 / (1.0 - phi[0] * phi[0]); } else { iupd = 1; ifault = starma(ip, iq, phi, theta, A, P, V); } nit = 0; delta = 0.001; //mdisplay(P, 1, np); karma(ip, iq, phi, theta, A, P, V, N, obj->x + offset, obj->x + offset + N, &sumlog, &ssq, iupd, delta, &iter, &nit); obj->ssq = ssq; //mdisplay(V, 1, np); value = 0.5 * (sumlog / (double)iter + log(ssq / (double)iter)); obj->loglik = value; //printf("sumlog ssq %g %g %d \n", sumlog,value,iter); free(phi); free(theta); free(A); free(P); free(V); return value; }
SEXP arma0fa(SEXP pG, SEXP inparams) { int i, j, ifault = 0, it, streg; double sumlog, ssq, tmp, ans; GET_STARMA; dotrans(G, REAL(inparams), G->params, G->trans); if(G->ns > 0) { /* expand out seasonal ARMA models */ for(i = 0; i < G->mp; i++) G->phi[i] = G->params[i]; for(i = 0; i < G->mq; i++) G->theta[i] = G->params[i + G->mp]; for(i = G->mp; i < G->p; i++) G->phi[i] = 0.0; for(i = G->mq; i < G->q; i++) G->theta[i] = 0.0; for(j = 0; j < G->msp; j++) { G->phi[(j + 1)*G->ns - 1] += G->params[j + G->mp + G->mq]; for(i = 0; i < G->mp; i++) G->phi[(j + 1)*G->ns + i] -= G->params[i]* G->params[j + G->mp + G->mq]; } for(j = 0; j < G->msq; j++) { G->theta[(j + 1)*G->ns - 1] += G->params[j + G->mp + G->mq + G->msp]; for(i = 0; i < G->mq; i++) G->theta[(j + 1)*G->ns + i] += G->params[i + G->mp]* G->params[j + G->mp + G->mq + G->msp]; } } else { for(i = 0; i < G->mp; i++) G->phi[i] = G->params[i]; for(i = 0; i < G->mq; i++) G->theta[i] = G->params[i + G->mp]; } streg = G->mp + G->mq + G->msp + G->msq; if(G->m > 0) { for(i = 0; i < G->n; i++) { tmp = G->wkeep[i]; for(j = 0; j < G->m; j++) tmp -= G->reg[i + G->n*j] * G->params[streg + j]; G->w[i] = tmp; } } if(G->method == 1) { int p = G->mp + G->ns * G->msp, q = G->mq + G->ns * G->msq, nu = 0; ssq = 0.0; for(i = 0; i < G->ncond; i++) G->resid[i] = 0.0; for(i = G->ncond; i < G->n; i++) { tmp = G->w[i]; for(j = 0; j < min(i - G->ncond, p); j++) tmp -= G->phi[j] * G->w[i - j - 1]; for(j = 0; j < min(i - G->ncond, q); j++) tmp -= G->theta[j] * G->resid[i - j - 1]; G->resid[i] = tmp; if(!ISNAN(tmp)) { nu++; ssq += tmp * tmp; } } G->s2 = ssq/(double)(nu); ans = 0.5 * log(G->s2); } else { starma(G, &ifault); if(ifault) error(_("starma error code %d"), ifault); sumlog = 0.0; ssq = 0.0; it = 0; karma(G, &sumlog, &ssq, 1, &it); G->s2 = ssq/(double)G->nused; ans = 0.5*(log(ssq/(double)G->nused) + sumlog/(double)G->nused); } return ScalarReal(ans); }
double fas154(double *b,int pq,void *params) { double value,ssq,sumlog,delta; int ip, iq, ir,i,np,ifault,N,iupd,nit,iter; double *phi, *theta, *A,*P,*V; alik_object obj = (alik_object)params; value = ssq = sumlog = 0.0; ip = obj->p; iq = obj->q; ir = obj->r; N = obj->N; np = (ir * (ir + 1)) / 2; phi = (double*)malloc(sizeof(double)* ir); theta = (double*)malloc(sizeof(double)* ir); A = (double*)malloc(sizeof(double)* ir); P = (double*)malloc(sizeof(double)* np); V = (double*)malloc(sizeof(double)* np); //bt = (double*)malloc(sizeof(double)* (ip+iq)); /* for (i = 0; i < ip + iq; ++i) { bt[i] = b[i]; } pdlreg(ip, bt, b); pdlreg(iq, bt + ip, b + ip); */ for (i = 0; i < ip; ++i) { phi[i] = b[i]; } for (i = ip; i < ir; ++i) { phi[i] = 0.0; } for (i = 0; i < iq; ++i) { theta[i] = b[i+ip]; } for (i = iq; i < ir; ++i) { theta[i] = 0.0; } if (obj->M == 1) { for (i = 0; i < N; ++i) { obj->x[i] = obj->x[2 * N + i] - b[ip + iq]; } } iupd = 0; if (ip == 1 && iq == 0) { *V = 1.0; *A = 0.0; *P = 1.0 / (1.0 - phi[0] * phi[0]); } else { iupd = 1; ifault = starma(ip, iq, phi, theta, A, P, V); } nit = 0; delta = 0.001; //mdisplay(P, 1, np); karma(ip, iq, phi, theta, A, P, V, N, obj->x, obj->x + N, &sumlog, &ssq, iupd, delta,&iter, &nit); obj->ssq = ssq; //mdisplay(phi, 1, ip); value = 0.5 * (sumlog/(double)iter + log(ssq/(double) iter)); obj->loglik = value; //printf("sumlog ssq %g %g %d \n", sumlog,value,iter); free(phi); free(theta); free(A); free(P); free(V); //free(bt); return value; }
/* start of AS 182 */ void forkal(Starma G, int d, int il, double *delta, double *y, double *amse, int *ifault) { int p = G->p, q = G->q, r = G->r, n = G->n, np = G->np; double *phi = G->phi, *V = G->V, *w = G->w, *xrow = G->xrow; double *a, *P, *store; int rd = r + d, rz = rd*(rd + 1)/2; double phii, phij, sigma2, a1, aa, dt, phijdt, ams, tmp; int i, j, k, l, nu = 0; int k1; int i45, jj, kk, lk, ll; int nt; int kk1, lk1; int ind, jkl, kkk; int ind1, ind2; /* Finite sample prediction from ARIMA processes. */ /* This routine will calculate the finite sample predictions and their conditional mean square errors for any ARIMA process. */ /* invoking this routine will calculate the finite sample predictions */ /* and their conditional mean square errors for any arima process. */ store = (double *) R_alloc(rd, sizeof(double)); Free(G->a); G->a = a = Calloc(rd, double); Free(G->P); G->P = P = Calloc(rz, double); /* check for input faults. */ *ifault = 0; if (p < 0) *ifault = 1; if (q < 0) *ifault += 2; if (p * p + q * q == 0) *ifault = 4; if (r != max(p, q + 1)) *ifault = 5; if (np != r * (r + 1) / 2) *ifault = 6; if (d < 0) *ifault = 8; if (il < 1) *ifault = 11; if (*ifault != 0) return; /* Find initial likelihood conditions. */ if (r == 1) { a[0] = 0.0; V[0] = 1.0; P[0] = 1.0 / (1.0 - phi[0] * phi[0]); } else starma(G, ifault); /* Calculate data transformations */ nt = n - d; if (d > 0) { for (j = 0; j < d; j++) { store[j] = w[n - j - 2]; if(ISNAN(store[j])) error(_("missing value in last %d observations"), d); } for (i = 0; i < nt; i++) { aa = 0.0; for (k = 0; k < d; ++k) aa -= delta[k] * w[d + i - k - 1]; w[i] = w[i + d] + aa; } } /* Evaluate likelihood to obtain final Kalman filter conditions */ { double sumlog = 0.0, ssq = 0.0; int nit = 0; G->n = nt; karma(G, &sumlog, &ssq, 1, &nit); } /* Calculate m.l.e. of sigma squared */ sigma2 = 0.0; for (j = 0; j < nt; j++) { /* MacOS X/gcc 3.5 does/didn't have isnan defined properly */ tmp = G->resid[j]; if(!ISNAN(tmp)) { nu++; sigma2 += tmp * tmp; } } sigma2 /= nu; /* reset the initial a and P when differencing occurs */ if (d > 0) { for (i = 0; i < np; i++) xrow[i] = P[i]; for (i = 0; i < rz; i++) P[i] = 0.0; ind = 0; for (j = 0; j < r; j++) { k = j * (rd + 1) - j * (j + 1) / 2; for (i = j; i < r; i++) P[k++] = xrow[ind++]; } for (j = 0; j < d; j++) a[r + j] = store[j]; } i45 = 2*rd + 1; jkl = r * (2*d + r + 1) / 2; for (l = 0; l < il; ++l) { /* predict a */ a1 = a[0]; for (i = 0; i < r - 1; i++) a[i] = a[i + 1]; a[r - 1] = 0.0; for (j = 0; j < p; j++) a[j] += phi[j] * a1; if (d > 0) { for (j = 0; j < d; j++) a1 += delta[j] * a[r + j]; for (i = rd - 1; i > r; i--) a[i] = a[i - 1]; a[r] = a1; } /* predict P */ if (d > 0) { for (i = 0; i < d; i++) { store[i] = 0.0; for (j = 0; j < d; j++) { ll = max(i, j); k = min(i, j); jj = jkl + (ll - k) + k * (2*d + 2 - k - 1) / 2; store[i] += delta[j] * P[jj]; } } if (d > 1) { for (j = 0; j < d - 1; j++) { jj = d - j - 1; lk = (jj - 1) * (2*d + 2 - jj) / 2 + jkl; lk1 = jj * (2*d + 1 - jj) / 2 + jkl; for (i = 0; i <= j; i++) P[lk1++] = P[lk++]; } for (j = 0; j < d - 1; j++) P[jkl + j + 1] = store[j] + P[r + j]; } P[jkl] = P[0]; for (i = 0; i < d; i++) P[jkl] += delta[i] * (store[i] + 2.0 * P[r + i]); for (i = 0; i < d; i++) store[i] = P[r + i]; for (j = 0; j < r; j++) { kk1 = (j+1) * (2*rd - j - 2) / 2 + r; k1 = j * (2*rd - j - 1) / 2 + r; for (i = 0; i < d; i++) { kk = kk1 + i; k = k1 + i; P[k] = phi[j] * store[i]; if (j < r - 1) P[k] += P[kk]; } } for (j = 0; j < r; j++) { store[j] = 0.0; kkk = (j + 1) * (i45 - j - 1) / 2 - d; for (i = 0; i < d; i++) store[j] += delta[i] * P[kkk++]; } for (j = 0; j < r; j++) { k = (j + 1) * (rd + 1) - (j + 1) * (j + 2) / 2; for (i = 0; i < d - 1; i++) { --k; P[k] = P[k - 1]; } } for (j = 0; j < r; j++) { k = j * (2*rd - j - 1) / 2 + r; P[k] = store[j] + phi[j] * P[0]; if (j < r - 1) P[k] += P[j + 1]; } } for (i = 0; i < r; i++) store[i] = P[i]; ind = 0; dt = P[0]; for (j = 0; j < r; j++) { phij = phi[j]; phijdt = phij * dt; ind2 = j * (2*rd - j + 1) / 2 - 1; ind1 = (j + 1) * (i45 - j - 1) / 2 - 1; for (i = j; i < r; i++) { ++ind2; phii = phi[i]; P[ind2] = V[ind++] + phii * phijdt; if (j < r - 1) P[ind2] += store[j + 1] * phii; if (i < r - 1) P[ind2] += store[i + 1] * phij + P[++ind1]; } } /* predict y */ y[l] = a[0]; for (j = 0; j < d; j++) y[l] += a[r + j] * delta[j]; /* calculate m.s.e. of y */ ams = P[0]; if (d > 0) { for (j = 0; j < d; j++) { k = r * (i45 - r) / 2 + j * (2*d + 1 - j) / 2; tmp = delta[j]; ams += 2.0 * tmp * P[r + j] + P[k] * tmp * tmp; } for (j = 0; j < d - 1; j++) { k = r * (i45 - r) / 2 + 1 + j * (2*d + 1 - j) / 2; for (i = j + 1; i < d; i++) ams += 2.0 * delta[i] * delta[j] * P[k++]; } } amse[l] = ams * sigma2; } return; }