void similarity_categorical(double *x, int n, int p, double *S)
{
int i, j, k, l, npairs = n * (n - 1)/2, mi;
double mean, var, sd, pi;
double *s = (double *)R_alloc(npairs, sizeof(double));
for(j = 0 ; j < p ; j++) {
l=0;
for (i = 0 ; i < n ; i++)
for (k = i+1 ; k < n ; k++)
s[l++] = (x[i + n*j] == x[k + n*j]) ? 1.0 : 0.0;
/* number of categories for column j */
R_rsort (x + n*j, n);
mi = 1;
mean = 0.0;
for (i = 0 ; i < n-1 ; i++)
if (x[i + n*j] == x[i + 1 + n*j])
mi++;
else {
pi = mi/(double)n;
mean += R_pow_di(pi,2);
mi = 1;
}
pi = mi/(double)n;
mean += R_pow_di(pi,2);
var = mean * ( 1.0 - mean);
sd = sqrt(var);
for (l = 0 ; l < npairs; l++)
S[l] += (s[l] - mean)/sd;
}
}
/**********************************************************************
* wtaverage
* calculate the weight average of the LOD scores
*********************************************************************/
double wtaverage(double *LOD, int n_draws)
{
int k, idx, nnewLOD;
double sum, sums, meanLOD, varLOD, *newLOD;
/* calculate the number of LOD needs to be thrown */
idx = (int) floor( 0.5*log(n_draws)/log(2) );
nnewLOD = n_draws-2*idx; /* number of items in newLOD vector */
/* allocate memory for newLOD */
newLOD = (double *)R_alloc( nnewLOD, sizeof(double) );
/* sort the LOD scores in ascending order */
R_rsort(LOD, n_draws);
/* get a new list of LOD scores, throwing the biggest
and smallest idx LOD scores. */
for(k=idx, sum=0.0; k<n_draws-idx; k++) {
newLOD[k-idx] = LOD[k];
sum += LOD[k]; /* calculate the sum of newLOD in the same loop */
}
/* calculate the mean of newLOD */
meanLOD = sum / nnewLOD;
/* calculate the variance of newLOD */
if(nnewLOD > 1) {
for(k=0,sums=0.0; k<nnewLOD; k++)
sums += (newLOD[k]-meanLOD) * (newLOD[k]-meanLOD);
varLOD = sums/(nnewLOD-1);
}
else varLOD = 0.0;
/* return the weight average */
return( meanLOD+0.5*log(10.0)*varLOD );
}
void predictInterp(double *alpha, double *lambda, double *beta, double *predictPositions, int *NpredictPositions, double *diffPositionj, double *currPositionsj, double *currPositionsjp1, double *thetaj, double *thetajp1, double *predvals) {
// Runs the prediction code when we are interpolating between two positions
int Nd = rpois((*lambda)*(*diffPositionj));
int i;
double depthEvents[Nd];
for(i=0;i<Nd;i++) depthEvents[i] = runif(*currPositionsj,*currPositionsjp1);
R_rsort(depthEvents,Nd);
double timeEventsUnsc[Nd+1],timeEventsSum=0.0;
for(i=0;i<Nd+1;i++) timeEventsUnsc[i] = rgamma(*alpha,1/(*beta));
for(i=0;i<Nd+1;i++) timeEventsSum += timeEventsUnsc[i];
double timeEvents[Nd+1];
for(i=0;i<Nd+1;i++) timeEvents[i] = (*thetajp1-*thetaj)*timeEventsUnsc[i]/timeEventsSum;
double timeEventsCumsum[Nd+1],allTimeEvents[Nd+2];
timeEventsCumsum[0] = 0.0;
for(i=1;i<Nd+1;i++) timeEventsCumsum[i] = timeEventsCumsum[i-1] + timeEvents[i];
for(i=0;i<Nd+1;i++) allTimeEvents[i] = timeEventsCumsum[i]+*thetaj;
allTimeEvents[Nd+1] = *thetajp1;
double allDepthEvents[Nd+2];
allDepthEvents[0] = *currPositionsj;
for(i=1;i<Nd+1;i++) allDepthEvents[i] = depthEvents[i-1];
allDepthEvents[Nd+1] = *currPositionsjp1;
int Ndp2 = Nd+2;
for(i=0;i<*NpredictPositions;i++) {
linInterp(&Ndp2,&predictPositions[i],allDepthEvents,allTimeEvents,&predvals[i]);
}
}
/**********************************************************************
* runningmean
*
* Get running mean or sum within a specified bp-width window
*
* method = 1 -> sum
* = 2 -> mean
* = 3 -> median
* = 4 -> sd
*
* We assume that pos and resultpos are both sorted (lo to high)
*
**********************************************************************/
void runningmean(int n, double *pos, double *value,
int n_result,
double *resultpos, double *result,
double window, int method)
{
int lo, ns;
int i, j;
double *work3, work4;
if(method==3)
work3 = (double *)R_alloc(n, sizeof(double));
window /= 2.0;
lo=0;
for(i=0; i<n_result; i++) {
R_CheckUserInterrupt(); /* check for ^C */
work4 = result[i] = 0.0; ns=0;
for(j=lo; j<n; j++) {
if(pos[j] < resultpos[i]-window) lo = j+1;
else if(pos[j] > resultpos[i]+window) break;
else {
if(method==1 || method==2 || method==4)
result[i] += value[j];
if(method==3)
work3[ns] = value[j];
if(method==4)
work4 += (value[j]*value[j]);
ns++;
}
}
if(ns==0 || (method==4 && ns==1)) result[i] = NA_REAL;
else {
if(method==2) result[i] /= (double)ns;
if(method==3) {
R_rsort(work3, ns);
if(ns % 2)
result[i] = work3[(ns-1)/2];
else /* even */
result[i] = (work3[ns/2-1]+work3[ns/2])/2.0;
}
if(method==4) { /* SD */
result[i] = (work4 - result[i]*result[i]/(double)ns)/(double)(ns-1);
if(result[i] < 0) result[i] = 0.0; /* handle potential round-off error by just thresholding to 0 */
else result[i] = sqrt(result[i]);
}
}
}
}
void similarity_ordinal(double *x, int n, int p, double *S)
{
int i, j, k, l, npairs = n * (n - 1)/2, hj, n2 = R_pow_di(n,2),
n4 = R_pow_di(n,4), incr;
double mean, var, sd, sum1, sum2;
double *s = (double *)R_alloc(npairs, sizeof(double));
int old = BLOCK_SIZE;
int *m = (int *)R_alloc(old, sizeof(int));
for(j = 0 ; j < p ; j++) {
/* similarity per variable */
l=0;
for (i = 0 ; i < n ; i++)
for (k = i+1 ; k < n ; k++)
s[l++] = fabs(x[i + n*j] - x[k + n*j]);
/* number of categories for column j */
R_rsort (x + n*j, n);
hj=0;
m[hj] = 1;
for (i = 0 ; i < n-1 ; i++)
if (x[i + n*j] == x[i + 1 + n*j])
m[hj]++;
else {
incr = x[i + 1 + n*j] - x[i + n*j];
if (hj + incr >= old) {
m = (int *)S_realloc((char *)m, old + BLOCK_SIZE, old, sizeof(int));
old += BLOCK_SIZE;
}
for (k=1;k<incr;k++)
m[hj+k] = 0;
hj += incr;
m[hj] = 1;
}
hj++;
/* computation of the expectation and the variance */
sum1 = 0.0; sum2 = 0.0;
for (i = 0 ; i < hj ; i++)
for (k = 0 ; k < i ; k++) {
sum1 += m[i] * m[k] * (i - k);
sum2 += m[i] * m[k] * R_pow_di(i - k,2);
}
mean = hj - 1.0 - 2.0/n2 * sum1;
var = 2.0/n2 * sum2 - 4.0/n4 * R_pow_di(sum1,2);
sd = sqrt(var);
for (l = 0 ; l < npairs; l++)
S[l] += (hj - 1.0 - s[l] - mean)/sd;
}
}
void gw_adapt(double *u, double *v, double *uout, double *vout, int *n1,
int *n2, double *bw, double *qin, double *d, int *lonlat)
{
int N1 = *n1, N2 = *n2, i, index;
double q = *qin;
double uo[1], vo[1];
index = (int) floor((N1-1)*q + 0.5); /* + 1 */
for (i=0; i<N2; i++) {
uo[0] = uout[i];
vo[0] = vout[i];
gw_dists(u, v, uo, vo, n1, d, lonlat);
R_rsort(d, N1);
bw[i] = d[index];
}
}
double median(double *x, int n)
{
double xmed;
int n2;
if(n == 0) {
/* Empty clusters are deleted in the R code */
xmed = DOUBLE_XMAX;
} else {
R_rsort (x, n);
n2 = n / 2;
if ((n2 << 1) == n) {
xmed = (x[n2] + x[n2 + 1]) * .5;
} else {
xmed = x[n2 + 1];
}
}
return xmed;
}
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];
}
}
}
/**********************************************************************
* runningmean
*
* Get running mean or sum within a specified bp-width window
*
* method = 1 -> sum
* = 2 -> mean
* = 3 -> median
*
**********************************************************************/
void runningmean(int n, double *pos, double *value, double *result,
double window, int method, double *work)
{
int lo, ns;
int i, j;
window /= 2.0;
lo=0;
for(i=0; i<n; i++) {
result[i] = 0.0; ns=0;
for(j=lo; j<n; j++) {
if(pos[j] < pos[i]-window) lo = j+1;
else if(pos[j] > pos[i]+window) break;
else {
if(!ISNAN(value[j])) {
if(method==1 || method==2)
result[i] += value[j];
else
work[ns] = value[j];
ns++;
}
}
}
if(method==2) result[i] /= (double)ns;
if(method==3) {
R_rsort(work, ns);
if(ns % 2) /* odd */
result[i] = work[(ns-1)/2];
else /* even */
result[i] = (work[ns/2-1]+work[ns/2])/2.0;
}
}
}
static void line(double *x, double *y, /* input (x[i],y[i])s */
double *z, double *w, /* work and output: resid. & fitted */
/* all the above of length */ int n,
double coef[2])
{
int i, j, k;
double xb, x1, x2, xt, yt, yb, tmp1, tmp2;
double slope, yint;
for(i = 0 ; i < n ; i++) {
z[i] = x[i];
w[i] = y[i];
}
R_rsort(z, n);/* z = ordered abscissae */
tmp1 = z[il(n, 1./6.)];
tmp2 = z[iu(n, 1./6.)]; xb = 0.5*(tmp1+tmp2);
tmp1 = z[il(n, 2./6.)];
tmp2 = z[iu(n, 2./6.)]; x1 = 0.5*(tmp1+tmp2);
tmp1 = z[il(n, 4./6.)];
tmp2 = z[iu(n, 4./6.)]; x2 = 0.5*(tmp1+tmp2);
tmp1 = z[il(n, 5./6.)];
tmp2 = z[iu(n, 5./6.)]; xt = 0.5*(tmp1+tmp2);
slope = 0.;
for(j = 1 ; j <= 1 ; j++) {
/* yb := Median(y[i]; x[i] <= quantile(x, 1/3) */
k = 0;
for(i = 0 ; i < n ; i++)
if(x[i] <= x1)
z[k++] = w[i];
R_rsort(z, k);
yb = 0.5 * (z[il(k, 0.5)] + z[iu(k, 0.5)]);
/* yt := Median(y[i]; x[i] >= quantile(x, 2/3) */
k = 0;
for(i = 0 ; i < n ; i++)
if(x[i] >= x2)
z[k++] = w[i];
R_rsort(z,k);
yt = 0.5 * (z[il(k, 0.5)] + z[iu(k, 0.5)]);
slope += (yt - yb)/(xt - xb);
for(i = 0 ; i < n ; i++) {
z[i] = y[i] - slope*x[i];
/* never used: w[i] = z[i]; */
}
R_rsort(z,n);
yint = 0.5 * (z[il(n, 0.5)] + z[iu(n, 0.5)]);
}
for( i = 0 ; i < n ; i++ ) {
w[i] = yint + slope*x[i];
z[i] = y[i] - w[i];
}
coef[0] = yint;
coef[1] = slope;
}
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];
}
}
/**********************************************************************
*
* meiosis
*
* chrlen Chromosome length (in cM)
*
* m interference parameter (0 corresponds to no interference)
*
* p for stahl model, proportion of chiasmata from NI mechanism
*
* maxwork
* work
*
* n_xo
*
**********************************************************************/
void meiosis(double L, int m, double p, int *maxwork, double **work,
int *n_xo)
{
int i, n, nn, j, first;
if(m > 0 && p < 1.0) { /* crossover interference */
/* simulate number of XOs and intermediates */
n = (int)rpois(L*(double)(m+1)/50.0*(1.0-p));
if(n > *maxwork) { /* need a bigger workspace */
*work = (double *)S_realloc((char *)*work, n*2, *maxwork, sizeof(double));
*maxwork = n*2;
}
for(i=0; i<n; i++)
(*work)[i] = L*unif_rand();
/* sort them */
R_rsort(*work, n);
/* which is the first crossover? */
first = random_int(0,m);
for(i=first, j=0; i<n; i += (m+1), j++)
(*work)[j] = (*work)[i];
n = j;
/* thin with probability 1/2 */
for(i=0, j=0; i<n; i++) {
if(unif_rand() < 0.5) {
(*work)[j] = (*work)[i];
j++;
}
}
n = j;
nn = (int) rpois(L*p/100.0);
if(n +nn > *maxwork) { /* need a bigger workspace */
*work = (double *)S_realloc((char *)*work, (n+nn)*2, *maxwork, sizeof(double));
*maxwork = (n+nn)*2;
}
for(i=0; i<nn; i++)
(*work)[i+n] = L*unif_rand();
R_rsort(*work, n+nn);
*n_xo = n+nn;
}
else { /* no crossover interference */
n = (int) rpois(L/100.0);
if(n > *maxwork) { /* need a bigger workspace */
*work = (double *)S_realloc((char *)*work, n*2, *maxwork, sizeof(double));
*maxwork = n*2;
}
for(i=0; i<n; i++)
(*work)[i] = L*unif_rand();
/* sort them */
R_rsort(*work, n);
*n_xo = n;
}
}
void simStahl(int *n_sim, double *nu, double *p, double *L,
int *nxo, double *loc, int *max_nxo,
int *n_bins4start)
{
double **Loc, scale;
double curloc=0.0, u;
double *startprob, step;
int i, j, n_nixo;
/* re-organize loc as a doubly index array */
Loc = (double **)R_alloc(*n_sim, sizeof(double *));
Loc[0] = loc;
for(i=1; i < *n_sim; i++)
Loc[i] = Loc[i-1] + *max_nxo;
GetRNGstate();
if(fabs(*nu - 1.0) < 1e-8) { /* looks like a Poisson model */
for(i=0; i< *n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
nxo[i] = rpois(*L);
if(nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < nxo[i]; j++)
Loc[i][j] = runif(0.0, *L);
}
}
else {
scale = 1.0 / (2.0 * *nu * (1.0 - *p));
/* set up starting distribution */
startprob = (double *)R_alloc(*n_bins4start, sizeof(double));
step = *L/(double)*n_bins4start;
startprob[0] = 2.0*(1.0 - *p)*pgamma(0.5*step, *nu, scale, 0, 0)*step;
for(i=1; i< *n_bins4start; i++) {
R_CheckUserInterrupt(); /* check for ^C */
startprob[i] = startprob[i-1] +
2.0*(1.0 - *p)*pgamma(((double)i+0.5)*step, *nu, scale, 0, 0)*step;
}
for(i=0; i< *n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
nxo[i] = 0;
/* locations of chiasmata from the gamma model */
/* shape = nu, rate = 2*nu*(1-p) [scale = 1/{2*nu*(1-p)}] */
u = unif_rand();
if( u > startprob[*n_bins4start-1] )
curloc = *L+1;
else {
for(j=0; j< *n_bins4start; j++) {
if(u <= startprob[j]) {
curloc = ((double)j+0.5)*step;
if(unif_rand() < 0.5) {
nxo[i] = 1;
Loc[i][0] = curloc;
}
break;
}
}
}
if(curloc < *L) {
while(curloc < *L) {
curloc += rgamma(*nu, scale);
if(curloc < *L && unif_rand() < 0.5) {
if(nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
Loc[i][nxo[i]] = curloc;
(nxo[i])++;
}
}
}
/* locations of crossovers from the no interference mechanism */
if(*p > 0) {
n_nixo = rpois(*L * *p);
if(n_nixo + nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < n_nixo; j++)
Loc[i][nxo[i]+j] = runif(0.0, *L);
nxo[i] += n_nixo;
}
}
}
/* sort the results */
for(i=0; i< *n_sim; i++)
R_rsort(Loc[i], nxo[i]);
PutRNGstate();
}
/* version when nu = m+1 is an integer
*
* m = interference parameter (m=0 gives no interference)
* p = proportion of chiasmata from no interference process
* L = length of chromosome (in cM)
* Lstar = revised length for simulating numbers of chiasmata, for case of obligate chiasma
* on same scale as L
* nxo = on output, the number of crossovers
* Loc = on output, the locations of the crossovers
* max_nxo = maximum no. crossovers allowed (length of loc)
* obligate_chiasma = 1 if require at least one chiasma (0 otherwise)
*
*/
void simStahl_int(int n_sim, int m, double p, double L,
double Lstar, int *nxo, double **Loc,
int max_nxo, int obligate_chiasma)
{
int i, j, k, n_nichi, n_pts, n_ichi, first, max_pts;
double *ptloc;
double lambda1, lambda2;
/* space for locations of chiasmata and intermediate pts */
max_pts = 2*max_nxo*(m+1);
ptloc = (double *)R_alloc(max_pts, sizeof(double));
GetRNGstate();
if(m==0) { /* looks like a Poisson model */
for(i=0; i< n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
if(obligate_chiasma) {
/* no. chiasmata, required >= 1 */
while((n_ichi = rpois(Lstar/50.0)) == 0);
/* no crossovers by thinning 1/2 */
nxo[i] = rbinom((double)n_ichi, 0.5);
}
else
nxo[i] = rpois(Lstar/100.0);
if(nxo[i] > max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < nxo[i]; j++)
Loc[i][j] = runif(0.0, L);
}
}
else {
lambda1 = Lstar/50.0 * (m+1) * (1.0 - p);
lambda2 = Lstar/50.0 * p;
for(i=0; i< n_sim; i++) {
while(1) {
R_CheckUserInterrupt(); /* check for ^C */
/* simulate no. chiasmata + intermediate pts from interference process */
n_pts = rpois(lambda1);
/* simulate location of the first */
first = random_int(0, m);
if(first > n_pts) n_ichi = 0;
else n_ichi = n_pts/(m+1) + (int)(first < (n_pts % (m+1)));
/* simulate no. chiamata from the no-interference model */
n_nichi = rpois(lambda2);
if(!obligate_chiasma || n_ichi + n_nichi > 0) break;
}
/* simulate no. chiasmta + intermediate points */
/* first check if we have space */
if(n_pts > max_pts) {
ptloc = (double *)S_realloc((char *)ptloc, n_pts*2, max_pts, sizeof(double));
max_pts = n_pts*2;
}
for(j=0; j<n_pts; j++)
ptloc[j] = runif(0.0, L);
/* sort them */
R_rsort(ptloc, n_pts);
/* take every (m+1)st */
for(j=first, k=0; j<n_pts; j += (m+1), k++)
ptloc[k] = ptloc[j];
n_ichi = k;
/* simulate chiasmata from no-interference model */
for(j=0; j<n_nichi; j++)
ptloc[n_ichi + j] = runif(0.0, L);
/* sort the combined ones */
R_rsort(ptloc, n_ichi + n_nichi);
/* thin by 1/2 */
nxo[i] = 0;
for(j=0; j<n_ichi + n_nichi; j++) {
if(unif_rand() < 0.5) {
Loc[i][nxo[i]] = ptloc[j];
(nxo[i])++;
}
}
} /* loop over no. simulations */
} /* m > 0 */
PutRNGstate();
}
static Rboolean
stem_leaf(double *x, int n, double scale, int width, double atom)
{
double r, c, x1, x2;
int mm, mu, k, i, j, hi, lo, xi;
int ldigits, hdigits, ndigits, pdigits;
R_rsort(x,n);
if(n <= 1)
return FALSE;
Rprintf("\n");
if(x[n-1] > x[0]) {
r = atom+(x[n-1]-x[0])/scale;
c = pow(10.,(11.-(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 ");
if(pdigits == 0)
Rprintf("at the |\n\n");
else
Rprintf("%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);
}
i++;
} while(i < n);
if(j > width) {
Rprintf("+%d", j-width);
}
Rprintf("\n");
if(i >= n)
break;
hi += mu;
lo += mu;
} while(1);
Rprintf("\n");
return TRUE;
}
