CROSSTABS: Fix computation of adjusted standardized residual.
[pspp] / perl-module / PSPP.xs
1 /* PSPP - computes sample statistics.
2    Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014,
3    2020 Free Software Foundation, Inc.
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 #undef VERSION
19 #include <config.h>
20
21 /* The Gnulib "strftime" module defines my_strftime in <config.h> for use by
22    gl/strftime.c.  Perl also defines my_strftime in embed.h for some other
23    purpose.  The former definition doesn't matter in this file, so suppress it
24    to avoid a compiler warning. */
25 #undef my_strftime
26
27 #include "EXTERN.h"
28 #include "perl.h"
29 #include "XSUB.h"
30
31 #include "ppport.h"
32
33 #include "minmax.h"
34 #include <libpspp/hmap.h>
35 #include <libpspp/hash-functions.h>
36 #include <libpspp/message.h>
37 #include <libpspp/version.h>
38 #include <libpspp/i18n.h>
39 #include <gl/xalloc.h>
40 #include <data/dictionary.h>
41 #include <data/case.h>
42 #include <data/casereader.h>
43 #include <data/casewriter.h>
44 #include <data/variable.h>
45 #include <data/attributes.h>
46 #include <data/file-handle-def.h>
47 #include <data/identifier.h>
48 #include <data/settings.h>
49 #include <data/sys-file-writer.h>
50 #include <data/value.h>
51 #include <data/vardict.h>
52 #include <data/value-labels.h>
53 #include <data/format.h>
54 #include <data/data-in.h>
55 #include <data/data-out.h>
56 #include <string.h>
57
58 typedef struct fmt_spec input_format ;
59 typedef struct fmt_spec output_format ;
60
61
62 /*  A thin wrapper around sfm_writer */
63 struct syswriter_info
64 {
65   bool opened;
66
67   /* A pointer to the writer. The writer is owned by the struct */
68   struct casewriter *writer;
69
70   /* A pointer to the dictionary. Owned externally */
71   const struct pspp_dict *dict;
72
73   /* The scalar containing the dictionary */
74   SV *dict_sv;
75 };
76
77
78 /*  A thin wrapper around sfm_reader */
79 struct sysreader_info
80 {
81   struct any_read_info opts;
82
83   /* A pointer to the reader. The reader is owned by the struct */
84   struct casereader *reader;
85
86   /* A pointer to the dictionary. */
87   struct pspp_dict *dict;
88 };
89
90
91 struct input_format {
92   struct hmap_node hmap_node;   /* In struct pspp_dict's input_formats map. */
93   const struct variable *var;
94   struct fmt_spec input_format;
95 };
96
97 /* A thin wrapper around struct dictionary.*/
98 struct pspp_dict {
99   struct dictionary *dict;
100   struct hmap input_formats;    /* Contains struct input_format. */
101 };
102
103
104 /*  A message handler which writes messages to PSPP::errstr */
105 static void
106 message_handler (const struct msg *m, void *aux)
107 {
108  SV *errstr = get_sv("PSPP::errstr", TRUE);
109  sv_setpv (errstr, m->text);
110 }
111
112 static int
113 sysfile_close (struct syswriter_info *swi)
114 {
115   int retval ;
116   if ( ! swi->opened )
117     return 0;
118
119   retval = casewriter_destroy (swi->writer);
120   if (retval > 0 )
121     swi->opened = false;
122
123   return retval;
124 }
125
126 static void
127 scalar_to_value (union value *val, SV *scalar, const struct variable *var)
128 {
129   if ( var_is_numeric (var))
130     {
131         if ( SvNOK (scalar) || SvIOK (scalar) )
132            val->f = SvNV (scalar);
133         else
134            val->f = SYSMIS;
135     }
136   else
137     {
138         STRLEN len;
139         const char *p = SvPV (scalar, len);
140         int width = var_get_width (var);
141         value_set_missing (val, width);
142         memcpy (val->s, p, len);
143     }
144 }
145
146
147 static SV *
148 value_to_scalar (const union value *val, const struct variable *var)
149 {
150   if ( var_is_numeric (var))
151     {
152       if (var_is_value_missing (var, val) == MV_SYSTEM)
153         return newSVpvn ("", 0);
154
155       return newSVnv (val->f);
156     }
157   else
158     {
159       int width = var_get_width (var);
160       return newSVpvn ((char *) val->s, width);
161     }
162 }
163
164
165 static void
166 make_value_from_scalar (union value *uv, SV *val, const struct variable *var)
167 {
168  value_init (uv, var_get_width (var));
169  scalar_to_value (uv, val, var);
170 }
171
172 static struct pspp_dict *
173 create_pspp_dict (struct dictionary *dict)
174 {
175   struct pspp_dict *pspp_dict = xmalloc (sizeof *pspp_dict);
176   pspp_dict->dict = dict;
177   hmap_init (&pspp_dict->input_formats);
178   return pspp_dict;
179 }
180
181 static const struct fmt_spec *
182 find_input_format (const struct pspp_dict *dict, const struct variable *var)
183 {
184   struct input_format *input_format;
185
186   HMAP_FOR_EACH_IN_BUCKET (input_format, struct input_format, hmap_node,
187                            hash_pointer (var, 0), &dict->input_formats)
188     if (input_format->var == var)
189       return &input_format->input_format;
190
191   return NULL;
192 }
193
194
195 MODULE = PSPP
196
197 MODULE = PSPP           PACKAGE = PSPP
198
199 PROTOTYPES: ENABLE
200
201 void
202 onBoot (ver)
203  const char *ver
204 CODE:
205  /* Check that the version is correct up to the length of 'ver'.
206     This allows PSPP autobuilders to add a "-build#" suffix to the
207     PSPP version without causing failures here. */
208  assert (0 == strncmp (ver, bare_version, strlen (ver)));
209
210  i18n_init ();
211 const struct msg_handler mh = { .output_msg = message_handler };
212  msg_set_handler (&mh);
213  settings_init ();
214  fh_init ();
215
216 SV *
217 format_value (val, var)
218  SV *val
219  struct variable *var
220 CODE:
221  SV *ret;
222  const struct fmt_spec *fmt = var_get_print_format (var);
223  union value uv;
224  char *s;
225  make_value_from_scalar (&uv, val, var);
226  s = data_out (&uv, var_get_encoding (var), fmt, settings_get_fmt_settings ());
227  value_destroy (&uv, var_get_width (var));
228  ret = newSVpv (s, fmt->w);
229  free (s);
230  RETVAL = ret;
231  OUTPUT:
232 RETVAL
233
234
235 int
236 value_is_missing (val, var)
237  SV *val
238  struct variable *var
239 CODE:
240  union value uv;
241  int ret;
242  make_value_from_scalar (&uv, val, var);
243  ret = var_is_value_missing (var, &uv) != 0;
244  value_destroy (&uv, var_get_width (var));
245  RETVAL = ret;
246  OUTPUT:
247 RETVAL
248
249
250
251 MODULE = PSPP           PACKAGE = PSPP::Dict
252
253 struct pspp_dict *
254 pxs_dict_new()
255 CODE:
256  RETVAL = create_pspp_dict (dict_create ("UTF-8"));
257 OUTPUT:
258  RETVAL
259
260
261 void
262 DESTROY (dict)
263  struct pspp_dict *dict
264 CODE:
265  if (dict != NULL)
266    {
267      struct input_format *input_format, *next_input_format;
268
269      HMAP_FOR_EACH_SAFE (input_format, next_input_format,
270                          struct input_format, hmap_node, &dict->input_formats)
271        {
272          hmap_delete (&dict->input_formats, &input_format->hmap_node);
273          free (input_format);
274        }
275      hmap_destroy (&dict->input_formats);
276      dict_unref (dict->dict);
277      free (dict);
278    }
279
280 int
281 get_var_cnt (dict)
282  struct pspp_dict *dict
283 CODE:
284  RETVAL = dict_get_n_vars (dict->dict);
285 OUTPUT:
286 RETVAL
287
288 void
289 set_label (dict, label)
290  struct pspp_dict *dict
291  char *label
292 CODE:
293  dict_set_label (dict->dict, label);
294
295 void
296 set_documents (dict, docs)
297  struct pspp_dict *dict
298  char *docs
299 CODE:
300  dict_set_documents_string (dict->dict, docs);
301
302
303 void
304 add_document (dict, doc)
305  struct pspp_dict *dict
306  char *doc
307 CODE:
308  dict_add_document_line (dict->dict, doc, false);
309
310
311 void
312 clear_documents (dict)
313  struct pspp_dict *dict
314 CODE:
315  dict_clear_documents (dict->dict);
316
317
318 void
319 set_weight (dict, var)
320  struct pspp_dict *dict
321  struct variable *var
322 CODE:
323  dict_set_weight (dict->dict, var);
324
325
326 struct variable *
327 pxs_get_variable (dict, idx)
328  struct pspp_dict *dict
329  SV *idx
330 INIT:
331  SV *errstr = get_sv("PSPP::errstr", TRUE);
332  sv_setpv (errstr, "");
333  if ( SvIV (idx) >= dict_get_n_vars (dict->dict))
334   {
335     sv_setpv (errstr, "The dictionary doesn't have that many variables.");
336     XSRETURN_UNDEF;
337   }
338 CODE:
339  RETVAL = dict_get_var (dict->dict, SvIV (idx));
340  OUTPUT:
341 RETVAL
342
343
344 struct variable *
345 pxs_get_var_by_name (dict, name)
346  struct pspp_dict *dict
347  const char *name
348 INIT:
349  SV *errstr = get_sv("PSPP::errstr", TRUE);
350  sv_setpv (errstr, "");
351 CODE:
352  struct variable *var = dict_lookup_var (dict->dict, name);
353  if ( ! var )
354       sv_setpv (errstr, "No such variable.");
355  RETVAL = var;
356  OUTPUT:
357 RETVAL
358
359
360 MODULE = PSPP           PACKAGE = PSPP::Var
361
362
363 struct variable *
364 pxs_dict_create_var (dict, name, ip_fmt)
365  struct pspp_dict * dict
366  char *name
367  input_format ip_fmt
368 INIT:
369  SV *errstr = get_sv("PSPP::errstr", TRUE);
370  sv_setpv (errstr, "");
371  if ( ! id_is_plausible (name, false))
372   {
373     sv_setpv (errstr, "The variable name is not valid.");
374     XSRETURN_UNDEF;
375   }
376 CODE:
377  struct fmt_spec op_fmt;
378  struct input_format *input_format;
379
380  struct variable *v;
381  op_fmt = fmt_for_output_from_input (&ip_fmt, settings_get_fmt_settings ());
382  v = dict_create_var (dict->dict, name,
383         fmt_is_string (op_fmt.type) ? op_fmt.w : 0);
384  if ( NULL == v )
385   {
386     sv_setpv (errstr, "The variable could not be created (probably already exists).");
387     XSRETURN_UNDEF;
388   }
389  var_set_both_formats (v, &op_fmt);
390
391  input_format = xmalloc (sizeof *input_format);
392  input_format->var = v;
393  input_format->input_format = ip_fmt;
394  hmap_insert (&dict->input_formats, &input_format->hmap_node,
395               hash_pointer (v, 0));
396
397  RETVAL = v;
398 OUTPUT:
399  RETVAL
400
401
402 int
403 set_missing_values (var, v1, ...)
404  struct variable *var;
405  SV *v1;
406 INIT:
407  int i;
408  union value val[3];
409
410  if ( items > 4 )
411   croak ("No more than 3 missing values are permitted");
412
413  for (i = 0; i < items - 1; ++i)
414    make_value_from_scalar (&val[i], ST(i+1), var);
415 CODE:
416  struct missing_values mv;
417  mv_init (&mv, var_get_width (var));
418  for (i = 0 ; i < items - 1; ++i )
419    {
420      mv_add_value (&mv, &val[i]);
421      value_destroy (&val[i], var_get_width (var));
422    }
423  var_set_missing_values (var, &mv);
424
425
426 void
427 set_label (var, label)
428  struct variable *var;
429  char *label
430 CODE:
431   var_set_label (var, label);
432
433
434 void
435 clear_value_labels (var)
436  struct variable *var;
437 CODE:
438  var_clear_value_labels (var);
439
440 SV *
441 get_write_format (var)
442  struct variable *var
443 CODE:
444  HV *fmthash = (HV *) sv_2mortal ((SV *) newHV());
445  const struct fmt_spec *fmt = var_get_write_format (var);
446
447  hv_store (fmthash, "fmt", 3, newSVnv (fmt->type), 0);
448  hv_store (fmthash, "decimals", 8, newSVnv (fmt->d), 0);
449  hv_store (fmthash, "width", 5, newSVnv (fmt->w), 0);
450
451  RETVAL = newRV ((SV *) fmthash);
452  OUTPUT:
453 RETVAL
454
455 SV *
456 get_print_format (var)
457  struct variable *var
458 CODE:
459  HV *fmthash = (HV *) sv_2mortal ((SV *) newHV());
460  const struct fmt_spec *fmt = var_get_print_format (var);
461
462  hv_store (fmthash, "fmt", 3, newSVnv (fmt->type), 0);
463  hv_store (fmthash, "decimals", 8, newSVnv (fmt->d), 0);
464  hv_store (fmthash, "width", 5, newSVnv (fmt->w), 0);
465
466  RETVAL = newRV ((SV *) fmthash);
467  OUTPUT:
468 RETVAL
469
470
471 void
472 pxs_set_write_format (var, fmt)
473  struct variable *var
474  output_format fmt
475 CODE:
476  var_set_write_format (var, &fmt);
477
478
479 void
480 pxs_set_print_format (var, fmt)
481  struct variable *var
482  output_format fmt
483 CODE:
484  var_set_print_format (var, &fmt);
485
486 void
487 pxs_set_output_format (var, fmt)
488  struct variable *var
489  output_format fmt
490 CODE:
491  var_set_both_formats (var, &fmt);
492
493
494 int
495 add_value_label (var, key, label)
496  struct variable *var
497  SV *key
498  char *label
499 INIT:
500  SV *errstr = get_sv("PSPP::errstr", TRUE);
501  sv_setpv (errstr, "");
502 CODE:
503  union value the_value;
504  int width = var_get_width (var);
505  int ok;
506
507  value_init (&the_value, width);
508  if ( var_is_numeric (var))
509  {
510   if ( ! looks_like_number (key))
511     {
512       sv_setpv (errstr, "Cannot add label with string key to a numeric variable");
513       value_destroy (&the_value, width);
514       XSRETURN_IV (0);
515     }
516   the_value.f = SvNV (key);
517  }
518  else
519  {
520   value_copy_str_rpad (&the_value, width, SvPV_nolen(key), ' ');
521  }
522  ok = var_add_value_label (var, &the_value, label);
523  value_destroy (&the_value, width);
524  if (!ok)
525  {
526    sv_setpv (errstr, "Something went wrong");
527    XSRETURN_IV (0);
528  }
529  XSRETURN_IV (1);
530
531
532 SV *
533 get_attributes (var)
534  struct variable *var
535 CODE:
536  HV *attrhash = (HV *) sv_2mortal ((SV *) newHV());
537
538  struct attrset *as = var_get_attributes (var);
539
540  if ( as )
541    {
542      struct attrset_iterator iter;
543      struct attribute *attr;
544
545      for (attr = attrset_first (as, &iter);
546           attr;
547           attr = attrset_next (as, &iter))
548        {
549          int i;
550          const char *name = attribute_get_name (attr);
551
552          AV *values = newAV ();
553
554          for (i = 0 ; i < attribute_get_n_values (attr); ++i )
555            {
556              const char *value = attribute_get_value (attr, i);
557              av_push (values, newSVpv (value, 0));
558            }
559
560          hv_store (attrhash, name, strlen (name),
561                    newRV_noinc ((SV*) values), 0);
562        }
563    }
564
565  RETVAL = newRV ((SV *) attrhash);
566  OUTPUT:
567 RETVAL
568
569
570 const char *
571 get_name (var)
572  struct variable * var
573 CODE:
574  RETVAL = var_get_name (var);
575  OUTPUT:
576 RETVAL
577
578
579 const char *
580 get_label (var)
581  struct variable * var
582 CODE:
583  RETVAL = var_get_label (var);
584  OUTPUT:
585 RETVAL
586
587
588 SV *
589 get_value_labels (var)
590  struct variable *var
591 CODE:
592  HV *labelhash = (HV *) sv_2mortal ((SV *) newHV());
593  const struct val_lab *vl;
594  const struct val_labs *labels = var_get_value_labels (var);
595
596  if ( labels )
597    {
598      for (vl = val_labs_first (labels);
599           vl;
600           vl = val_labs_next (labels, vl))
601        {
602          SV *sv = value_to_scalar (&vl->value, var);
603          STRLEN len;
604          const char *s = SvPV (sv, len);
605          hv_store (labelhash, s, len, newSVpv (val_lab_get_label (vl), 0), 0);
606        }
607    }
608
609  RETVAL = newRV ((SV *) labelhash);
610  OUTPUT:
611 RETVAL
612
613
614
615 MODULE = PSPP           PACKAGE = PSPP::Sysfile
616
617
618 struct syswriter_info *
619 pxs_create_sysfile (name, dict, opts_hr)
620  char *name
621  struct pspp_dict *dict;
622  SV *opts_hr
623 INIT:
624  SV *dict_sv = ST(1);
625  struct sfm_write_options opts;
626  if (!SvROK (opts_hr))
627   {
628     opts = sfm_writer_default_options ();
629   }
630  else
631   {
632     HV *opt_h = (HV *) SvRV (opts_hr);
633     SV** readonly = hv_fetch(opt_h, "readonly", 8, 0);
634     SV** compress = hv_fetch(opt_h, "compress", 8, 0);
635     SV** version = hv_fetch(opt_h, "version", 7, 0);
636
637     opts.create_writeable = readonly ? ! SvIV (*readonly) : true;
638     opts.compression = (compress && SvIV (*compress)
639                         ? ANY_COMP_SIMPLE
640                         : ANY_COMP_NONE);
641     opts.version = version ? SvIV (*version) : 3 ;
642   }
643 CODE:
644  struct file_handle *fh =
645    fh_create_file (NULL, name, "UTF-8", fh_default_properties () );
646  struct syswriter_info *swi = xmalloc (sizeof (*swi));
647  swi->writer = sfm_open_writer (fh, dict->dict, opts);
648  swi->dict = dict;
649  swi->opened = true;
650  swi->dict_sv = dict_sv;
651  SvREFCNT_inc (swi->dict_sv);
652
653  RETVAL = swi;
654  OUTPUT:
655 RETVAL
656
657 int
658 close (swi)
659  struct syswriter_info *swi
660 CODE:
661  RETVAL = sysfile_close (swi);
662 OUTPUT:
663  RETVAL
664
665 void
666 DESTROY (swi)
667  struct syswriter_info *swi
668 CODE:
669  sysfile_close (swi);
670  SvREFCNT_dec (swi->dict_sv);
671  free (swi);
672
673 int
674 append_case (swi, ccase)
675  struct syswriter_info *swi
676  SV *ccase
677 INIT:
678  SV *errstr = get_sv("PSPP::errstr", TRUE);
679  sv_setpv (errstr, "");
680  if ( (!SvROK(ccase)))
681   {
682     XSRETURN_UNDEF;
683   }
684 CODE:
685  int i = 0;
686  AV *av_case = (AV*) SvRV (ccase);
687
688  const struct variable **vv;
689  size_t nv;
690  struct ccase *c;
691
692  if ( av_len (av_case) >= dict_get_n_vars (swi->dict->dict))
693    XSRETURN_UNDEF;
694
695  c =  case_create (dict_get_proto (swi->dict->dict));
696
697  dict_get_vars (swi->dict->dict, &vv, &nv,
698                 1u << DC_ORDINARY | 1u << DC_SYSTEM);
699
700  for (SV *sv = av_shift (av_case); SvOK (sv);  sv = av_shift (av_case))
701   {
702     const struct variable *v = vv[i++];
703     const struct fmt_spec *ifmt = find_input_format (swi->dict, v);
704
705     /* If an input format has been set, then use it.
706        Otherwise just convert the raw value.    */
707     if (ifmt)
708       {
709         struct substring ss = ss_cstr (SvPV_nolen (sv));
710         char *error = data_in (ss,
711                                SvUTF8(sv) ? UTF8: "iso-8859-1",
712                                ifmt->type,
713                                settings_get_fmt_settings (),
714                                case_data_rw (c, v),
715                                var_get_width (v),
716                                dict_get_encoding (swi->dict->dict));
717         if (error)
718           {
719             free (error);
720             RETVAL = 0;
721             SvREFCNT_dec_NN (sv);
722             case_unref (c);
723             goto finish;
724           }
725       }
726     else
727       {
728         scalar_to_value (case_data_rw (c, v), sv, v);
729       }
730     SvREFCNT_dec_NN (sv);
731   }
732
733  /* The remaining variables must be sysmis or blank string */
734  while (i < dict_get_n_vars (swi->dict->dict))
735  {
736    const struct variable *v = vv[i++];
737    union value *val = case_data_rw (c, v);
738    value_set_missing (val, var_get_width (v));
739  }
740  casewriter_write (swi->writer, c);
741  RETVAL = 1;
742  finish:
743  free (vv);
744 OUTPUT:
745  RETVAL
746
747
748 \f
749
750 MODULE = PSPP           PACKAGE = PSPP::Reader
751
752 struct sysreader_info *
753 pxs_open_sysfile (name)
754  char * name
755 CODE:
756  struct sysreader_info *sri = NULL;
757  struct file_handle *fh =
758    fh_create_file (NULL, name, "UTF-8", fh_default_properties () );
759  struct dictionary *dict;
760
761  sri = xmalloc (sizeof (*sri));
762  sri->reader = any_reader_open_and_decode (fh, NULL, &dict, &sri->opts);
763  if (sri->reader)
764    sri->dict = create_pspp_dict (dict);
765  else
766    {
767      free (sri);
768      sri = NULL;
769    }
770
771  RETVAL = sri;
772  OUTPUT:
773 RETVAL
774
775
776 struct pspp_dict *
777 pxs_get_dict (reader)
778  struct sysreader_info *reader;
779 CODE:
780  RETVAL = reader->dict;
781  OUTPUT:
782 RETVAL
783
784 SV *
785 get_case_cnt (sfr)
786  struct sysreader_info *sfr;
787 CODE:
788  SV *ret;
789  casenumber n = casereader_get_n_cases (sfr->reader);
790  if (n == CASENUMBER_MAX)
791   ret = &PL_sv_undef;
792  else
793   ret = newSViv (n);
794  RETVAL = ret;
795  OUTPUT:
796 RETVAL
797
798
799
800 void
801 get_next_case (sfr)
802  struct sysreader_info *sfr;
803 PPCODE:
804  struct ccase *c;
805
806  if ((c = casereader_read (sfr->reader)) != NULL)
807  {
808   int v;
809
810   EXTEND (SP, dict_get_n_vars (sfr->dict->dict));
811   for (v = 0; v < dict_get_n_vars (sfr->dict->dict); ++v )
812     {
813       const struct variable *var = dict_get_var (sfr->dict->dict, v);
814       const union value *val = case_data (c, var);
815
816       PUSHs (sv_2mortal (value_to_scalar (val, var)));
817     }
818
819   case_unref (c);
820  }