Logo Search packages:      
Sourcecode: gretl version File versions  Download package

libglue.c

/* 
 *  gretl -- Gnu Regression, Econometrics and Time-series Library
 *  Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
 * 
 *  This program is free software: you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation, either version 3 of the License, or
 *  (at your option) any later version.
 * 
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 * 
 *  You should have received a copy of the GNU General Public License
 *  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 * 
 */

/* Miscellaneous functions to bridge between gretl commands and
   the corresponding libgretl functions. This glue allows a cleaner
   interface for the latter, hiding some parsing of strings
   coming from the command line.
*/

#include "libgretl.h"
#include "var.h"
#include "system.h"
#include "gretl_panel.h"
#include "usermat.h"
#include "gretl_scalar.h"
#include "gretl_string_table.h"
#include "libglue.h"

/*
 * model_test_driver:
 * @param: auxiliary parameter for some uses.
 * @dset: dataset struct.
 * @opt: controls which test(s) will be performed; %OPT_Q
 * gives less verbose results.
 * @prn: gretl printing struct.
 * 
 * Performs some subset of gretl's "modtest" tests on the
 * model last estimated, and prints the results to @prn.
 * 
 * Returns: 0 on successful completion, error code on error.
 */

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;
}

static int get_chow_dummy (const char *s, const DATASET *dset, 
                     int *err)
{
    int v = current_series_index(dset, s);

    if (v < 0) {
      *err = E_UNKVAR;
    } else if (!gretl_isdummy(dset->t1, dset->t2, dset->Z[v])) {
      *err = E_DATA;
    }

    return v;
}

/*
 * chow_test_driver:
 * @line: command line for parsing.
 * @pmod: pointer to model to be tested.
 * @dset: dataset struct.
 * @opt: if flags include OPT_S, save test results to model;
 * if OPT_D included, do the Chow test based on a given dummy
 * variable.
 * @prn: gretl printing struct.
 *
 * Returns: 0 on successful completion, error code on error.
 */

int chow_test_driver (const char *line, MODEL *pmod, DATASET *dset, 
                  gretlopt opt, PRN *prn)
{
    char chowstr[VNAMELEN];
    int chowparm = 0;
    int err = 0;

    /* chowstr should hold either an observation at which to
       split the sample, or the name of a dummy variable
       to be used to divide the sample (if given OPT_D)
    */

    if (sscanf(line, "%*s %15s", chowstr) != 1) {
      err = E_PARSE;
    } else if (opt & OPT_D) {
      chowparm = get_chow_dummy(chowstr, dset, &err);
    } else {
      chowparm = dateton(chowstr, dset);
    }

    if (!err) {
      if (opt & OPT_D) {
          err = chow_test_from_dummy(chowparm, pmod, dset, opt, prn);
      } else {
          err = chow_test(chowparm, pmod, dset, opt, prn);
      }
    }

    return err;
}

/* The @parm here may contain a scalar or a matrix: in either case,
   convert to a list of lag-orders before handing off to the real
   Levin-Lin-Chu code.
*/

int llc_test_driver (const char *parm, const int *list, 
                 DATASET *dset, gretlopt opt, PRN *prn)
{
    gretl_matrix *m = NULL;
    int *plist = NULL;
    int p0 = -1;
    int err = 0;

    if (*parm == '{') {
      m = generate_matrix(parm, dset, &err);
      if (!err) {
          plist = gretl_list_from_vector(m, &err);
      }
      gretl_matrix_free(m);
    } else if (gretl_is_matrix(parm)) {
      m = get_matrix_by_name(parm);
      plist = gretl_list_from_vector(m, &err);
    } else if (integer_string(parm)) {
      p0 = atoi(parm);
    } else if (gretl_is_scalar(parm)) {
      p0 = gretl_scalar_get_value(parm);
    } else {
      err = E_DATA;
    }

    if (!err) {
      if (plist != NULL) {
          err = levin_lin_test(list[1], plist, dset, opt, prn);
          free(plist);
      } else {
          int tmplist[2] = {1, p0};

          err = levin_lin_test(list[1], tmplist, dset, opt, prn);
      }
    }

    return err;
}

/* parse the tau vector out of @parm before calling the
   "real" quantreg function
*/

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);
      mod.errcode = err;
    } else {
      mod = quantreg(tau, list, dset, opt, prn);
    }

    gretl_matrix_free(tau);

    return mod;
}

/* wrapper for the various sorts of logit and probit models
   that gretl supports
*/

MODEL logit_probit (int *list, DATASET *dset, int ci, 
                gretlopt opt, PRN *prn)
{
    int yv = list[1];

    if (ci == LOGIT && (opt & OPT_M)) {
      return multinomial_logit(list, dset, opt, prn);
    } else if (gretl_isdummy(dset->t1, dset->t2, dset->Z[yv])) {
      if (ci == LOGIT) {
          return binary_logit(list, dset, opt, prn);
      } else {
          return binary_probit(list, dset, opt, prn);
      }
    } else {
      if (ci == LOGIT) {
          return ordered_logit(list, dset, opt, prn);
      } else {
          return ordered_probit(list, dset, opt, prn);
      }
    } 
}

/* parse out optional "ymax=..." parameter before calling the real
   logistic model function 
*/

