/* gev_func():
* Returns the neg log likelihood of a complete or censored GEV data sample;
* in the API of the conjugate gradient descent optimizer in esl_minimizer.
*/
static double
gev_func(double *p, int nparam, void *dptr)
{
double mu, w, lambda, alpha;
struct gev_data *data;
double logL;
int i;
/* Unpack what the optimizer gave us.
*/
mu = p[0];
w = p[1]; /* w is a c.o.v. to allow unconstrained opt of lambda>0 */
lambda = exp(w);
alpha = p[2];
data = (struct gev_data *) dptr;
logL = 0.;
for (i = 0; i < data->n; i++)
logL += esl_gev_logpdf(data->x[i], mu, lambda, alpha);
if (data->is_censored)
logL += data->z * esl_gev_logcdf(data->phi, mu, lambda, alpha);
return -logL; /* goal: minimize NLL */
}
/* stats_fittest()
* Samples <n> numbers from a GEV w/ parameters <mu>, <lambda>, <alpha>;
* then fits to a GEV and print info about how good the fit is.
*
* Repeat this <ntrials> times.
*
* For each trial, outputs a line to <fp>:
* <trial> <nll> <est_nll> <est_mu> <mu %error> <est_lambda> <%err>\
* <est_alpha> <%err> <est E-val at parametric E=1>
*
* Each sampled set is done with the random number generator seeded to
* the trial number. This should make each set reproducible and
* identical to the sets used to test R's fitting.
*
* xref STL9/191; xref 2005/0718-weibull-debugging
*/
static int
stats_fittest(FILE *fp, int ntrials, int n, double mu, double lambda, double alpha)
{
ESL_RANDOMNESS *r = NULL;
double *x = NULL;
int i;
int trial;
double est_mu, est_lambda, est_alpha;
double z;
double nll, est_nll;
int status;
ESL_ALLOC(x, sizeof(double) * n);
for (trial = 1; trial <= ntrials; trial++)
{
r = esl_randomness_Create(trial);
nll = 0.;
for (i = 0; i < n; i++)
{
x[i] = esl_gev_Sample(r, mu, lambda, alpha);
nll -= esl_gev_logpdf(x[i], mu, lambda, alpha);
}
esl_randomness_Destroy(r);
esl_gev_FitComplete(x, n, &est_mu, &est_lambda, &est_alpha);
est_nll = 0.;
for (i = 0; i < n; i++)
est_nll -= esl_gev_logpdf(x[i], est_mu, est_lambda, est_alpha);
z = mu + (exp(-alpha*log(1/(double)n)) - 1 ) / (alpha*lambda);/* x at E=1*/
z = (double) n * esl_gev_surv(z, est_mu, est_lambda, est_alpha); /* E at x */
printf("%4d %10.2f %10.2f %8.3f %8.3f %8.5f %8.3f %8.5f %8.3f %6.4f\n",
trial, nll, est_nll,
est_mu, 100* fabs((est_mu-mu)/mu),
est_lambda, 100* fabs((est_lambda-lambda)/lambda),
est_alpha, 100* fabs((est_alpha-alpha)/alpha),
z);
}
free(x);
return eslOK;
ERROR:
return status;
}
/* Function: esl_mixgev_logpdf()
*
* Purpose: Returns the log of the PDF ($\log P(X=x)$) for quantile <x>,
* given mixture GEV parameters <mg>.
*/
double
esl_mixgev_logpdf(double x, ESL_MIXGEV *mg)
{
int k;
for (k = 0; k < mg->K; k++)
if (mg->q[k] == 0.0)
mg->wrk[k] = -eslINFINITY;
else
mg->wrk[k] = log(mg->q[k]) +
esl_gev_logpdf(x, mg->mu[k], mg->lambda[k], mg->alpha[k]);
return esl_vec_DLogSum(mg->wrk, mg->K);
}
int
main(int argc, char **argv)
{
FILE *fp;
double mu = 0.0;
double lambda = 1.0;
double xmin = -20.;
double xmax = 60.;
double xstep = 0.1;
double x,z;
int do_test[MAX_STATS_TESTS+1];
int i;
for (i = 0; i <= MAX_STATS_TESTS; i++) do_test[i] = 0;
for (i = 1; i < argc; i++)
do_test[atoi(argv[i])] = 1;
/* stats.1: xmgrace xy file w/ densities for Gumbel, Frechet, Weibull */
if (do_test[1]) {
if ((fp = fopen("stats.1", "w")) == NULL) abort();
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_pdf(x, mu, lambda, 0.0));
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_pdf(x, mu, lambda, 0.1));
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_pdf(x, mu, lambda, -0.1));
fprintf(fp, "&\n");
fclose(fp);
}
/* stats.2: xmgrace xy file w/ log densities for Gumbel, Frechet, Weibull */
if (do_test[2]) {
if ((fp = fopen("stats.2", "w")) == NULL) abort();
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logpdf(x, mu, lambda, 0.0);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logpdf(x, mu, lambda, 0.1);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logpdf(x, mu, lambda, -0.1);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
fclose(fp);
}
/* stats.3: xmgrace xy file w/ CDF for Gumbel, Frechet, Weibull */
if (do_test[3]) {
if ((fp = fopen("stats.3", "w")) == NULL) abort();
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_cdf(x, mu, lambda, 0.0));
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_cdf(x, mu, lambda, 0.6));
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_cdf(x, mu, lambda, -0.6));
fprintf(fp, "&\n");
fclose(fp);
}
/* stats.4: xmgrace xy file w/ logCDF for Gumbel, Frechet, Weibull */
if (do_test[4]) {
if ((fp = fopen("stats.4", "w")) == NULL) abort();
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logcdf(x, mu, lambda, 0.0);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logcdf(x, mu, lambda, 0.2);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logcdf(x, mu, lambda, -0.2);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
fclose(fp);
}
/* stats.5: xmgrace xy file w/ surv for Gumbel, Frechet, Weibull */
if (do_test[5]) {
if ((fp = fopen("stats.5", "w")) == NULL) abort();
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_surv(x, mu, lambda, 0.0));
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_surv(x, mu, lambda, 0.6));
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep)
fprintf(fp, "%.1f %9.7f\n", x, esl_gev_surv(x, mu, lambda, -0.6));
fprintf(fp, "&\n");
fclose(fp);
}
/* stats.6: xmgrace xy file w/ logsurv for Gumbel, Frechet, Weibull */
if (do_test[6]) {
if ((fp = fopen("stats.6", "w")) == NULL) abort();
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logsurv(x, mu, lambda, 0.0);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logsurv(x, mu, lambda, 0.2);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
for (x = xmin; x <= xmax; x+= xstep) {
z = esl_gev_logsurv(x, mu, lambda, -0.2);
if (finite(z)) fprintf(fp, "%.1f %9.7f\n", x, z);
}
fprintf(fp, "&\n");
fclose(fp);
}
/* stats.7. R input file of 10,000 random GEV samples.
*/
if (do_test[7]) {
if ((fp = fopen("stats.7", "w")) == NULL) abort();
stats_sample(fp);
fclose(fp);
}
/* stats.8. Test 500 fits of the Frechet.
*/
if (do_test[8]) {
if ((fp = fopen("stats.8", "w")) == NULL) abort();
stats_fittest(fp, 500, 10000, mu, lambda, 0.2);
fclose(fp);
}
/* stats.9. Test 500 fits of the near-Gumbel
*/
if (do_test[9]) {
if ((fp = fopen("stats.9", "w")) == NULL) abort();
stats_fittest(fp, 500, 10000, mu, lambda, 0.00001);
fclose(fp);
}
/* stats.10. Test 500 fits of the Weibull
*/
if (do_test[10]) {
if ((fp = fopen("stats.10", "w")) == NULL) abort();
stats_fittest(fp, 500, 10000, mu, lambda, -0.2);
fclose(fp);
}
return 0;
}
