static int qr_make_cluster_vcv (MODEL *pmod, int ci,
const DATASET *dset,
gretl_matrix *XX,
gretlopt opt)
{
gretl_matrix *cvals = NULL;
gretl_matrix *V = NULL;
const char *cname;
int cvar, n_c = 0;
int err = 0;
if (pmod->ci != OLS && pmod->ci != IVREG) {
/* relax this? */
return E_NOTIMP;
}
cname = get_optval_string(ci, OPT_C);
if (cname == NULL) {
return E_PARSE;
}
cvar = current_series_index(dset, cname);
if (cvar < 1 || cvar >= dset->v) {
err = E_UNKVAR;
}
if (!err) {
cvals = cluster_var_values(dset->Z[cvar], pmod, &err);
if (!err) {
n_c = gretl_vector_get_length(cvals);
if (n_c < 2) {
err = E_DATA;
}
}
}
#if CDEBUG
fprintf(stderr, "qr_make_cluster_vcv: err = %d\n", err);
fprintf(stderr, "cluster var = %s (%d)\n", cname, cvar);
gretl_matrix_print(cvals, "cvals");
#endif
if (!err) {
V = cluster_vcv_calc(pmod, cvar, cvals, XX, dset, &err);
}
if (!err) {
err = gretl_model_write_vcv(pmod, V);
}
if (!err) {
gretl_model_set_vcv_info(pmod, VCV_CLUSTER, cvar);
gretl_model_set_int(pmod, "n_clusters", n_c);
}
gretl_matrix_free(V);
gretl_matrix_free(cvals);
return err;
}
static int cval_count_max (MODEL *pmod, const gretl_matrix *cvals,
const double *cZ)
{
int n = gretl_vector_get_length(cvals);
int i, cc, cmax = 0;
for (i=0; i<n; i++) {
cc = cval_count(pmod, cvals->val[i], cZ);
if (cc > cmax) {
cmax = cc;
}
}
return cmax;
}
MODEL quantreg_driver (const char *parm, const int *list,
DATASET *dset, gretlopt opt, PRN *prn)
{
gretl_vector *tau;
MODEL mod;
int err = 0;
tau = generate_matrix(parm, dset, &err);
if (!err && gretl_vector_get_length(tau) == 0) {
err = E_DATA;
}
if (err) {
gretl_model_init(&mod, dset);
mod.errcode = err;
} else {
mod = quantreg(tau, list, dset, opt, prn);
}
gretl_matrix_free(tau);
return mod;
}
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 parse_midas_info (const char *s,
midas_info *minfo, int i,
const DATASET *dset)
{
midas_info *m = &minfo[i];
char lname[VNAMELEN];
char mname[VNAMELEN];
char fmt[48];
int n, m1, m2, p;
int umidas = 0;
int err = 0;
midas_info_init(m);
if (!strncmp(s, "mds(", 4)) {
/* calling for auto-generated lags */
s += 4;
sprintf(fmt, "%%%d[^, ] , %%d , %%d , %%d, %%%d[^) ])",
VNAMELEN-1, VNAMELEN-1);
n = sscanf(s, fmt, lname, &m1, &m2, &p, mname);
if (n == 4 && p == MIDAS_U) {
umidas = 1;
} else if (n != 5) {
err = E_PARSE;
}
} else if (!strncmp(s, "mdsl(", 5)) {
/* list already hold lags */
m->prelag = 1;
s += 5;
sprintf(fmt, "%%%d[^, ] , %%d, %%%d[^) ])",
VNAMELEN-1, VNAMELEN-1);
n = sscanf(s, fmt, lname, &p, mname);
if (n == 2 && p == MIDAS_U) {
umidas = 1;
} else if (n != 3) {
err = E_PARSE;
}
m1 = m2 = 0; /* got no min/max info */
} else {
err = E_INVARG;
}
if (!err) {
gretl_matrix *theta = NULL;
int *list = get_list_by_name(lname);
int k = 0;
if (!umidas) {
theta = get_matrix_by_name(mname);
if (theta == NULL) {
theta = maybe_make_auto_theta(mname, i, p, m1, m2);
}
}
if (m->prelag && list == NULL) {
err = E_INVARG;
} else if (!m->prelag && !gretl_is_midas_list(list, dset)) {
gretl_errmsg_set("mds(): the first term must be a MIDAS list");
err = E_INVARG;
} else if (m1 > m2) {
err = E_INVARG;
} else if (p < 0 || p >= MIDAS_MAX) {
err = E_INVARG;
} else if (umidas) {
if (m->prelag) {
k = list[0];
} else {
k = m2 - m1 + 1;
}
} else {
k = gretl_vector_get_length(theta);
if (k < 1 || (p == MIDAS_BETA0 && k != 2) ||
(p == MIDAS_BETAN && k != 3)) {
err = E_INVARG;
}
}
if (!err) {
strcpy(m->lnam0, lname);
strcpy(m->lname, lname);
if (!umidas) {
strcpy(m->mname, mname);
}
if (m->prelag) {
/* scrounge lag info from incoming list */
lag_info_from_prelag_list(m, list, dset);
} else {
m->minlag = m1;
m->maxlag = m2;
}
m->type = p;
m->nparm = k;
}
}
return err;
}