MODEL logistic_driver (const int *list, DATASET *dset,
                   const char *param) 
{
    double lmax;

    if (param == NULL || sscanf(param, "ymax=%lf", &lmax) != 1) {
      lmax = NADBL;
    }

    return logistic_model(list, lmax, dset);
}

/* assemble the left and right limits for tobit using gretl's
   option apparatus before calling the real tobit function
*/

MODEL tobit_driver (const int *list, DATASET *dset, 
                gretlopt opt, PRN *prn)
{
    MODEL model;
    double llim = -1.0e300;
    double rlim = NADBL;
    int err = 0;

    if (opt & OPT_L) {
      /* we should have an explicit lower limit */
      llim = get_optval_double(TOBIT, OPT_L);
      if (na(llim)) {
          err = E_BADOPT;
      } 
    }

    if (!err && (opt & OPT_M)) {
      /* we should have an explicit upper limit */
      rlim = get_optval_double(TOBIT, OPT_M);
      if (na(rlim) || rlim <= llim) {
          err = E_BADOPT; 
      }     
    }

    if (err) {
      gretl_model_init(&model);
      model.errcode = err;
      return model;
    }

    if (!(opt & (OPT_L | OPT_M))) {
      /* the default: left-censoring at zero */
      llim = 0;
    }

    return tobit_model(list, llim, rlim, dset, opt, prn);
}

/*
 * do_modprint:
 * @line: command line.
 * @opt: may contain %OPT_C for CSV, %OPT_R for RTF, or %OPT_T 
 * to use TeX format.  If %OPT_T is given, then %OPT_O calls for
 * a complete LaTeX document, otherwise %OPT_O is ignored.
 * @prn: gretl printer.
 *
 * Prints to @prn the coefficient table and optional additional statistics
 * for a model estimated "by hand". Mainly useful for user-written functions.
 * 
 * The string @line must contain, in order: (1) the name of a k x 2 matrix
 * containing k coefficients and k associated standard errors and (2) the
 * name of a string variable containing at least k comma- or space-
 * separated names for the coefficients (or a string literal on that 
 * pattern). 
 *
 * Optionally, @line may contain a third element, the name of a vector 
 * containing p additional statistics.  In that case element (2) should 
 * contain k + p names, the additional p names to be associated with the 
 * additional statistics. 
 *
 * Returns: 0 on success, non-zero on failure.
 */

int do_modprint (const char *line, gretlopt opt, PRN *prn)
{
    gretl_matrix *coef_se = NULL;
    gretl_matrix *addstats = NULL;
    char *parnames = NULL;
    char *litstr = NULL;
    const char *s;
    char name[VNAMELEN];
    int err = 0;

    err = incompatible_options(opt, OPT_C | OPT_R | OPT_T);
    if (err) {
      return err;
    }

    /* skip the command word, if present */
    s = line;
    s += strspn(s, " ");
    if (!strncmp(s, "modprint ", 9)) {
      s += 9;
    }

    /* first up, name of k x 2 matrix */
    if (sscanf(s, "%15s", name) == 1) {
      coef_se = get_matrix_by_name(name);
      if (coef_se == NULL) {
          err = E_UNKVAR;
      } else if (gretl_matrix_cols(coef_se) != 2) {
          gretl_errmsg_set(_("modprint: the first matrix argument must have 2 columns"));
          err = E_DATA;
      }
    } else {
      err = E_PARSE;
    }

    if (!err) {
      /* second up, string containing names */
      s += strspn(s, " ");
      s += strlen(name);
      s += strspn(s, " ");
      if (*s == '"') {
          /* got a string literal */
          litstr = gretl_quoted_string_strdup(s, &s);
          if (litstr == NULL) {
            err = E_PARSE;
          } else {
            parnames = litstr;
            s += strspn(s, " ");
          }
      } else if (sscanf(s, "%15s", name) == 1) {
          parnames = get_string_by_name(name);
          if (parnames == NULL) {
            err = E_UNKVAR;
          } else {
            /* advance past string name */
            s += strspn(s, " ");
            s += strlen(name);
            s += strspn(s, " ");
          }
      } else {
          err = E_PARSE;
      }
    }

    if (!err) {
      /* optional third field: extra matrix */
      if (*s != '\0') {
          sscanf(s, "%15s", name);
          addstats = get_matrix_by_name(name);
          if (addstats == NULL) {
            err = E_UNKVAR;
          }     
      }
    }

    if (!err) {
      if (opt & OPT_C) {
          gretl_print_set_format(prn, GRETL_FORMAT_CSV);
      } else if (opt & OPT_R) {
          gretl_print_set_format(prn, GRETL_FORMAT_RTF);
      } else if (opt & OPT_T) {
          if (opt & OPT_O) {
            gretl_print_set_format(prn, GRETL_FORMAT_TEX | GRETL_FORMAT_DOC);
          } else {
            gretl_print_set_format(prn, GRETL_FORMAT_TEX);
          }
      }
      err = print_model_from_matrices(coef_se, addstats, parnames, prn);
    }

    free(litstr);

    return err;
}

int script_add_obs_markers (DATASET *dset)
{
    const char *fname = get_optval_string(SETOBS, OPT_M);
    int err;

    if (fname == NULL) {
      err = E_PARSE;
    } else {
      fname = gretl_maybe_switch_dir(fname);
      err = add_obs_markers_from_file(dset, fname);
    }

    return err;
}

Generated by  Doxygen 1.6.0   Back to index