gretl_bundle *bundle_from_model (MODEL *pmod,
DATASET *dset,
int *err)
{
gretl_bundle *b = NULL;
gretl_matrix *m;
double *x;
double val;
int *list;
const char *s;
const char *key;
int i, t, berr;
if (pmod == NULL) {
/* get the "last model" */
GretlObjType type = 0;
void *p = get_last_model(&type);
if (p == NULL || type != GRETL_OBJ_EQN) {
*err = E_DATA;
return NULL;
} else {
pmod = p;
}
}
x = malloc(dset->n * sizeof *x);
if (x == NULL) {
*err = E_ALLOC;
return NULL;
}
b = gretl_bundle_new();
if (b == NULL) {
free(x);
*err = E_ALLOC;
return NULL;
}
for (i=M_ESS; i<M_SCALAR_MAX && !*err; i++) {
berr = 0;
val = gretl_model_get_scalar(pmod, i, dset, &berr);
if (!berr) {
key = mvarname(i) + 1;
*err = gretl_bundle_set_scalar(b, key, val);
}
}
for (i=M_SCALAR_MAX+1; i<M_SERIES_MAX && !*err; i++) {
for (t=0; t<dset->n; t++) {
x[t] = NADBL;
}
berr = gretl_model_get_series(x, pmod, dset, i);
if (!berr) {
key = mvarname(i) + 1;
*err = gretl_bundle_set_series(b, key, x, dset->n);
}
}
for (i=M_SERIES_MAX+1; i<M_MATRIX_MAX && !*err; i++) {
berr = 0;
m = gretl_model_get_matrix(pmod, i, &berr);
if (!berr) {
key = mvarname(i) + 1;
*err = gretl_bundle_donate_data(b, key, m,
GRETL_TYPE_MATRIX,
0);
}
}
for (i=M_MBUILD_MAX+1; i<M_LIST_MAX && !*err; i++) {
list = NULL;
if (i == M_XLIST) {
list = gretl_model_get_x_list(pmod);
} else if (i == M_YLIST) {
list = gretl_model_get_y_list(pmod);
}
if (list != NULL) {
/* convert list to matrix for bundling */
m = matrix_from_list(list);
if (m != NULL) {
key = mvarname(i) + 1;
*err = gretl_bundle_donate_data(b, key, m,
GRETL_TYPE_MATRIX,
0);
}
free(list);
}
}
for (i=M_LIST_MAX+1; i<M_STR_MAX && !*err; i++) {
s = NULL;
if (i == M_DEPVAR) {
s = gretl_model_get_depvar_name(pmod, dset);
} else if (i == M_COMMAND) {
s = gretl_command_word(pmod->ci);
}
if (s != NULL && *s != '\0') {
key = mvarname(i) + 1;
*err = gretl_bundle_set_string(b, key, s);
}
}
free(x);
/* don't return a broken bundle */
if (*err && b != NULL) {
gretl_bundle_destroy(b);
b = NULL;
}
return b;
}
int model_test_driver (const char *param, DATASET *dset,
gretlopt opt, PRN *prn)
{
GretlObjType type;
gretlopt testopt;
void *ptr;
int k = 0;
int err = 0;
if (opt == OPT_NONE || opt == OPT_Q) {
pprintf(prn, "modtest: no options selected\n");
return 0;
}
err = incompatible_options(opt, OPT_A | OPT_H | OPT_L | OPT_S |
OPT_N | OPT_P | OPT_W | OPT_X);
if (err) {
return err;
}
ptr = get_last_model(&type);
if (ptr == NULL) {
return E_DATA;
}
if (type == GRETL_OBJ_EQN && exact_fit_check(ptr, prn)) {
return 0;
}
if (opt & (OPT_A | OPT_H)) {
/* autocorrelation and arch: lag order */
k = atoi(param);
if (k == 0) {
k = dset->pd;
}
}
testopt = (opt & OPT_Q)? OPT_Q : OPT_NONE;
/* non-linearity (squares) */
if (!err && (opt & OPT_S)) {
if (type == GRETL_OBJ_EQN) {
err = nonlinearity_test(ptr, dset, AUX_SQ,
testopt, prn);
} else {
err = E_NOTIMP;
}
}
/* non-linearity (logs) */
if (!err && (opt & OPT_L)) {
if (type == GRETL_OBJ_EQN) {
err = nonlinearity_test(ptr, dset, AUX_LOG,
testopt, prn);
} else {
err = E_NOTIMP;
}
}
/* heteroskedasticity (White or Breusch-Pagan) */
if (!err && (opt & (OPT_W | OPT_X | OPT_B))) {
if (type == GRETL_OBJ_EQN) {
transcribe_option_flags(&testopt, opt, OPT_B | OPT_X);
if ((opt & OPT_B) && (opt & OPT_R)) {
testopt |= OPT_R;
}
err = whites_test(ptr, dset, testopt, prn);
} else {
err = E_NOTIMP;
}
}
/* autocorrelation */
if (!err && (opt & OPT_A)) {
if (type == GRETL_OBJ_EQN) {
err = autocorr_test(ptr, k, dset, testopt, prn);
} else if (type == GRETL_OBJ_VAR) {
err = gretl_VAR_autocorrelation_test(ptr, k, dset,
testopt, prn);
} else if (type == GRETL_OBJ_SYS) {
err = system_autocorrelation_test(ptr, k, testopt, prn);
} else {
err = E_NOTIMP;
}
}
/* ARCH */
if (!err && (opt & OPT_H)) {
if (type == GRETL_OBJ_EQN) {
err = arch_test(ptr, k, dset, testopt, prn);
} else if (type == GRETL_OBJ_VAR) {
err = gretl_VAR_arch_test(ptr, k, dset,
testopt, prn);
} else if (type == GRETL_OBJ_SYS) {
err = system_arch_test(ptr, k, testopt, prn);
} else {
err = E_NOTIMP;
}
}
/* normality of residual */
if (!err && (opt & OPT_N)) {
err = last_model_test_uhat(dset, testopt, prn);
}
/* groupwise heteroskedasticity */
if (!err && (opt & OPT_P)) {
if (type == GRETL_OBJ_EQN) {
err = groupwise_hetero_test(ptr, dset, testopt, prn);
} else {
err = E_NOTIMP;
}
}
/* common factor restriction */
if (!err && (opt & OPT_C)) {
if (type == GRETL_OBJ_EQN) {
err = comfac_test(ptr, dset, testopt, prn);
} else {
err = E_NOTIMP;
}
}
return err;
}
