1 /*
2 * gretl -- Gnu Regression, Econometrics and Time-series Library
3 * Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
4 *
5 * This program is free software: you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 *
18 */
19
20 /* Miscellaneous functions to bridge between gretl commands and
21 the corresponding libgretl functions. This glue allows a cleaner
22 interface for the latter, hiding some parsing of strings
23 coming from the command line.
24 */
25
26 #include "libgretl.h"
27 #include "var.h"
28 #include "system.h"
29 #include "gretl_panel.h"
30 #include "usermat.h"
31 #include "uservar.h"
32 #include "matrix_extra.h"
33 #include "boxplots.h"
34 #include "libglue.h"
35
36 /*
37 * model_test_driver:
38 * @order: lag order for --autocorr and --arch.
39 * @dset: dataset struct.
40 * @opt: controls which test(s) will be performed; OPT_Q
41 * gives less verbose results, OPT_I gives silent operation.
42 * @prn: gretl printing struct.
43 *
44 * Performs some subset of gretl's "modtest" tests on the
45 * model last estimated, and prints the results to @prn.
46 *
47 * Returns: 0 on successful completion, error code on error.
48 */
49
model_test_driver(int order,DATASET * dset,gretlopt opt,PRN * prn)50 int model_test_driver (int order, DATASET *dset,
51 gretlopt opt, PRN *prn)
52 {
53 GretlObjType type;
54 gretlopt testopt = OPT_NONE;
55 void *ptr;
56 int k = 0;
57 int err = 0;
58
59 if (opt == OPT_NONE || opt == OPT_Q || opt == OPT_I) {
60 /* note: OPT_Q and OPT_I are just quiet and silent respectively */
61 pprintf(prn, "modtest: no options selected\n");
62 return 0;
63 }
64
65 err = incompatible_options(opt, OPT_A | OPT_H | OPT_L | OPT_S |
66 OPT_N | OPT_P | OPT_W | OPT_X | OPT_D);
67 if (err) {
68 return err;
69 }
70
71 ptr = get_last_model(&type);
72 if (ptr == NULL) {
73 return E_DATA;
74 }
75
76 if (type == GRETL_OBJ_EQN && exact_fit_check(ptr, prn)) {
77 return 0;
78 }
79
80 if (opt & (OPT_A | OPT_H)) {
81 /* autocorrelation and arch: lag order */
82 k = order > 0 ? order : dset->pd;
83 }
84
85 /* transcribe the quietness flags */
86 if (opt & OPT_I) {
87 testopt = OPT_I | OPT_Q;
88 } else if (opt & OPT_Q) {
89 testopt = OPT_Q;
90 }
91
92 /* non-linearity (squares) */
93 if (!err && (opt & OPT_S)) {
94 if (type == GRETL_OBJ_EQN) {
95 err = nonlinearity_test(ptr, dset, AUX_SQ,
96 testopt, prn);
97 } else {
98 err = E_NOTIMP;
99 }
100 return err;
101 }
102
103 /* non-linearity (logs) */
104 if (!err && (opt & OPT_L)) {
105 if (type == GRETL_OBJ_EQN) {
106 err = nonlinearity_test(ptr, dset, AUX_LOG,
107 testopt, prn);
108 } else {
109 err = E_NOTIMP;
110 }
111 return err;
112 }
113
114 /* heteroskedasticity (White or Breusch-Pagan) */
115 if (!err && (opt & (OPT_W | OPT_X | OPT_B))) {
116 if (type == GRETL_OBJ_EQN) {
117 transcribe_option_flags(&testopt, opt, OPT_B | OPT_X);
118 if ((opt & OPT_B) && (opt & OPT_R)) {
119 testopt |= OPT_R;
120 }
121 err = whites_test(ptr, dset, testopt, prn);
122 } else {
123 err = E_NOTIMP;
124 }
125 return err;
126 }
127
128 /* autocorrelation */
129 if (!err && (opt & OPT_A)) {
130 if (type == GRETL_OBJ_EQN) {
131 err = autocorr_test(ptr, k, dset, testopt, prn);
132 } else if (type == GRETL_OBJ_VAR) {
133 if (opt & OPT_U) {
134 /* --univariate */
135 testopt |= OPT_U;
136 }
137 err = gretl_VAR_autocorrelation_test(ptr, k, dset,
138 testopt, prn);
139 } else if (type == GRETL_OBJ_SYS) {
140 err = system_autocorrelation_test(ptr, k, testopt, prn);
141 } else {
142 err = E_NOTIMP;
143 }
144 return err;
145 }
146
147 /* ARCH */
148 if (!err && (opt & OPT_H)) {
149 if (type == GRETL_OBJ_EQN) {
150 err = arch_test(ptr, k, dset, testopt, prn);
151 } else if (type == GRETL_OBJ_VAR) {
152 if (opt & OPT_U) {
153 /* --univariate */
154 testopt |= OPT_U;
155 }
156 err = gretl_VAR_arch_test(ptr, k, dset,
157 testopt, prn);
158 } else if (type == GRETL_OBJ_SYS) {
159 err = system_arch_test(ptr, k, testopt, prn);
160 } else {
161 err = E_NOTIMP;
162 }
163 return err;
164 }
165
166 /* normality of residual */
167 if (!err && (opt & OPT_N)) {
168 return last_model_test_uhat(dset, testopt, prn);
169 }
170
171 /* groupwise heteroskedasticity */
172 if (!err && (opt & OPT_P)) {
173 if (type == GRETL_OBJ_EQN) {
174 err = groupwise_hetero_test(ptr, dset, testopt, prn);
175 } else {
176 err = E_NOTIMP;
177 }
178 return err;
179 }
180
181 /* common factor restriction */
182 if (!err && (opt & OPT_C)) {
183 if (type == GRETL_OBJ_EQN) {
184 err = comfac_test(ptr, dset, testopt, prn);
185 } else {
186 err = E_NOTIMP;
187 }
188 return err;
189 }
190
191 /* cross-sectional dependence */
192 if (!err && (opt & OPT_D)) {
193 if (type == GRETL_OBJ_EQN) {
194 err = panel_xdepend_test(ptr, dset, testopt, prn);
195 } else {
196 err = E_NOTIMP;
197 }
198 return err;
199 }
200
201 return err;
202 }
203
get_chow_dummy(const char * s,const DATASET * dset,int * err)204 static int get_chow_dummy (const char *s, const DATASET *dset,
205 int *err)
206 {
207 int v = current_series_index(dset, s);
208
209 if (v < 0) {
210 *err = E_UNKVAR;
211 } else if (!gretl_isdummy(dset->t1, dset->t2, dset->Z[v])) {
212 *err = E_DATA;
213 }
214
215 return v;
216 }
217
218 /*
219 * chow_test_driver:
220 * @param: parameter (observation or name of dummy)
221 * @pmod: pointer to model to be tested.
222 * @dset: dataset struct.
223 * @opt: if flags include OPT_S, save test results to model;
224 * if OPT_D included, do the Chow test based on a given dummy
225 * variable.
226 * @prn: gretl printing struct.
227 *
228 * Returns: 0 on successful completion, error code on error.
229 */
230
chow_test_driver(const char * param,MODEL * pmod,DATASET * dset,gretlopt opt,PRN * prn)231 int chow_test_driver (const char *param, MODEL *pmod, DATASET *dset,
232 gretlopt opt, PRN *prn)
233 {
234 int chowparm = 0;
235 int err = 0;
236
237 if (param == NULL || *param == '\0') {
238 return E_DATA;
239 }
240
241 if (opt & OPT_D) {
242 chowparm = get_chow_dummy(param, dset, &err);
243 } else {
244 chowparm = dateton(param, dset);
245 }
246
247 if (!err) {
248 if (opt & OPT_D) {
249 err = chow_test_from_dummy(chowparm, pmod, dset, opt, prn);
250 } else {
251 err = chow_test(chowparm, pmod, dset, opt, prn);
252 }
253 }
254
255 return err;
256 }
257
258 /* The @param here may contain a scalar or a matrix: in either case,
259 convert to a list of lag-orders before handing off to the real
260 Levin-Lin-Chu code.
261 */
262
llc_test_driver(const char * param,const int * list,DATASET * dset,gretlopt opt,PRN * prn)263 int llc_test_driver (const char *param, const int *list,
264 DATASET *dset, gretlopt opt, PRN *prn)
265 {
266 gretl_matrix *m = NULL;
267 int *plist = NULL;
268 int p0 = -1;
269 int err = 0;
270
271 if (param == NULL) {
272 err = E_DATA;
273 } else if (*param == '{') {
274 m = generate_matrix(param, dset, &err);
275 if (!err) {
276 plist = gretl_auxlist_from_vector(m, &err);
277 }
278 gretl_matrix_free(m);
279 } else if (get_matrix_by_name(param)) {
280 m = get_matrix_by_name(param);
281 plist = gretl_auxlist_from_vector(m, &err);
282 } else if (integer_string(param)) {
283 p0 = atoi(param);
284 } else if (gretl_is_scalar(param)) {
285 p0 = gretl_scalar_get_value(param, NULL);
286 } else {
287 err = E_DATA;
288 }
289
290 if (!err) {
291 if (plist != NULL) {
292 err = levin_lin_test(list[1], plist, dset, opt, prn);
293 free(plist);
294 } else {
295 int tmplist[2] = {1, p0};
296
297 err = levin_lin_test(list[1], tmplist, dset, opt, prn);
298 }
299 }
300
301 return err;
302 }
303
bds_print(const gretl_matrix * m,const char * vname,int order,double eps,int c1,int boot,double * detail,PRN * prn)304 static void bds_print (const gretl_matrix *m,
305 const char *vname,
306 int order, double eps,
307 int c1, int boot,
308 double *detail, PRN *prn)
309 {
310 double z, pv;
311 int i;
312
313 /* header */
314 pputc(prn, '\n');
315 pprintf(prn, _("BDS test for %s, maximum order %d"), vname, order);
316 pputc(prn, '\n');
317 pputs(prn, _("H0: the series is linear/IID"));
318 pputc(prn, '\n');
319 if (boot > 0) {
320 pputs(prn, _("Bootstrapped p-values in []"));
321 } else {
322 pputs(prn, _("Asymptotic p-values in []"));
323 }
324 pputs(prn, "\n\n");
325
326 /* test statistics */
327 for (i=0; i<order-1; i++) {
328 z = gretl_matrix_get(m, 0, i);
329 pv = gretl_matrix_get(m, 1, i);
330 pputs(prn, " ");
331 pprintf(prn, _("test order %d: z = %.3f [%.3f]"), i+2, z, pv);
332 pputc(prn, '\n');
333 }
334 pputc(prn, '\n');
335
336 /* trailer */
337 if (c1) {
338 pputs(prn, _("Distance criterion based on first-order correlation"));
339 } else {
340 pprintf(prn, _("Distance criterion based on sd(%s)"), vname);
341 }
342 pputc(prn, '\n');
343 pprintf(prn, _("eps = %g, first-order correlation %.3f"),
344 detail[0], detail[1]);
345 pputs(prn, "\n\n");
346 }
347
get_vector_x(const double ** px,int * n,const char ** pvname)348 static int get_vector_x (const double **px, int *n,
349 const char **pvname)
350 {
351 const char *mname = get_optval_string(BDS, OPT_X);
352 int err = 0;
353
354 if (mname != NULL) {
355 gretl_matrix *m = get_matrix_by_name(mname);
356
357 if (gretl_is_null_matrix(m)) {
358 err = E_INVARG;
359 } else {
360 *n = gretl_vector_get_length(m);
361 if (*n == 0) {
362 err = E_INVARG;
363 } else {
364 *px = m->val;
365 *pvname = mname;
366 }
367 }
368 } else {
369 err = E_INVARG;
370 }
371
372 return err;
373 }
374
bds_test_driver(int order,int * list,DATASET * dset,gretlopt opt,PRN * prn)375 int bds_test_driver (int order, int *list, DATASET *dset,
376 gretlopt opt, PRN *prn)
377 {
378 gretl_matrix *res = NULL;
379 const double *x = NULL;
380 const char *vname = NULL;
381 double detail[2] = {0};
382 double eps = -0.7;
383 int t1 = dset->t1;
384 int t2 = dset->t2;
385 int boot = -1;
386 int c1 = 1;
387 int n, v = 0;
388 int err = 0;
389
390 if (list == NULL) {
391 err = get_vector_x(&x, &n, &vname);
392 if (err) {
393 return err;
394 }
395 } else {
396 v = list[1];
397 x = dset->Z[v];
398 vname = dset->varname[v];
399 }
400
401 if (order < 2) {
402 err = E_INVARG;
403 } else {
404 err = series_adjust_sample(x, &t1, &t2);
405 }
406
407 if (!err) {
408 err = incompatible_options(opt, OPT_S | OPT_C);
409 }
410
411 if (!err) {
412 if (opt & OPT_S) {
413 /* eps as multiple of std dev of @x */
414 eps = get_optval_double(BDS, OPT_S, &err);
415 if (!err && eps <= 0) {
416 err = E_INVARG;
417 }
418 c1 = 0;
419 } else if (opt & OPT_C) {
420 /* eps as target first-order correlation */
421 eps = get_optval_double(BDS, OPT_C, &err);
422 if (!err && (eps < 0.1 || eps > 0.9)) {
423 err = E_INVARG;
424 }
425 c1 = 1;
426 }
427 }
428
429 if (!err && (opt & OPT_B)) {
430 boot = get_optval_int(BDS, OPT_B, &err);
431 if (boot < 0) {
432 err = E_INVARG;
433 }
434 }
435
436 if (!err) {
437 gretl_matrix *(*bdstest) (const double *, int, int, double,
438 int, int, double *, int *);
439
440 bdstest = get_plugin_function("bdstest");
441 if (bdstest == NULL) {
442 err = E_FOPEN;
443 } else {
444 n = t2 - t1 + 1;
445 if (boot < 0) {
446 /* auto selection */
447 boot = n < 600;
448 }
449 res = bdstest(x + t1, n, order, eps, c1, boot, detail, &err);
450 }
451 }
452
453 if (res != NULL) {
454 if (!(opt & OPT_Q)) {
455 bds_print(res, vname, order, eps, c1, boot, detail, prn);
456 }
457 set_last_result_data(res, GRETL_TYPE_MATRIX);
458 }
459
460 return err;
461 }
462
463 /* parse the tau vector out of @param before calling the
464 "real" quantreg function
465 */
466
quantreg_driver(const char * param,const int * list,DATASET * dset,gretlopt opt,PRN * prn)467 MODEL quantreg_driver (const char *param, const int *list,
468 DATASET *dset, gretlopt opt, PRN *prn)
469 {
470 gretl_vector *tau;
471 MODEL mod;
472 int err = 0;
473
474 tau = generate_matrix(param, dset, &err);
475
476 if (!err && gretl_vector_get_length(tau) == 0) {
477 err = E_DATA;
478 }
479
480 if (err) {
481 gretl_model_init(&mod, dset);
482 mod.errcode = err;
483 } else {
484 mod = quantreg(tau, list, dset, opt, prn);
485 }
486
487 gretl_matrix_free(tau);
488
489 return mod;
490 }
491
492 /* wrapper for the various sorts of logit and probit models
493 that gretl supports
494 */
495
logit_probit(int * list,DATASET * dset,int ci,gretlopt opt,PRN * prn)496 MODEL logit_probit (int *list, DATASET *dset, int ci,
497 gretlopt opt, PRN *prn)
498 {
499 MODEL ret;
500 int yv = list[1];
501
502 if (ci == LOGIT && (opt & OPT_M)) {
503 ret = multinomial_logit(list, dset, opt, prn);
504 } else if (ci == PROBIT && (opt & OPT_E)) {
505 ret = reprobit_model(list, dset, opt, prn);
506 } else if (gretl_isdummy(dset->t1, dset->t2, dset->Z[yv])) {
507 if (ci == LOGIT) {
508 ret = binary_logit(list, dset, opt, prn);
509 } else {
510 ret = binary_probit(list, dset, opt, prn);
511 }
512 } else {
513 if (ci == LOGIT) {
514 ret = ordered_logit(list, dset, opt, prn);
515 } else {
516 ret = ordered_probit(list, dset, opt, prn);
517 }
518 }
519
520 return ret;
521 }
522
523 /* parse out optional "ymax=..." parameter before calling the real
524 logistic model function
525 */
526
logistic_driver(const int * list,DATASET * dset,gretlopt opt)527 MODEL logistic_driver (const int *list, DATASET *dset,
528 gretlopt opt)
529 {
530 double lmax = NADBL;
531
532 if (opt & OPT_M) {
533 int err = 0;
534
535 lmax = get_optval_double(LOGISTIC, OPT_M, &err);
536 if (err) {
537 MODEL mdl;
538
539 gretl_model_init(&mdl, dset);
540 mdl.errcode = err;
541 return mdl;
542 }
543 }
544
545 return logistic_model(list, lmax, dset, opt);
546 }
547
548 /* assemble the left and right limits for tobit using gretl's
549 option apparatus before calling the real tobit function
550 */
551
tobit_driver(const int * list,DATASET * dset,gretlopt opt,PRN * prn)552 MODEL tobit_driver (const int *list, DATASET *dset,
553 gretlopt opt, PRN *prn)
554 {
555 MODEL model;
556 double llim = -1.0e300;
557 double rlim = NADBL;
558 int err = 0;
559
560 if (opt & OPT_L) {
561 /* we should have an explicit lower limit */
562 llim = get_optval_double(TOBIT, OPT_L, &err);
563 if (!err && na(llim)) {
564 err = E_INVARG;
565 }
566 }
567
568 if (!err && (opt & OPT_M)) {
569 /* we should have an explicit upper limit */
570 rlim = get_optval_double(TOBIT, OPT_M, &err);
571 if (!err && (na(rlim) || rlim <= llim)) {
572 err = E_INVARG;
573 }
574 }
575
576 if (err) {
577 gretl_model_init(&model, dset);
578 model.errcode = err;
579 return model;
580 }
581
582 if (!(opt & (OPT_L | OPT_M))) {
583 /* the default: left-censoring at zero */
584 llim = 0;
585 }
586
587 return tobit_model(list, llim, rlim, dset, opt, prn);
588 }
589
strings_array_from_string(const char * s,int n,int * err)590 static gretl_array *strings_array_from_string (const char *s,
591 int n, int *err)
592 {
593 gretl_array *names = NULL;
594 const char *sep = ",";
595 char *tmp;
596 int i;
597
598 if (s == NULL) {
599 *err = E_DATA;
600 return NULL;
601 }
602
603 /* copy the incoming string @s before applying strtok */
604 tmp = gretl_strdup(s);
605 if (tmp == NULL) {
606 *err = E_ALLOC;
607 return NULL;
608 }
609
610 names = gretl_array_new(GRETL_TYPE_STRINGS, n, err);
611 if (*err) {
612 free(tmp);
613 return NULL;
614 }
615
616 if (strchr(s, ',') == NULL) {
617 sep = " ";
618 }
619
620 for (i=0; i<n && !*err; i++) {
621 char *name = strtok((i == 0)? tmp : NULL, sep);
622
623 if (name == NULL || *name == '\0') {
624 gretl_errmsg_sprintf(_("modprint: expected %d names"), n);
625 *err = E_DATA;
626 } else {
627 while (isspace(*name)) {
628 name++;
629 }
630 gretl_array_set_element(names, i, name,
631 GRETL_TYPE_STRING, 1);
632 }
633 }
634
635 free(tmp);
636
637 if (*err) {
638 gretl_array_destroy(names);
639 names = NULL;
640 }
641
642 return names;
643 }
644
645 /*
646 * do_modprint:
647 * @line: command line.
648 * @opt: may contain %OPT_O for specifying output, and if
649 * TeX output is called for then %OPT_C calls for
650 * a complete LaTeX document.
651 * @prn: gretl printer.
652 *
653 * Prints to @prn the coefficient table and optional additional statistics
654 * for a model estimated "by hand". Mainly useful for user-written functions.
655 *
656 * The string @line must contain, in order: (1) the name of a k x 2 matrix
657 * containing k coefficients and k associated standard errors and (2) the
658 * name of a string variable containing at least k comma- or space-
659 * separated names for the coefficients (or a string literal on that
660 * pattern).
661 *
662 * Optionally, @line may contain a third element, the name of a vector
663 * containing p additional statistics. In that case element (2) should
664 * contain k + p names, the additional p names to be associated with the
665 * additional statistics.
666 *
667 * Returns: 0 on success, non-zero on failure.
668 */
669
do_modprint(const char * mname,const char * names,gretlopt opt,PRN * prn)670 int do_modprint (const char *mname, const char *names,
671 gretlopt opt, PRN *prn)
672 {
673 gretl_matrix *coef_se = NULL;
674 gretl_matrix *addstats = NULL;
675 gretl_array *parnames = NULL;
676 const char *parstr = NULL;
677 const char **rnames = NULL;
678 int free_coef_se = 0;
679 int free_parnames = 0;
680 int nnames = 0;
681 int ncoef = 0;
682 int err = 0;
683
684 if (mname == NULL) {
685 return E_ARGS;
686 }
687
688 /* k x 2 matrix: coeffs and standard errors */
689 coef_se = get_matrix_by_name(mname);
690 if (coef_se == NULL) {
691 gretl_errmsg_set(_("modprint: expected the name of a matrix"));
692 return E_INVARG;
693 } else if (gretl_matrix_cols(coef_se) != 2) {
694 gretl_errmsg_set(_("modprint: the first matrix argument must have 2 columns"));
695 return E_INVARG;
696 }
697
698 nnames = ncoef = coef_se->rows;
699
700 if (names != NULL) {
701 /* names for coeffs: string literal, string variable,
702 or array of strings */
703 if (opt & OPT_L) {
704 /* treat as string _L_iteral */
705 parstr = names;
706 } else {
707 parstr = get_string_by_name(names);
708 if (parstr == NULL) {
709 parnames = get_array_by_name(names);
710 if (parnames == NULL ||
711 gretl_array_get_type(parnames) != GRETL_TYPE_STRINGS) {
712 err = E_TYPES;
713 }
714 }
715 }
716 } else {
717 rnames = gretl_matrix_get_rownames(coef_se);
718 if (rnames == NULL) {
719 return E_ARGS;
720 }
721 }
722
723 if (!err && (opt & OPT_A)) {
724 /* optional third field: extra statistics */
725 const char *aname = get_optval_string(MODPRINT, OPT_A);
726
727 if (aname != NULL) {
728 addstats = get_matrix_by_name(aname);
729 if (addstats == NULL) {
730 err = E_TYPES;
731 } else {
732 nnames += gretl_vector_get_length(addstats);
733 }
734 }
735 }
736
737 if (!err && nnames > ncoef && rnames != NULL) {
738 /* for now reject this case */
739 err = E_ARGS;
740 }
741
742 if (!err) {
743 if (rnames != NULL) {
744 /* use matrix rownames: convert to array */
745 parnames = gretl_array_from_strings((char **) rnames, ncoef, 1, &err);
746 free_parnames = 1;
747 } else if (parnames == NULL) {
748 /* we need to construct the strings array */
749 parnames = strings_array_from_string(parstr, nnames, &err);
750 free_parnames = 1;
751 } else if (gretl_array_get_length(parnames) < nnames) {
752 err = E_NONCONF;
753 }
754 }
755
756 if (!err) {
757 PrnFormat fmt = GRETL_FORMAT_TXT;
758 char fname[FILENAME_MAX];
759
760 *fname = '\0';
761
762 if (opt & OPT_O) {
763 /* try for --output=filename, and if found let
764 the suffix determine the output type
765 */
766 const char *s = get_optval_string(MODPRINT, OPT_O);
767
768 if (s != NULL && *s != '\0') {
769 strcpy(fname, s);
770 if (has_suffix(fname, ".tex")) {
771 fmt = GRETL_FORMAT_TEX;
772 if (opt & OPT_C) {
773 fmt |= GRETL_FORMAT_DOC;
774 }
775 } else if (has_suffix(fname, ".rtf")) {
776 fmt = GRETL_FORMAT_RTF;
777 } else if (has_suffix(fname, ".csv")) {
778 fmt = GRETL_FORMAT_CSV;
779 }
780 }
781 }
782
783 if (*fname != '\0') {
784 PRN *myprn;
785
786 gretl_maybe_switch_dir(fname);
787 myprn = gretl_print_new_with_filename(fname, &err);
788 if (!err) {
789 gretl_print_set_format(myprn, fmt);
790 err = print_model_from_matrices(coef_se, addstats,
791 parnames, 0, OPT_NONE,
792 myprn);
793 gretl_print_destroy(myprn);
794 }
795 } else {
796 gretl_print_set_format(prn, fmt);
797 err = print_model_from_matrices(coef_se, addstats,
798 parnames, 0, OPT_NONE,
799 prn);
800 }
801 }
802
803 if (free_coef_se) {
804 gretl_matrix_free(coef_se);
805 }
806 if (free_parnames) {
807 gretl_array_destroy(parnames);
808 }
809
810 return err;
811 }
812
matrix_bandplot_biglist(int ci,const gretl_matrix * m,const int * list,int * err)813 static int *matrix_bandplot_biglist (int ci,
814 const gretl_matrix *m,
815 const int *list,
816 int *err)
817 {
818 const char *s = get_optval_string(ci, OPT_N);
819 gchar **S = NULL;
820 int *biglist = NULL;
821 int ccol = 0, wcol = 0;
822 int c, i;
823
824 if (s == NULL) {
825 *err = E_INVARG;
826 return NULL;
827 }
828
829 S = g_strsplit(s, ",", -1);
830
831 for (i=0; i<2 && !*err; i++) {
832 c = 0;
833 if (S[i] == NULL) {
834 *err = E_DATA;
835 } else if (integer_string(S[i])) {
836 c = atoi(S[i]);
837 } else {
838 c = get_scalar_value_by_name(S[i], err);
839 }
840 if (!*err && c >= 1 && c <= m->cols) {
841 if (i == 0) {
842 ccol = c;
843 } else {
844 wcol = c;
845 }
846 } else {
847 c = 0;
848 }
849 if (!*err && c == 0) {
850 *err = invalid_field_error(S[i]);
851 }
852 }
853
854 g_strfreev(S);
855
856 if (!*err) {
857 biglist = gretl_list_copy(list);
858 gretl_list_append_term(&biglist, ccol);
859 gretl_list_append_term(&biglist, wcol);
860 }
861
862 return biglist;
863 }
864
matrix_command_driver(int ci,const int * list,const char * param,const DATASET * dset,gretlopt opt,PRN * prn)865 int matrix_command_driver (int ci,
866 const int *list,
867 const char *param,
868 const DATASET *dset,
869 gretlopt opt,
870 PRN *prn)
871 {
872 gretl_matrix *m = NULL;
873 DATASET *mdset = NULL;
874 int *collist = NULL;
875 const char *mname;
876 int cmax = 0;
877 int err = 0;
878
879 mname = get_optval_string(ci, OPT_X);
880
881 if (mname != NULL) {
882 m = get_matrix_by_name(mname);
883 }
884
885 if (gretl_is_null_matrix(m)) {
886 return E_DATA;
887 }
888
889 if (ci == GNUPLOT && (opt & OPT_N)) {
890 /* --band=... */
891 int *biglist = matrix_bandplot_biglist(ci, m, list, &err);
892
893 if (!err) {
894 mdset = gretl_dataset_from_matrix(m, biglist, OPT_B, &err);
895 cmax = mdset->v - 3;
896 free(biglist);
897 }
898 } else if (ci == SCATTERS) {
899 /* note: this is a special case, for now */
900 return matrix_scatters(m, list, dset, opt);
901 } else if (list != NULL && list[0] == 0) {
902 /* use all columns of the matrix */
903 mdset = gretl_dataset_from_matrix(m, NULL, OPT_B, &err);
904 } else if (list != NULL && list[0] == 1 && ci == SUMMARY) {
905 /* summary stats for a single specified column */
906 mdset = gretl_dataset_from_matrix(m, list, OPT_B | OPT_N, &err);
907 } else {
908 /* note that a NULL list is OK here */
909 mdset = gretl_dataset_from_matrix(m, list, OPT_B, &err);
910 }
911
912 if (!err) {
913 if (cmax == 0) {
914 cmax = mdset->v - 1;
915 }
916 dataset_set_matrix_name(mdset, mname);
917 collist = gretl_consecutive_list_new(1, cmax);
918 if (collist == NULL) {
919 err = E_ALLOC;
920 }
921 }
922
923 if (!err) {
924 if (ci != GNUPLOT) {
925 opt &= ~OPT_X;
926 }
927 if (ci == BXPLOT) {
928 err = boxplots(collist, param, mdset, opt);
929 } else if (ci == GNUPLOT) {
930 err = gnuplot(collist, param, mdset, opt);
931 } else if (ci == SUMMARY) {
932 err = list_summary(collist, 0, mdset, opt, prn);
933 } else if (ci == CORR) {
934 err = gretl_corrmx(collist, mdset, opt, prn);
935 } else {
936 err = E_DATA;
937 }
938 }
939
940 destroy_dataset(mdset);
941 free(collist);
942
943 return err;
944 }
945
matrix_freq_driver(const int * list,gretlopt opt,PRN * prn)946 int matrix_freq_driver (const int *list,
947 gretlopt opt,
948 PRN *prn)
949 {
950 gretl_matrix *m = NULL;
951 DATASET *mdset = NULL;
952 const char *mname;
953 int err = 0;
954
955 if (list != NULL && list[0] != 1) {
956 return E_DATA;
957 }
958
959 mname = get_optval_string(FREQ, OPT_X);
960 if (mname != NULL) {
961 m = get_matrix_by_name(mname);
962 }
963
964 if (gretl_is_null_matrix(m)) {
965 err = E_DATA;
966 } else {
967 if (list == NULL) {
968 /* this is OK if m is a column vector */
969 if (m->cols == 1) {
970 int mlist[2] = {1, 1};
971
972 mdset = gretl_dataset_from_matrix(m, mlist, OPT_B, &err);
973 } else {
974 err = E_ARGS;
975 }
976 } else {
977 mdset = gretl_dataset_from_matrix(m, list, OPT_B, &err);
978 }
979 }
980
981 if (!err) {
982 err = freqdist(1, mdset, opt, prn);
983 }
984
985 destroy_dataset(mdset);
986
987 return err;
988 }
989
list_summary_driver(const int * list,const DATASET * dset,gretlopt opt,PRN * prn)990 int list_summary_driver (const int *list, const DATASET *dset,
991 gretlopt opt, PRN *prn)
992 {
993 int wtvar = 0;
994 int err = 0;
995
996 if (opt & OPT_W) {
997 const char *wname = get_optval_string(SUMMARY, OPT_W);
998
999 if (wname == NULL) {
1000 err = E_DATA;
1001 } else {
1002 wtvar = current_series_index(dset, wname);
1003 if (wtvar < 0) {
1004 err = E_UNKVAR;
1005 }
1006 }
1007 }
1008
1009 if (!err) {
1010 err = list_summary(list, wtvar, dset, opt, prn);
1011 }
1012
1013 return err;
1014 }
1015