static void whittle2 (Array acf, Array Aold, Array Bold, int lag,
char *direction, Array A, Array K, Array E)
{
int d, i, nser=DIM(acf)[1];
const void *vmax;
Array beta, tmp, id;
d = strcmp(direction, "forward") == 0;
vmax = vmaxget();
beta = make_zero_matrix(nser,nser);
tmp = make_zero_matrix(nser, nser);
id = make_identity_matrix(nser);
set_array_to_zero(E);
copy_array(id, subarray(A,0));
for(i = 0; i < lag; i++) {
matrix_prod(subarray(acf,lag - i), subarray(Aold,i), d, 1, tmp);
array_op(beta, tmp, '+', beta);
matrix_prod(subarray(acf,i), subarray(Bold,i), d, 1, tmp);
array_op(E, tmp, '+', E);
}
qr_solve(E, beta, K);
transpose_matrix(K,K);
for (i = 1; i <= lag; i++) {
matrix_prod(K, subarray(Bold,lag - i), 0, 0, tmp);
array_op(subarray(Aold,i), tmp, '-', subarray(A,i));
}
vmaxset(vmax);
}
int *poly_multi_divcon(int *P, int *Q, int n)
{
if (n == 1) {
int *out = calloc(2, sizeof(int));
*out = P[0] * Q[0];
return out;
}
int i;
int d = (n/2) + (n%2);
//split p and q
int *p2 = calloc(d, sizeof(int));
int *q2 = calloc(d, sizeof(int));
int *p1 = calloc(d-(n%2), sizeof(int));
int *q1 = calloc(d-(n%2), sizeof(int));
for (int i = 0; i < d; i++) {
p2[i] = P[i];
q2[i] = Q[i];
p1[i] = P[i+d];
q1[i] = Q[i+d];
}
int *PP = array_op(p1, p2, d-(n%2), d); //add P1 and P2
int *QQ = array_op(q1, q2, d-(n%2), d); //add Q1 and Q2
int *R = poly_multi_divcon(p2, q2, d); //Mult P2*Q2
int *S = poly_multi_divcon(PP, QQ, d); //Mult (P1+P2)(Q1+Q2)
int *T = poly_multi_divcon(p1, q1, d); //Mult P1*Q1
int *outt = calloc((n*2), sizeof(int));
//x^2d(R) + x^d(S-R-T) + T
for (i = 0; i<n; i++) {
//printf("n= %d i=%d T[i]=%7d S-R-T=%7d R[i]=%7d\n", n, i, T[i], S[i] - R[i] - T[i], R[i]);
outt[i] += R[i];
outt[i+d] += S[i] - R[i] - T[i];
outt[i+(d*2)] += T[i];
}
free(R); free(S); free(T); free(PP); free(QQ);
return outt;
}
static void whittle(Array acf, int nlag, Array *A, Array *B, Array p_forward,
Array v_forward, Array p_back, Array v_back)
{
int lag, nser = DIM(acf)[1];
const void *vmax;
Array EA, EB; /* prediction variance */
Array KA, KB; /* partial correlation coefficient */
Array id, tmp;
vmax = vmaxget();
KA = make_zero_matrix(nser, nser);
EA = make_zero_matrix(nser, nser);
KB = make_zero_matrix(nser, nser);
EB = make_zero_matrix(nser, nser);
id = make_identity_matrix(nser);
copy_array(id, subarray(A[0],0));
copy_array(id, subarray(B[0],0));
copy_array(id, subarray(p_forward,0));
copy_array(id, subarray(p_back,0));
for (lag = 1; lag <= nlag; lag++) {
whittle2(acf, A[lag-1], B[lag-1], lag, "forward", A[lag], KA, EB);
whittle2(acf, B[lag-1], A[lag-1], lag, "back", B[lag], KB, EA);
copy_array(EA, subarray(v_forward,lag-1));
copy_array(EB, subarray(v_back,lag-1));
copy_array(KA, subarray(p_forward,lag));
copy_array(KB, subarray(p_back,lag));
}
tmp = make_zero_matrix(nser,nser);
matrix_prod(KB,KA, 1, 1, tmp);
array_op(id, tmp, '-', tmp);
matrix_prod(EA, tmp, 0, 0, subarray(v_forward, nlag));
vmaxset(vmax);
}
static void burg2(Array ss_ff, Array ss_bb, Array ss_fb, Array E,
Array KA, Array KB)
/*
Estimate partial correlation by minimizing (1/2)*log(det(s)) where
"s" is the the sum of the forward and backward prediction errors.
In the multivariate case, the forward (KA) and backward (KB) partial
correlation coefficients are related by
KA = solve(E) %*% t(KB) %*% E
where E is the prediction variance.
*/
{
int i, j, k, l, nser = NROW(ss_ff);
int iter;
Array ss_bf;
Array s, tmp, d1;
Array D1, D2, THETA, THETAOLD, THETADIFF, TMP;
Array obj;
Array e, f, g, h, sg, sh;
Array theta;
ss_bf = make_zero_matrix(nser,nser);
transpose_matrix(ss_fb, ss_bf);
s = make_zero_matrix(nser, nser);
tmp = make_zero_matrix(nser, nser);
d1 = make_zero_matrix(nser, nser);
e = make_zero_matrix(nser, nser);
f = make_zero_matrix(nser, nser);
g = make_zero_matrix(nser, nser);
h = make_zero_matrix(nser, nser);
sg = make_zero_matrix(nser, nser);
sh = make_zero_matrix(nser, nser);
theta = make_zero_matrix(nser, nser);
D1 = make_zero_matrix(nser*nser, 1);
D2 = make_zero_matrix(nser*nser, nser*nser);
THETA = make_zero_matrix(nser*nser, 1); /* theta in vector form */
THETAOLD = make_zero_matrix(nser*nser, 1);
THETADIFF = make_zero_matrix(nser*nser, 1);
TMP = make_zero_matrix(nser*nser, 1);
obj = make_zero_matrix(1,1);
/* utility matrices e,f,g,h */
qr_solve(E, ss_bf, e);
qr_solve(E, ss_fb, f);
qr_solve(E, ss_bb, tmp);
transpose_matrix(tmp, tmp);
qr_solve(E, tmp, g);
qr_solve(E, ss_ff, tmp);
transpose_matrix(tmp, tmp);
qr_solve(E, tmp, h);
for(iter = 0; iter < BURG_MAX_ITER; iter++)
{
/* Forward and backward partial correlation coefficients */
transpose_matrix(theta, tmp);
qr_solve(E, tmp, tmp);
transpose_matrix(tmp, KA);
qr_solve(E, theta, tmp);
transpose_matrix(tmp, KB);
/* Sum of forward and backward prediction errors ... */
set_array_to_zero(s);
/* Forward */
array_op(s, ss_ff, '+', s);
matrix_prod(KA, ss_bf, 0, 0, tmp);
array_op(s, tmp, '-', s);
transpose_matrix(tmp, tmp);
array_op(s, tmp, '-', s);
matrix_prod(ss_bb, KA, 0, 1, tmp);
matrix_prod(KA, tmp, 0, 0, tmp);
array_op(s, tmp, '+', s);
/* Backward */
array_op(s, ss_bb, '+', s);
matrix_prod(KB, ss_fb, 0, 0, tmp);
array_op(s, tmp, '-', s);
transpose_matrix(tmp, tmp);
array_op(s, tmp, '-', s);
matrix_prod(ss_ff, KB, 0, 1, tmp);
matrix_prod(KB, tmp, 0, 0, tmp);
array_op(s, tmp, '+', s);
matrix_prod(s, f, 0, 0, d1);
matrix_prod(e, s, 1, 0, tmp);
array_op(d1, tmp, '+', d1);
/*matrix_prod(g,s,0,0,sg);*/
matrix_prod(s,g,0,0,sg);
matrix_prod(s,h,0,0,sh);
for (i = 0; i < nser; i++) {
for (j = 0; j < nser; j++) {
MATRIX(D1)[nser*i+j][0] = MATRIX(d1)[i][j];
for (k = 0; k < nser; k++)
for (l = 0; l < nser; l++) {
MATRIX(D2)[nser*i+j][nser*k+l] =
(i == k) * MATRIX(sg)[j][l] +
MATRIX(sh)[i][k] * (j == l);
}
}
}
copy_array(THETA, THETAOLD);
qr_solve(D2, D1, THETA);
for (i = 0; i < vector_length(theta); i++)
VECTOR(theta)[i] = VECTOR(THETA)[i];
matrix_prod(D2, THETA, 0, 0, TMP);
array_op(THETAOLD, THETA, '-', THETADIFF);
matrix_prod(D2, THETADIFF, 0, 0, TMP);
matrix_prod(THETADIFF, TMP, 1, 0, obj);
if (VECTOR(obj)[0] < BURG_TOL)
break;
}
if (iter == BURG_MAX_ITER)
error(_("Burg's algorithm failed to find partial correlation"));
}
static void burg0(int omax, Array resid_f, Array resid_b, Array *A, Array *B,
Array P, Array V, int vmethod)
{
int i, j, m, n = NCOL(resid_f), nser=NROW(resid_f);
Array ss_ff, ss_bb, ss_fb;
Array resid_f_tmp, resid_b_tmp;
Array KA, KB, E;
Array id, tmp;
ss_ff = make_zero_matrix(nser, nser);
ss_fb = make_zero_matrix(nser, nser);
ss_bb = make_zero_matrix(nser, nser);
resid_f_tmp = make_zero_matrix(nser, n);
resid_b_tmp = make_zero_matrix(nser, n);
id = make_identity_matrix(nser);
tmp = make_zero_matrix(nser, nser);
E = make_zero_matrix(nser, nser);
KA = make_zero_matrix(nser, nser);
KB = make_zero_matrix(nser, nser);
set_array_to_zero(A[0]);
set_array_to_zero(B[0]);
copy_array(id, subarray(A[0],0));
copy_array(id, subarray(B[0],0));
matrix_prod(resid_f, resid_f, 0, 1, E);
scalar_op(E, n, '/', E);
copy_array(E, subarray(V,0));
for (m = 0; m < omax; m++) {
for(i = 0; i < nser; i++) {
for (j = n - 1; j > m; j--) {
MATRIX(resid_b)[i][j] = MATRIX(resid_b)[i][j-1];
}
MATRIX(resid_f)[i][m] = 0.0;
MATRIX(resid_b)[i][m] = 0.0;
}
matrix_prod(resid_f, resid_f, 0, 1, ss_ff);
matrix_prod(resid_b, resid_b, 0, 1, ss_bb);
matrix_prod(resid_f, resid_b, 0, 1, ss_fb);
burg2(ss_ff, ss_bb, ss_fb, E, KA, KB); /* Update K */
for (i = 0; i <= m + 1; i++) {
matrix_prod(KA, subarray(B[m], m + 1 - i), 0, 0, tmp);
array_op(subarray(A[m], i), tmp, '-', subarray(A[m+1], i));
matrix_prod(KB, subarray(A[m], m + 1 - i), 0, 0, tmp);
array_op(subarray(B[m], i), tmp, '-', subarray(B[m+1], i));
}
matrix_prod(KA, resid_b, 0, 0, resid_f_tmp);
matrix_prod(KB, resid_f, 0, 0, resid_b_tmp);
array_op(resid_f, resid_f_tmp, '-', resid_f);
array_op(resid_b, resid_b_tmp, '-', resid_b);
if (vmethod == 1) {
matrix_prod(KA, KB, 0, 0, tmp);
array_op(id, tmp, '-', tmp);
matrix_prod(tmp, E, 0, 0, E);
}
else if (vmethod == 2) {
matrix_prod(resid_f, resid_f, 0, 1, E);
matrix_prod(resid_b, resid_b, 0, 1, tmp);
array_op(E, tmp, '+', E);
scalar_op(E, 2.0*(n - m - 1), '/', E);
}
else error(_("Invalid vmethod"));
copy_array(E, subarray(V,m+1));
copy_array(KA, subarray(P,m+1));
}
}
void multi_burg(int *pn, double *x, int *pomax, int *pnser, double *coef,
double *pacf, double *var, double *aic, int *porder, int *useaic,
int *vmethod)
{
int i, j, m, omax = *pomax, n = *pn, nser=*pnser, order=*porder;
int dim1[3];
double aicmin;
Array xarr, resid_f, resid_b, resid_f_tmp;
Array *A, *B, P, V;
dim1[0] = omax+1; dim1[1] = dim1[2] = nser;
A = (Array *) R_alloc(omax+1, sizeof(Array));
B = (Array *) R_alloc(omax+1, sizeof(Array));
for (i = 0; i <= omax; i++) {
A[i] = make_zero_array(dim1, 3);
B[i] = make_zero_array(dim1, 3);
}
P = make_array(pacf, dim1, 3);
V = make_array(var, dim1, 3);
xarr = make_matrix(x, nser, n);
resid_f = make_zero_matrix(nser, n);
resid_b = make_zero_matrix(nser, n);
set_array_to_zero(resid_b);
copy_array(xarr, resid_f);
copy_array(xarr, resid_b);
resid_f_tmp = make_zero_matrix(nser, n);
burg0(omax, resid_f, resid_b, A, B, P, V, *vmethod);
/* Model order selection */
for (i = 0; i <= omax; i++) {
aic[i] = n * ldet(subarray(V,i)) + 2 * i * nser * nser;
}
if (*useaic) {
order = 0;
aicmin = aic[0];
for (i = 1; i <= omax; i++) {
if (aic[i] < aicmin) {
aicmin = aic[i];
order = i;
}
}
}
else order = omax;
*porder = order;
for(i = 0; i < vector_length(A[order]); i++)
coef[i] = VECTOR(A[order])[i];
if (*useaic) {
/* Recalculate residuals for chosen model */
set_array_to_zero(resid_f);
set_array_to_zero(resid_f_tmp);
for (m = 0; m <= order; m++) {
for (i = 0; i < NROW(resid_f_tmp); i++) {
for (j = 0; j < NCOL(resid_f_tmp) - order; j++) {
MATRIX(resid_f_tmp)[i][j + order] = MATRIX(xarr)[i][j + order - m];
}
}
matrix_prod(subarray(A[order],m), resid_f_tmp, 0, 0, resid_f_tmp);
array_op(resid_f_tmp, resid_f, '+', resid_f);
}
}
copy_array(resid_f, xarr);
}
