static gretl_matrix *maybe_make_auto_theta (char *name, int i,
int ptype,
int m1, int m2)
{
gretl_matrix *theta = NULL;
int k = 0;
if (!strcmp(name, "null")) {
/* OK if we know how many parameters are needed? */
if (ptype == MIDAS_BETA0) {
k = 2;
} else if (ptype == MIDAS_BETAN) {
k = 3;
} else if (ptype == MIDAS_U) {
k = m2 - m1 + 1;
}
} else if (integer_string(name)) {
int chk = atoi(name);
if (chk >= 1 && chk < 100) {
k = chk;
}
}
if (k > 0) {
theta = gretl_zero_matrix_new(k, 1);
if (theta != NULL) {
if (ptype == MIDAS_BETA0) {
theta->val[0] = 1;
theta->val[1] = 5;
} else if (ptype == MIDAS_BETAN) {
theta->val[0] = 1;
theta->val[1] = 1;
theta->val[2] = 0;
}
sprintf(name, "theta___%d", i+1);
private_matrix_add(theta, name);
}
}
#if MIDAS_DEBUG
gretl_matrix_print(theta, "auto-generated theta");
#endif
return theta;
}
gretl_matrix *HAC_XOX (const gretl_matrix *uhat,
const gretl_matrix *X,
VCVInfo *vi, int use_prior,
int *err)
{
gretl_matrix *XOX = NULL;
gretl_matrix *Wtj = NULL;
gretl_matrix *Gj = NULL;
gretl_matrix *H = NULL;
gretl_matrix *A = NULL;
gretl_matrix *w = NULL;
int prewhiten;
int data_based;
int kern;
int T = X->rows;
int k = X->cols;
int p, j, t;
double bt = 0;
if (use_prior) {
kern = vi->vmin;
prewhiten = vi->flags & HAC_PREWHITEN;
if (kern == KERNEL_QS) {
bt = vi->bw;
p = T - 1;
} else {
p = vi->order;
}
data_based = 0;
} else {
kern = libset_get_int(HAC_KERNEL);
data_based = data_based_hac_bandwidth();
prewhiten = libset_get_bool(PREWHITEN);
}
#if NW_DEBUG
fprintf(stderr, "*** HAC: kern = %d, prewhiten = %d ***\n",
kern, prewhiten);
#endif
if (use_prior) {
H = newey_west_H(X, uhat, NULL);
} else if (prewhiten || data_based) {
H = newey_west_H(X, uhat, &w);
} else {
H = newey_west_H(X, uhat, NULL);
}
if (H == NULL) {
*err = E_ALLOC;
return NULL;
} else if (prewhiten) {
*err = nw_prewhiten(H, &A);
}
if (!*err) {
XOX = gretl_zero_matrix_new(k, k);
Wtj = gretl_matrix_alloc(k, k);
Gj = gretl_matrix_alloc(k, k);
if (XOX == NULL || Wtj == NULL || Gj == NULL) {
*err = E_ALLOC;
}
}
if (*err) {
goto bailout;
}
/* determine the bandwidth setting */
if (!use_prior) {
if (data_based) {
*err = newey_west_bandwidth(H, w, kern, prewhiten, &p, &bt);
if (*err) {
goto bailout;
}
} else if (kern == KERNEL_QS) {
bt = libset_get_double(QS_BANDWIDTH);
p = T - 1;
} else {
p = get_hac_lag(T);
}
}
if (!*err) {
double wj;
for (j=0; j<=p; j++) {
/* cumulate running sum of Gamma-hat terms */
gretl_matrix_zero(Gj);
for (t=j; t<T; t++) {
/* W(t)-transpose * W(t-j) */
wtw(Wtj, H, k, t, j);
gretl_matrix_add_to(Gj, Wtj);
}
if (j > 0) {
/* Gamma(j) = Gamma(j) + Gamma(j)-transpose */
gretl_matrix_add_self_transpose(Gj);
if (kern == KERNEL_QS) {
wj = qs_hac_weight(bt, j);
} else {
wj = hac_weight(kern, p, j);
}
gretl_matrix_multiply_by_scalar(Gj, wj);
}
gretl_matrix_add_to(XOX, Gj);
}
}
if (A != NULL) {
hac_recolor(XOX, A);
}
if (!use_prior) {
vi->vmaj = VCV_HAC;
vi->vmin = kern;
vi->flags = prewhiten ? HAC_PREWHITEN : 0;
if (kern == KERNEL_QS) {
vi->order = 0;
vi->bw = bt;
} else {
vi->order = p;
vi->bw = NADBL;
}
}
bailout:
gretl_matrix_free(H);
gretl_matrix_free(Wtj);
gretl_matrix_free(Gj);
gretl_matrix_free(A);
gretl_matrix_free(w);
if (*err && XOX != NULL) {
gretl_matrix_free(XOX);
XOX = NULL;
}
return XOX;
}
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;
}
static int add_midas_matrices (int yno,
const int *xlist,
const DATASET *dset,
midas_info *minfo,
int nmidas,
int *pslopes)
{
gretl_matrix *X = NULL;
gretl_matrix *y = NULL;
gretl_matrix *b = NULL;
gretl_matrix *c = NULL;
int hfslopes = 0;
int init_err = 0;
int i, T, nx = 0;
int err = 0;
T = sample_size(dset);
if (xlist != NULL) {
nx = xlist[0];
X = gretl_matrix_data_subset(xlist, dset,
dset->t1, dset->t2,
M_MISSING_ERROR,
&err);
if (!err) {
err = private_matrix_add(X, "MX___");
}
if (!err) {
b = gretl_zero_matrix_new(nx, 1);
if (b!= NULL) {
err = private_matrix_add(b, "bx___");
} else {
err = E_ALLOC;
}
}
}
if (!err) {
/* for initialization only */
y = gretl_column_vector_alloc(T);
if (y != NULL) {
memcpy(y->val, dset->Z[yno] + dset->t1,
T * sizeof(double));
} else {
init_err = 1;
}
}
if (!err) {
/* count the HF slope coeffs */
for (i=0; i<nmidas && !err; i++) {
if (takes_coeff(minfo[i].type)) {
hfslopes++;
}
}
/* "full-length" coeff vector */
c = gretl_zero_matrix_new(nx + hfslopes, 1);
if (c == NULL) {
init_err = 1;
}
}
if (!err && !init_err) {
gretl_matrix *XZ = NULL;
if (hfslopes > 0) {
XZ = build_XZ(X, dset, minfo, T, nmidas, hfslopes);
if (XZ == NULL) {
/* fallback, ignoring "Z" */
c->rows = nx;
}
}
if (XZ != NULL) {
init_err = gretl_matrix_ols(y, XZ, c, NULL,
NULL, NULL);
} else {
init_err = gretl_matrix_ols(y, X, c, NULL,
NULL, NULL);
}
gretl_matrix_free(XZ);
}
#if MIDAS_DEBUG
if (!err && !init_err) {
gretl_matrix_print(c, "MIDAS OLS initialization");
}
#endif
if (!err) {
if (!init_err) {
/* initialize X coeffs from OLS */
for (i=0; i<nx; i++) {
b->val[i] = c->val[i];
}
}
if (hfslopes > 0) {
/* initialize hf slopes, with fallback to zero */
int use_c = !init_err && c->rows > nx;
char tmp[16];
double bzi;
for (i=0; i<nmidas && !err; i++) {
if (takes_coeff(minfo[i].type)) {
sprintf(tmp, "bmlc___%d", i+1);
bzi = use_c ? c->val[nx+i] : 0.0;
err = private_scalar_add(bzi, tmp);
}
}
}
}
gretl_matrix_free(y);
gretl_matrix_free(c);
/* we're finished with the per-term laglists now */
for (i=0; i<nmidas; i++) {
if (!minfo[i].prelag) {
free(minfo[i].laglist);
}
minfo[i].laglist = NULL;
}
#if MIDAS_DEBUG
fprintf(stderr, "add_midas_matrices: returning %d\n", err);
#endif
*pslopes = hfslopes;
return err;
}
gretl_matrix *irf_bootstrap (GRETL_VAR *var,
int targ, int shock,
int periods, double alpha,
const DATASET *dset,
int *err)
{
gretl_matrix *R = NULL; /* the return value */
GRETL_VAR *vbak = NULL;
irfboot *boot = NULL;
int scount = 0;
int iter;
if (var->X == NULL || var->Y == NULL) {
gretl_errmsg_set("X and/or Y matrix missing, can't do this");
*err = E_DATA;
return NULL;
}
#if BDEBUG
fprintf(stderr, "\n*** irf_bootstrap() called\n");
#endif
R = gretl_zero_matrix_new(periods, 3);
if (R == NULL) {
*err = E_ALLOC;
return NULL;
}
vbak = back_up_VAR(var);
if (vbak == NULL) {
*err = E_ALLOC;
gretl_matrix_free(R);
return NULL;
}
boot = irf_boot_new(var, periods);
if (boot == NULL) {
*err = E_ALLOC;
goto bailout;
}
if (var->ci == VECM) {
boot->C0 = VAR_coeff_matrix_from_VECM(var);
if (boot->C0 == NULL) {
*err = E_ALLOC;
} else {
*err = init_VECM_dataset(boot, var, dset);
}
}
for (iter=0; iter<BOOT_ITERS && !*err; iter++) {
#if BDEBUG
fprintf(stderr, "starting iteration %d\n", iter);
#endif
irf_resample_resids(boot, vbak);
if (var->ci == VECM) {
compute_VECM_dataset(boot, var, iter);
*err = re_estimate_VECM(boot, var, targ, shock, iter, scount);
} else {
compute_VAR_dataset(boot, var, vbak);
*err = re_estimate_VAR(boot, var, targ, shock, iter);
}
if (*err && !VAR_FATAL(*err, iter, scount)) {
/* excessive collinearity: try again, unless this is becoming a habit */
scount++;
iter--;
*err = 0;
}
}
if (*err && scount == MAXSING) {
gretl_errmsg_set("Excessive collinearity in resampled datasets");
}
if (!*err) {
*err = irf_boot_quantiles(boot, R, alpha);
}
irf_boot_free(boot);
bailout:
restore_VAR_data(var, vbak);
if (*err) {
gretl_matrix_free(R);
R = NULL;
}
return R;
}
