Float tweedie_logW(Float y, Float phi, Float p){
bool ok = (0 < y) && (0 < phi) && (1 < p) && (p < 2);
if (!ok) return NAN;
Float p1 = p - 1.0, p2 = 2.0 - p;
Float a = - p2 / p1, a1 = 1.0 / p1;
Float cc, w, sum_ww = 0.0, ww_max ;
double j;
/* only need the lower bound and the # terms to be stored */
int jh, jl, jd;
double jmax = 0;
Float logz = 0;
/* compute jmax for the given y > 0*/
cc = a * log(p1) - log(p2);
jmax = asDouble( fmax2(1.0, pow(y, p2) / (phi * p2)) );
logz = - a * log(y) - a1 * log(phi) + cc;
/* find bounds in the summation */
/* locate upper bound */
cc = logz + a1 + a * log(-a);
j = jmax ;
w = a1 * j ;
while (1) {
j += TWEEDIE_INCRE ;
if (j * (cc - a1 * log(j)) < (w - TWEEDIE_DROP))
break ;
}
jh = ceil(j);
/* locate lower bound */
j = jmax;
while (1) {
j -= TWEEDIE_INCRE ;
if (j < 1 || j * (cc - a1 * log(j)) < w - TWEEDIE_DROP)
break ;
}
jl = imax2(1, floor(j)) ;
jd = jh - jl + 1;
/* set limit for # terms in the sum */
int nterms = imin2(imax(&jd, 1), TWEEDIE_NTERM), iterm ;
Float *ww = Calloc(nterms, Float) ;
/* evaluate series using the finite sum*/
/* y > 0 */
sum_ww = 0.0 ;
iterm = imin2(jd, nterms) ;
for (int k = 0; k < iterm; k++) {
j = k + jl ;
ww[k] = j * logz - lgamma(1 + j) - lgamma(-a * j);
}
ww_max = dmax(ww, iterm) ;
for (int k = 0; k < iterm; k++)
sum_ww += exp(ww[k] - ww_max);
Float ans = log(sum_ww) + ww_max ;
Free(ww);
return ans;
}
void Stack_Blend_Mc2(Stack *stack, const Stack *mask1, double h1,
const Stack *mask2, double h2)
{
ASSERT(mask1->kind == GREY, "GREY mask only");
ASSERT(stack->kind == COLOR, "color canvas only");
if (mask2 == NULL) {
Stack_Blend_Mc(stack, mask1, h1);
return;
}
ASSERT(mask2->kind == GREY, "GREY mask only");
size_t i;
size_t offset = 0;
size_t nvoxel = Stack_Voxel_Number(stack);
Rgb_Color color;
Rgb_Color color2;
int r, g, b;
for (i = 0; i < nvoxel; i++) {
uint8 code = (mask1->array[i] << 1) + mask2->array[i];
double v = 0.0;
if (code > 0) {
v = 0.5 + (double) stack->array[offset] / 510.0;
if (v > 1.0) {
v = 1.0;
}
switch (code) {
case 1:
Set_Color_Hsv(&color, h2, v, v);
break;
case 2:
Set_Color_Hsv(&color, h1, v, v);
break;
case 3:
Set_Color_Hsv(&color, h1, v, v);
Set_Color_Hsv(&color2, h2, v, v);
r = color.r;
r += color2.r;
color.r = imin2(255, r);
g = color.g;
g += color2.g;
color.g = imin2(255, g);
b = color.b;
b += color2.b;
color.b = imin2(255, b);
break;
}
stack->array[offset] = color.r;
stack->array[offset + 1] = color.g;
stack->array[offset + 2] = color.b;
}
offset += 3;
}
}
void Matrix_Overlap(const dim_type dim[],const dim_type bdim[],const dim_type offset[],ndim_type ndim,dim_type op1[],dim_type op2[])
{
ndim_type i;
for(i=0; i<ndim; i++) {
op1[i*2] = imax2(0,(int)(bdim[i])-1-offset[i]);
op1[i*2+1] = imin2(bdim[i]-1,bdim[i]+dim[i]-2-offset[i]);
op2[i*2] = imax2(0,(int)(offset[i])-bdim[i]+1);
op2[i*2+1] = imin2(dim[i]-1,offset[i]);
}
}
QColor ZPunctum::highlightingColor(const QColor &color) const
{
QColor highlight;
highlight.setRed(imin2(255, color.red() + 96));
highlight.setGreen(imin2(255, color.green() + 96));
highlight.setBlue(imin2(255, color.blue() + 96));
return highlight;
}
static void
int_d2x2xk(int K, double *m, double *n, double *t, double *d)
{
int i, j, l, w, y, z;
double u, **c;
c = (double **) R_alloc(K + 1, sizeof(double *));
l = y = z = 0;
c[0] = (double *) R_alloc(1, sizeof(double));
c[0][0] = 1;
for(i = 0; i < K; i++) {
y = imax2(0, (int)(*t - *n));
z = imin2((int)*m, (int)*t);
c[i + 1] = (double *) R_alloc(l + z - y + 1, sizeof(double));
for(j = 0; j <= l + z - y; j++) c[i + 1][j] = 0;
for(j = 0; j <= z - y; j++) {
u = dhyper(j + y, *m, *n, *t, FALSE);
for(w = 0; w <= l; w++) c[i + 1][w + j] += c[i][w] * u;
}
l = l + z - y;
m++; n++; t++;
}
u = 0;
for(j = 0; j <= l; j++) u += c[K][j];
for(j = 0; j <= l; j++) d[j] = c[K][j] / u;
}
void
trl_ritz_projection(trl_matprod op,
trl_info * info, int lde, int mev, double *evec,
double *eres, int lwrk, double *wrk, double *base,
void *lparam)
{
char trans = 'T', notrans = 'N', upper = 'U', job = 'V';
double one = 1.0, zero = 0.0;
int i__1 = 1;
int i, j, ierr, nev, nsqr, nrow, iuau, irvv, lwrk2;
double d__1;
double *rvv, *uau, *wrk2, *avec;
nrow = info->nloc;
if (info->nec > 0) {
nev = info->nec + 1;
} else {
nev = imin2(info->ned, mev - 1);
if (info->lohi != 0)
nev++;
}
nsqr = nev * nev;
if (lwrk < 0) {
lwrk = 0;
}
if (base != NULL) {
avec = base;
} else if (mev > nev) {
avec = &evec[(mev - 1) * nrow];
} else {
avec = Calloc(nrow, double);
}
if (info->verbose >= 0) {
if (info->log_fp == NULL) {
trl_reopen_logfile(info);
}
if (info->log_fp)
fprintf(info->log_fp,
"TRLAN performing a separate Rayleigh-Ritz project for %d vectors.",
nev);
else
Rprintf("TRLAN performing a separate Rayleigh-Ritz project for %d vectors.",
nev);
}
/* memory allocation -- need 3*nev*nev elements, will allocate them */
/* in two consecutive blocks, uau(nev*nev), rvv(2*nev*nev) */
/* in actual use, rvv is further split in two until the last operation */
iuau = nsqr;
irvv = nsqr + nsqr;
if (lwrk >= iuau + irvv) {
uau = wrk;
rvv = &wrk[nsqr];
wrk2 = &wrk[nsqr + nsqr];
lwrk2 = lwrk - nsqr - nsqr;
} else if (lwrk >= irvv) {
rvv = wrk;
wrk2 = &wrk[nsqr];
lwrk2 = lwrk - nsqr;
uau = Calloc(nsqr, double);
} else if (lwrk >= iuau) {
static double
csignrank(int k, int n)
{
int c, u, j;
#ifndef MATHLIB_STANDALONE
R_CheckUserInterrupt();
#endif
u = n * (n + 1) / 2;
c = (u / 2);
if (k < 0 || k > u)
return 0;
if (k > c)
k = u - k;
if (n == 1)
return 1.;
if (w[0] == 1.)
return w[k];
w[0] = w[1] = 1.;
for(j=2; j < n+1; ++j) {
int i, end = imin2(j*(j+1)/2, c);
for(i=end; i >= j; --i) {
w[i] += w[i-j];
}
}
return w[k];
}
dim_type* Get_Area_Part(dim_type bdim[],dim_type dim[],dim_type start[],dim_type end[],ndim_type ndim)
{
dim_type area_dim[TZ_MATRIX_MAX_DIM];
dim_type i,j;
for(i=0; i<ndim; i++) {
if (end == NULL) {
area_dim[i] = dim[i];
} else {
area_dim[i] = end[i] + 1;
}
if (start != NULL) {
area_dim[i] -= start[i];
}
}
dim_type length = matrix_size(area_dim,ndim);
dim_type *array = (dim_type *)malloc(sizeof(dim_type)*length);
dim_type sub[TZ_MATRIX_MAX_DIM];
for(i=0; i<length; i++) {
array[i] = 1;
ind2sub(area_dim,ndim,i,sub);
for(j=0; j<ndim; j++) {
array[i] *= imin2(bdim[j]+dim[j]-2,sub[j]+start[j]+bdim[j]-1)
-imax2(sub[j]+start[j],bdim[j]-2)+1;
}
}
return array;
}
ZIntCuboid &ZIntCuboid::join(const ZIntCuboid &cuboid)
{
for (int i = 0; i < 3; i++) {
m_firstCorner[i] = imin2(m_firstCorner[i], cuboid.m_firstCorner[i]);
m_lastCorner[i] = imax2(m_lastCorner[i], cuboid.m_lastCorner[i]);
}
return *this;
}
void comp_adjfactor
(double cut_dpoi[1], int no_qf[1], int no_lmd[1],
double qf[], double lmd[], double adjfactor[1] )
{
double dpoi_low, dpoi_up, adjfactor_lmd[no_lmd[0]], lambda,
sum_dpois [no_qf[0]]; // sumalldpoi;
int m, l, l_low, l_up, L_md, L_low, L_up, L_max;
L_max = no_qf[0] - 1;
for(l = 0; l <= L_max; l++) sum_dpois [l] = 0;
for(m = 0; m < no_lmd[0]; m ++)
{
lambda = lmd[m];
//determine lower and upper starting l
L_md = floor (lambda);
L_low = imin2 (L_md, L_max);
L_up = L_low + 1;
dpoi_low = exp (-lambda+ L_low * log(lambda)- lgammafn (L_low + 1) );
dpoi_up = dpoi_low * lambda / L_up;
// summing poisson weight in lower tail
for (l_low = L_low; l_low >= 0; l_low --)
{
if (dpoi_low > cut_dpoi[0])
{
sum_dpois[l_low] += dpoi_low;
dpoi_low /= lambda/l_low;
}
else break;
}
if (L_up > L_max) continue;
// summing poisson weight in upper tail
for (l_up = L_up; l_up <= L_max; l_up ++)
{
if (dpoi_up > cut_dpoi[0])
{
sum_dpois[l_up] += dpoi_up;
dpoi_up *= lambda/(l_up+1);
}
else break;
}
}
adjfactor [0] = 0;
// sumalldpoi = 0;
for(l = 0; l <= L_max; l++) {
adjfactor [0] += qf [l] * sum_dpois[l];
// sumalldpoi += sum_dpois [l];
}
adjfactor [0] /= no_lmd[0];
}
ZIntCuboidFaceArray ZIntCuboidFace::cropBy(const ZIntCuboidFace &face) const
{
ZIntCuboidFaceArray faceArray;
if (hasOverlap(face)) {
if (isWithin(face)) {
return faceArray;
} else {
ZIntCuboidFace subface(getAxis(), isNormalPositive());
subface.setZ(getPlanePosition());
subface.set(getFirstCorner(),
Corner(getUpperBound(0), face.getLowerBound(1) - 1));
faceArray.appendValid(subface);
subface.set(Corner(getLowerBound(0),
imax2(getLowerBound(1), face.getLowerBound(1))),
Corner(face.getLowerBound(0) - 1, getUpperBound(1)));
faceArray.appendValid(subface);
subface.set(Corner(face.getUpperBound(0) + 1,
imax2(getLowerBound(1), face.getLowerBound(1))),
getLastCorner());
faceArray.appendValid(subface);
subface.set(Corner(imax2(getLowerBound(0), face.getLowerBound(0)),
face.getUpperBound(1) + 1),
Corner(imin2(getUpperBound(0), face.getUpperBound(0)),
getUpperBound(1)));
faceArray.appendValid(subface);
}
#if 0
else if (face.isWithin(*this)) {
ZIntCuboidFace subface(getAxis(), isNormalPositive());
secondCorner.set(getUpperBound(0), face.getLowerBound(1));
subface.set(getFirstCorner(), secondCorner);
faceArray.appendValid(subface);
subface.set(Corner(getLowerBound(0), face.getLowerBound(1)),
face.getCorner(2));
faceArray.appendValid(subface);
subface.set(Corner(getLowerBound(0), face.getUpperBound(1)),
getLastCorner());
faceArray.appendValid(subface);
} else {
}
#endif
} else {
void ZSparseObject::setVoxelValue(ZStack *stack)
{
#if defined(_USE_OPENVDB_2)
#ifdef _DEBUG_2
stack->save(GET_TEST_DATA_DIR + "/test.tif");
#endif
if (stack != NULL && stack->kind() == GREY) {
int z0 = stack->getOffset().getZ();
int z1 = z0 + stack->depth() - 1;
int y0 = stack->getOffset().getY();
int y1 = y0 + stack->height() - 1;
int x0 = stack->getOffset().getX();
int x1 = x0 + stack->width() - 1;
#ifdef _DEBUG_2
clear();
for (int y = y0; y <= y1; ++y) {
addStripe(z0, y);
addSegment(x0, x1);
}
#endif
size_t area = stack->width() * stack->height();
uint8_t *array = stack->array8();
for (size_t i = 0; i < getStripeNumber(); ++i) {
const ZObject3dStripe &stripe = getStripe(i);
int y = stripe.getY();
int z = stripe.getZ();
if (IS_IN_CLOSE_RANGE(z, z0, z1) &&
IS_IN_CLOSE_RANGE(y, y0, y1)) {
for (int j = 0; j < stripe.getSegmentNumber(); ++j) {
int tx0 = imax2(x0, stripe.getSegmentStart(j));
int tx1 = imin2(x1, stripe.getSegmentEnd(j));
size_t offset = area * (z - z0) + stack->width() * (y - y0) +
tx0 - x0;
for (int x = tx0; x <= tx1; ++x) {
m_voxelValueObject.setValue(x, y, z, array[offset++]);
}
}
}
}
m_voxelValueObject.repack();
}
#endif
}
void d_swap(SEXP rx, SEXP rincx, SEXP ry, SEXP rincy)
{
int
nx, ny, n,
incx = asInteger(rincx),
incy = asInteger(rincy);
double
* x, * y;
unpackVector(rx, &nx, &x);
unpackVector(ry, &ny, &y);
n = imin2(nx, ny);
cublasDswap(n, x, incx, y, incy);
checkCublasError("d_swap");
}
void d_axpy(SEXP ralpha, SEXP rx, SEXP rincx, SEXP ry, SEXP rincy)
{
int
nx, ny, n,
incx = asInteger(rincx),
incy = asInteger(rincy);
double
alpha = asReal(ralpha),
* x, * y;
unpackVector(rx, &nx, &x);
unpackVector(ry, &ny, &y);
n = imin2(nx, ny);
cublasDaxpy(n, alpha, x, incx, y, incy);
checkCublasError("d_axpy");
}
void d_rot(SEXP rx, SEXP rincx, SEXP ry, SEXP rincy, SEXP rsc, SEXP rss)
{
int
nx, ny, n,
incx = asInteger(rincx),
incy = asInteger(rincy);
double
sc = asReal(rsc),
ss = asReal(rss),
* x, * y;
unpackVector(rx, &nx, &x);
unpackVector(ry, &ny, &y);
n = imin2(nx, ny);
cublasDrot(n, x, incx, y, incy, sc, ss);
checkCublasError("d_rot");
}
void d_rotm(SEXP rx, SEXP rincx, SEXP ry, SEXP rincy, SEXP rsparam)
{
int
nx, ny, n, ns,
incx = asInteger(rincx),
incy = asInteger(rincy);
double
* sparam,
* x, * y;
unpackVector(rsparam, &ns, &sparam);
unpackVector(rx, &nx, &x);
unpackVector(ry, &ny, &y);
n = imin2(nx, ny);
cublasDrotm(n, x, incx, y, incy, sparam);
checkCublasError("d_rotm");
}
void alpha3d(int *n1, int *n2, double *xtab, double *ytab, double *xref, double *yref,
double *lambda, double *res1, double *alpha)
{
int i, j, k, test_max, in, ind1;
for(i=0; i < *n2; i++)
{
//initialisation
in=0;
for(j=0; j < *n1; j++)
{
// efficiency score calculated in the output direction
test_max=0;
for(k=0; k < 2; k++)
{if(xtab[2*j+k]<=xref[2*i+k]) // test if the xtab<xref
{test_max = test_max + 1;
}
}
if(test_max==2)
{
res1[j]=ytab[j]/yref[i];
}
else
{res1[j]=0;
in=in+1;}
}
if(in==*n1)
{lambda[i]=-1;}
else
{R_rsort(res1, *n1);
ind1=imin2(*n1-1,ftrunc(in+*alpha*(*n1-in)));
//if(ind1!=(in+*alpha*(*n1-in)))
// {ind1=ind1+1;}
lambda[i]=res1[ind1];
}
}
}
SEXP d_dot(SEXP rx, SEXP rincx, SEXP ry, SEXP rincy)
{
int
nx, ny, n,
incx = asInteger(rincx),
incy = asInteger(rincy);
double
* x, * y;
unpackVector(rx, &nx, &x);
unpackVector(ry, &ny, &y);
n = imin2(nx, ny);
SEXP out;
PROTECT(out = allocVector(REALSXP, 1));
REAL(out)[0] = cublasDdot(n, x, incx, y, incy);
checkCublasError("d_dot");
UNPROTECT(1);
return out;
}
// rhyper(NR, NB, n) -- NR 'red', NB 'blue', n drawn, how many are 'red'
double rhyper(double nn1in, double nn2in, double kkin)
{
/* extern double afc(int); */
int nn1, nn2, kk;
int ix; // return value (coerced to double at the very end)
Rboolean setup1, setup2;
/* These should become 'thread_local globals' : */
static int ks = -1, n1s = -1, n2s = -1;
static int m, minjx, maxjx;
static int k, n1, n2; // <- not allowing larger integer par
static double tn;
// II :
static double w;
// III:
static double a, d, s, xl, xr, kl, kr, lamdl, lamdr, p1, p2, p3;
/* check parameter validity */
if(!R_FINITE(nn1in) || !R_FINITE(nn2in) || !R_FINITE(kkin))
ML_ERR_return_NAN;
nn1in = R_forceint(nn1in);
nn2in = R_forceint(nn2in);
kkin = R_forceint(kkin);
if (nn1in < 0 || nn2in < 0 || kkin < 0 || kkin > nn1in + nn2in)
ML_ERR_return_NAN;
if (nn1in >= INT_MAX || nn2in >= INT_MAX || kkin >= INT_MAX) {
/* large n -- evade integer overflow (and inappropriate algorithms)
-------- */
// FIXME: Much faster to give rbinom() approx when appropriate; -> see Kuensch(1989)
// Johnson, Kotz,.. p.258 (top) mention the *four* different binomial approximations
if(kkin == 1.) { // Bernoulli
return rbinom(kkin, nn1in / (nn1in + nn2in));
}
// Slow, but safe: return F^{-1}(U) where F(.) = phyper(.) and U ~ U[0,1]
return qhyper(unif_rand(), nn1in, nn2in, kkin, FALSE, FALSE);
}
nn1 = (int)nn1in;
nn2 = (int)nn2in;
kk = (int)kkin;
/* if new parameter values, initialize */
if (nn1 != n1s || nn2 != n2s) {
setup1 = TRUE; setup2 = TRUE;
} else if (kk != ks) {
setup1 = FALSE; setup2 = TRUE;
} else {
setup1 = FALSE; setup2 = FALSE;
}
if (setup1) {
n1s = nn1;
n2s = nn2;
tn = nn1 + nn2;
if (nn1 <= nn2) {
n1 = nn1;
n2 = nn2;
} else {
n1 = nn2;
n2 = nn1;
}
}
if (setup2) {
ks = kk;
if (kk + kk >= tn) {
k = (int)(tn - kk);
} else {
k = kk;
}
}
if (setup1 || setup2) {
m = (int) ((k + 1.) * (n1 + 1.) / (tn + 2.));
minjx = imax2(0, k - n2);
maxjx = imin2(n1, k);
#ifdef DEBUG_rhyper
REprintf("rhyper(nn1=%d, nn2=%d, kk=%d), setup: floor(mean)= m=%d, jx in (%d..%d)\n",
nn1, nn2, kk, m, minjx, maxjx);
#endif
}
/* generate random variate --- Three basic cases */
if (minjx == maxjx) { /* I: degenerate distribution ---------------- */
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch I (degenerate)\n");
#endif
ix = maxjx;
goto L_finis; // return appropriate variate
} else if (m - minjx < 10) { // II: (Scaled) algorithm HIN (inverse transformation) ----
const static double scale = 1e25; // scaling factor against (early) underflow
const static double con = 57.5646273248511421;
// 25*log(10) = log(scale) { <==> exp(con) == scale }
if (setup1 || setup2) {
double lw; // log(w); w = exp(lw) * scale = exp(lw + log(scale)) = exp(lw + con)
if (k < n2) {
lw = afc(n2) + afc(n1 + n2 - k) - afc(n2 - k) - afc(n1 + n2);
} else {
lw = afc(n1) + afc( k ) - afc(k - n2) - afc(n1 + n2);
}
w = exp(lw + con);
}
double p, u;
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch II; w = %g > 0\n", w);
#endif
L10:
p = w;
ix = minjx;
u = unif_rand() * scale;
#ifdef DEBUG_rhyper
REprintf(" _new_ u = %g\n", u);
#endif
while (u > p) {
u -= p;
p *= ((double) n1 - ix) * (k - ix);
ix++;
p = p / ix / (n2 - k + ix);
#ifdef DEBUG_rhyper
REprintf(" ix=%3d, u=%11g, p=%20.14g (u-p=%g)\n", ix, u, p, u-p);
#endif
if (ix > maxjx)
goto L10;
// FIXME if(p == 0.) we also "have lost" => goto L10
}
} else { /* III : H2PE Algorithm --------------------------------------- */
double u,v;
if (setup1 || setup2) {
s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);
/* remark: d is defined in reference without int. */
/* the truncation centers the cell boundaries at 0.5 */
d = (int) (1.5 * s) + .5;
xl = m - d + .5;
xr = m + d + .5;
a = afc(m) + afc(n1 - m) + afc(k - m) + afc(n2 - k + m);
kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
- afc((int) (k - xl))
- afc((int) (n2 - k + xl)));
kr = exp(a - afc((int) (xr - 1))
- afc((int) (n1 - xr + 1))
- afc((int) (k - xr + 1))
- afc((int) (n2 - k + xr - 1)));
lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) / (k - xl + 1));
lamdr = -log((n1 - xr + 1) * (k - xr + 1) / xr / (n2 - k + xr));
p1 = d + d;
p2 = p1 + kl / lamdl;
p3 = p2 + kr / lamdr;
}
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch III {accept/reject}: (xl,xr)= (%g,%g); (lamdl,lamdr)= (%g,%g)\n",
xl, xr, lamdl,lamdr);
REprintf("-------- p123= c(%g,%g,%g)\n", p1,p2, p3);
#endif
int n_uv = 0;
L30:
u = unif_rand() * p3;
v = unif_rand();
n_uv++;
if(n_uv >= 10000) {
REprintf("rhyper() branch III: giving up after %d rejections", n_uv);
ML_ERR_return_NAN;
}
#ifdef DEBUG_rhyper
REprintf(" ... L30: new (u=%g, v ~ U[0,1])[%d]\n", u, n_uv);
#endif
if (u < p1) { /* rectangular region */
ix = (int) (xl + u);
} else if (u <= p2) { /* left tail */
ix = (int) (xl + log(v) / lamdl);
if (ix < minjx)
goto L30;
v = v * (u - p1) * lamdl;
} else { /* right tail */
ix = (int) (xr - log(v) / lamdr);
if (ix > maxjx)
goto L30;
v = v * (u - p2) * lamdr;
}
/* acceptance/rejection test */
Rboolean reject = TRUE;
if (m < 100 || ix <= 50) {
/* explicit evaluation */
/* The original algorithm (and TOMS 668) have
f = f * i * (n2 - k + i) / (n1 - i) / (k - i);
in the (m > ix) case, but the definition of the
recurrence relation on p134 shows that the +1 is
needed. */
int i;
double f = 1.0;
if (m < ix) {
for (i = m + 1; i <= ix; i++)
f = f * (n1 - i + 1) * (k - i + 1) / (n2 - k + i) / i;
} else if (m > ix) {
for (i = ix + 1; i <= m; i++)
f = f * i * (n2 - k + i) / (n1 - i + 1) / (k - i + 1);
}
if (v <= f) {
reject = FALSE;
}
} else {
const static double deltal = 0.0078;
const static double deltau = 0.0034;
double e, g, r, t, y;
double de, dg, dr, ds, dt, gl, gu, nk, nm, ub;
double xk, xm, xn, y1, ym, yn, yk, alv;
#ifdef DEBUG_rhyper
REprintf(" ... accept/reject 'large' case v=%g\n", v);
#endif
/* squeeze using upper and lower bounds */
y = ix;
y1 = y + 1.0;
ym = y - m;
yn = n1 - y + 1.0;
yk = k - y + 1.0;
nk = n2 - k + y1;
r = -ym / y1;
s = ym / yn;
t = ym / yk;
e = -ym / nk;
g = yn * yk / (y1 * nk) - 1.0;
dg = 1.0;
if (g < 0.0)
dg = 1.0 + g;
gu = g * (1.0 + g * (-0.5 + g / 3.0));
gl = gu - .25 * (g * g * g * g) / dg;
xm = m + 0.5;
xn = n1 - m + 0.5;
xk = k - m + 0.5;
nm = n2 - k + xm;
ub = y * gu - m * gl + deltau
+ xm * r * (1. + r * (-0.5 + r / 3.0))
+ xn * s * (1. + s * (-0.5 + s / 3.0))
+ xk * t * (1. + t * (-0.5 + t / 3.0))
+ nm * e * (1. + e * (-0.5 + e / 3.0));
/* test against upper bound */
alv = log(v);
if (alv > ub) {
reject = TRUE;
} else {
/* test against lower bound */
dr = xm * (r * r * r * r);
if (r < 0.0)
dr /= (1.0 + r);
ds = xn * (s * s * s * s);
if (s < 0.0)
ds /= (1.0 + s);
dt = xk * (t * t * t * t);
if (t < 0.0)
dt /= (1.0 + t);
de = nm * (e * e * e * e);
if (e < 0.0)
de /= (1.0 + e);
if (alv < ub - 0.25 * (dr + ds + dt + de)
+ (y + m) * (gl - gu) - deltal) {
reject = FALSE;
}
else {
/* * Stirling's formula to machine accuracy
*/
if (alv <= (a - afc(ix) - afc(n1 - ix)
- afc(k - ix) - afc(n2 - k + ix))) {
reject = FALSE;
} else {
reject = TRUE;
}
}
}
} // else
if (reject)
goto L30;
}
L_finis:
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
}
double igraph_rpois(double mu)
{
/* Factorial Table (0:9)! */
const double fact[10] =
{
1., 1., 2., 6., 24., 120., 720., 5040., 40320., 362880.
};
/* These are static --- persistent between calls for same mu : */
static int l, m;
static double b1, b2, c, c0, c1, c2, c3;
static double pp[36], p0, p, q, s, d, omega;
static double big_l;/* integer "w/o overflow" */
static double muprev = 0., muprev2 = 0.;/*, muold = 0.*/
/* Local Vars [initialize some for -Wall]: */
double del, difmuk= 0., E= 0., fk= 0., fx, fy, g, px, py, t, u= 0., v, x;
double pois = -1.;
int k, kflag, big_mu, new_big_mu = FALSE;
if (!R_FINITE(mu))
ML_ERR_return_NAN;
if (mu <= 0.)
return 0.;
big_mu = mu >= 10.;
if(big_mu)
new_big_mu = FALSE;
if (!(big_mu && mu == muprev)) {/* maybe compute new persistent par.s */
if (big_mu) {
new_big_mu = TRUE;
/* Case A. (recalculation of s,d,l because mu has changed):
* The poisson probabilities pk exceed the discrete normal
* probabilities fk whenever k >= m(mu).
*/
muprev = mu;
s = sqrt(mu);
d = 6. * mu * mu;
big_l = floor(mu - 1.1484);
/* = an upper bound to m(mu) for all mu >= 10.*/
}
else { /* Small mu ( < 10) -- not using normal approx. */
/* Case B. (start new table and calculate p0 if necessary) */
/*muprev = 0.;-* such that next time, mu != muprev ..*/
if (mu != muprev) {
muprev = mu;
m = imax2(1, (int) mu);
l = 0; /* pp[] is already ok up to pp[l] */
q = p0 = p = exp(-mu);
}
repeat {
/* Step U. uniform sample for inversion method */
u = RNG_UNIF01();
if (u <= p0)
return 0.;
/* Step T. table comparison until the end pp[l] of the
pp-table of cumulative poisson probabilities
(0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */
if (l != 0) {
for (k = (u <= 0.458) ? 1 : imin2(l, m); k <= l; k++)
if (u <= pp[k])
return (double)k;
if (l == 35) /* u > pp[35] */
continue;
}
/* Step C. creation of new poisson
probabilities p[l..] and their cumulatives q =: pp[k] */
l++;
for (k = l; k <= 35; k++) {
p *= mu / k;
q += p;
pp[k] = q;
if (u <= q) {
l = k;
return (double)k;
}
}
l = 35;
} /* end(repeat) */
}/* mu < 10 */
} /* end {initialize persistent vars} */
/* Only if mu >= 10 : ----------------------- */
/* Step N. normal sample */
g = mu + s * igraph_norm_rand();/* norm_rand() ~ N(0,1), standard normal */
if (g >= 0.) {
pois = floor(g);
/* Step I. immediate acceptance if pois is large enough */
if (pois >= big_l)
return pois;
/* Step S. squeeze acceptance */
fk = pois;
difmuk = mu - fk;
u = RNG_UNIF01(); /* ~ U(0,1) - sample */
if (d * u >= difmuk * difmuk * difmuk)
return pois;
}
/* Step P. preparations for steps Q and H.
(recalculations of parameters if necessary) */
if (new_big_mu || mu != muprev2) {
/* Careful! muprev2 is not always == muprev
because one might have exited in step I or S
*/
muprev2 = mu;
omega = M_1_SQRT_2PI / s;
/* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite
* approximations to the discrete normal probabilities fk. */
b1 = one_24 / mu;
b2 = 0.3 * b1 * b1;
c3 = one_7 * b1 * b2;
c2 = b2 - 15. * c3;
c1 = b1 - 6. * b2 + 45. * c3;
c0 = 1. - b1 + 3. * b2 - 15. * c3;
c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */
}
if (g >= 0.) {
/* 'Subroutine' F is called (kflag=0 for correct return) */
kflag = 0;
goto Step_F;
}
repeat {
/* Step E. Exponential Sample */
E = igraph_exp_rand(); /* ~ Exp(1) (standard exponential) */
/* sample t from the laplace 'hat'
(if t <= -0.6744 then pk < fk for all mu >= 10.) */
u = 2 * RNG_UNIF01() - 1.;
t = 1.8 + fsign(E, u);
if (t > -0.6744) {
pois = floor(mu + s * t);
fk = pois;
difmuk = mu - fk;
/* 'subroutine' F is called (kflag=1 for correct return) */
kflag = 1;
Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */
if (pois < 10) { /* use factorials from table fact[] */
px = -mu;
py = pow(mu, pois) / fact[(int)pois];
}
else {
/* Case pois >= 10 uses polynomial approximation
a0-a7 for accuracy when advisable */
del = one_12 / fk;
del = del * (1. - 4.8 * del * del);
v = difmuk / fk;
if (fabs(v) <= 0.25)
px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) *
v + a3) * v + a2) * v + a1) * v + a0)
- del;
else /* |v| > 1/4 */
px = fk * log(1. + v) - difmuk - del;
py = M_1_SQRT_2PI / sqrt(fk);
}
x = (0.5 - difmuk) / s;
x *= x;/* x^2 */
fx = -0.5 * x;
fy = omega * (((c3 * x + c2) * x + c1) * x + c0);
if (kflag > 0) {
/* Step H. Hat acceptance (E is repeated on rejection) */
if (c * fabs(u) <= py * exp(px + E) - fy * exp(fx + E))
break;
} else
/* Step Q. Quotient acceptance (rare case) */
if (fy - u * fy <= py * exp(px - fx))
break;
}/* t > -.67.. */
}
return pois;
}
static
void clowess(double *x, double *y, int n,
double f, int nsteps, double delta,
double *ys, double *rw, double *res)
{
int i, iter, j, last, m1, m2, nleft, nright, ns;
int ok;
double alpha, c1, c9, cmad, cut, d1, d2, denom, r, sc;
if (n < 2) {
ys[0] = y[0]; return;
}
/* nleft, nright, last, etc. must all be shifted to get rid of these: */
x--;
y--;
ys--;
/* at least two, at most n points */
ns = imax2(2, imin2(n, (int)(f*n + 1e-7)));
/* robustness iterations */
iter = 1;
while (iter <= nsteps+1) {
nleft = 1;
nright = ns;
last = 0; /* index of prev estimated point */
i = 1; /* index of current point */
for(;;) {
if (nright < n) {
/* move nleft, nright to right */
/* if radius decreases */
d1 = x[i] - x[nleft];
d2 = x[nright+1] - x[i];
/* if d1 <= d2 with */
/* x[nright+1] == x[nright], */
/* lowest fixes */
if (d1 > d2) {
/* radius will not */
/* decrease by */
/* move right */
nleft++;
nright++;
continue;
}
}
/* fitted value at x[i] */
lowest(&x[1], &y[1], n, &x[i], &ys[i],
nleft, nright, res, iter>1, rw, &ok);
if (!ok) ys[i] = y[i];
/* all weights zero */
/* copy over value (all rw==0) */
if (last < i-1) {
denom = x[i]-x[last];
/* skipped points -- interpolate */
/* non-zero - proof? */
for(j = last+1; j < i; j++) {
alpha = (x[j]-x[last])/denom;
ys[j] = alpha*ys[i] + (1.-alpha)*ys[last];
}
}
/* last point actually estimated */
last = i;
/* x coord of close points */
cut = x[last]+delta;
for (i = last+1; i <= n; i++) {
if (x[i] > cut)
break;
if (x[i] == x[last]) {
ys[i] = ys[last];
last = i;
}
}
i = imax2(last+1, i-1);
if (last >= n)
break;
}
/* residuals */
for(i = 0; i < n; i++)
res[i] = y[i+1] - ys[i+1];
/* overall scale estimate */
sc = 0.;
for(i = 0; i < n; i++) sc += fabs(res[i]);
sc /= n;
/* compute robustness weights */
/* except last time */
if (iter > nsteps)
break;
/* Note: The following code, biweight_{6 MAD|Ri|}
is also used in stl(), loess and several other places.
--> should provide API here (MM) */
for(i = 0 ; i < n ; i++)
rw[i] = fabs(res[i]);
/* Compute cmad := 6 * median(rw[], n) ---- */
/* FIXME: We need C API in R for Median ! */
m1 = n/2;
/* partial sort, for m1 & m2 */
rPsort((double *)rw, (int)n, (int)m1);
if(n % 2 == 0) {
m2 = n-m1-1;
rPsort((double *)rw, (int)n, (int)m2);
cmad = 3.*(rw[m1]+rw[m2]);
}
else { /* n odd */
cmad = 6.*rw[m1];
}
if(cmad < 1e-7 * sc) /* effectively zero */
break;
c9 = 0.999*cmad;
c1 = 0.001*cmad;
for(i = 0 ; i < n ; i++) {
r = fabs(res[i]);
if (r <= c1)
rw[i] = 1.;
else if (r <= c9)
rw[i] = fsquare(1.-fsquare(r/cmad));
else
rw[i] = 0.;
}
iter++;
}
}
SEXP R_cpermdist2(SEXP score_a, SEXP score_b, SEXP m_a, SEXP m_b,
SEXP retProb) {
/*
compute the joint permutation distribution of the
sum of the first m_a elements of score_a and score_b
(usually score_a = rep(1, length(score_a)) and
score_b = Data scores, Wilcoxon, Ansari ...).
In this case the exact conditional distribution
in the simple independent two-sample problem is computed.
*/
int n, im_a, im_b; /* number of observations */
SEXP H, x; /* matrix of permutations and vector
of probabilities */
int i, j, k, sum_a = 0, sum_b = 0, s_a = 0, s_b = 0, isb;
double msum = 0.0; /* little helpers */
int *iscore_a, *iscore_b; /* pointers to R structures */
double *dH, *dx;
/* some basic checks, should be improved */
if (!isVector(score_a))
error("score_a is not a vector");
n = LENGTH(score_a);
if (!isVector(score_b))
error("score_b is not a vector");
if (LENGTH(score_b) != n)
error("length of score_a and score_b differ");
iscore_a = INTEGER(score_a);
iscore_b = INTEGER(score_b);
if (TYPEOF(retProb) != LGLSXP)
error("retProb is not a logical");
im_a = INTEGER(m_a)[0]; /* cosmetics only */
im_b = INTEGER(m_b)[0];
/* compute the total sum of the scores and check if they are >= 0 */
for (i = 0; i < n; i++) {
if (iscore_a[i] < 0)
error("score_a for observation number %d is negative", i);
if (iscore_b[i] < 0)
error("score_b for observation number %d is negative", i);
sum_a += iscore_a[i];
sum_b += iscore_b[i];
}
/*
optimization according to Streitberg & Roehmel
*/
sum_a = imin2(sum_a, im_a);
sum_b = imin2(sum_b, im_b);
/*
initialize H
*/
PROTECT(H = allocVector(REALSXP, (sum_a + 1) * (sum_b + 1)));
dH = REAL(H);
for (i = 0; i <= sum_a; i++) {
isb = i * (sum_b + 1);
for (j = 0; j <= sum_b; j++) dH[isb + j] = 0.0;
}
/*
start the Shift-Algorithm with H[0,0] = 1
*/
dH[0] = 1.0;
for (k = 0; k < n; k++) {
s_a += iscore_a[k];
s_b += iscore_b[k];
/*
compute H up to row im_aand column im_b
Note:
sum_a = min(sum_a, m)
sum_b = min(sum_b, c)
*/
for (i = imin2(im_a, s_a); i >= iscore_a[k]; i--) {
isb = i * (sum_b + 1);
for (j = imin2(im_b,s_b); j >= iscore_b[k]; j--)
dH[isb + j] +=
dH[(i - iscore_a[k]) * (sum_b + 1) + (j - iscore_b[k])];
}
}
/*
return the whole matrix H
Note: use matrix(H, nrow=m_a+1, byrow=TRUE) in R
*/
if (!LOGICAL(retProb)[0]) {
UNPROTECT(1);
return(H);
} else {
PROTECT(x = allocVector(REALSXP, sum_b));
dx = REAL(x);
/*
get the values for sample size im_a (in row m) and sum it up
*/
isb = im_a * (sum_b + 1);
for (j = 0; j < sum_b; j++) {
if (!R_FINITE(dH[isb + j + 1]))
error("overflow error; cannot compute exact distribution");
dx[j] = dH[isb + j + 1];
msum += dx[j];
}
if (!R_FINITE(msum) || msum == 0.0)
error("overflow error; cannot compute exact distribution");
/*
compute probabilities and return the density x to R
the support is min(score_b):sum(score_b)
[dpq] stuff is done in R
*/
for (j = 0; j < sum_b; j++)
dx[j] = dx[j]/msum;
UNPROTECT(2);
return(x);
}
}
double rhyper(double nn1in, double nn2in, double kkin)
{
const static double con = 57.56462733;
const static double deltal = 0.0078;
const static double deltau = 0.0034;
const static double scale = 1e25;
/* extern double afc(int); */
int nn1, nn2, kk;
int i, ix;
Rboolean reject, setup1, setup2;
double e, f, g, p, r, t, u, v, y;
double de, dg, dr, ds, dt, gl, gu, nk, nm, ub;
double xk, xm, xn, y1, ym, yn, yk, alv;
/* These should become `thread_local globals' : */
static int ks = -1;
static int n1s = -1, n2s = -1;
static int k, m;
static int minjx, maxjx, n1, n2;
static double a, d, s, w;
static double tn, xl, xr, kl, kr, lamdl, lamdr, p1, p2, p3;
/* check parameter validity */
if(!R_FINITE(nn1in) || !R_FINITE(nn2in) || !R_FINITE(kkin))
ML_ERR_return_NAN;
nn1 = floor(nn1in+0.5);
nn2 = floor(nn2in+0.5);
kk = floor(kkin +0.5);
if (nn1 < 0 || nn2 < 0 || kk < 0 || kk > nn1 + nn2)
ML_ERR_return_NAN;
/* if new parameter values, initialize */
reject = TRUE;
if (nn1 != n1s || nn2 != n2s) {
setup1 = TRUE; setup2 = TRUE;
} else if (kk != ks) {
setup1 = FALSE; setup2 = TRUE;
} else {
setup1 = FALSE; setup2 = FALSE;
}
if (setup1) {
n1s = nn1;
n2s = nn2;
tn = nn1 + nn2;
if (nn1 <= nn2) {
n1 = nn1;
n2 = nn2;
} else {
n1 = nn2;
n2 = nn1;
}
}
if (setup2) {
ks = kk;
if (kk + kk >= tn) {
k = tn - kk;
} else {
k = kk;
}
}
if (setup1 || setup2) {
m = (k + 1.0) * (n1 + 1.0) / (tn + 2.0);
minjx = imax2(0, k - n2);
maxjx = imin2(n1, k);
}
/* generate random variate --- Three basic cases */
if (minjx == maxjx) { /* I: degenerate distribution ---------------- */
ix = maxjx;
/* return ix;
No, need to unmangle <TSL>*/
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
} else if (m - minjx < 10) { /* II: inverse transformation ---------- */
if (setup1 || setup2) {
if (k < n2) {
w = exp(con + afc(n2) + afc(n1 + n2 - k)
- afc(n2 - k) - afc(n1 + n2));
} else {
w = exp(con + afc(n1) + afc(k)
- afc(k - n2) - afc(n1 + n2));
}
}
L10:
p = w;
ix = minjx;
u = unif_rand() * scale;
L20:
if (u > p) {
u -= p;
p *= (n1 - ix) * (k - ix);
ix++;
p = p / ix / (n2 - k + ix);
if (ix > maxjx)
goto L10;
goto L20;
}
} else { /* III : h2pe --------------------------------------------- */
if (setup1 || setup2) {
s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);
/* remark: d is defined in reference without int. */
/* the truncation centers the cell boundaries at 0.5 */
d = (int) (1.5 * s) + .5;
xl = m - d + .5;
xr = m + d + .5;
a = afc(m) + afc(n1 - m) + afc(k - m) + afc(n2 - k + m);
kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
- afc((int) (k - xl))
- afc((int) (n2 - k + xl)));
kr = exp(a - afc((int) (xr - 1))
- afc((int) (n1 - xr + 1))
- afc((int) (k - xr + 1))
- afc((int) (n2 - k + xr - 1)));
lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) / (k - xl + 1));
lamdr = -log((n1 - xr + 1) * (k - xr + 1) / xr / (n2 - k + xr));
p1 = d + d;
p2 = p1 + kl / lamdl;
p3 = p2 + kr / lamdr;
}
L30:
u = unif_rand() * p3;
v = unif_rand();
if (u < p1) { /* rectangular region */
ix = xl + u;
} else if (u <= p2) { /* left tail */
ix = xl + log(v) / lamdl;
if (ix < minjx)
goto L30;
v = v * (u - p1) * lamdl;
} else { /* right tail */
ix = xr - log(v) / lamdr;
if (ix > maxjx)
goto L30;
v = v * (u - p2) * lamdr;
}
/* acceptance/rejection test */
if (m < 100 || ix <= 50) {
/* explicit evaluation */
/* The original algorithm (and TOMS 668) have
f = f * i * (n2 - k + i) / (n1 - i) / (k - i);
in the (m > ix) case, but the definition of the
recurrence relation on p134 shows that the +1 is
needed. */
f = 1.0;
if (m < ix) {
for (i = m + 1; i <= ix; i++)
f = f * (n1 - i + 1) * (k - i + 1) / (n2 - k + i) / i;
} else if (m > ix) {
for (i = ix + 1; i <= m; i++)
f = f * i * (n2 - k + i) / (n1 - i + 1) / (k - i + 1);
}
if (v <= f) {
reject = FALSE;
}
} else {
/* squeeze using upper and lower bounds */
y = ix;
y1 = y + 1.0;
ym = y - m;
yn = n1 - y + 1.0;
yk = k - y + 1.0;
nk = n2 - k + y1;
r = -ym / y1;
s = ym / yn;
t = ym / yk;
e = -ym / nk;
g = yn * yk / (y1 * nk) - 1.0;
dg = 1.0;
if (g < 0.0)
dg = 1.0 + g;
gu = g * (1.0 + g * (-0.5 + g / 3.0));
gl = gu - .25 * (g * g * g * g) / dg;
xm = m + 0.5;
xn = n1 - m + 0.5;
xk = k - m + 0.5;
nm = n2 - k + xm;
ub = y * gu - m * gl + deltau
+ xm * r * (1. + r * (-0.5 + r / 3.0))
+ xn * s * (1. + s * (-0.5 + s / 3.0))
+ xk * t * (1. + t * (-0.5 + t / 3.0))
+ nm * e * (1. + e * (-0.5 + e / 3.0));
/* test against upper bound */
alv = log(v);
if (alv > ub) {
reject = TRUE;
} else {
/* test against lower bound */
dr = xm * (r * r * r * r);
if (r < 0.0)
dr /= (1.0 + r);
ds = xn * (s * s * s * s);
if (s < 0.0)
ds /= (1.0 + s);
dt = xk * (t * t * t * t);
if (t < 0.0)
dt /= (1.0 + t);
de = nm * (e * e * e * e);
if (e < 0.0)
de /= (1.0 + e);
if (alv < ub - 0.25 * (dr + ds + dt + de)
+ (y + m) * (gl - gu) - deltal) {
reject = FALSE;
}
else {
/* * Stirling's formula to machine accuracy
*/
if (alv <= (a - afc(ix) - afc(n1 - ix)
- afc(k - ix) - afc(n2 - k + ix))) {
reject = FALSE;
} else {
reject = TRUE;
}
}
}
}
if (reject)
goto L30;
}
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
}
static void Y_bessel(double *x, double *alpha, long *nb,
double *by, long *ncalc)
{
/* ----------------------------------------------------------------------
This routine calculates Bessel functions Y_(N+ALPHA) (X)
for non-negative argument X, and non-negative order N+ALPHA.
Explanation of variables in the calling sequence
X - Non-negative argument for which
Y's are to be calculated.
ALPHA - Fractional part of order for which
Y's are to be calculated. 0 <= ALPHA < 1.0.
NB - Number of functions to be calculated, NB > 0.
The first function calculated is of order ALPHA, and the
last is of order (NB - 1 + ALPHA).
BY - Output vector of length NB. If the
routine terminates normally (NCALC=NB), the vector BY
contains the functions Y(ALPHA,X), ... , Y(NB-1+ALPHA,X),
If (0 < NCALC < NB), BY(I) contains correct function
values for I <= NCALC, and contains the ratios
Y(ALPHA+I-1,X)/Y(ALPHA+I-2,X) for the rest of the array.
NCALC - Output variable indicating possible errors.
Before using the vector BY, the user should check that
NCALC=NB, i.e., all orders have been calculated to
the desired accuracy. See error returns below.
*******************************************************************
Error returns
In case of an error, NCALC != NB, and not all Y's are
calculated to the desired accuracy.
NCALC < -1: An argument is out of range. For example,
NB <= 0, IZE is not 1 or 2, or IZE=1 and ABS(X) >=
XMAX. In this case, BY[0] = 0.0, the remainder of the
BY-vector is not calculated, and NCALC is set to
MIN0(NB,0)-2 so that NCALC != NB.
NCALC = -1: Y(ALPHA,X) >= XINF. The requested function
values are set to 0.0.
1 < NCALC < NB: Not all requested function values could
be calculated accurately. BY(I) contains correct function
values for I <= NCALC, and and the remaining NB-NCALC
array elements contain 0.0.
Intrinsic functions required are:
DBLE, EXP, INT, MAX, MIN, REAL, SQRT
Acknowledgement
This program draws heavily on Temme's Algol program for Y(a,x)
and Y(a+1,x) and on Campbell's programs for Y_nu(x). Temme's
scheme is used for x < THRESH, and Campbell's scheme is used
in the asymptotic region. Segments of code from both sources
have been translated into Fortran 77, merged, and heavily modified.
Modifications include parameterization of machine dependencies,
use of a new approximation for ln(gamma(x)), and built-in
protection against over/underflow.
References: "Bessel functions J_nu(x) and Y_nu(x) of float
order and float argument," Campbell, J. B.,
Comp. Phy. Comm. 18, 1979, pp. 133-142.
"On the numerical evaluation of the ordinary
Bessel function of the second kind," Temme,
N. M., J. Comput. Phys. 21, 1976, pp. 343-350.
Latest modification: March 19, 1990
Modified by: W. J. Cody
Applied Mathematics Division
Argonne National Laboratory
Argonne, IL 60439
----------------------------------------------------------------------*/
/* ----------------------------------------------------------------------
Mathematical constants
FIVPI = 5*PI
PIM5 = 5*PI - 15
----------------------------------------------------------------------*/
const static double fivpi = 15.707963267948966192;
const static double pim5 = .70796326794896619231;
/*----------------------------------------------------------------------
Coefficients for Chebyshev polynomial expansion of
1/gamma(1-x), abs(x) <= .5
----------------------------------------------------------------------*/
const static double ch[21] = { -6.7735241822398840964e-24,
-6.1455180116049879894e-23,2.9017595056104745456e-21,
1.3639417919073099464e-19,2.3826220476859635824e-18,
-9.0642907957550702534e-18,-1.4943667065169001769e-15,
-3.3919078305362211264e-14,-1.7023776642512729175e-13,
9.1609750938768647911e-12,2.4230957900482704055e-10,
1.7451364971382984243e-9,-3.3126119768180852711e-8,
-8.6592079961391259661e-7,-4.9717367041957398581e-6,
7.6309597585908126618e-5,.0012719271366545622927,
.0017063050710955562222,-.07685284084478667369,
-.28387654227602353814,.92187029365045265648 };
/* Local variables */
long i, k, na;
double alfa, div, ddiv, even, gamma, term, cosmu, sinmu,
b, c, d, e, f, g, h, p, q, r, s, d1, d2, q0, pa,pa1, qa,qa1,
en, en1, nu, ex, ya,ya1, twobyx, den, odd, aye, dmu, x2, xna;
en1 = ya = ya1 = 0; /* -Wall */
ex = *x;
nu = *alpha;
if (*nb > 0 && 0. <= nu && nu < 1.) {
if(ex < DBL_MIN || ex > xlrg_BESS_Y) {
/* Warning is not really appropriate, give
* proper limit:
* ML_ERROR(ME_RANGE, "Y_bessel"); */
*ncalc = *nb;
if(ex > xlrg_BESS_Y) by[0]= 0.; /*was ML_POSINF */
else if(ex < DBL_MIN) by[0]=ML_NEGINF;
for(i=0; i < *nb; i++)
by[i] = by[0];
return;
}
xna = ftrunc(nu + .5);
na = (long) xna;
if (na == 1) {/* <==> .5 <= *alpha < 1 <==> -5. <= nu < 0 */
nu -= xna;
}
if (nu == -.5) {
p = M_SQRT_2dPI / sqrt(ex);
ya = p * sin(ex);
ya1 = -p * cos(ex);
} else if (ex < 3.) {
/* -------------------------------------------------------------
Use Temme's scheme for small X
------------------------------------------------------------- */
b = ex * .5;
d = -log(b);
f = nu * d;
e = pow(b, -nu);
if (fabs(nu) < M_eps_sinc)
c = M_1_PI;
else
c = nu / sin(nu * M_PI);
/* ------------------------------------------------------------
Computation of sinh(f)/f
------------------------------------------------------------ */
if (fabs(f) < 1.) {
x2 = f * f;
en = 19.;
s = 1.;
for (i = 1; i <= 9; ++i) {
s = s * x2 / en / (en - 1.) + 1.;
en -= 2.;
}
} else {
s = (e - 1. / e) * .5 / f;
}
/* --------------------------------------------------------
Computation of 1/gamma(1-a) using Chebyshev polynomials */
x2 = nu * nu * 8.;
aye = ch[0];
even = 0.;
alfa = ch[1];
odd = 0.;
for (i = 3; i <= 19; i += 2) {
even = -(aye + aye + even);
aye = -even * x2 - aye + ch[i - 1];
odd = -(alfa + alfa + odd);
alfa = -odd * x2 - alfa + ch[i];
}
even = (even * .5 + aye) * x2 - aye + ch[20];
odd = (odd + alfa) * 2.;
gamma = odd * nu + even;
/* End of computation of 1/gamma(1-a)
----------------------------------------------------------- */
g = e * gamma;
e = (e + 1. / e) * .5;
f = 2. * c * (odd * e + even * s * d);
e = nu * nu;
p = g * c;
q = M_1_PI / g;
c = nu * M_PI_2;
if (fabs(c) < M_eps_sinc)
r = 1.;
else
r = sin(c) / c;
r = M_PI * c * r * r;
c = 1.;
d = -b * b;
h = 0.;
ya = f + r * q;
ya1 = p;
en = 1.;
while (fabs(g / (1. + fabs(ya))) +
fabs(h / (1. + fabs(ya1))) > DBL_EPSILON) {
f = (f * en + p + q) / (en * en - e);
c *= (d / en);
p /= en - nu;
q /= en + nu;
g = c * (f + r * q);
h = c * p - en * g;
ya += g;
ya1+= h;
en += 1.;
}
ya = -ya;
ya1 = -ya1 / b;
} else if (ex < thresh_BESS_Y) {
/* --------------------------------------------------------------
Use Temme's scheme for moderate X : 3 <= x < 16
-------------------------------------------------------------- */
c = (.5 - nu) * (.5 + nu);
b = ex + ex;
e = ex * M_1_PI * cos(nu * M_PI) / DBL_EPSILON;
e *= e;
p = 1.;
q = -ex;
r = 1. + ex * ex;
s = r;
en = 2.;
while (r * en * en < e) {
en1 = en + 1.;
d = (en - 1. + c / en) / s;
p = (en + en - p * d) / en1;
q = (-b + q * d) / en1;
s = p * p + q * q;
r *= s;
en = en1;
}
f = p / s;
p = f;
g = -q / s;
q = g;
L220:
en -= 1.;
if (en > 0.) {
r = en1 * (2. - p) - 2.;
s = b + en1 * q;
d = (en - 1. + c / en) / (r * r + s * s);
p = d * r;
q = d * s;
e = f + 1.;
f = p * e - g * q;
g = q * e + p * g;
en1 = en;
goto L220;
}
f = 1. + f;
d = f * f + g * g;
pa = f / d;
qa = -g / d;
d = nu + .5 - p;
q += ex;
pa1 = (pa * q - qa * d) / ex;
qa1 = (qa * q + pa * d) / ex;
b = ex - M_PI_2 * (nu + .5);
c = cos(b);
s = sin(b);
d = M_SQRT_2dPI / sqrt(ex);
ya = d * (pa * s + qa * c);
ya1 = d * (qa1 * s - pa1 * c);
} else { /* x > thresh_BESS_Y */
/* ----------------------------------------------------------
Use Campbell's asymptotic scheme.
---------------------------------------------------------- */
na = 0;
d1 = ftrunc(ex / fivpi);
i = (long) d1;
dmu = ex - 15. * d1 - d1 * pim5 - (*alpha + .5) * M_PI_2;
if (i - (i / 2 << 1) == 0) {
cosmu = cos(dmu);
sinmu = sin(dmu);
} else {
cosmu = -cos(dmu);
sinmu = -sin(dmu);
}
ddiv = 8. * ex;
dmu = *alpha;
den = sqrt(ex);
for (k = 1; k <= 2; ++k) {
p = cosmu;
cosmu = sinmu;
sinmu = -p;
d1 = (2. * dmu - 1.) * (2. * dmu + 1.);
d2 = 0.;
div = ddiv;
p = 0.;
q = 0.;
q0 = d1 / div;
term = q0;
for (i = 2; i <= 20; ++i) {
d2 += 8.;
d1 -= d2;
div += ddiv;
term = -term * d1 / div;
p += term;
d2 += 8.;
d1 -= d2;
div += ddiv;
term *= (d1 / div);
q += term;
if (fabs(term) <= DBL_EPSILON) {
break;
}
}
p += 1.;
q += q0;
if (k == 1)
ya = M_SQRT_2dPI * (p * cosmu - q * sinmu) / den;
else
ya1 = M_SQRT_2dPI * (p * cosmu - q * sinmu) / den;
dmu += 1.;
}
}
if (na == 1) {
h = 2. * (nu + 1.) / ex;
if (h > 1.) {
if (fabs(ya1) > DBL_MAX / h) {
h = 0.;
ya = 0.;
}
}
h = h * ya1 - ya;
ya = ya1;
ya1 = h;
}
/* ---------------------------------------------------------------
Now have first one or two Y's
--------------------------------------------------------------- */
by[0] = ya;
*ncalc = 1;
if(*nb > 1) {
by[1] = ya1;
if (ya1 != 0.) {
aye = 1. + *alpha;
twobyx = 2. / ex;
*ncalc = 2;
for (i = 2; i < *nb; ++i) {
if (twobyx < 1.) {
if (fabs(by[i - 1]) * twobyx >= DBL_MAX / aye)
goto L450;
} else {
if (fabs(by[i - 1]) >= DBL_MAX / aye / twobyx)
goto L450;
}
by[i] = twobyx * aye * by[i - 1] - by[i - 2];
aye += 1.;
++(*ncalc);
}
}
}
L450:
for (i = *ncalc; i < *nb; ++i)
by[i] = ML_NEGINF;/* was 0 */
} else {
by[0] = 0.;
*ncalc = imin2(*nb,0) - 1;
}
}
/*
Efficient calculation of the conditional log likelihood, along with
the score and information matrix, for a single stratum.
Input parameters:
X T x m matrix of covariate values
y T-vector that indicates if an individual is a case (y[t]==1)
or control (y[t]==0)
T Number of individuals in the stratum
m Number of covariates
offset Vector of offsets for the linear predictor
beta m-vector of log odds ratio parameters
Output parameters:
loglik The conditional log-likelihood (scalar)
score The score function (m-vector)
info The information matrix (m x m matrix)
The contribution from this stratum will be *added* to the output
parameters, so they must be correctly initialized before calling
cloglik.
*/
static void cloglik_stratum(double const *X, int const *y, double const *offset,
int T, int m, double const *beta,
double *loglik, double *score, double *info)
{
double *f, *g, *h, *xt, *xmean;
int i,j,k,t;
int K = 0, Kp;
int iscase = 1;
double sign = 1;
double lpmax;
/* Calculate number of cases */
for (t = 0; t < T; ++t) {
if (y[t] != 0 && y[t] != 1) {
error("Invalid outcome in conditional log likelihood");
}
K += y[t];
}
if (K==0 || K==T) {
return; /* Non-informative stratum */
}
/*
If there are more cases than controls then define cases to be
those with y[t] == 0, and reverse the sign of the covariate values.
*/
if (2 * K > T ) {
K = T - K;
iscase = 0;
sign = -1;
}
/*
Calculate the maximum value of the linear predictor (lpmax) within the
stratum. This is subtracted from the linear predictor when taking
exponentials for numerical stability. Note that we must correct
the log-likelihood for this, but not the score or information matrix.
*/
lpmax = sign * offset[0];
for (i = 0; i < m; ++i) {
lpmax += sign * beta[i] * X[T*i];
}
for (t = 1; t < T; ++t) {
double lp = sign * offset[t];
for (i = 0; i < m; ++i) {
lp += sign * beta[i] * X[t + T*i];
}
if (lp > lpmax) {
lpmax = lp;
}
}
/*
Calculate the mean value of the covariates within the stratum.
This is used to improve the numerical stability of the score
and information matrix.
*/
xmean = Calloc(m, double);
for (i = 0; i < m; ++i) {
xmean[i] = 0;
for (t = 0; t < T; ++t) {
xmean[i] += sign * X[t + T*i];
}
xmean[i] /= T;
}
/* Contribution from cases */
for (t = 0; t < T; ++t) {
if (y[t] == iscase) {
loglik[0] += sign * offset[t];
for (i = 0; i < m; ++i) {
loglik[0] += sign * X[t + i*T] * beta[i];
score[i] += sign * X[t + i*T] - xmean[i];
}
loglik[0] -= lpmax;
}
}
/* Allocate and initialize workspace for recursive calculations */
Kp = K + 1;
f = Calloc(Kp, double);
g = Calloc(m * Kp, double);
h = Calloc(m * m * Kp, double);
xt = Calloc(m, double);
for (k = 0; k < Kp; ++k) {
f[k] = 0;
for (i = 0; i < m; ++i) {
g[k+Kp*i] = 0;
for (j = 0; j < m; ++j) {
h[k + Kp*(i + m*j)] = 0;
}
}
}
f[0] = 1;
/*
Recursively calculate contributions over all possible case sets
of size K.
*/
for (t = 0; t < T; ++t) {
double Ct = offset[t];
for (i = 0; i < m; ++i) {
xt[i] = sign * X[t + T*i] - xmean[i];
Ct += sign * beta[i] * X[t + T*i];
}
Ct = exp(Ct - lpmax);
for (k = imin2(K,t+1); k > 0; --k) {
for (i = 0; i < m; ++i) {
double const *gpi = g + Kp*i;
for (j = 0; j < m; ++j) {
double const *gpj = g + Kp*j;
double *hp = h + Kp*(i + m*j);
hp[k] += Ct * (hp[k-1] +
xt[i] * gpj[k-1] +
xt[j] * gpi[k-1] +
xt[i] * xt[j] * f[k-1]);
}
}
for (i = 0; i < m; ++i) {
double *gp = g + Kp*i;
gp[k] += Ct * (gp[k-1] + xt[i] * f[k-1]);
}
f[k] += Ct * f[k-1];
}
}
/* Add contributions from this stratum to the output parameters */
loglik[0] -= log(f[K]);
for (i = 0; i < m; ++i) {
double const *gpi = g + Kp*i;
score[i] -= gpi[K] / f[K];
for (j = 0; j < m; ++j) {
double const *gpj = g + Kp*j;
double const *hp = h + Kp*(i + m*j);
info[i + m*j] += hp[K]/f[K] - (gpi[K]/f[K]) * (gpj[K]/f[K]);
}
}
Free(f);
Free(g);
Free(h);
Free(xt);
Free(xmean);
}
static void fftmx(double *a, double *b, int ntot, int n, int nspan, int isn,
int m, int kt, double *at, double *ck, double *bt, double *sk,
int *np, int *nfac)
{
/* called from fft_work() */
/* Design BUG: One purpose of fft_factor() would be to compute
* ---------- nfac[] once and for all; and fft_work() [i.e. fftmx ]
* could reuse the factorization.
* However: nfac[] is `destroyed' currently in the code below
*/
double aa, aj, ajm, ajp, ak, akm, akp;
double bb, bj, bjm, bjp, bk, bkm, bkp;
double c1, c2=0, c3=0, c72, cd;
double dr, rad;
double s1, s120, s2=0, s3=0, s72, sd;
int i, inc, j, jc, jf, jj;
int k, k1, k2, k3=0, k4, kk, klim, ks, kspan, kspnn;
int lim, maxf, mm, nn, nt;
a--; b--; at--; ck--; bt--; sk--;
np--;
nfac--;/*the global one!*/
inc = abs(isn);
nt = inc*ntot;
ks = inc*nspan;
rad = M_PI_4;/* = pi/4 =^= 45 degrees */
s72 = rad/0.625;/* 72 = 45 / .625 degrees */
c72 = cos(s72);
s72 = sin(s72);
s120 = 0.5*M_SQRT_3;/* sin(120) = sqrt(3)/2 */
if(isn <= 0) {
s72 = -s72;
s120 = -s120;
rad = -rad;
} else {
#ifdef SCALING
/* scale by 1/n for isn > 0 */
ak = 1.0/n;
for(j=1 ; j<=nt ; j+=inc) {
a[j] *= ak;
b[j] *= ak;
}
#endif
}
kspan = ks;
nn = nt - inc;
jc = ks/n;
/* sin, cos values are re-initialized each lim steps */
lim = 32;
klim = lim*jc;
i = 0;
jf = 0;
maxf = nfac[m - kt];
if(kt > 0) maxf = imax2(nfac[kt],maxf);
/* compute fourier transform */
L_start:
dr = (8.0*jc)/kspan;
cd = sin(0.5*dr*rad);
cd = 2.0*cd*cd;
sd = sin(dr*rad);
kk = 1;
i++;
if( nfac[i] != 2) goto L110;
/* transform for factor of 2 (including rotation factor) */
kspan /= 2;
k1 = kspan + 2;
do {
do {
k2 = kk + kspan;
ak = a[k2];
bk = b[k2];
a[k2] = a[kk] - ak;
b[k2] = b[kk] - bk;
a[kk] += ak;
b[kk] += bk;
kk = k2 + kspan;
} while(kk <= nn);
kk -= nn;
} while(kk <= jc);
if(kk > kspan) goto L_fin;
L60:
c1 = 1.0 - cd;
s1 = sd;
mm = imin2(k1/2,klim);
goto L80;
L70:
ak = c1 - (cd*c1+sd*s1);
s1 = (sd*c1-cd*s1) + s1;
/* the following three statements compensate for truncation error. */
/* if rounded arithmetic is used (nowadays always ?!), substitute c1=ak */
#ifdef TRUNCATED_ARITHMETIC
c1 = 0.5/(ak*ak+s1*s1) + 0.5;
s1 = c1*s1;
c1 = c1*ak;
#else
c1 = ak;
#endif
L80:
do {
k2 = kk + kspan;
ak = a[kk] - a[k2];
bk = b[kk] - b[k2];
a[kk] += a[k2];
b[kk] += b[k2];
a[k2] = c1*ak - s1*bk;
b[k2] = s1*ak + c1*bk;
kk = k2 + kspan;
} while(kk < nt);
k2 = kk - nt;
c1 = -c1;
kk = k1 - k2;
if( kk > k2) goto L80;
kk += jc;
if(kk <= mm) goto L70;
if(kk >= k2) {
k1 = k1 + inc + inc;
kk = (k1-kspan)/2 + jc;
if( kk <= jc+jc) goto L60;
goto L_start;
}
s1 = ((kk-1)/jc)*dr*rad;
c1 = cos(s1);
s1 = sin(s1);
mm = imin2(k1/2,mm+klim);
goto L80;
/* transform for factor of 3 (optional code) */
L100:
k1 = kk + kspan;
k2 = k1 + kspan;
ak = a[kk];
bk = b[kk];
aj = a[k1] + a[k2];
bj = b[k1] + b[k2];
a[kk] = ak + aj;
b[kk] = bk + bj;
ak = -0.5*aj + ak;
bk = -0.5*bj + bk;
aj = (a[k1]-a[k2])*s120;
bj = (b[k1]-b[k2])*s120;
a[k1] = ak - bj;
b[k1] = bk + aj;
a[k2] = ak + bj;
b[k2] = bk - aj;
kk = k2 + kspan;
if( kk < nn) goto L100;
kk = kk - nn;
if( kk <= kspan) goto L100;
goto L290;
/* transform for factor of 4 */
L110:
if( nfac[i] != 4) goto L_f_odd;
kspnn = kspan;
kspan /= 4;
L120:
c1 = 1.0;
s1 = 0;
mm = imin2(kspan,klim);
goto L150;
L130:
c2 = c1 - (cd*c1+sd*s1);
s1 = (sd*c1-cd*s1) + s1;
/* the following three statements compensate for truncation error. */
/* if rounded arithmetic is used (nowadays always ?!), substitute c1=c2 */
#ifdef TRUNCATED_ARITHMETIC
c1 = 0.5/(c2*c2+s1*s1) + 0.5;
s1 = c1*s1;
c1 = c1*c2;
#else
c1 = c2;
#endif
L140:
c2 = c1*c1 - s1*s1;
s2 = c1*s1*2.0;
c3 = c2*c1 - s2*s1;
s3 = c2*s1 + s2*c1;
L150:
k1 = kk + kspan;
k2 = k1 + kspan;
k3 = k2 + kspan;
akp = a[kk] + a[k2];
akm = a[kk] - a[k2];
ajp = a[k1] + a[k3];
ajm = a[k1] - a[k3];
a[kk] = akp + ajp;
ajp = akp - ajp;
bkp = b[kk] + b[k2];
bkm = b[kk] - b[k2];
bjp = b[k1] + b[k3];
bjm = b[k1] - b[k3];
b[kk] = bkp + bjp;
bjp = bkp - bjp;
if( isn < 0) goto L180;
akp = akm - bjm;
akm = akm + bjm;
bkp = bkm + ajm;
bkm = bkm - ajm;
if( s1 == 0.0) goto L190;
L160:
a[k1] = akp*c1 - bkp*s1;
b[k1] = akp*s1 + bkp*c1;
a[k2] = ajp*c2 - bjp*s2;
b[k2] = ajp*s2 + bjp*c2;
a[k3] = akm*c3 - bkm*s3;
b[k3] = akm*s3 + bkm*c3;
kk = k3 + kspan;
if( kk <= nt) goto L150;
L170:
kk = kk - nt + jc;
if( kk <= mm) goto L130;
if( kk < kspan) goto L200;
kk = kk - kspan + inc;
if(kk <= jc) goto L120;
if(kspan == jc) goto L_fin;
goto L_start;
L180:
akp = akm + bjm;
akm = akm - bjm;
bkp = bkm - ajm;
bkm = bkm + ajm;
if( s1 != 0.0) goto L160;
L190:
a[k1] = akp;
b[k1] = bkp;
a[k2] = ajp;
b[k2] = bjp;
a[k3] = akm;
b[k3] = bkm;
kk = k3 + kspan;
if( kk <= nt) goto L150;
goto L170;
L200:
s1 = ((kk-1)/jc)*dr*rad;
c1 = cos(s1);
s1 = sin(s1);
mm = imin2(kspan,mm+klim);
goto L140;
/* transform for factor of 5 (optional code) */
L_f5:
c2 = c72*c72 - s72*s72;
s2 = 2.0*c72*s72;
L220:
k1 = kk + kspan;
k2 = k1 + kspan;
k3 = k2 + kspan;
k4 = k3 + kspan;
akp = a[k1] + a[k4];
akm = a[k1] - a[k4];
bkp = b[k1] + b[k4];
bkm = b[k1] - b[k4];
ajp = a[k2] + a[k3];
ajm = a[k2] - a[k3];
bjp = b[k2] + b[k3];
bjm = b[k2] - b[k3];
aa = a[kk];
bb = b[kk];
a[kk] = aa + akp + ajp;
b[kk] = bb + bkp + bjp;
ak = akp*c72 + ajp*c2 + aa;
bk = bkp*c72 + bjp*c2 + bb;
aj = akm*s72 + ajm*s2;
bj = bkm*s72 + bjm*s2;
a[k1] = ak - bj;
a[k4] = ak + bj;
b[k1] = bk + aj;
b[k4] = bk - aj;
ak = akp*c2 + ajp*c72 + aa;
bk = bkp*c2 + bjp*c72 + bb;
aj = akm*s2 - ajm*s72;
bj = bkm*s2 - bjm*s72;
a[k2] = ak - bj;
a[k3] = ak + bj;
b[k2] = bk + aj;
b[k3] = bk - aj;
kk = k4 + kspan;
if( kk < nn) goto L220;
kk = kk - nn;
if( kk <= kspan) goto L220;
goto L290;
/* transform for odd factors */
L_f_odd:
k = nfac[i];
kspnn = kspan;
kspan /= k;
if(k == 3) goto L100;
if(k == 5) goto L_f5;
if(k == jf) goto L250;
jf = k;
s1 = rad/(k/8.0);
c1 = cos(s1);
s1 = sin(s1);
ck[jf] = 1.0;
sk[jf] = 0.0;
for(j = 1; j < k; j++) { /* k is changing as well */
ck[j] = ck[k]*c1 + sk[k]*s1;
sk[j] = ck[k]*s1 - sk[k]*c1;
k--;
ck[k] = ck[j];
sk[k] = -sk[j];
}
L250:
k1 = kk;
k2 = kk + kspnn;
aa = a[kk];
bb = b[kk];
ak = aa;
bk = bb;
j = 1;
k1 = k1 + kspan;
L260:
k2 = k2 - kspan;
j++;
at[j] = a[k1] + a[k2];
ak = at[j] + ak;
bt[j] = b[k1] + b[k2];
bk = bt[j] + bk;
j++;
at[j] = a[k1] - a[k2];
bt[j] = b[k1] - b[k2];
k1 = k1 + kspan;
if( k1 < k2) goto L260;
a[kk] = ak;
b[kk] = bk;
k1 = kk;
k2 = kk + kspnn;
j = 1;
L270:
k1 += kspan;
k2 -= kspan;
jj = j;
ak = aa;
bk = bb;
aj = 0.0;
bj = 0.0;
k = 1;
for(k=2; k < jf; k++) {
ak += at[k]*ck[jj];
bk += bt[k]*ck[jj];
k++;
aj += at[k]*sk[jj];
bj += bt[k]*sk[jj];
jj += j;
if(jj > jf) jj -= jf;
}
k = jf - j;
a[k1] = ak - bj;
b[k1] = bk + aj;
a[k2] = ak + bj;
b[k2] = bk - aj;
j++;
if( j < k) goto L270;
kk = kk + kspnn;
if( kk <= nn) goto L250;
kk = kk - nn;
if( kk <= kspan) goto L250;
/* multiply by rotation factor (except for factors of 2 and 4) */
L290:
if(i == m) goto L_fin;
kk = jc + 1;
L300:
c2 = 1.0 - cd;
s1 = sd;
mm = imin2(kspan,klim);
do { /* L320: */
c1 = c2;
s2 = s1;
kk += kspan;
do { /* L330: */
do {
ak = a[kk];
a[kk] = c2*ak - s2*b[kk];
b[kk] = s2*ak + c2*b[kk];
kk += kspnn;
} while(kk <= nt);
ak = s1*s2;
s2 = s1*c2 + c1*s2;
c2 = c1*c2 - ak;
kk += -nt + kspan;
} while(kk <= kspnn);
kk += -kspnn + jc;
if(kk <= mm) { /* L310: */
c2 = c1 - (cd*c1+sd*s1);
s1 = s1 + (sd*c1-cd*s1);
/* the following three statements compensate for truncation error.*/
/* if rounded arithmetic is used (nowadays always ?!), they may be deleted. */
#ifdef TRUNCATED_ARITHMETIC
c1 = 0.5/(c2*c2+s1*s1) + 0.5;
s1 = c1*s1;
c2 = c1*c2;
#endif
continue/* goto L320*/;
}
if(kk >= kspan) {
kk = kk - kspan + jc + inc;
if( kk <= jc+jc) goto L300;
goto L_start;
}
s1 = ((kk-1)/jc)*dr*rad;
c2 = cos(s1);
s1 = sin(s1);
mm = imin2(kspan,mm+klim);
} while(1);
/*------------------------------------------------------------*/
/* permute the results to normal order---done in two stages */
/* permutation for square factors of n */
L_fin:
np[1] = ks;
if( kt == 0) goto L440;
k = kt + kt + 1;
if( m < k) k--;
np[k+1] = jc;
for(j = 1; j < k; j++, k--) {
np[j+1] = np[j]/nfac[j];
np[k] = np[k+1]*nfac[j];
}
k3 = np[k+1];
kspan = np[2];
kk = jc + 1;
k2 = kspan + 1;
j = 1;
if(n == ntot) {
/* permutation for single-variate transform (optional code) */
L370:
do {
ak = a[kk]; a[kk] = a[k2]; a[k2] = ak;
bk = b[kk]; b[kk] = b[k2]; b[k2] = bk;
kk += inc;
k2 += kspan;
} while(k2 < ks);
L380:
do { k2 -= np[j]; j++; k2 += np[j+1]; } while(k2 > np[j]);
j = 1;
do {
if(kk < k2) goto L370;
kk += inc;
k2 += kspan;
} while(k2 < ks);
if( kk < ks) goto L380;
jc = k3;
} else {
/* permutation for multivariate transform */
L400:
k = kk + jc;
do {
ak = a[kk]; a[kk] = a[k2]; a[k2] = ak;
bk = b[kk]; b[kk] = b[k2]; b[k2] = bk;
kk += inc;
k2 += inc;
} while( kk < k);
kk += ks - jc;
k2 += ks - jc;
if(kk < nt) goto L400;
k2 += - nt + kspan;
kk += - nt + jc;
if( k2 < ks) goto L400;
do {
do { k2 -= np[j]; j++; k2 += np[j+1]; } while(k2 > np[j]);
j = 1;
do {
if(kk < k2) goto L400;
kk += jc;
k2 += kspan;
} while(k2 < ks);
} while(kk < ks);
jc = k3;
}
L440:
if( 2*kt+1 >= m) return;
kspnn = np[kt+1];
/* permutation for square-free factors of n */
/* Here, nfac[] is overwritten... -- now CUMULATIVE ("cumprod") factors */
nn = m - kt;
nfac[nn+1] = 1;
for(j = nn; j > kt; j--)
nfac[j] *= nfac[j+1];
kt++;
nn = nfac[kt] - 1;
jj = 0;
j = 0;
goto L480;
L460:
jj -= k2;
k2 = kk;
k++;
kk = nfac[k];
L470:
jj += kk;
if( jj >= k2) goto L460;
np[j] = jj;
L480:
k2 = nfac[kt];
k = kt + 1;
kk = nfac[k];
j++;
if( j <= nn) goto L470;
/* determine the permutation cycles of length greater than 1 */
j = 0;
goto L500;
do {
do { k = kk; kk = np[k]; np[k] = -kk; } while(kk != j);
k3 = kk;
L500:
do { j++; kk = np[j]; } while(kk < 0);
} while(kk != j);
np[j] = -j;
if( j != nn) goto L500;
maxf *= inc;
goto L570;
/* reorder a and b, following the permutation cycles */
L_ord:
do j--; while(np[j] < 0);
jj = jc;
L520:
kspan = imin2(jj,maxf);
jj -= kspan;
k = np[j];
kk = jc*k + i + jj;
for(k1= kk + kspan, k2= 1; k1 != kk;
k1 -= inc, k2++) {
at[k2] = a[k1];
bt[k2] = b[k1];
}
do {
k1 = kk + kspan;
k2 = k1 - jc*(k+np[k]);
k = -np[k];
do {
a[k1] = a[k2];
b[k1] = b[k2];
k1 -= inc;
k2 -= inc;
} while( k1 != kk);
kk = k2;
} while(k != j);
for(k1= kk + kspan, k2= 1; k1 > kk;
k1 -= inc, k2++) {
a[k1] = at[k2];
b[k1] = bt[k2];
}
if(jj != 0) goto L520;
if( j != 1) goto L_ord;
L570:
j = k3 + 1;
nt = nt - kspnn;
i = nt - inc + 1;
if( nt >= 0) goto L_ord;
} /* fftmx */
int stem_leaf(double *x, int n, double scale, int width, double atom) {
extern int sorted_flag;
double r, c, x1, x2;
int mm, mu, k, i, j, hi, lo, xi;
int ldigits, hdigits, ndigits, pdigits;
/*R_rsort(x,n);*/
if (!sorted_flag)
qsort(x, n, sizeof(double), dbl_cmp);
if (n <= 1)
return 1;
/*Rprintf("\n");*/
printf("\n");
if (x[n-1] > x[0]) {
r = atom+(x[n-1] - x[0]) / scale;
c = pow(10.0, (11.0 - (int)(log10(r) + 10)));
mm = imin2(2, imax2(0, (int)(r * c / 25)));
k = 3 * mm + 2 - 150 / (n+50);
if ((k-1) * (k-2) * (k-5)==0)
c *= 10.;
/* need to ensure that x[i]*c does not integer overflow */
x1 = fabs(x[0]); x2 = fabs(x[n-1]);
if (x2 > x1) x1 = x2;
while (x1*c > INT_MAX) c /= 10;
if (k*(k-4)*(k-8)==0) mu = 5;
if ((k-1)*(k-5)*(k-6)==0) mu = 20;
} else {
r = atom + fabs(x[0])/scale;
c = pow(10.,(11.-(int)(log10(r)+10)));
k = 2; /* not important what */
}
mu = 10;
if (k*(k-4)*(k-8)==0) mu = 5;
if ((k-1)*(k-5)*(k-6)==0) mu = 20;
/* Find the print width of the stem. */
lo = floor(x[0] *c/mu)*mu;
hi = floor(x[n-1]*c/mu)*mu;
ldigits = (lo < 0) ? floor(log10(-lo)) + 1 : 0;
hdigits = (hi > 0) ? floor(log10(hi)) : 0;
ndigits = (ldigits < hdigits) ? hdigits : ldigits;
/* Starting cell */
if (lo < 0 && floor(x[0]*c) == lo)
lo = lo - mu;
hi = lo + mu;
if (floor(x[0] * c + 0.5) > hi) {
lo = hi;
hi = lo + mu;
}
/* Print out the info about the decimal place */
pdigits = 1 - floor(log10(c) + 0.5);
/*Rprintf(" The decimal point is ");*/
printf(" n = %d. The decimal point is ", n);
if (pdigits == 0)
/*Rprintf("at the |\n\n");*/
printf("at the |\n\n");
else
/*Rprintf("%d digit(s) to the %s of the |\n\n",abs(pdigits),
(pdigits > 0) ? "right" : "left");*/
printf("%d digit(s) to the %s of the |\n\n",abs(pdigits),
(pdigits > 0) ? "right" : "left");
i = 0;
do {
if (lo < 0)
stem_print(hi,lo,ndigits);
else
stem_print(lo,hi,ndigits);
j = 0;
do {
if (x[i] < 0)
xi = x[i]*c - .5;
else
xi = x[i]*c + .5;
if ( (hi == 0 && x[i] >= 0)||
(lo < 0 && xi > hi) ||
(lo >= 0 && xi >= hi) )
break;
j++;
if (j <= width-12) {
/*Rprintf("%1d", abs(xi)%10);*/
printf("%1d", abs(xi)%10);
}
i++;
} while (i < n);
if (j > width) {
/*Rprintf("+%d", j-width);*/
printf("+%d", j-width);
}
/*Rprintf("\n");*/
printf("\n");
if (i >= n)
break;
hi += mu;
lo += mu;
} while (1);
/*Rprintf("\n");*/
printf("\n");
return 0;
}
void orderalpha(int *n1, int *n2, int *pinput, int *qoutput, double *xtab,
double *ytab, double *xref, double *yref, double *lambda, double *output_ref,
double *theta, double *input_ref, double *gammaa, double *hyper_ref,
double *res1, double *res2, double *res3, double *alpha)
{
int i, j, k, l, test_max, test_min, in, out, ind1, ind2, ind3;
double min_ref, max_ref, minmax_ref;
for(i=0; i < *n2; i++)
{
//initialisation
in=0;
out=0;
for(j=0; j < *n1; j++)
{
// efficiency score calculated in the output direction
test_max=0;
for(k=0; k < *pinput; k++)
{if(xtab[*pinput*j+k]<=xref[*pinput*i+k]) // test if the xtab<xref
{test_max = test_max + 1;
}
}
if(test_max==*pinput)
{
min_ref=ytab[*qoutput*j]/yref[*qoutput*i];
for(l=1; l < *qoutput; l++) // research of which output
{min_ref=fmin2(min_ref, ytab[*qoutput*j+l]/yref[*qoutput*i+l]);}
// if(lambda[i]<min_ref)
// {lambda[i]=min_ref;
// output_ref[i]=j+1;
// }
res1[j]=min_ref;
}
else
{res1[j]=0;
in=in+1;}
// efficiency score calculated in the input direction
test_min=0;
for(k=0; k < *qoutput; k++)
{if(ytab[*qoutput*j+k]>=yref[*qoutput*i+k]) // test if the ytab>yref
{test_min = test_min + 1;
}
}
if(test_min==*qoutput)
{
max_ref=xtab[*pinput*j]/xref[*pinput*i];
for(l=1; l < *pinput; l++) // research of which output
{max_ref=fmax2(max_ref,xtab[*pinput*j+l]/xref[*pinput*i+l]);}
if(theta[i]==0) // initialisation of theta[i]
{theta[i]=max_ref;
input_ref[i]=j+1;
}
// if(theta[i]>max_ref)
// {theta[i]=max_ref;
// input_ref[i]=j+1;
// }
res2[j]=max_ref;
}
else
{res2[j]=999;
out=out+1;
}
// efficiency score calculated in the hyperbolic direction
max_ref=xtab[*pinput*j]/xref[*pinput*i];
for(l=1; l < *pinput; l++) // research of which output
{max_ref=fmax2(max_ref,xtab[*pinput*j+l]/xref[*pinput*i+l]);}
min_ref=yref[*qoutput*i]/ytab[*qoutput*j];
for(l=1; l < *qoutput; l++) // research of which output
{min_ref=fmax2(min_ref,yref[*qoutput*i+l]/ytab[*qoutput*j+l]);}
minmax_ref=fmax2(min_ref,max_ref);
// if(gammaa[i]>minmax_ref)
// {gammaa[i]=minmax_ref;
// hyper_ref[i]=j+1;}
res3[j]=minmax_ref;
}
if(in==*n1)
{lambda[i]=-1;}
else
{R_rsort(res1, *n1);
ind1=imin2(*n1-1,ftrunc(in+alpha[i]*(*n1-in)));
//if(ind1!=(in+*alpha*(*n1-in)))
// {ind1=ind1+1;}
lambda[i]=res1[ind1];
}
if(out==*n1)
{theta[i]=-1;}
else
{ R_rsort(res2, *n1);
ind2=ftrunc((1-alpha[i])*(*n1-out));
// if(ind2!=((1-*alpha)*(*n1-out)))
// {ind2=ind2+1;}
theta[i]=res2[ind2];}
R_rsort(res3, *n1);
ind3=ftrunc((1-alpha[i])**n1);
// if(ind3!=fround(((1-*alpha)**n1),5))
// {ind3=fmin2(ind3+1,(*n1-1));}
gammaa[i]=res3[ind3];
}
}
/* From R, currently only used for kode = 1, m = 1, n in {0,1,2,3} : */
static void dpsifn(double x, int n, int kode, int m, double *ans, int *nz, int *ierr)
{
const static double bvalues[] = { /* Bernoulli Numbers */
1.00000000000000000e+00,
-5.00000000000000000e-01,
1.66666666666666667e-01,
-3.33333333333333333e-02,
2.38095238095238095e-02,
-3.33333333333333333e-02,
7.57575757575757576e-02,
-2.53113553113553114e-01,
1.16666666666666667e+00,
-7.09215686274509804e+00,
5.49711779448621554e+01,
-5.29124242424242424e+02,
6.19212318840579710e+03,
-8.65802531135531136e+04,
1.42551716666666667e+06,
-2.72982310678160920e+07,
6.01580873900642368e+08,
-1.51163157670921569e+10,
4.29614643061166667e+11,
-1.37116552050883328e+13,
4.88332318973593167e+14,
-1.92965793419400681e+16
};
int i, j, k, mm, mx, nn, np, nx, fn;
double arg, den, elim, eps, fln, fx, rln, rxsq,
r1m4, r1m5, s, slope, t, ta, tk, tol, tols, tss, tst,
tt, t1, t2, wdtol, xdmln, xdmy, xinc, xln = 0.0 /* -Wall */,
xm, xmin, xq, yint;
double trm[23], trmr[n_max + 1];
*ierr = 0;
if (n < 0 || kode < 1 || kode > 2 || m < 1) {
*ierr = 1;
return;
}
if (x <= 0.) {
/* use Abramowitz & Stegun 6.4.7 "Reflection Formula"
* psi(k, x) = (-1)^k psi(k, 1-x) - pi^{n+1} (d/dx)^n cot(x)
*/
if (x == (long)x) {
/* non-positive integer : +Inf or NaN depends on n */
for(j=0; j < m; j++) /* k = j + n : */
ans[j] = ((j+n) % 2) ? HUGE_VAL : FP_NAN;
return;
}
/* This could cancel badly */
dpsifn(1. - x, n, /*kode = */ 1, m, ans, nz, ierr);
/* ans[j] == (-1)^(k+1) / gamma(k+1) * psi(k, 1 - x)
* for j = 0:(m-1) , k = n + j
*/
/* Cheat for now: only work for m = 1, n in {0,1,2,3} : */
if(m > 1 || n > 3) {/* doesn't happen for digamma() .. pentagamma() */
/* not yet implemented */
*ierr = 4; return;
}
x *= M_PI; /* pi * x */
if (n == 0)
tt = cos(x)/sin(x);
else if (n == 1)
tt = -1/pow(sin(x),2);
else if (n == 2)
tt = 2*cos(x)/pow(sin(x),3);
else if (n == 3)
tt = -2*(2*pow(cos(x),2) + 1)/pow(sin(x),4);
else /* can not happen! */
tt = FP_NAN;
/* end cheat */
s = (n % 2) ? -1. : 1.;/* s = (-1)^n */
/* t := pi^(n+1) * d_n(x) / gamma(n+1) , where
* d_n(x) := (d/dx)^n cot(x)*/
t1 = t2 = s = 1.;
for(k=0, j=k-n; j < m; k++, j++, s = -s) {
/* k == n+j , s = (-1)^k */
t1 *= M_PI;/* t1 == pi^(k+1) */
if(k >= 2)
t2 *= k;/* t2 == k! == gamma(k+1) */
if(j >= 0) /* by cheat above, tt === d_k(x) */
ans[j] = s*(ans[j] + t1/t2 * tt);
}
if (n == 0 && kode == 2) /* unused from R, but "wrong": xln === 0 :*/
ans[0] += xln;
return;
} /* x <= 0 */
/* else : x > 0 */
*nz = 0;
xln = log(x);
if(kode == 1 && m == 1) {/* the R case --- for very large x: */
double lrg = 1/(2. * DBL_EPSILON);
if(n == 0 && x * xln > lrg) {
ans[0] = -xln;
return;
}
else if(n >= 1 && x > n * lrg) {
ans[0] = exp(-n * xln)/n; /* == x^-n / n == 1/(n * x^n) */
return;
}
}
mm = m;
nx = imin2(-DBL_MIN_EXP, DBL_MAX_EXP);/* = 1021 */
r1m5 = M_LOG10_2;
r1m4 = DBL_EPSILON * 0.5;
wdtol = fmax(r1m4, 0.5e-18); /* 1.11e-16 */
/* elim = approximate exponential over and underflow limit */
elim = 2.302 * (nx * r1m5 - 3.0);/* = 700.6174... */
for(;;) {
nn = n + mm - 1;
fn = nn;
t = (fn + 1) * xln;
/* overflow and underflow test for small and large x */
if (fabs(t) > elim) {
if (t <= 0.0) {
*nz = 0;
*ierr = 2;
return;
}
}
else {
if (x < wdtol) {
ans[0] = pow(x, -n-1.0);
if (mm != 1) {
for(k = 1; k < mm ; k++)
ans[k] = ans[k-1] / x;
}
if (n == 0 && kode == 2)
ans[0] += xln;
return;
}
/* compute xmin and the number of terms of the series, fln+1 */
rln = r1m5 * DBL_MANT_DIG;
rln = fmin(rln, 18.06);
fln = fmax(rln, 3.0) - 3.0;
yint = 3.50 + 0.40 * fln;
slope = 0.21 + fln * (0.0006038 * fln + 0.008677);
xm = yint + slope * fn;
mx = (int)xm + 1;
xmin = mx;
if (n != 0) {
xm = -2.302 * rln - fmin(0.0, xln);
arg = xm / n;
arg = fmin(0.0, arg);
eps = exp(arg);
xm = 1.0 - eps;
if (fabs(arg) < 1.0e-3)
xm = -arg;
fln = x * xm / eps;
xm = xmin - x;
if (xm > 7.0 && fln < 15.0)
break;
}
xdmy = x;
xdmln = xln;
xinc = 0.0;
if (x < xmin) {
nx = (int)x;
xinc = xmin - nx;
xdmy = x + xinc;
xdmln = log(xdmy);
}
/* generate w(n+mm-1, x) by the asymptotic expansion */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
tk = fmax(fabs(t), fmax(fabs(t1), fabs(t2)));
if (tk <= elim) /* for all but large x */
goto L10;
}
nz++; /* underflow */
mm--;
ans[mm] = 0.;
if (mm == 0)
return;
} /* end{for()} */
nn = (int)fln + 1;
np = n + 1;
t1 = (n + 1) * xln;
t = exp(-t1);
s = t;
den = x;
for(i=1; i <= nn; i++) {
den += 1.;
trm[i] = pow(den, (double)-np);
s += trm[i];
}
ans[0] = s;
if (n == 0 && kode == 2)
ans[0] = s + xln;
if (mm != 1) { /* generate higher derivatives, j > n */
tol = wdtol / 5.0;
for(j = 1; j < mm; j++) {
t /= x;
s = t;
tols = t * tol;
den = x;
for(i=1; i <= nn; i++) {
den += 1.;
trm[i] /= den;
s += trm[i];
if (trm[i] < tols)
break;
}
ans[j] = s;
}
}
return;
L10:
tss = exp(-t);
tt = 0.5 / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0)
t1 = tt + 1.0 / fn;
rxsq = 1.0 / (xdmy * xdmy);
ta = 0.5 * rxsq;
t = (fn + 1) * ta;
s = t * bvalues[2];
if (fabs(s) >= tst) {
tk = 2.0;
for(k = 4; k <= 22; k++) {
t = t * ((tk + fn + 1)/(tk + 1.0))*((tk + fn)/(tk + 2.0)) * rxsq;
trm[k] = t * bvalues[k-1];
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
/* backward recur from xdmy to x */
nx = (int)xinc;
np = nn + 1;
if (nx > n_max) {
*nz = 0;
*ierr = 3;
return;
}
else {
if (nn==0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
/* this loop should not be changed. fx is accurate when x is small */
for(i = 1; i <= nx; i++) {
trmr[i] = pow(fx, (double)-np);
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
}
ans[mm-1] = s;
if (fn == 0)
goto L30;
/* generate lower derivatives, j < n+mm-1 */
for(j = 2; j <= mm; j++) {
fn--;
tss *= xdmy;
t1 = tt;
if (fn!=0)
t1 = tt + 1.0 / fn;
t = (fn + 1) * ta;
s = t * bvalues[2];
if (fabs(s) >= tst) {
tk = 4 + fn;
for(k=4; k <= 22; k++) {
trm[k] = trm[k] * (fn + 1) / tk;
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
if (fn == 0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
for(i=1 ; i<=nx ; i++) {
trmr[i] = trmr[i] * fx;
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
ans[mm - j] = s;
if (fn == 0)
goto L30;
}
return;
L20:
for(i = 1; i <= nx; i++)
s += 1. / (x + (nx - i)); /* avoid disastrous cancellation, PR#13714 */
L30:
if (kode != 2) /* always */
ans[0] = s - xdmln;
else if (xdmy != x) {
xq = xdmy / x;
ans[0] = s - log(xq);
}
return;
} /* dpsifn() */
static
void fuzzy(int nn, int k, double *p,
double *dp, double *pt, double *dss, double *esp, double *ef,
double *obj,/* of length 4;
* in : (cluster_only, trace_lev, compute_p, 0)
* out: (ktrue , cryt, PC ("dunn"), normalized_PC)
*/
double r, /* the exponent, > 1. -- was fixed to 2 originally */
double tol,/* the precision for the iterations */
int *nit, /* the maximal number of iterations --
originally fixed to 500 */
int trace_lev)
{
double dt, xx, ddd, crt, reen, cryt;
int p_d = nn, dp_d = nn;
int i, j, m, mi, it;
Rboolean converged = FALSE, compute_p = (int)obj[2];
if(trace_lev)
Rprintf("fanny()'s fuzzy(n = %d, k = %d):\n", nn, k);
if(compute_p) {
/* Compute initial fuzzy clustering, i.e. membership matrix p[,] */
int nd, ndk;
double p0 = 0.1 / (k - 1);
for (m = 0; m < nn; ++m)
for (j = 0; j < k; ++j)
p[m + j * p_d] = p0;
ndk = nn / k;
nd = ndk;
j = 0;
for (m = 0; m < nn; ++m) {
int jj;
p[m + j * p_d] = 0.9;
if (m+1 >= nd) {
++j;
if (j+1 == k) /* reset */
nd = nn;
else nd += ndk;
}
for (jj = 0; jj < k; ++jj)
p[m + jj * p_d] = pow(p[m + jj * p_d], r);
}
}
else { /* p[,] already contains memberships */
for (m = 0; m < nn; ++m)
for (j = 0; j < k; ++j)
p[m + j * p_d] = pow(p[m + j * p_d], r);
}
/* initial criterion value */
cryt = 0.;
for (j = 0; j < k; ++j) {
esp[j] = 0.;
ef[j] = 0.;
for (m = 0; m < nn; ++m) {
esp[j] += p[m + j * p_d];
for (i = 0; i < nn; ++i) {
if (i != m) {
mi = imin2(m,i);
mi = mi * nn - (mi + 1) * (mi + 2) / 2 + imax2(m,i);
dp[m + j * dp_d] += p[i + j * p_d] * dss[mi];
ef[j] += p[i + j * p_d] * p[m + j * p_d] * dss[mi];
}
}
}
cryt += ef[j] / (esp[j] * 2.);
}
crt = cryt;
if(trace_lev) {
Rprintf("fuzzy(): initial obj = %g\n", cryt);
if(trace_lev >= 2) {
Rprintf(" ef[]= (");
for(j=0; j < k; j++) Rprintf(" %g%s", ef[j], ((j < k-1)? "," : ")\n"));
Rprintf(" esp[]= (");
for(j=0; j < k; j++) Rprintf(" %g%s",esp[j], ((j < k-1)? "," : ")\n"));
}
}
reen = 1. / (r - 1.);
it = 0;
while(++it <= *nit) { /* . . . . . iterations . . . . . . . . . . . . . */
for(m = 0; m < nn; m++) {
/* the new membership coefficients of the objects are calculated,
and the resulting value of the criterion is computed. */
dt = 0.;
for (j = 0; j < k; ++j) {
pt[j] = pow(esp[j] / (dp[m + j * dp_d] - ef[j] / (2 * esp[j])),
reen);
dt += pt[j];
}
xx = 0.;
for (j = 0; j < k; ++j) {
pt[j] /= dt;
if (pt[j] < 0.)
xx += pt[j];
}
/* now: sum_j (pt[j]) == 1; xx := sum_{pt[j] < 0} pt[j] */
for (j = 0; j < k; ++j) {
double d_mj;
pt[j] = (pt[j] > 0.) ? pow(pt[j] / (1 - xx), r) : 0.;
d_mj = pt[j] - p[m + j * p_d];
esp[j] += d_mj;
for (i = 0; i < nn; ++i) {
if (i != m) {
mi = imin2(m,i);
mi = mi * nn - (mi + 1) * (mi + 2) / 2 + imax2(m,i);
ddd = d_mj * dss[mi];
dp[i + j * dp_d] += ddd;
ef[j] += p[i + j * p_d] * 2. * ddd;
}
}
p[m + j * p_d] = pt[j];
}
if(trace_lev >= 3) {
Rprintf(" pt[m= %d, *]: ",m);
for (j = 0; j < k; ++j)
Rprintf(" %g%s", pt[j], ((j < k-1)? "," : "\n"));
}
}
/* m == nn */
cryt = 0.;
for (j = 0; j < k; ++j)
cryt += ef[j] / (esp[j] * 2.);
if(trace_lev >= 2) Rprintf(" m == n: obj = %#20.14g", cryt);
/* Convergence check */
if((converged = (fabs(cryt - crt) <= tol * cryt)))
break;
if(trace_lev >= 2) Rprintf(" not converged: it = %d\n", it);
crt = cryt;
} /* while */
*nit = (converged)? it : -1;
if(trace_lev) {
Rprintf("%s%sonverged after %d iterations, obj = %#20.*g\n",
trace_lev >=2 ? "\n" : "", (converged) ? "C" : "NOT c",
it, (int)((trace_lev >= 2)? 20 : 7), cryt);
}
/* obj[0] = (double) it; << no longer; return it via *nit ! */
obj[1] = cryt;
/* PC (partition coefficient), "non-fuzzyness index" of libert is computed
* C = 1/n sum_{i,j} u_{i,j} ^ r fulfills
* 1 >= C >= sum_j (1/k)^r = k * k^-r = k^(1-r)
* ==> normalization (C - k^(1-r)) / (1 - k^(1-r)) = (k^(r-1) * C - 1) / (k^(r-1) - 1)
*/
for (j = 0, crt = 0.; j < k; ++j)
crt += esp[j];
crt /= nn;
obj[2] = crt; /* the PC */
xx = pow((double)k, r - 1.);
obj[3] = (xx * crt - 1.) / (xx - 1.);
/* Note however, that for r != 2, MM rather prefers to use
* the "original definition" C = 1/n sum_{i,j} u_{i,j} ^ 2, and its normalization */
/* p[m,j] := (u_{m,j} ^ r) ^{1/r} == u_{m,j} : */
xx = 1. / r;
for (m = 0; m < nn; ++m)
for (j = 0; j < k; ++j)
p[m + j * p_d] = pow(p[m + j * p_d], xx);
} /* fuzzy */
