void gsl_complex_arccos (complex_t const *a, complex_t *res) { /* z = arccos(a) */ gnm_float R = GSL_REAL (a), I = GSL_IMAG (a); if (I == 0) { gsl_complex_arccos_real (R, res); } else { gnm_float x = gnm_abs (R); gnm_float y = gnm_abs (I); gnm_float r = gnm_hypot (x + 1, y); gnm_float s = gnm_hypot (x - 1, y); gnm_float A = 0.5 * (r + s); gnm_float B = x / A; gnm_float y2 = y * y; gnm_float real, imag; const gnm_float A_crossover = 1.5; const gnm_float B_crossover = 0.6417; if (B <= B_crossover) { real = gnm_acos (B); } else { if (x <= 1) { gnm_float D = 0.5 * (A + x) * (y2 / (r + x + 1) + (s + (1 - x))); real = gnm_atan (gnm_sqrt (D) / x); } else { gnm_float Apx = A + x; gnm_float D = 0.5 * (Apx / (r + x + 1) + Apx / (s + (x - 1))); real = gnm_atan ((y * gnm_sqrt (D)) / x); } } if (A <= A_crossover) { gnm_float Am1; if (x < 1) { Am1 = 0.5 * (y2 / (r + (x + 1)) + y2 / (s + (1 - x))); } else { Am1 = 0.5 * (y2 / (r + (x + 1)) + (s + (x - 1))); } imag = gnm_log1p (Am1 + gnm_sqrt (Am1 * (A + 1))); } else { imag = gnm_log (A + gnm_sqrt (A * A - 1)); } complex_init (res, (R >= 0) ? real : M_PIgnum - real, (I >= 0) ? -imag : imag); } }
static gnm_float lgammacor(gnm_float x) { static const gnm_float algmcs[15] = { GNM_const(+.1666389480451863247205729650822e+0), GNM_const(-.1384948176067563840732986059135e-4), GNM_const(+.9810825646924729426157171547487e-8), GNM_const(-.1809129475572494194263306266719e-10), GNM_const(+.6221098041892605227126015543416e-13), GNM_const(-.3399615005417721944303330599666e-15), GNM_const(+.2683181998482698748957538846666e-17), GNM_const(-.2868042435334643284144622399999e-19), GNM_const(+.3962837061046434803679306666666e-21), GNM_const(-.6831888753985766870111999999999e-23), GNM_const(+.1429227355942498147573333333333e-24), GNM_const(-.3547598158101070547199999999999e-26), GNM_const(+.1025680058010470912000000000000e-27), GNM_const(-.3401102254316748799999999999999e-29), GNM_const(+.1276642195630062933333333333333e-30) }; gnm_float tmp; #ifdef NOMORE_FOR_THREADS static int nalgm = 0; static gnm_float xbig = 0, xmax = 0; /* Initialize machine dependent constants, the first time gamma() is called. FIXME for threads ! */ if (nalgm == 0) { /* For IEEE gnm_float precision : nalgm = 5 */ nalgm = chebyshev_init(algmcs, 15, GNM_EPSILON/2);/*was d1mach(3)*/ xbig = 1 / gnm_sqrt(GNM_EPSILON/2); /* ~ 94906265.6 for IEEE gnm_float */ xmax = gnm_exp(fmin2(gnm_log(GNM_MAX / 12), -gnm_log(12 * GNM_MIN))); /* = GNM_MAX / 48 ~= 3.745e306 for IEEE gnm_float */ } #else /* For IEEE gnm_float precision GNM_EPSILON = 2^-52 = GNM_const(2.220446049250313e-16) : * xbig = 2 ^ 26.5 * xmax = GNM_MAX / 48 = 2^1020 / 3 */ # define nalgm 5 # define xbig GNM_const(94906265.62425156) # define xmax GNM_const(3.745194030963158e306) #endif if (x < 10) ML_ERR_return_NAN else if (x >= xmax) { ML_ERROR(ME_UNDERFLOW); return ML_UNDERFLOW; } else if (x < xbig) { tmp = 10 / x; return chebyshev_eval(tmp * tmp * 2 - 1, algmcs, nalgm) / x; } else return 1 / (x * 12); }
gnm_float dst (gnm_float x, gnm_float n, gnm_float shape, gboolean give_log) { if (shape == 0.) return dt (x, n, give_log); else { gnm_float pdf = dt (x, n, give_log); gnm_float cdf = pt (shape * x * gnm_sqrt ((n + 1)/(x * x + n)), n + 1, TRUE, give_log); return ((give_log) ? (gnm_log (2.) + pdf + cdf) : (2. * pdf * cdf)); } }
gnm_float dst (gnm_float x, gnm_float n, gnm_float shape, gboolean give_log) { if (n <= 0 || gnm_isnan (x) || gnm_isnan (n) || gnm_isnan (shape)) return gnm_nan; if (shape == 0.) return dt (x, n, give_log); else { gnm_float pdf = dt (x, n, give_log); gnm_float cdf = pt (shape * x * gnm_sqrt ((n + 1)/(x * x + n)), n + 1, TRUE, give_log); return give_log ? (M_LN2gnum + pdf + cdf) : (2. * pdf * cdf); } }
static gboolean rosenbrock_iter (GnmNlsolve *nl) { GnmSolver *sol = nl->parent; const int n = nl->vars->len; int i, j; const gnm_float alpha = 3; const gnm_float beta = 0.5; gboolean any_at_all = FALSE; gnm_float *d, **A, *x, *dx, *t; char *state; int dones = 0; gnm_float ykm1 = nl->yk, *xkm1; gnm_float eps = gnm_pow2 (-16); int safety = 0; if (nl->tentative) { nl->tentative--; if (nl->tentative == 0) { if (nl->debug) g_printerr ("Tentative move rejected\n"); rosenbrock_tentative_end (nl, FALSE); } } if (nl->k % 20 == 0) { for (i = 0; i < n; i++) for (j = 0; j < n; j++) nl->xi[i][j] = (i == j); } A = g_new (gnm_float *, n); for (i = 0; i < n; i++) A[i] = g_new (gnm_float, n); dx = g_new (gnm_float, n); for (i = 0; i < n; i++) dx[i] = 0; x = g_new (gnm_float, n); t = g_new (gnm_float, n); d = g_new (gnm_float, n); for (i = 0; i < n; i++) { d[i] = (nl->xk[i] == 0) ? eps : gnm_abs (nl->xk[i]) * eps; } xkm1 = g_memdup (nl->xk, n * sizeof (gnm_float)); state = g_new0 (char, n); while (dones < n) { /* * A safety that shouldn't get hit, but might if the function * being optimized is non-deterministic. */ if (safety++ > n * GNM_MANT_DIG) break; for (i = 0; i < n; i++) { gnm_float y; if (state[i] == 2) continue; /* x = xk + (d[i] * xi[i]) */ for (j = 0; j < n; j++) x[j] = nl->xk[j] + d[i] * nl->xi[i][j]; set_vector (nl, x); y = get_value (nl); if (y <= nl->yk && gnm_solver_check_constraints (sol)) { if (y < nl->yk) { nl->yk = y; memcpy (nl->xk, x, n * sizeof (gnm_float)); dx[i] += d[i]; any_at_all = TRUE; } switch (state[i]) { case 0: state[i] = 1; /* Fall through */ case 1: d[i] *= alpha; break; default: case 2: break; } } else { switch (state[i]) { case 1: state[i] = 2; dones++; /* Fall through */ case 0: d[i] *= -beta; break; default: case 2: /* No sign change. */ d[i] *= 0.5; break; } } } } if (any_at_all) { gnm_float div, sum; for (j = n - 1; j >= 0; j--) for (i = 0; i < n; i++) A[j][i] = (j == n - 1 ? 0 : A[j + 1][i]) + dx[j] * nl->xi[j][i]; sum = 0; for (i = n - 1; i >= 0; i--) { sum += dx[i] * dx[i]; t[i] = sum; } for (i = n - 1; i > 0; i--) { div = gnm_sqrt (t[i - 1] * t[i]); if (div != 0) for (j = 0; j < n; j++) { nl->xi[i][j] = (dx[i - 1] * A[i][j] - nl->xi[i - 1][j] * t[i]) / div; g_assert (gnm_finite (nl->xi[i][j])); } } gnm_range_hypot (dx, n, &div); if (div != 0) { for (i = 0; i < n; i++) { nl->xi[0][i] = A[0][i] / div; if (!gnm_finite (nl->xi[0][i])) { g_printerr ("%g %g %g\n", div, A[0][i], nl->xi[0][i]); g_assert (gnm_finite (nl->xi[0][i])); } } } /* ---------------------------------------- */ if (!nl->tentative) { set_vector (nl, nl->xk); gnm_nlsolve_set_solution (nl); } if (nl->tentative) { if (nl->yk < nl->tentative_yk) { if (nl->debug) g_printerr ("Tentative move accepted!\n"); rosenbrock_tentative_end (nl, TRUE); } } else if (gnm_abs (nl->yk - ykm1) > gnm_abs (ykm1) * 0.01) { /* A big step. */ nl->smallsteps = 0; } else { nl->smallsteps++; } if (!nl->tentative && nl->smallsteps > 50) { gnm_float yk = nl->yk; nl->tentative = 10; nl->tentative_xk = g_memdup (nl->xk, n * sizeof (gnm_float)); nl->tentative_yk = yk; for (i = 0; i < 4; i++) { gnm_float ymax = yk + gnm_abs (yk) * (0.10 / (i + 1)); if (i > 0) ymax = MIN (ymax, nl->yk); if (!newton_improve (nl, nl->xk, &nl->yk, ymax)) break; } if (nl->debug) print_vector ("Tentative move to", nl->xk, n); } } g_free (x); g_free (xkm1); g_free (dx); g_free (t); g_free (d); free_matrix (A, n); g_free (state); return any_at_all; }
gnm_float pst (gnm_float x, gnm_float n, gnm_float shape, gboolean lower_tail, gboolean log_p) { gnm_float p; if (n <= 0 || gnm_isnan (x) || gnm_isnan (n) || gnm_isnan (shape)) return gnm_nan; if (shape == 0.) return pt (x, n, lower_tail, log_p); if (n > 100) { /* Approximation */ return psnorm (x, shape, 0.0, 1.0, lower_tail, log_p); } /* Flip to a lower-tail problem. */ if (!lower_tail) { x = -x; shape = -shape; lower_tail = !lower_tail; } /* Generic fallback. */ if (log_p) gnm_log (pst (x, n, shape, TRUE, FALSE)); if (n != gnm_floor (n)) { /* We would need numerical integration for this. */ return gnm_nan; } /* * Use recurrence formula from "Recurrent relations for * distributions of a skew-t and a linear combination of order * statistics form a bivariate-t", Computational Statistics * and Data Analysis volume 52, 2009 by Jamallizadeh, * Khosravi, Balakrishnan. * * This brings us down to n==1 or n==2 for which explicit formulas * are available. */ p = 0; while (n > 2) { double a, lb, c, d, pv, v = n - 1; d = v == 2 ? M_LN2gnum - gnm_log (M_PIgnum) + gnm_log (3) / 2 : (0.5 + M_LN2gnum / 2 - gnm_log (M_PIgnum) / 2 + v / 2 * (gnm_log1p (-1 / (v - 1)) + gnm_log (v + 1)) - 0.5 * (gnm_log (v - 2) + gnm_log (v + 1)) + stirlerr (v / 2 - 1) - stirlerr ((v - 1) / 2)); a = v + 1 + x * x; lb = (d - gnm_log (a) * v / 2); c = pt (gnm_sqrt (v) * shape * x / gnm_sqrt (a), v, TRUE, FALSE); pv = x * gnm_exp (lb) * c; p += pv; n -= 2; x *= gnm_sqrt ((v - 1) / (v + 1)); } g_return_val_if_fail (n == 1 || n == 2, gnm_nan); if (n == 1) { gnm_float p1; p1 = (gnm_atan (x) + gnm_acos (shape / gnm_sqrt ((1 + shape * shape) * (1 + x * x)))) / M_PIgnum; p += p1; } else if (n == 2) { gnm_float p2, f; f = x / gnm_sqrt (2 + x * x); p2 = (gnm_atan_mpihalf (shape) + f * gnm_atan_mpihalf (-shape * f)) / -M_PIgnum; p += p2; } else { return gnm_nan; } /* * Negatives can occur due to rounding errors and hopefully for no * other reason. */ p = CLAMP (p, 0.0, 1.0); return p; }
static GnmValue * gnumeric_periodogram (GnmFuncEvalInfo *ei, GnmValue const * const *argv) { gnm_float *ord, *absc; int filter, interp; int n0, n1, nb; GnmValue *error = NULL; GnmValue *res; CollectFlags flags; GnmEvalPos const * const ep = ei->pos; GnmValue const * const Pt = argv[0]; int i; GSList *missing0 = NULL, *missing1 = NULL; gnm_complex *in, *out = NULL; int const cols = value_area_get_width (Pt, ep); int const rows = value_area_get_height (Pt, ep); if (cols == 1) nb=rows; else { if (rows == 1) nb=cols; else nb=0; } if (nb == 0) { res = value_new_error_std (ei->pos, GNM_ERROR_VALUE); return res; } flags=COLLECT_IGNORE_BLANKS | COLLECT_IGNORE_STRINGS | COLLECT_IGNORE_BOOLS; ord = collect_floats_value_with_info (argv[0], ei->pos, flags, &n0, &missing0, &error); if (error) { g_slist_free (missing0); return error; } if (n0 == 0) { res = value_new_error_std (ei->pos, GNM_ERROR_VALUE); return res; } if (argv[1]) { filter = (int) gnm_floor (value_get_as_float (argv[1])); if (filter < 0 || filter > FILTER_WELCH) { g_slist_free (missing0); g_free (ord); res = value_new_error_std (ei->pos, GNM_ERROR_VALUE); return res; } } else filter = FILTER_NONE; if (argv[2]) { gnm_float *interpolated, *new_ord, start, incr; int n2; INTERPPROC(interpproc) = NULL; absc = collect_floats_value_with_info (argv[2], ei->pos, flags, &n1, &missing1, &error); if (n1 == 1) { g_slist_free (missing1); g_free (absc); goto no_absc; } if (error) { g_slist_free (missing0); g_slist_free (missing1); g_free (absc); return error; } if (n1 == 0) { g_slist_free (missing0); g_slist_free (missing1); g_free (absc); g_free (ord); return value_new_error_std (ei->pos, GNM_ERROR_VALUE); } if (argv[3]) { interp = (int) gnm_floor (value_get_as_float (argv[3])); if (interp < 0 || interp > INTERPOLATION_SPLINE_AVG) { g_slist_free (missing0); g_slist_free (missing1); g_free (absc); g_free (ord); return error; } } else interp = INTERPOLATION_LINEAR; if (missing0 || missing1) { GSList *missing = gnm_slist_sort_merge (missing0, missing1); gnm_strip_missing (ord, &n0, missing); gnm_strip_missing (absc, &n1, missing); g_slist_free (missing); if (n0 != n1) g_warning ("This should not happen. n0=%d n1=%d\n", n0, n1); } n0 = n1 = MIN (n0, n1); /* here we test if there is abscissas are always increasing, if not, an error is returned */ if (n0 < 2 || !gnm_range_increasing (absc, n0) || n0 == 0) { g_free (absc); g_free (ord); return value_new_error_std (ei->pos, GNM_ERROR_VALUE); } if (argv[4]) { n1 = (int) gnm_floor (value_get_as_float (argv[4])); if (n1 < n0) { g_free (absc); g_free (ord); return value_new_error_std (ei->pos, GNM_ERROR_VALUE); } nb = 1; while (nb < n1) nb *= 2; } else { n1 = 1; while (n1 < n0) n1 *= 2; nb = n1; } incr = (absc[n0 - 1] - absc[0]) / n1; switch (interp) { case INTERPOLATION_LINEAR: interpproc = linear_interpolation; start = absc[0]; n2 = n1; break; case INTERPOLATION_LINEAR_AVG: interpproc = linear_averaging; start = absc[0] - incr / 2.; n2 = n1 + 1; break; case INTERPOLATION_STAIRCASE: interpproc = staircase_interpolation; start = absc[0]; n2 = n1; break; case INTERPOLATION_STAIRCASE_AVG: interpproc = staircase_averaging; start = absc[0] - incr / 2.; n2 = n1 + 1; break; case INTERPOLATION_SPLINE: interpproc = spline_interpolation; start = absc[0]; n2 = n1; break; case INTERPOLATION_SPLINE_AVG: interpproc = spline_averaging; start = absc[0] - incr / 2.; n2 = n1 + 1; break; default: g_free (absc); g_free (ord); return value_new_error_std (ei->pos, GNM_ERROR_NA); } interpolated = g_new (gnm_float, n1); for (i = 0; i < n2; i++) interpolated[i] = start + i * incr; new_ord = interpproc (absc, ord, n0, interpolated, n1); g_free (ord); ord = new_ord; if (ord == NULL) { g_free (absc); g_free (interpolated); return value_new_error_std (ei->pos, GNM_ERROR_NA); } n0 = n1; } else { no_absc: /* we have no interpolation to apply, so just take the values */ if (missing0) { gnm_strip_missing (ord, &n0, missing0); g_slist_free (missing0); } nb = 1; while (nb < n0) nb *= 2; } /* Now apply the filter if any */ if (filter != FILTER_NONE) { gnm_float factor; switch (filter) { case FILTER_BARTLETT: factor = n0 / 2.; for (i = 0; i < n0; i++) ord[i] *= 1. - gnm_abs ((i / factor - 1)); break; case FILTER_HANN: factor = 2. * M_PIgnum / n0; for (i = 0; i < n0; i++) ord[i] *= 0.5 * (1 - gnm_cos (factor * i)); break; case FILTER_WELCH: factor = n0 / 2.; for (i = 0; i < n0; i++) ord[i] *= 1. - (i / factor - 1.) * (i / factor - 1.); break; } } /* Transform and return the result */ in = g_new0 (gnm_complex, nb); for (i = 0; i < n0; i++){ in[i].re = ord[i]; } g_free (ord); gnm_fourier_fft (in, nb, 1, &out, FALSE); g_free (in); nb /= 2; if (out && nb > 0) { res = value_new_array_non_init (1 , nb); res->v_array.vals[0] = g_new (GnmValue *, nb); for (i = 0; i < nb; i++) res->v_array.vals[0][i] = value_new_float (gnm_sqrt ( out[i].re * out[i].re + out[i].im * out[i].im)); g_free (out); } else