plugins/fn-r/generate

   1 #!/usr/bin/perl -w
   2 # -----------------------------------------------------------------------------
   3
   4 use strict;
   5 $| = 1;
   6
   7 sub distribution;
   8
   9 my %funcs = ();
  10 my %argoverride = ();
  11 my %defaults;
  12
  13 {
  14     my $of = "of the distribution";
  15     my @common = ('give_log' =>
  16                   "if true, log of the result will be returned instead",
  17
  18                   'lower_tail' =>
  19                   "if true (the default), the lower tail of the distribution is considered",
  20
  21                   'log_p' => 'if true, the natural logarithm of the probability is given or returned; defaults to false',
  22
  23                   'x' => 'observation',
  24                   'p' => 'probability or natural logarithm of the probability',
  25
  26                   'shape' => "the shape parameter $of",
  27                   'scale' => "the scale parameter $of",
  28                   );
  29
  30     $funcs{'dnorm'} = $funcs{'pnorm'} = $funcs{'qnorm'} =
  31         [\&distribution,
  32          'normal',
  33          ({ 'mu' => "mean $of",
  34             'sigma' => "standard deviation $of",
  35             @common }),
  36          [ { 'x' => 1, 'mu' => 0, 'sigma' => 1 },
  37            { 'x' => 2, 'mu' => 0, 'sigma' => 1 },
  38            { 'x' => 3, 'mu' => 0, 'sigma' => 1 } ],
  39         ];
  40
  41     $funcs{'dlnorm'} = $funcs{'plnorm'} = $funcs{'qlnorm'} =
  42         [\&distribution,
  43          'log-normal',
  44          ({ 'logmean' => "mean of the underlying normal distribution",
  45             'logsd' => "standard deviation of the underlying normal distribution",
  46             @common }),
  47          [ { 'x' => 2.5, 'logmean' => 1, 'logsd' => 2 } ],
  48         ];
  49
  50     $funcs{'dgamma'} = $funcs{'pgamma'} = $funcs{'qgamma'} =
  51         [\&distribution,
  52          'gamma',
  53          ({ @common }),
  54          [ { 'x' => 3, 'shape' => 5, 'scale' => 1 } ],
  55         ];
  56
  57     $funcs{'dbeta'} = $funcs{'pbeta'} = $funcs{'qbeta'} =
  58         [\&distribution,
  59          'beta',
  60          ({ 'a' => "the first shape parameter $of",
  61             'b' => "the second scale parameter $of",
  62             @common }),
  63          [ { 'x' => 0.4, 'a' => 1, 'b' => 4 } ],
  64         ];
  65
  66     $funcs{'dt'} = $funcs{'pt'} = $funcs{'qt'} =
  67         [\&distribution,
  68          'Student t',
  69          ({ 'n' => "the number of degrees of freedom $of",
  70             @common }),
  71          [ { 'x' => 1.5, 'n' => 5 } ],
  72         ];
  73
  74     $funcs{'df'} = $funcs{'pf'} = $funcs{'qf'} =
  75         [\&distribution,
  76          'F',
  77          ({ 'n1' => "the first number of degrees of freedom $of",
  78             'n2' => "the second number of degrees of freedom $of",
  79             @common }),
  80          [ { 'x' => 1.5, 'n1' => 2, 'n2' => 3 } ],
  81          ];
  82
  83     $funcs{'dchisq'} = $funcs{'pchisq'} = $funcs{'qchisq'} =
  84         [\&distribution,
  85          'chi-square',
  86          ({ 'df' => "the number of degrees of freedom $of",
  87             @common }),
  88          [ { 'x' => 2.5, 'df' => 4 } ],
  89         ];
  90
  91     $funcs{'dweibull'} = $funcs{'pweibull'} = $funcs{'qweibull'} =
  92         [\&distribution,
  93          'Weibull',
  94          ({ @common }),
  95          [ { 'x' => 2.1, 'shape' => 1.5, 'scale' => 1 } ],
  96         ];
  97
  98     $funcs{'dpois'} = $funcs{'ppois'} = $funcs{'qpois'} =
  99         [\&distribution,
 100          'Poisson',
 101          ({ 'lambda' => "the mean $of",
 102             @common }),
 103          [ { 'x' => 4, 'lambda' => 4 } ],
 104         ];
 105
 106     $funcs{'dexp'} = $funcs{'pexp'} = $funcs{'qexp'} =
 107         [\&distribution,
 108          'exponential',
 109          ({ @common }),
 110          [ { 'x' => 1.5, 'scale' => 4 } ],
 111         ];
 112
 113     $funcs{'dbinom'} = $funcs{'pbinom'} = $funcs{'qbinom'} =
 114         [\&distribution,
 115          'binomial',
 116          ({ 'n' => 'the number of trials',
 117             'psuc' => "the probability of success in each trial",
 118             @common }),
 119          [ { 'x' => 4, 'n' => 10, 'psuc' => 0.4 } ],
 120         ];
 121
 122     $funcs{'dnbinom'} = $funcs{'pnbinom'} = $funcs{'qnbinom'} =
 123         [\&distribution,
 124          'negative binomial',
 125          ({ 'n' => 'required number of successes',
 126             'psuc' => "the probability of success in each trial",
 127             @common,
 128             'x' => 'observation (number of failures)' }),
 129          [ { 'x' => 8, 'n' => 10, 'psuc' => 0.45 } ],
 130         ];
 131
 132     $funcs{'dhyper'} = $funcs{'phyper'} = $funcs{'qhyper'} =
 133         [\&distribution,
 134          'hypergeometric',
 135          ({ 'r' => "the number of red balls",
 136             'b' => "the number of black balls",
 137             'n' => "the number of balls drawn",
 138             @common }),
 139          [ { 'x' => 12, 'r' => 50, 'b' => 450, 'n' => 100 } ],
 140         ];
 141
 142     $funcs{'dcauchy'} = $funcs{'pcauchy'} = $funcs{'qcauchy'} =
 143         [\&distribution,
 144          'Cauchy',
 145          ({ 'location' => "the center $of",
 146             @common }),
 147          [ { 'x' => 1.5, 'location' => 1, 'scale' => 4 } ],
 148         ];
 149
 150     $funcs{'dgeom'} = $funcs{'pgeom'} = $funcs{'qgeom'} =
 151         [\&distribution,
 152          'geometric',
 153          ({ 'psuc' => "the probability of success in each trial",
 154             @common }),
 155          [ { 'x' => 3, 'psuc' => 0.2 } ],
 156         ];
 157
 158     $funcs{'dsnorm'} =  $funcs{'psnorm'} =  $funcs{'qsnorm'} =
 159         [\&distribution,
 160          'skew-normal',
 161          ({ 'location' => "the location parameter $of",
 162             @common }),
 163          [ { 'x' => 3, 'shape' => 2, 'location' => 0, 'scale' => 1 } ],
 164         ];
 165
 166     $funcs{'dst'} = $funcs{'pst'} = $funcs{'qst'} =
 167         [\&distribution,
 168          'skew-t',
 169          ({ 'n' => "the number of degrees of freedom $of",
 170             @common }),
 171          [ { 'x' => 2, 'n' => 5, 'shape' => 2 } ],
 172         ];
 173
 174     $funcs{'ptukey'} = $funcs{'qtukey'} =
 175         [\&distribution,
 176          'Studentized range',
 177          ({ 'nranges' => "the number of ranges; default is 1",
 178             'nmeans' => "the number of means",
 179             'df' => "the number of degrees of freedom $of",
 180             @common }),
 181         ];
 182     $defaults{'ptukey:nranges'} = $defaults{'qtukey:nranges'} = 1;
 183
 184     $funcs{'dgumbel'} = $funcs{'pgumbel'} = $funcs{'qgumbel'} =
 185         [\&distribution,
 186          'Gumbel',
 187          ({ 'mu' => "the location parameter of freedom $of",
 188             'beta' => "the scale parameter of freedom $of",
 189             @common }),
 190          [ { 'x' => 2.5, 'mu' => 2, 'beta' => 1 } ],
 191         ];
 192
 193     $funcs{'drayleigh'} = $funcs{'prayleigh'} = $funcs{'qrayleigh'} =
 194         [\&distribution,
 195          'Rayleigh',
 196          ({ @common }),
 197          [ { 'x' => 2, 'scale' => 1 } ],
 198         ];
 199 }
 200
 201
 202 my %odf_note =
 203     ('qchisq' => 'A two argument invocation R.QCHISQ(@{p},@{df}) is exported to OpenFormula as CHISQINV(@{p},@{df}).',
 204      'pchisq' => 'A two argument invocation R.PCHISQ(@{x},@{df}) is exported to OpenFormula as CHISQDIST(@{x},@{df}).',
 205      'dchisq' => 'A two argument invocation R.DCHISQ(@{x},@{df}) is exported to OpenFormula as CHISQDIST(@{x},@{df},FALSE()).',
 206     );
 207
 208 my %test_status = ();
 209 my @burkardt_tests =
 210     ('pbeta', 'pbinom', 'pcauchy', 'pchisq', 'pexp',
 211      'pf', 'pgamma', 'pgeom', 'phyper', 'dhyper', 'plnorm',
 212      'pnbinom', 'pnorm', 'ppois', 'pt', 'pweibull', );
 213 my @amath_tests =
 214     ('dbeta', 'dbinom', 'dcauchy', 'dchisq', 'dexp', 'df', 'dgamma',
 215      'dhyper', 'dlnorm', 'dnbinom', 'dnorm', 'dpois', 'dt',
 216      'dweibull', 'pbeta', 'pbinom', 'pcauchy', 'pchisq', 'pexp', 'pf',
 217      'pgamma', 'phyper', 'plnorm', 'pnbinom', 'pnorm', 'ppois', 'pt',
 218      'pweibull', 'qbeta', 'qcauchy', 'qchisq', 'qexp', 'qf', 'qgamma',
 219      'qlnorm', 'qnorm', 'qt', 'qweibull');
 220 foreach (@burkardt_tests, @amath_tests) {
 221     $test_status{$_} = 'EXHAUSTIVE';
 222 }
 223
 224 my %type_getter =
 225     ('gnm_float' => 'value_get_as_float',
 226      'gboolean' => 'value_get_as_checked_bool',
 227      );
 228
 229 my %type_spec =
 230     ('gnm_float' => 'f',
 231      'gboolean' => 'b',
 232      );
 233
 234 my %type_setter =
 235     ('gnm_float' => 'value_new_float',
 236      'int' => 'value_new_int',
 237      'gboolean' => 'value_new_bool',
 238      );
 239
 240 # -----------------------------------------------------------------------------
 241
 242 my $mathfunch = $0;
 243 $mathfunch =~ s|[^/]+$|../../src/mathfunc.h|;
 244
 245 my $dpqh = $0;
 246 $dpqh =~ s|[^/]+$|../../src/sf-dpq.h|;
 247
 248
 249 my $funcdefs = "";
 250 my %functions;
 251
 252 my $emitted = "";
 253
 254 &emit ("/* This code was generated by $0.  Do not edit. */\n\n" .
 255        "#include <gnumeric-config.h>\n" .
 256        "#include <gnumeric.h>\n" .
 257        "#include <goffice/goffice.h>\n" .
 258        "#include <gnm-plugin.h>\n" .
 259        "#include <func.h>\n" .
 260        "#include <gnm-i18n.h>\n" .
 261        "#include <value.h>\n" .
 262        "#include <mathfunc.h>\n" .
 263        "#include <sf-dpq.h>\n" .
 264        "#include \"extra.h\"\n\n" .
 265        "GNM_PLUGIN_MODULE_HEADER;\n\n");
 266
 267 foreach my $header ($mathfunch, $dpqh, "extra.h") {
 268     local (*HEADER);
 269     open (HEADER, "<$header") or die "$0: Cannot read $header: $!\n";
 270     while (<HEADER>) {
 271         chomp;
 272
 273         if (/^(gnm_float)\s+([a-zA-Z_][a-zA-Z0-9_]*)\s*\(.*\)/) {
 274             my $restype = $1;
 275             my $func = $2;
 276             next unless exists $funcs{$func};
 277             $functions{$func} = [$restype,$_];
 278         }
 279     }
 280     close (HEADER);
 281 }
 282
 283 foreach my $func (sort { &cfileorder($a,$b) } keys %functions) {
 284     my ($restype,$proto) = @{$functions{$func}};
 285     my ($handler,@args) = @{ $funcs{$func} };
 286     &$handler ($func, $restype, $proto, @args);
 287 }
 288
 289
 290 &emit_line ();
 291
 292 &emit ("G_MODULE_EXPORT void\n" .
 293        "go_plugin_init (GOPlugin *plugin, GOCmdContext *cc)\n" .
 294        "{\n" .
 295        "}\n\n");
 296
 297 &emit ("G_MODULE_EXPORT void\n" .
 298        "go_plugin_shutdown (GOPlugin *plugin, GOCmdContext *cc)\n" .
 299        "{\n" .
 300        "}\n\n");
 301
 302 &emit_line ();
 303
 304 &emit ("GnmFuncDescriptor const rstat_functions[] = {\n" .
 305        $funcdefs .
 306        "\t{ NULL }\n" .
 307        "};\n");
 308 &emit_dump ("functions.c");
 309
 310 &create_plugin_xml_in (keys %functions);
 311
 312 # -----------------------------------------------------------------------------
 313
 314 sub cfileorder {
 315     my ($a,$b) = @_;
 316     return ((substr($a,1) cmp substr($b,1)) ||
 317             (substr($a,0,1) cmp substr($b,0,1)));
 318 }
 319
 320 # -----------------------------------------------------------------------------
 321
 322 sub distribution {
 323     my ($func,$restype,$proto,$distname,$argdescs,$psamples) = @_;
 324
 325     my $args = $proto;
 326     $args =~ s/^.*\((.*)\)\s*;$/$1/;
 327
 328     my @args = ();
 329     foreach (split (/\s*,\s*/, $args)) {
 330         my ($type,$name) = split (' ');
 331         $name = $argoverride{"$func:$name"} || $argoverride{$name} || $name;
 332         push @args, [$type,$name];
 333     }
 334
 335     # ----------------------------------------
 336     # Output help description.
 337
 338     &emit_line ();
 339     &emit ("static GnmFuncHelp const help_r_$func\[\] = {\n");
 340
 341     my $short_what = ($func =~ /^d/
 342                       ? "probability density function"
 343                       : ($func =~ /^p/
 344                          ? "cumulative distribution function"
 345                          : "probability quantile function")) .
 346                          " of the $distname distribution";
 347     &emit ("\t{ GNM_FUNC_HELP_NAME, F_(\"" . uc ("r.$func") . ":$short_what\") },\n");
 348
 349     foreach (@args) {
 350         my ($type,$name) = @{ $_ };
 351
 352         my $desc = $argdescs->{$name};
 353         if (!defined $desc) {
 354             $desc = "";
 355             warn "$0: Argument $name of r.$func has no description\n";
 356         }
 357         &emit ("\t{ GNM_FUNC_HELP_ARG, F_(\"$name:$desc\") },\n");
 358     }
 359
 360     my $what = "This function returns the " .
 361         ($func =~ /^d/
 362          ? "probability density function"
 363          : ($func =~ /^p/
 364             ? "cumulative distribution function"
 365             : "probability quantile function, i.e., the inverse of the cumulative distribution function,")) .
 366             " of the $distname distribution.";
 367     &emit ("\t{ GNM_FUNC_HELP_DESCRIPTION, F_(\"$what\") },\n");
 368
 369     my $odf = $odf_note{$func};
 370     if ($odf) {
 371         &emit ("\t{ GNM_FUNC_HELP_ODF, F_(\"$odf\") },\n");
 372     }
 373
 374     my $sdef = { 'p' => 0.3,
 375                  'give_log' => undef,
 376                  'lower_tail' => undef};
 377
 378     if ($psamples) {
 379       SAMPLE:
 380         foreach my $s (@$psamples) {
 381             my @sample_args = ();
 382           ARG:
 383             foreach (@args) {
 384                 my ($type,$name) = @{ $_ };
 385                 if (exists $s->{$name}) {
 386                     my $a = $s->{$name};
 387                     push @sample_args, $a;
 388                 } elsif (exists $sdef->{$name}) {
 389                     my $a = $sdef->{$name};
 390                     last ARG unless defined $a;
 391                     push @sample_args, $a;
 392                 } else {
 393                     next SAMPLE;
 394                 }
 395             }
 396             &emit ("\t{ GNM_FUNC_HELP_EXAMPLES, \"=r.$func(" . join (",", @sample_args) . ")\" },\n");
 397         }
 398     }
 399
 400     my $seealso = "";
 401     my $f1 = substr ($func, 1);
 402     my $F1 = uc ($f1);
 403     $seealso .= ",R.D$F1" if ($func !~ /^d/) && exists $funcs{"d$f1"};
 404     $seealso .= ",R.P$F1" if $func !~ /^p/ && exists $funcs{"p$f1"};
 405     $seealso .= ",R.Q$F1" if $func !~ /^q/ && exists $funcs{"q$f1"};
 406     $seealso =~ s/^,\s*//;
 407     if ($seealso) {
 408         &emit ("\t{ GNM_FUNC_HELP_SEEALSO, \"$seealso\" },\n");
 409     }
 410
 411     &emit ("\t{ GNM_FUNC_HELP_END }\n" .
 412            "};\n\n");
 413
 414     # ----------------------------------------
 415     # Output the function body.
 416
 417     &emit ("static GnmValue *\n" .
 418            "gnumeric_r_$func (GnmFuncEvalInfo *ei, GnmValue const * const *args)\n" .
 419            "{\n");
 420
 421     my $typespec = "";
 422     my $n = 0;
 423     foreach (@args) {
 424         my ($type,$name) = @{ $_ };
 425         my $def = $defaults{"$func:$name"};
 426         $def = 'TRUE' if $name eq 'lower_tail';
 427         $def = 'FALSE' if $name eq 'give_log' || $name eq 'log_p';
 428
 429         &emit ("\t$type $name = " .
 430                (defined ($def) ? "args[$n] ? " : "") .
 431                $type_getter{$type} . " (args[$n])" .
 432                (defined ($def) ? " : $def" : "") .
 433                ";\n");
 434
 435         if ($typespec =~ /\|/) {
 436             die "$0: argument $name for $func needs a default"
 437                 unless defined $def;
 438         } elsif (defined ($def)) {
 439             $typespec .= "|" ;
 440         }
 441         $typespec .= $type_spec{$type};
 442         $n++;
 443     }
 444
 445     &emit ("\n" .
 446            "\treturn " . $type_setter{$restype} . " (" .
 447            "$func (" . join (", ", map { $_->[1] } @args) . "));\n" .
 448            "}\n\n");
 449
 450     my $arglist = join (",", map { $_->[1] } @args);
 451
 452     my $test_status = $test_status{$func} || 'NO_TESTSUITE';
 453
 454     $funcdefs .= ("\t{\n" .
 455                   "\t\t\"r.$func\",\n" .
 456                   "\t\t\"$typespec\",\n" .
 457                   "\t\thelp_r_$func,\n" .
 458                   "\t\tgnumeric_r_$func, NULL,\n" .
 459                   "\t\tGNM_FUNC_SIMPLE, GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC, GNM_FUNC_TEST_STATUS_$test_status,\n" .
 460                   "\t},\n");
 461 }
 462
 463 # -----------------------------------------------------------------------------
 464
 465 sub emit {
 466     my ($code) = @_;
 467     $emitted .= $code;
 468 }
 469
 470 sub emit_line {
 471     &emit ("/* " . ('-' x 73) . " */\n\n");
 472 }
 473
 474 sub emit_dump {
 475     my ($filename) = @_;
 476
 477     my $tmpfilename = "$filename.new";
 478     print STDERR "Creating $filename";
 479     local (*FIL);
 480     open (FIL, ">$tmpfilename") or die "Cannot write to $tmpfilename: $!\n";
 481     print FIL $emitted;
 482     close (*FIL);
 483
 484     &update_file ($filename);
 485
 486     $emitted = "";
 487 }
 488
 489 # -----------------------------------------------------------------------------
 490
 491 sub update_file {
 492     my ($old) = @_;
 493     my ($new) = "$old.new";
 494
 495     if (!-r $old) {
 496         rename $new, $old or
 497             die "$0: Cannot rename $new to $old: $!\n";
 498         print STDERR " -- done.\n";
 499     } else {
 500         system ("cmp '$old' '$new' >/dev/null");
 501         if ($? == 0) {
 502             print STDERR " -- unchanged.\n";
 503             unlink $new;
 504         } else {
 505             rename $new, $old or
 506                 die "$0: Cannot rename $new to $old: $!\n";
 507             print STDERR " -- done.\n";
 508         }
 509     }
 510 }
 511
 512 # -----------------------------------------------------------------------------
 513
 514 sub create_plugin_xml_in {
 515     my (@funcnames) = @_;
 516
 517     &emit ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" .
 518            "<plugin id=\"Gnumeric_r\">\n" .
 519            "\t<information>\n" .
 520            "\t\t<_name>Statistical Functions</_name>\n" .
 521            "\t\t<_description>Statistical Functions with naming and calling conventions from The R Project</_description>\n" .
 522            "\t</information>\n" .
 523            "\t<loader type=\"Gnumeric_Builtin:module\">\n" .
 524            "\t\t<attribute name=\"module_file\" value=\"rstat\"/>\n" .
 525            "\t</loader>\n" .
 526            "\t<services>\n" .
 527            "\t\t<service type=\"function_group\" id=\"rstat\">\n" .
 528            "\t\t\t<_category>Statistics</_category>\n" .
 529            "\t\t\t<functions textdomain=\"gnumeric-VERSION-functions\">\n");
 530
 531     foreach my $func (sort @funcnames) {
 532         my $rfunc = "r.$func";
 533         &emit ("\t\t\t\t<function name=\"$rfunc\"/>\n");
 534     }
 535
 536     &emit ("\t\t\t</functions>\n" .
 537            "\t\t</service>\n" .
 538            "\t</services>\n" .
 539            "</plugin>\n");
 540
 541     &emit_dump ("plugin.xml.in");
 542 }
 543
 544 # -----------------------------------------------------------------------------