static int
recalculate_impulse_responses (irfboot *b, GRETL_VAR *v,
int targ, int shock, int iter)
{
gretl_matrix *C = v->C;
double x;
int t, err = 0;
if (v->ord != NULL) {
C = reorder_responses(v, &err);
if (err) {
return err;
}
}
for (t=0; t<b->horizon; t++) {
if (t == 0) {
/* initial estimated responses */
gretl_matrix_copy_values(b->rtmp, C);
} else {
/* calculate further estimated responses */
gretl_matrix_multiply(v->A, b->rtmp, b->ctmp);
gretl_matrix_copy_values(b->rtmp, b->ctmp);
}
x = gretl_matrix_get(b->rtmp, targ, shock);
gretl_matrix_set(b->resp, t, iter, x);
}
if (C != v->C) {
gretl_matrix_free(C);
}
return err;
}
static int revise_VAR_residuals (gretl_matrix *A,
gretl_matrix *Y,
gretl_matrix *X,
gretl_matrix *E)
{
gretl_matrix *Xt, *Pt;
double yti;
int k = X->cols;
int T = X->rows;
int i, t;
Xt = gretl_matrix_alloc(1, k);
Pt = gretl_matrix_alloc(1, k);
if (Xt == NULL || Pt == NULL) {
return E_ALLOC;
}
for (t=0; t<T; t++) {
for (i=0; i<k; i++) {
Xt->val[i] = gretl_matrix_get(X, t, i);
}
gretl_matrix_multiply(Xt, A, Pt);
for (i=0; i<k; i++) {
yti = gretl_matrix_get(Y, t, i);
gretl_matrix_set(E, t, i, yti - Pt->val[i]);
}
}
gretl_matrix_free(Xt);
gretl_matrix_free(Pt);
return 0;
}
int qr_matrix_hccme (const gretl_matrix *X,
const gretl_matrix *h,
const gretl_matrix *XTXi,
gretl_matrix *d,
gretl_matrix *VCV,
int hc_version)
{
gretl_matrix *tmp1 = NULL;
gretl_matrix *tmp2 = NULL;
int T = X->rows;
int k = X->cols;
int t, err = 0;
tmp1 = gretl_matrix_alloc(k, T);
tmp2 = gretl_matrix_alloc(k, k);
if (tmp1 == NULL || tmp2 == NULL) {
gretl_matrix_free(tmp1);
gretl_matrix_free(tmp2);
return E_ALLOC;
}
if (hc_version == 1) {
for (t=0; t<T; t++) {
d->val[t] *= (double) T / (T - k);
}
} else if (hc_version > 1) {
/* do the h_t calculations */
for (t=0; t<T; t++) {
double ht = h->val[t];
if (hc_version == 2) {
d->val[t] /= (1.0 - ht);
} else {
/* HC3 */
d->val[t] /= (1.0 - ht) * (1.0 - ht);
}
}
}
do_X_prime_diag(X, d, tmp1);
gretl_matrix_multiply(tmp1, X, tmp2);
gretl_matrix_qform(XTXi, GRETL_MOD_NONE, tmp2,
VCV, GRETL_MOD_NONE);
gretl_matrix_free(tmp1);
gretl_matrix_free(tmp2);
return err;
}
static void duration_update_Xb (duration_info *dinfo, const double *theta)
{
int j;
if (theta == NULL) {
theta = dinfo->theta;
}
for (j=0; j<dinfo->k; j++) {
dinfo->beta->val[j] = theta[j];
}
gretl_matrix_multiply(dinfo->X, dinfo->beta, dinfo->Xb);
}
static void compute_VAR_dataset (irfboot *b, GRETL_VAR *var,
const GRETL_VAR *vbak)
{
double x;
int i, j, k, t;
int nl = var_n_lags(var);
#if BDEBUG
gretl_matrix_print(var->Y, "var->Y before resampling");
gretl_matrix_print(var->X, "var->X before resampling");
#endif
for (t=0; t<var->T; t++) {
/* extract row of var->X at t */
gretl_matrix_extract_matrix(b->Xt, var->X, t, 0, GRETL_MOD_NONE);
/* multiply Xt into original coeff matrix, forming Yt */
gretl_matrix_multiply(b->Xt, vbak->B, b->Yt);
/* extract resampled residuals at t */
gretl_matrix_extract_matrix(b->Et, b->rE, t, 0, GRETL_MOD_NONE);
/* add resampled residual to Yt */
gretl_matrix_add_to(b->Yt, b->Et);
/* write into big Y matrix */
gretl_matrix_inscribe_matrix(var->Y, b->Yt, t, 0, GRETL_MOD_NONE);
/* revise lagged Y columns in X */
k = var->ifc;
for (i=0; i<var->neqns; i++) {
x = b->Yt->val[i];
for (j=1; j<=nl && t+j < var->T; j++) {
gretl_matrix_set(var->X, t+j, k++, x);
}
}
}
#if BDEBUG > 1
gretl_matrix_print(var->Y, "var->Y after resampling");
gretl_matrix_print(var->X, "var->X after resampling");
#endif
}
int maybe_limit_VAR_coeffs (gretl_matrix *A,
gretl_matrix *Y,
gretl_matrix *X,
gretl_matrix *E)
{
gretl_matrix *B = NULL;
gretl_matrix *D = NULL;
gretl_matrix *C = NULL;
gretl_matrix *T = NULL;
int i, k = A->rows;
int amod = 0;
int err;
err = gretl_matrix_SVD(A, &B, &D, &C);
if (!err) {
for (i=0; i<k; i++) {
if (D->val[i] > 0.97) {
D->val[i] = 0.97;
amod = 1;
}
}
if (amod) {
/* "shrink" A */
T = gretl_matrix_dot_op(B, D, '*', &err);
gretl_matrix_multiply(T, C, A);
}
}
if (amod && X != NULL && Y != NULL && E != NULL) {
err = revise_VAR_residuals(A, Y, X, E);
}
gretl_matrix_free(B);
gretl_matrix_free(D);
gretl_matrix_free(C);
gretl_matrix_free(T);
return err;
}
static int qr_make_hccme (MODEL *pmod, const DATASET *dset,
gretl_matrix *Q, gretl_matrix *XTXi)
{
gretl_matrix *X;
gretl_matrix *diag = NULL;
gretl_matrix *tmp1 = NULL, *tmp2 = NULL, *vcv = NULL;
int T = pmod->nobs;
int k = pmod->list[0] - 1;
int hc_version;
int i, t;
int err = 0;
X = make_data_X(pmod, dset);
if (X == NULL) return 1;
diag = gretl_vector_from_array(pmod->uhat + pmod->t1, T,
GRETL_MOD_SQUARE);
if (diag == NULL) {
err = 1;
goto bailout;
}
tmp1 = gretl_matrix_alloc(k, T);
tmp2 = gretl_matrix_alloc(k, k);
vcv = gretl_matrix_alloc(k, k);
if (tmp1 == NULL || tmp2 == NULL || vcv == NULL) {
err = 1;
goto bailout;
}
hc_version = libset_get_int(HC_VERSION);
gretl_model_set_vcv_info(pmod, VCV_HC, hc_version);
if (hc_version == 1) {
for (t=0; t<T; t++) {
diag->val[t] *= (double) T / (T - k);
}
} else if (hc_version > 1) {
/* do the h_t calculations */
for (t=0; t<T; t++) {
double q, ht = 0.0;
for (i=0; i<k; i++) {
q = gretl_matrix_get(Q, t, i);
ht += q * q;
}
if (hc_version == 2) {
diag->val[t] /= (1.0 - ht);
} else {
/* HC3 */
diag->val[t] /= (1.0 - ht) * (1.0 - ht);
}
}
}
do_X_prime_diag(X, diag, tmp1);
gretl_matrix_multiply(tmp1, X, tmp2);
gretl_matrix_qform(XTXi, GRETL_MOD_NONE, tmp2,
vcv, GRETL_MOD_NONE);
/* Transcribe vcv into triangular representation */
err = qr_make_vcv(pmod, vcv, VCV_ROBUST);
bailout:
gretl_matrix_free(X);
gretl_matrix_free(diag);
gretl_matrix_free(tmp1);
gretl_matrix_free(tmp2);
gretl_matrix_free(vcv);
return err;
}
static gretl_matrix *cluster_vcv_calc (MODEL *pmod,
int cvar,
gretl_matrix *cvals,
gretl_matrix *XX,
const DATASET *dset,
int *err)
{
gretl_matrix *V = NULL;
gretl_matrix *W = NULL;
gretl_matrix *XXW = NULL;
gretl_vector *ei = NULL;
gretl_matrix *Xi = NULL;
gretl_vector *eXi = NULL;
const double *cZ;
int n_c, M, N, k = pmod->ncoeff;
int total_obs = 0;
int i, j, v, t;
cZ = dset->Z[cvar];
N = cval_count_max(pmod, cvals, cZ);
#if CDEBUG
fprintf(stderr, "max cval count = %d\n", N);
#endif
V = gretl_matrix_alloc(k, k);
W = gretl_zero_matrix_new(k, k);
XXW = gretl_zero_matrix_new(k, k);
ei = gretl_column_vector_alloc(N);
Xi = gretl_matrix_alloc(N, k);
eXi = gretl_vector_alloc(k);
if (V == NULL || W == NULL || XXW == NULL ||
ei == NULL || Xi == NULL || eXi == NULL) {
*err = E_ALLOC;
goto bailout;
}
M = gretl_vector_get_length(cvals);
n_c = 0;
for (i=0; i<M; i++) {
double cvi = cvals->val[i];
int Ni = cval_count(pmod, cvi, cZ);
int s = 0;
if (Ni == 0) {
continue;
}
#if CDEBUG
fprintf(stderr, "i=%d, cvi=%g, Ni=%d\n", i, cvi, Ni);
#endif
ei = gretl_matrix_reuse(ei, Ni, -1);
Xi = gretl_matrix_reuse(Xi, Ni, -1);
for (t=pmod->t1; t<=pmod->t2; t++) {
if (!na(pmod->uhat[t]) && cZ[t] == cvi) {
gretl_vector_set(ei, s, pmod->uhat[t]);
for (j=0; j<k; j++) {
v = pmod->list[j+2];
gretl_matrix_set(Xi, s, j, dset->Z[v][t]);
}
s++;
}
if (s == Ni) {
/* we've filled this matrix */
break;
}
}
gretl_matrix_multiply_mod(ei, GRETL_MOD_TRANSPOSE,
Xi, GRETL_MOD_NONE,
eXi, GRETL_MOD_NONE);
gretl_matrix_multiply_mod(eXi, GRETL_MOD_TRANSPOSE,
eXi, GRETL_MOD_NONE,
W, GRETL_MOD_CUMULATE);
#if CDEBUG > 1
gretl_matrix_print(ei, "e(i)");
gretl_matrix_print(Xi, "X(i)");
gretl_matrix_print(W, "W");
#endif
n_c++;
total_obs += s;
}
if (n_c < 2) {
gretl_errmsg_set("Invalid clustering variable");
*err = E_DATA;
goto bailout;
} else if (total_obs < pmod->nobs) {
*err = E_MISSDATA;
goto bailout;
}
/* form V(W) = (X'X)^{-1} W (X'X)^{-1} */
gretl_matrix_multiply(XX, W, XXW);
gretl_matrix_multiply(XXW, XX, V);
gretl_matrix_xtr_symmetric(V);
#if CDEBUG
gretl_matrix_print(XX, "X'X^{-1}");
gretl_matrix_print(W, "W");
gretl_matrix_print(V, "V");
#endif
if (!(pmod->opt & OPT_N)) {
/* apply df adjustment a la Stata */
double dfadj;
N = pmod->nobs;
dfadj = (M/(M-1.0)) * (N-1.0)/(N-k);
gretl_matrix_multiply_by_scalar(V, dfadj);
#if CDEBUG > 1
gretl_matrix_print(V, "V(adjusted)");
#endif
}
bailout:
gretl_matrix_free(W);
gretl_matrix_free(XXW);
gretl_matrix_free(ei);
gretl_matrix_free(Xi);
gretl_matrix_free(eXi);
if (*err) {
gretl_matrix_free(V);
V = NULL;
}
return V;
}
int gretl_qr_regress (MODEL *pmod, DATASET *dset, gretlopt opt)
{
integer T, k;
gretl_matrix *Q = NULL, *y = NULL;
gretl_matrix *R = NULL, *g = NULL, *b = NULL;
gretl_matrix *V = NULL;
int rank, warn = 0, err = 0;
T = pmod->nobs; /* # of rows (observations) */
k = pmod->list[0] - 1; /* # of cols (variables) */
Q = gretl_matrix_alloc(T, k);
R = gretl_matrix_alloc(k, k);
V = gretl_matrix_alloc(k, k);
if (y == NULL) {
y = gretl_matrix_alloc(T, 1);
}
if (Q == NULL || R == NULL || V == NULL || y == NULL) {
err = E_ALLOC;
goto qr_cleanup;
}
get_model_data(pmod, dset, Q, y);
err = QR_decomp_plus(Q, R, &rank, &warn);
/* handling of near-perfect collinearity */
if (err == E_SINGULAR && !(opt & OPT_Z)) {
drop_redundant_vars(pmod, dset, R, rank, opt);
k = pmod->list[0] - 1;
gretl_matrix_reuse(Q, T, k);
gretl_matrix_reuse(R, k, k);
gretl_matrix_reuse(V, k, k);
get_model_data(pmod, dset, Q, y);
err = QR_decomp_plus(Q, R, NULL, &warn);
if (!err) {
maybe_shift_ldepvar(pmod, dset);
}
}
if (err) {
goto qr_cleanup;
}
/* allocate temporary arrays */
g = gretl_matrix_alloc(k, 1);
b = gretl_matrix_alloc(k, 1);
if (g == NULL || b == NULL) {
err = E_ALLOC;
goto qr_cleanup;
}
if (allocate_model_arrays(pmod, k, dset->n)) {
err = E_ALLOC;
goto qr_cleanup;
}
/* make "g" into gamma-hat */
gretl_matrix_multiply_mod(Q, GRETL_MOD_TRANSPOSE,
y, GRETL_MOD_NONE,
g, GRETL_MOD_NONE);
/* OLS coefficients */
gretl_matrix_multiply(R, g, b);
pmod->coeff = gretl_matrix_steal_data(b);
/* write vector of fitted values into y */
gretl_matrix_multiply(Q, g, y);
/* get vector of residuals and SSR */
get_resids_and_SSR(pmod, dset, y, dset->n);
/* standard error of regression */
if (T - k > 0) {
if (pmod->opt & OPT_N) {
/* no-df-corr */
pmod->sigma = sqrt(pmod->ess / T);
} else {
pmod->sigma = sqrt(pmod->ess / (T - k));
}
} else {
pmod->sigma = 0.0;
}
/* create (X'X)^{-1} */
gretl_matrix_multiply_mod(R, GRETL_MOD_NONE,
R, GRETL_MOD_TRANSPOSE,
V, GRETL_MOD_NONE);
/* VCV and standard errors */
if (opt & OPT_R) {
pmod->opt |= OPT_R;
if (opt & OPT_C) {
err = qr_make_cluster_vcv(pmod, OLS, dset, V, opt);
} else if ((opt & OPT_T) && !libset_get_bool(FORCE_HC)) {
err = qr_make_hac(pmod, dset, V);
} else {
err = qr_make_hccme(pmod, dset, Q, V);
}
} else {
err = qr_make_regular_vcv(pmod, V, opt);
}
if (!err) {
/* get R^2, F-stat */
qr_compute_stats(pmod, dset, T, opt);
/* D-W stat and p-value */
if ((opt & OPT_I) && pmod->missmask == NULL) {
qr_dw_stats(pmod, dset, Q, y);
}
/* near-singularity? */
if (warn) {
gretl_model_set_int(pmod, "near-singular", 1);
}
}
qr_cleanup:
gretl_matrix_free(Q);
gretl_matrix_free(R);
gretl_matrix_free(y);
gretl_matrix_free(g);
gretl_matrix_free(b);
gretl_matrix_free(V);
pmod->errcode = err;
return err;
}
