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
