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