void similarity_numerical_cosinus(double *x, int n, int p, double *S)
{
int i, j, k, l, npairs = n * (n - 1)/2, n2 = R_pow_di(n,2);
double mean, var, sd;
double *s = (double *)R_alloc(npairs, sizeof(double));
for(j = 0 ; j < p ; j++) {
l=0;
mean = 0.0;
for (i = 0 ; i < n ; i++)
for (k = i+1 ; k < n ; k++) {
s[l] = 1.0/p - 0.5 * R_pow_di(x[i + n*j] - x[k + n*j],2);
mean += s[l++];
}
mean = (mean * 2.0 + n/(double)p) / n2;
var =0.0;
for (l = 0 ; l < npairs; l++)
var += R_pow_di(s[l] - mean,2);
var = (var * 2.0 + n * R_pow_di(1.0/p - mean,2)) / n2;
sd = sqrt(var);
for (l = 0 ; l < npairs; l++)
S[l] += (s[l] - mean)/sd;
}
}
/* this one genrealizes the previous code and accepts a vector of k (length m)
and matrix of p (m copies of l dimensional vector) */
void RpoisbinomEffMatrix(int *k, int *maxk, double *p, int *l, int *m, double *Rs) {
double ptmp, *dtmp, *sumT;
int h, i, j;
dtmp = doubleArray(*maxk+1);
sumT = doubleArray(*maxk);
for (h = 0; h < *m; h++) {
dtmp[0] = 1.0;
if (k[h] > 0) {
for (i = 1; i <= k[h]; i++) {
dtmp[i] = 0.0;
sumT[i-1] = 0.0;
for (j = 0; j < *l; j++) {
ptmp = p[h*l[0]+j];
sumT[i-1] += R_pow_di(ptmp/(1-ptmp), i);
}
for (j = 1; j <= i; j++) {
dtmp[i] += R_pow_di(-1.0, j+1) * sumT[j-1] * dtmp[i-j];
}
dtmp[i] /= i;
}
}
Rs[h] = dtmp[k[h]];
}
free(dtmp);
free(sumT);
}
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;
}
}
void similarity_numerical_euclidean(double *x, int n, int p, double *S)
{
int i, j, k, l, npairs = n * (n - 1)/2, n2 = R_pow_di(n,2);
double mean, var, sd, max;
double *s = (double *)R_alloc(npairs, sizeof(double));
for(j = 0 ; j < p ; j++) {
l=0;
mean = 0.0;
max = 0.0;
for (i = 0 ; i < n ; i++)
for (k = i+1 ; k < n ; k++) {
s[l] = R_pow_di(x[i + n*j] - x[k + n*j],2);
if (s[l] > max)
max = s[l];
mean += s[l++];
}
mean = (n2 * max - 2.0 * mean) / n2;
var =0.0;
for (l = 0 ; l < npairs; l++)
var += R_pow_di(s[l] - mean,2);
var = (var * 2.0 + n * R_pow_di(max - mean,2)) / n2;
sd = sqrt(var);
for (l = 0 ; l < npairs; l++)
S[l] += (s[l] - mean)/sd;
}
}
double fround(double x, double digits) {
#define MAX_DIGITS DBL_MAX_10_EXP
/* = 308 (IEEE); was till R 0.99: (DBL_DIG - 1) */
/* Note that large digits make sense for very small numbers */
LDOUBLE pow10, sgn, intx;
int dig;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(digits))
return x + digits;
if(!R_FINITE(x)) return x;
#endif
if (digits > MAX_DIGITS)
digits = MAX_DIGITS;
dig = (int)floor(digits + 0.5);
if(x < 0.) {
sgn = -1.;
x = -x;
} else
sgn = 1.;
if (dig == 0) {
return sgn * R_rint(x);
} else if (dig > 0) {
pow10 = R_pow_di(10., dig);
intx = floor(x);
return sgn * (intx + R_rint((x-intx) * pow10) / pow10);
} else {
pow10 = R_pow_di(10., -dig);
return sgn * R_rint(x/pow10) * pow10;
}
}
double info_null(double g,double R2,int n,int k){
double aux;
aux= -((double)n-1.-(double)k)/R_pow_di(1.+g,2);
aux=aux+((double)n-1.)*R_pow_di(1.-R2,2)/R_pow_di(1.+(1.-R2)*g,2)+3/R_pow_di(g,2);
aux=aux-2.*(double)n/R_pow_di(g,3);
aux=aux/2.;
return(aux);
}
double info_full(double g, double eps, int n, int p, int k){
double aux;
aux=-((double)n-((double)p+1.))/R_pow_di(1.+g,2);
aux=aux+((double)n-((double)k+1.))*R_pow_di(eps,2)/R_pow_di(1.+eps*g,2);
aux=aux+3./R_pow_di(g,2)-2*(double)n/R_pow_di(g,3);
aux=aux/2.;
return(aux);
return(aux);
}
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;
}
}
double gk(int n, double *x, double *y, scaleFnPtr *scalefn)
{
double mu = 0.0;
const arma::vec xx(x,n,false,true);
const arma::vec yy(y,n,false,true);
arma::vec plus_ts = xx + yy;
const double plus = scalefn(n, plus_ts.colptr(0), &mu);
arma::vec minus_ts = xx - yy;
const double minus = scalefn(n, minus_ts.colptr(0), &mu);
return (R_pow_di(plus, 2) - R_pow_di(minus, 2)) / 4.0;
}
static void homozygote (unsigned r, double probl, double statl, double u, double x2, COUNTTYPE * R)
{
// If the process takes longer than `timeLimit` seconds, set
// `tableCount` negative to signify that the job is aborted
if(tableCount < 0) return;
if(time(NULL) - start >= timeLimit) tableCount = -tableCount;
COUNTTYPE * res, *resn;
int lower, upper, exindix;
unsigned i, arr;
double arrln2;
COUNTTYPE * Rnew = R + nAlleles;
memcpy(Rnew, R, Rbytes);
//Find upper and lower limits for arr.
res = R-1; // So res is a 1-based version of R
resn = Rnew-1; // resn is 1 based for Rnew
lower = res[r];
for (i = 1; i <= r-1; i++) lower -= res[i];
lower = lower < 2 ? 0 : lower/2;
upper = res[r]/2;
//For each possible value of arr, examine the heterozygote at r, r-1
for(arr = lower; arr <= upper; arr++) {
resn[r] = res[r] - 2*arr;
arrln2 = arr * M_LN2;
exindix = (r-1)*nAlleles + r - 1; // index of homozygote
heterozygote(r,
r-1,
probl + lnFact[arr] + arrln2,
statl + xlnx[arr] + arrln2,
u + (double)arr/mi[r],
x2 + R_pow_di(arr - exa[exindix],2)/exa[exindix],
Rnew);
}
}
void call_binegbin_logMV(double *nu0, double *nu1, double *nu2,
double *p0, double *p1, double *p2,
double *const_add, double *tol, int *add_carefully,
double *EX, double *EY, double *EX2, double *EY2, double *EXY){
double nexterm=0, oldterm=0;
int xmodeflag=0;
int xstopflag=0;
double i=0, j=0, x, y;
for(i=0;xstopflag==0;i++){
nexterm = do_dnegbin_convolution(i,*nu0,*nu1,*p0,*p1,*add_carefully);
if(nexterm < oldterm) xmodeflag = 1;
*EX += nexterm * log(i + *const_add);
*EX2 += nexterm * R_pow_di(log(i + *const_add),2);
if(nexterm * R_pow_di(log(i + *const_add),2) < *tol && xmodeflag==1) xstopflag=1;
//if(nexterm==0) xstopflag=1;
oldterm = nexterm;
}
R_CheckUserInterrupt();
//Now do for y as was done for x, unless they have the same marginal distributions:
if( *nu1==*nu2 && *p1==*p2 ){
*EY = *EX;
*EY2 = *EX2;
j = i;
}
else{
int ymodeflag=0, ystopflag=0;
oldterm=0;
for(j=0;ystopflag==0;j++){
nexterm = do_dnegbin_convolution(j,*nu0,*nu2,*p0,*p2,*add_carefully);
if(nexterm < oldterm) ymodeflag = 1;
*EY += nexterm * log(j + *const_add);
*EY2 += nexterm * R_pow_di(log(j + *const_add),2);
if(nexterm * R_pow_di(log(j + *const_add),2) < *tol && ymodeflag==1) ystopflag=1;
//if(nexterm==0) ystopflag=1;
oldterm = nexterm;
}}
R_CheckUserInterrupt();
for(x=0;x<=i;x++){
for(y=0;y<=j;y++){
*EXY += do_dbinegbin(x,y,*nu0,*nu1,*nu2,*p0,*p1,*p2,0,*add_carefully) *
log(x + *const_add) * log(y + *const_add);
}
R_CheckUserInterrupt();
}
}
void posroot(double a, double b, double c, double *root, double *status)
{ /* this computes the real roots of a cubic polynomial; in the end, if
status==1, root stores the nonegative root; if status is not one,
then status is the total number of nonegative roots and root is
useless
*/
int i;
double Q,R,disc,Q3,A,B,aux,x[3];
*root = 0.;
*status=0.;
Q=(R_pow_di(a,2)-3.*b)/9.;
R=(2*R_pow_di(a,3)-9*a*b+27.*c)/54.;
Q3=R_pow_di(Q,3);
disc=R_pow_di(R,2)-Q3;
if(disc>=0.){
if(R>=0) A=-cbrt(R+sqrt(disc));
else A=-cbrt(R-sqrt(disc));
if(A==0.) B=0.;
else B=Q/(A);
*root=(A+B)-a/3.;
if(*root>=0) *status=1.;
}
else{
A=acos(R/sqrt(Q3));
aux= 2. * sqrt(Q);
x[0]=-aux * cos(A/3.);
x[1]=-aux * cos((A+4.*asin(1.))/3.);
x[2]=-aux * cos((A-4.*asin(1.))/3.);
aux=a/3.;
for(i=0;i<3;i++) x[i]=x[i]-aux;
for(i=0;i<3;i++){
if (x[i]>=0.){
*status=*status+1.;
*root=x[i];
}
}
}
}
double oldpack(int l, int *icat) {
/* icat is a binary integer with ones for categories going left
* and zeroes for those going right. The sub returns npack- the integer */
int k;
double pack = 0.0;
for (k = 0; k < l; ++k) {
if (icat[k]) pack += R_pow_di(2.0, k);
}
return(pack);
}
double scaleTau2(int n, double *x, double *mu) {
double *dwork1 = new double[n];
double *dwork2 = new double[n];
const double C1 = 4.5, C2squared = 9.0;
// const double C2 = 3.0;
const double Es2c = 0.9247153921761315;
double medx = 0.0, sigma0 = 0.0, tmpsum = 0.0;
int i = 0, IONE = 1;
F77_CALL(dcopy)(&n, x, &IONE, dwork1, &IONE);
medx = my_median(n, dwork1);
for(i = 0; i < n; i++)
dwork1[i] = fabs(dwork1[i] - medx);
sigma0 = my_median(n, dwork1);
F77_CALL(dcopy)(&n, x, &IONE, dwork1, &IONE);
for(i = 0; i < n; i++) {
dwork1[i] = fabs(dwork1[i] - medx);
dwork1[i] = dwork1[i] / (C1 * sigma0);
dwork2[i] = 1.0 - R_pow_di(dwork1[i], 2);
dwork2[i] = R_pow_di(((fabs(dwork2[i]) + dwork2[i])/2.0), 2);
}
tmpsum = dsum(n, dwork2, 1, dwork1);
for(i = 0; i < n; i++)
dwork1[i] = x[i] * dwork2[i];
*mu = dsum(n, dwork1, 1, dwork2) / tmpsum;
F77_CALL(dcopy)(&n, x, &IONE, dwork1, &IONE);
for(i = 0; i < n; i++) {
dwork2[i] = R_pow_di((dwork1[i] - *mu) / sigma0, 2);
dwork2[i] = dwork2[i] > C2squared ? C2squared : dwork2[i];
}
double ans = sigma0 * sqrt(dsum(n, dwork2, 1, dwork1) / (n*Es2c));
delete[] dwork1;
delete[] dwork2;
return ans;
}
/* direct use of recursive formula */
double Rpoisbinom(int k, double *p, int l) {
double dtmp = 0.0, sumT;
int i, j;
if (k == 0) {
dtmp = 1.0;
} else if (k > 0) {
dtmp = 0.0;
for (i = 1; i <= k; i++) {
sumT = 0.0;
for (j = 0; j < l; j++) {
sumT += R_pow_di(p[j]/(1-p[j]), i);
}
dtmp += R_pow_di(-1.0, i+1) * sumT * Rpoisbinom(k-i, p, l);
}
dtmp /= k;
} else {
error("Rpoisbinom: invalid input for k.\n");
}
return(dtmp);
}
void posroot_full(double a, double b, double c, double *root, double *status)
{
int i;
double Q,R,disc,Q3,A,B,aux,x[3];
*status=0.;
Q=(R_pow_di(a,2)-3.*b)/9.;
R=(2*R_pow_di(a,3)-9*a*b+27.*c)/54.;
Q3=R_pow_di(Q,3);
disc=R_pow_di(R,2)-Q3;
if(disc>=0.){
if(R>=0) A=-cbrt(R+sqrt(disc));
else A=-cbrt(R-sqrt(disc));
if(A==0.)B=0.;
else B=Q/A;
*root=(A+B)-a/3.;
if(*root>=0) *status=1.;
}
else{
A=acos(R/sqrt(Q3));
aux= 2. * sqrt(Q);
x[0]=-aux * cos(A/3.);
x[1]=-aux * cos((A+4.*asin(1.))/3.);
x[2]=-aux * cos((A-4.*asin(1.))/3.);
aux=a/3.;
for(i=0;i<3;i++) x[i]=x[i]-aux;
for(i=0;i<3;i++){
if (x[i]>=0.){
*status=*status+1.;
*root=x[i];
}
}
}
}
void RpoisbinomEff(int *k, double *p, int *l, double *Rs) {
double *sumT;
int i, j;
sumT = doubleArray(*k);
Rs[0] = 1.0;
if (*k > 0) {
for (i = 1; i <= *k; i++) {
Rs[i] = 0.0;
sumT[i-1] = 0.0;
for (j = 0; j < *l; j++) {
sumT[i-1] += R_pow_di(p[j]/(1-p[j]), i);
}
for (j = 1; j <= i; j++) {
Rs[i] += R_pow_di(-1.0, j+1) * sumT[j-1] * Rs[i-j];
}
Rs[i] /= i;
}
}
free(sumT);
}
double fprec(double x, double digits)
{
double l10, pow10, sgn, p10, P10;
int e10, e2, do_round, dig;
/* Max.expon. of 10 (=308.2547) */
const static int max10e = DBL_MAX_EXP * M_LOG10_2;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(digits))
return x + digits;
if (!R_FINITE(x)) return x;
if (!R_FINITE(digits)) {
if(digits > 0) return x;
else return 0;
}
#endif
if(x == 0) return x;
dig = (int)floor(digits+0.5);
if (dig > MAX_DIGITS) {
return x;
} else if (dig < 1)
dig = 1;
sgn = 1.0;
if(x < 0.0) {
sgn = -sgn;
x = -x;
}
l10 = log10(x);
e10 = (int)(dig-1-floor(l10));
if(fabs(l10) < max10e - 2) {
p10 = 1.0;
if(e10 > max10e) { /* numbers less than 10^(dig-1) * 1e-308 */
p10 = R_pow_di(10., e10-max10e);
e10 = max10e;
}
if(e10 > 0) { /* Try always to have pow >= 1
and so exactly representable */
pow10 = R_pow_di(10., e10);
return(sgn*(R_rint((x*pow10)*p10)/pow10)/p10);
} else {
pow10 = R_pow_di(10., -e10);
return(sgn*(R_rint((x/pow10))*pow10));
}
} else { /* -- LARGE or small -- */
do_round = max10e - l10 >= R_pow_di(10., -dig);
e2 = dig + ((e10>0)? 1 : -1) * MAX_DIGITS;
p10 = R_pow_di(10., e2); x *= p10;
P10 = R_pow_di(10., e10-e2); x *= P10;
/*-- p10 * P10 = 10 ^ e10 */
if(do_round) x += 0.5;
x = floor(x) / p10;
return(sgn*x/P10);
}
}
void normalize_similarity(double *S, int npairs)
{
double mean, var, sd;
int l;
mean = 0.0;
for (l = 0 ; l < npairs; l++)
mean += S[l];
mean /= (double)npairs;
var =0.0;
for (l = 0 ; l < npairs; l++)
var += R_pow_di(S[l] - mean,2);
var /= (double)npairs;
sd = sqrt(var);
for (l = 0 ; l < npairs; l++)
S[l] = (S[l]-mean)/sd;
}
void direct(int *n, int *nSite, int *grid, int *covmod, double *coord, int *dim,
double *nugget, double *sill, double *range, double *smooth,
double *ans){
int neffSite = *nSite, lagi = 1, lagj = 1;
if (*grid){
neffSite = R_pow_di(neffSite, *dim);
lagi = neffSite;
}
else
lagj = *n;
double *covmat = malloc(neffSite * neffSite * sizeof(double));
buildcovmat(nSite, grid, covmod, coord, dim, nugget, sill, range,
smooth, covmat);
/* Compute the Cholesky decomposition of the covariance matrix */
int info = 0;
F77_CALL(dpotrf)("U", &neffSite, covmat, &neffSite, &info);
if (info != 0)
error("error code %d from Lapack routine '%s'", info, "dpotrf");
/* Simulation part */
GetRNGstate();
for (int i=0;i<*n;i++){
for (int j=0;j<neffSite;j++)
ans[j * lagj + i * lagi] = norm_rand();
F77_CALL(dtrmv)("U", "T", "N", &neffSite, covmat, &neffSite,
ans + i * lagi, &lagj);
}
PutRNGstate();
free(covmat);
return;
}
void normalize_data(double *x, int n, int p)
{
int i, j, k;
double norm;
for (i = 0 ; i < n ; i++) {
k = i;
norm = 0.0;
for(j = 0 ; j < p ; j++) {
norm += R_pow_di(x[k],2);
k += n;
}
norm = sqrt(norm);
k = i;
for(j = 0 ; j < p ; j++) {
x[k] /= norm;
k += n;
}
}
}
void gw_gcdist(double *lon1, double *lon2, double *lat1, double *lat2,
double *dist) {
double F, G, L, sinG2, cosG2, sinF2, cosF2, sinL2, cosL2, S, C;
double w, R, a, f, D, H1, H2;
double lat1R, lat2R, lon1R, lon2R, DE2RA;
DE2RA = M_PI/180;
a = 6378.137; /* WGS-84 equatorial radius in km */
f = 1.0/298.257223563; /* WGS-84 ellipsoid flattening factor */
lat1R = lat1[0]*DE2RA;
lat2R = lat2[0]*DE2RA;
lon1R = lon1[0]*DE2RA;
lon2R = lon2[0]*DE2RA;
F = ( lat1R + lat2R )/2.0;
G = ( lat1R - lat2R )/2.0;
L = ( lon1R - lon2R )/2.0;
sinG2 = R_pow_di( sin( G ), 2 );
cosG2 = R_pow_di( cos( G ), 2 );
sinF2 = R_pow_di( sin( F ), 2 );
cosF2 = R_pow_di( cos( F ), 2 );
sinL2 = R_pow_di( sin( L ), 2 );
cosL2 = R_pow_di( cos( L ), 2 );
S = sinG2*cosL2 + cosF2*sinL2;
C = cosG2*cosL2 + sinF2*sinL2;
w = atan( sqrt( S/C ) );
R = sqrt( S*C )/w;
D = 2*w*a;
H1 = ( 3*R - 1 )/( 2*C );
H2 = ( 3*R + 2 )/( 2*S );
dist[0] = D*( 1 + f*H1*sinF2*cosG2 - f*H2*cosF2*sinG2 );
}
void montenomialTest (int * obs,
double * expr,
int * ntrials,
int * nn,
int * statTypeR,
double * pLLR, // the LLR p-value
double * pProb, // the prob p-value
double * pChi, // the chi sq p-value
double * obsLLR, // the observed LLR
double * obsProb, // the observed prob
double * obsChiStat, // observed Chi Sq statistic
int * histoBinsR,
double * histoBounds,
int * histoData) {
double * probs = Calloc(*nn, double);
double * lprobs = Calloc(*nn, double);
double gnp1; // lgamma(n+1)
double * expected = Calloc(*nn, double);
double statLeft, statSpan; // for histogram
int hdex; // for histogram
// get the total sample size, n
unsigned n = 0;
for (int i = 0; i < (*nn); i++) n += obs[i];
// scale the exp array so that they are probabilities. (This may already have been done in R)
double exum = 0;
for (int i = 0; i < (*nn); i++) exum += expr[i];
for (int i = 0; i < (*nn); i++) {
probs[i] = expr[i]/exum;
lprobs[i] = log(probs[i]);
expected[i] = probs[i] * n;
}
#ifdef NOT_READY_FOR_R
srand((unsigned)time(NULL)); // seed machine random
// compute observed values. This is normally done in R
*obsLLR = 0;
for (int i = 0; i < *nn; i++) {
if (obs[i] > 0) {
(*obsLLR) += obs[i] * log(expected[i]/obs[i]);
}
}
*obsProb = exp(lmultiProb(obs, probs, *nn) + lgamma(1. + n));
*obsChiStat = 0;
for (int i = 0; i < *nn; i++) {
*obsChiStat += R_pow_di(expected[i] - obs[i], 2)/expected[i];
}
#endif
// Adjust the observed to avoid tests for floating equality
double adj = 1.0000000001;
*obsProb *= adj;
*obsLLR /= adj;
*obsChiStat /= adj;
gnp1 = lgammafn(1. + n);
unsigned * rm = Calloc(*nn, unsigned); // Where we'll put the random multinomial
double pr, stat;
double lobsProb = 0;
for (int i = 0; i < *nn; i++) {
lobsProb += obs[i] * lprobs[i] - lgammafn(1. + obs[i]);
}
pr = (gnp1 + lobsProb);
pr = exp(pr);
lobsProb /= adj;
double logProbPerfect = 0;
int intexpi;
for (int i = 0; i < *nn; i++) {
intexpi = round(expected[i]);
logProbPerfect += intexpi * lprobs[i] - lgammafn(1. + intexpi);
}
if (*histoBinsR) { // prepare for histogram
for (int i = 0; i < *histoBinsR; i++) histoData[i] = 0;
statLeft = histoBounds[0];
statSpan = (histoBounds[1] - statLeft)/(*histoBinsR);
if (statSpan == 0) *histoBinsR = 0; // No histogram can be made
}
*pLLR = 0; *pChi = 0; *pProb = 0;
// GetRNGstate();
//************************************
// This is the main loop to generate (*ntrials) random cases
//************************************
for (int kk = 0; kk < *ntrials; kk++) {
// Get a random multinomial
rmultinom(n, probs, *nn, (int*)rm);
// // Display the random sample
// Rprintf("\nTrial %d: ",kk);
// for (int m = 0; m < *nn; m++) {
// Rprintf("%5d", rm[m]);
// }
// Use switch to compute only the requested statistic to save time.
// Actually, though, LLR and Chisquare are fast relative to getting the random multinomial. Only Prob is slow.
switch (*statTypeR) {
case 1:
stat = 0; // Use LLR as measure of distance
for (int i = 0; i < *nn; i++) {
if (rm[i] > 0) {
stat += rm[i] * log(expected[i]/rm[i]);
}
}
if (stat <= *obsLLR) {
*pLLR += 1;
}
break;
case 2: // Use probability of outcome as measure of "distance"
stat = 0;
for (int i = 0; i < *nn; i++) {
stat += rm[i] * lprobs[i] - lgammafn(1. + rm[i]);
}
if (stat <= lobsProb) {
*pProb += 1;
}
break;
case 3:
stat = 0; // Use chisquare as measure of distance
for (int i = 0; i < *nn; i++) {
stat += R_pow_di(expected[i] - rm[i], 2)/expected[i];
}
if (stat >= *obsChiStat) {
*pChi += 1;
}
break;
default:
break;
}
if (*histoBinsR) { // Do this only if user requested histobram by setting *histoBinsR > 0
if(*statTypeR == 1) stat *= (-2.); // convert to have asymptotic chisquare dist'n
if(*statTypeR == 2) stat = -2 * (stat - logProbPerfect);
hdex = (stat - statLeft)/statSpan;
if ((hdex >= 0) && (hdex < *histoBinsR)) {
(histoData[hdex])++;
}
}
}
*pLLR /= *ntrials;
*pProb /= *ntrials;
*pChi /= *ntrials;
// PutRNGstate();
Free(probs); Free(expected);
Free(lprobs);
Free(rm);
}
void rgeomcirc(int *nObs, int *ngrid, double *steps, int *dim,
int *covmod, double *sigma2, double *nugget, double *range,
double *smooth, double *uBound, double *ans){
/* This function generates random fields from the geometric model
nObs: the number of observations to be generated
ngrid: the number of locations along one axis
dim: the random field is generated in R^dim
covmod: the covariance model
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
uBound: the uniform upper bound for the stoch. proc.
ans: the generated random field */
int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2,
zero = 0;
double sigma = sqrt(*sigma2), sill = 1 - *nugget, *rho, *irho, *dist;
//Below is a table of highly composite numbers
int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240,
360, 720, 840, 1260, 1680, 2520, 5040, 7560,
10080, 15120, 20160, 25200, 27720, 45360, 50400,
55440, 83160, 110880, 166320, 221760, 277200,
332640, 498960, 554400, 665280, 720720, 1081080};
/* Find the smallest size m for the circulant embedding matrix */
{
int dummy = 2 * (*ngrid - 1);
do {
k++;
m = HCN[k];
} while (m < dummy);
}
/* ---------- beginning of the embedding stage ---------- */
int mbar = m * m, halfM = m / 2, notPosDef = 0;
do {
dist = (double *)R_alloc(mbar, sizeof(double));
notPosDef = 0;
//Computation of the distance
for (r=mbar;r--;){
i = r % m;
j = r / m;
if (i > halfM)
i -= m;
if (j > halfM)
j -= m;
dist[r] = hypot(steps[0] * i, steps[1] * j);
}
//Computations of the covariances
rho = (double *)R_alloc(mbar, sizeof(double));
irho = (double *)R_alloc(mbar, sizeof(double));
for (i=mbar;i--;)
irho[i] = 0;
switch (*covmod){
case 1:
whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 2:
cauchy(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 3:
powerExp(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 4:
bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho);
break;
}
/* Compute the eigen values to check if the circulant embbeding
matrix is positive definite */
/* Note : The next lines is only valid for 2d random fields. I
need to change if there are m_1 \neq m_2 as I suppose that m_1
= m_2 = m */
int maxf, maxp;
fft_factor(m, &maxf, &maxp);
double *work = (double *)R_alloc(4 * maxf, sizeof(double));
int *iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, 1, m, m, -1, work, iwork);
//Check if the eigenvalues are all positive
for (i=mbar;i--;){
notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001);
}
if (notPosDef){
k++;
m = HCN[k];
halfM = m / 2;
mbar = m * m;
}
if (k > 30)
error("Impossible to embbed the covariance matrix");
} while (notPosDef);
/* --------- end of the embedding stage --------- */
/* Computation of the square root of the eigenvalues */
for (i=mbar;i--;){
rho[i] = sqrt(rho[i]);
irho[i] = 0;//No imaginary part
}
int mdag = m / 2 + 1, mdagbar = mdag * mdag;
double isqrtMbar = 1 / sqrt(mbar);
double *a = (double *)R_alloc(mbar, sizeof(double));
double *ia = (double *)R_alloc(mbar, sizeof(double));
GetRNGstate();
for (i=*nObs;i--;){
int nKO = nbar;
double poisson = 0;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
int j;
double *gp = (double *)R_alloc(nbar, sizeof(double));
poisson += exp_rand();
double ipoisson = -log(poisson), thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp);
nKO = nbar;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=nbar;j--;){
ans[j + i * nbar] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j + i * nbar]);
nKO -= (thresh <= ans[j + i * nbar]);
}
}
}
PutRNGstate();
/* So fare we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * nbar;i--;)
ans[i] = exp(ans[i]);
return;
}
void rextremaltdirect(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *nugget, double *range,
double *smooth, double *DoF, double *uBound, double *ans){
/* This function generates random fields for the Extremal-t model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
DoF: the degree of freedom
blockSize: see rextremalttbm.
ans: the generated random field */
int neffSite, lagi = 1, lagj = 1, oneInt = 1;
double sill = 1 - *nugget;
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *covmat = malloc(neffSite * neffSite * sizeof(double)),
*gp = malloc(neffSite * sizeof(double));
buildcovmat(nSite, grid, covmod, coord, dim, nugget, &sill, range,
smooth, covmat);
/* Compute the Cholesky decomposition of the covariance matrix */
int info = 0;
F77_CALL(dpotrf)("U", &neffSite, covmat, &neffSite, &info);
if (info != 0)
error("error code %d from Lapack routine '%s'", info, "dpotrf");
GetRNGstate();
for (int i=*nObs;i--;){
double poisson = 0;
int nKO = neffSite;
while (nKO){
poisson += exp_rand();
double ipoisson = 1 / poisson,
thresh = *uBound * ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (int j=neffSite;j--;)
gp[j] = norm_rand();
F77_CALL(dtrmv)("U", "T", "N", &neffSite, covmat, &neffSite, gp, &oneInt);
nKO = neffSite;
for (int j=neffSite;j--;){
double dummy = R_pow(fmax2(0, gp[j]), *DoF) * ipoisson;
ans[j * lagj + i * lagi] = fmax2(dummy, ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
//Lastly we multiply by the normalizing constant
const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) /
gammafn(0.5 * (*DoF + 1));
for (int i=(neffSite * *nObs);i--;)
ans[i] *= imean;
free(covmat); free(gp);
return;
}
void xtest (int * rm,
int * rk,
double * robservedVals, // observed stats: LLR, Prob, U, X2
double * rPvals, // computed P values: LLR, Prob, U, X2
int * rstatID, // which statistic to use for histogram (1-4)
int * rhistobins, // number of bins for histogram. (no histogram if 0)
double * rhistobounds, // Two values indicating the range for histogram
double * rhistoData, // histogram data. length = histobounds.
int * rsafeSecs, // abort calculation after this many seconds
double * tables // the number of tables examined
)
{
// Set up global variables used during recursion
nAlleles = *rk;
pU = pLLR = pPr = pX2 =probSum = 0;
hProb = rhistoData;
Rbytes = *rk * sizeof(COUNTTYPE);
statID = *rstatID;
timeLimit = *rsafeSecs;
HN = *rhistobins;
start = time(NULL);
Rarray = Calloc(*rk * *rk * (*rk-1)/2, COUNTTYPE);
for (int i = 0; i < nAlleles; i++) Rarray[i] = rm[i];
mi = rm-1; // 1-based list of allele counts
tableCount = 0;
umean = 0; uvariance = 0;
// Make lookup tables
xlnx = Calloc(rm[0] + 1, double);
lnFact = Calloc(rm[0] + 1, double);
uTerm1 = Calloc(rm[0]/2 + 1, double);
uTerm2 = Calloc(rm[1]/2 + 1, double);
int biggesta11 = rm[0]/2;
int biggesta22 = rm[1]/2;
int biggesta21 = rm[1];
x211 = Calloc((biggesta11+1), double);
x222 = Calloc((biggesta22 + 1), double);
x221 = Calloc((biggesta21+1), double);
xlnx[0] = 0;
lnFact[0] = 0;
double lni;
for (int i = 1; i <= rm[0]; i++) {
lni = log(i);
xlnx[i] = lni * i;
lnFact[i] = lnFact[i-1] + lni;
}
for(int i = 0; i <= rm[0]/2; i++) uTerm1[i] = (double)i/rm[0];
for(int i = 0; i <= rm[1]/2; i++) uTerm2[i] = (double)i/rm[1];
size_t nsq = fmax(2, nAlleles * nAlleles);
exa = Calloc(nsq, double); // Expected numbers. Array uses extra space but saves time
int nGenes = 0;
for(int i = 0; i < nAlleles; i++) nGenes += rm[i];
ntotal = nGenes/2;
for(int i = 0; i < nAlleles; i++) {
exa[i * nAlleles + i] = (double)(rm[i] * rm[i])/(2.0 * nGenes);
for (int j = 0; j < i; j++) {
exa[i * nAlleles + j] = (double)(rm[i] * rm[j])/nGenes;
}
}
for(int i = 0; i <= biggesta11; i++) x211[i] = R_pow_di(exa[0] - i, 2)/exa[0];
for(int i = 0; i <= biggesta21; i++) x221[i] = R_pow_di(exa[nAlleles] - i, 2)/exa[nAlleles];
for(int i = 0; i <= biggesta22; i++) x222[i] = R_pow_di(exa[nAlleles + 1] - i, 2)/exa[nAlleles + 1];
// Get constant terms for LLR and Prob
constProbTerm = constLLRterm = 0;
for (int i = 0; i < nAlleles; i++) {
constProbTerm += lgammafn(rm[i] + 1); //lnFact[rm[i]];
constLLRterm += xlnx[rm[i]];
}
constProbTerm += log(2)*ntotal + lgammafn(ntotal+1) - lgammafn(nGenes +1);
constLLRterm += -log(2)*ntotal - log(ntotal) * ntotal;
// Get cutoffs for the four test statistics
double oneMinus = 0.9999999; // Guards against floating-point-equality-test errors
if(robservedVals[0] > 0.000000000001) robservedVals[0] = 0; // positive values are rounding errors
maxLLR = robservedVals[0] * oneMinus;
maxlPr = log(robservedVals[1]) * oneMinus;
minmaxU = robservedVals[2] * oneMinus;
minX2 = robservedVals[3] * oneMinus;
// Set up histogram
if (HN) {
switch (*rstatID) {
case 0: // LLR -- histobounds gives bounds for -2LLR
leftStat = rhistobounds[0]/(-2.0);
statSpan = -2.0 * HN/(rhistobounds[1] - rhistobounds[0]);
break;
case 1: // Prob -- histobounds gives bounds for -2ln(pr)
leftStat = rhistobounds[0]/(-2.0);
statSpan = -2.0 * HN/(rhistobounds[1] - rhistobounds[0]);
break;
case 2: // U score -- histobounds is actual bounds
leftStat = rhistobounds[0];
statSpan = (double)HN/(rhistobounds[1] - rhistobounds[0]);
break;
case 3: // X2 -- histobounds is actual bounds
leftStat = rhistobounds[0];
statSpan = (double)HN/(rhistobounds[1] - rhistobounds[0]);
break;
default:
break;
}
hProb = rhistoData;
for(int i = 0; i < HN; i++) hProb[i] = 0;
}
start = time(NULL);
if (nAlleles == 2) {
twoAlleleSpecialCase();
} else {
homozygote(nAlleles, 0, 0, 0, 0, Rarray);
}
*tables = tableCount;
rPvals[0] = pLLR;
rPvals[1] = pPr;
rPvals[2] = pU;
rPvals[3] = pX2;
if (tableCount < 0) for(int i = 0; i < 4; i++) rPvals[i] = -1; // Process timed out and p values are meaningless
// printf("\nU mean = %.8f", umean);
// printf("\nU variance = %.8f\n", uvariance - umean * umean);
Free(xlnx);Free(lnFact);Free(Rarray);
Free(exa); Free(uTerm1); Free(uTerm2);
Free(x211); Free(x221); Free(x222);
}
static void heterozygote (unsigned r, unsigned c, double probl, double statl, double u, double x2, COUNTTYPE * R)
{
if(tableCount < 0) return;
COUNTTYPE *res, *resn;
int lower, upper, exindex;
unsigned i, arc, ar1, ar2, a31, a32, a11, a21, a22;
unsigned res1, res2, resTemp, dT;
int hdex;
double probl3, statl3, x23, problT, statlT, uT, x2T, prob, x=0;
COUNTTYPE * Rnew = R + nAlleles;
res = R-1; // to make res a 1-based version of R
resn = Rnew-1; // so resn is 1-based for Rnew
lower = res[r];
for (i = 1; i < c; i++) lower -= res[i];
lower = fmax(0, lower);
upper = fmin(res[r], res[c]);
if(c > 2) for (arc = lower; arc <= upper; arc++) {
memcpy(Rnew, R, Rbytes); // Put a fresh set of residuals from R into Rnew
// decrement residuals for the current value of arc.
resn[r] -= arc;
resn[c] -= arc;
exindex = (r-1)*nAlleles + c - 1;
heterozygote(r, c-1,
probl+lnFact[arc],
statl + xlnx[arc],
u,
x2 + R_pow_di(arc - exa[exindex], 2)/exa[exindex],
Rnew);
} // for arc
if(c==2){
if(r > 3) for (ar2= lower; ar2 <= upper; ar2++) {
memcpy(Rnew, R, Rbytes); // Put a fresh set of residuals from R into Rnew
// decrement residuals for the current value of arc.
resn[r] -= ar2;
resn[c] -= ar2;
// The value of ar1 is now fixed, so no need for any more calls to heterozygote in this row
ar1 = fmin(resn[r], resn[1]);
resn[1] -= ar1;
resn[r] -= ar1;
exindex = (r-1)*nAlleles;
homozygote(r-1,
probl + lnFact[ar2] + lnFact[ar1],
statl + xlnx[ar2] + xlnx[ar1],
u,
x2 + R_pow_di(ar1 - exa[exindex], 2)/exa[exindex]+ R_pow_di(ar2 - exa[exindex+1], 2)/exa[exindex+1] ,
Rnew);
} // if r > 3
if(r==3) // and c = 2, then we can handle a series of two-allele cases with no deeper recursion
{
double * uT1, *uT2, *x11, *x22;
for(a32 = lower; a32 <= upper; a32++) {
a31 = fmin(res[1], res[3]-a32); //Value of a31 is now fixed for each a32
probl3 = probl + lnFact[a32] + lnFact[a31];
statl3 = statl + xlnx[a32] + xlnx[a31];
exindex = 2*nAlleles;
x23 = x2 + R_pow_di(a31 - exa[exindex], 2)/exa[exindex]+ R_pow_di(a32 - exa[exindex+1], 2)/exa[exindex+1] ;
// get residual allele counts for two-allele case
res1 = res[1] - a31;
res2 = res[2] - a32;
// make pointers to lookups in case they need to be swapped
uT1 = uTerm1;
uT2 = uTerm2;
x11 = x211;
x22 = x222;
if(res1 > res2) { // make sure res1 <= res2. If they need swapping, then swap lookups too
resTemp = res2;
res2 = res1;
res1 = resTemp;
uT1 = uTerm2;
uT2 = uTerm1;
x11 = x222;
x22 = x211;
}
// Now process two-allele case with allele counts res1 and res2
tableCount += res1/2 + 1;
for(a11 = 0; a11 <= res1/2; a11++) {
a21 = res1-a11*2; // integer arithmetic rounds down
a22 = (res2-a21)/2;
problT = probl3 + lnFact[a11] + lnFact[a21] + lnFact[a22];
statlT = statl3 + xlnx[a11] + xlnx[a21] + xlnx[a22];
dT = a11 + a22;
// Here come the actual probability and LLR and X2 and U values
problT = constProbTerm - problT -dT * M_LN2;
prob = exp(problT);
statlT = constLLRterm - statlT - dT * M_LN2;
uT = 2 * ntotal * (u + uT1[a11] + uT2[a22]) - ntotal;
x2T = x23 + x221[a21] + x11[a11] + x22[a22];
// umean += prob * uT;
// uvariance += prob * uT * uT;
//Now process the new values of prob and stat
probSum += prob;
if(statlT <= maxLLR) pLLR += prob;
if(problT <= maxlPr) pPr += prob;
if (minmaxU < 0) {
if(uT <= minmaxU) pU += prob;
} else {
if(uT >= minmaxU) pU += prob;
}
if(x2T >= minX2) pX2 += prob;
// Update histogram if needed
if (HN) {
switch (statID) {
case 0:
x = statlT;
break;
case 1:
x = problT;
break;
case 2:
x = uT;
break;
case 3:
x = x2T;
default:
break;
}
hdex = statSpan * (x - leftStat);
if ((hdex >= 0) && (hdex < HN)) {
hProb[hdex] += prob;
}
}
} // for a11
} // for a32
} // if r == 3
} // if c == 2
}
void rextremaltcirc(int *nObs, int *ngrid, double *steps, int *dim,
int *covmod, double *nugget, double *range,
double *smooth, double *DoF, double *uBound, double *ans){
/* This function generates random fields from the Schlather model
nObs: the number of observations to be generated
ngrid: the number of locations along one axis
dim: the random field is generated in R^dim
covmod: the covariance model
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
DoF: the degree of freedom
blockSize: see rextremalttbm
ans: the generated random field */
int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m;
const double zero = 0;
double *rho, *irho, sill = 1 - *nugget;
//Below is a table of highly composite numbers
int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240,
360, 720, 840, 1260, 1680, 2520, 5040, 7560,
10080, 15120, 20160, 25200, 27720, 45360, 50400,
55440, 83160, 110880, 166320, 221760, 277200,
332640, 498960, 554400, 665280, 720720, 1081080};
/* Find the smallest size m for the circulant embedding matrix */
{
int dummy = 2 * (*ngrid - 1);
do {
k++;
m = HCN[k];
} while (m < dummy);
}
/* ---------- beginning of the embedding stage ---------- */
int mbar = m * m, halfM = m / 2, notPosDef = 0;
do {
double *dist = (double *)R_alloc(mbar, sizeof(double));
notPosDef = 0;
//Computation of the distance
for (r=mbar;r--;){
i = r % m;
j = r / m;
if (i > halfM)
i -= m;
if (j > halfM)
j -= m;
dist[r] = hypot(steps[0] * i, steps[1] * j);
}
//Computations of the covariances
rho = (double *)R_alloc(mbar, sizeof(double));
irho = (double *)R_alloc(mbar, sizeof(double));
for (i=mbar;i--;)
irho[i] = 0;
switch (*covmod){
case 1:
whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 2:
cauchy(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 3:
powerExp(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 4:
bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho);
break;
}
/* Compute the eigen values to check if the circulant embbeding
matrix is positive definite */
/* Note : The next lines is only valid for 2d random fields. I
need to change if there are m_1 \neq m_2 as I suppose that m_1
= m_2 = m */
int maxf, maxp, *iwork;
double *work;
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, 1, m, m, -1, work, iwork);
//Check if the eigenvalues are all positive
for (i=mbar;i--;){
notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001);
}
if (notPosDef){
k++;
m = HCN[k];
halfM = m / 2;
mbar = m * m;
}
if (k > 30)
error("Impossible to embbed the covariance matrix");
} while (notPosDef);
/* --------- end of the embedding stage --------- */
/* Computation of the square root of the eigenvalues */
for (i=mbar;i--;){
rho[i] = sqrt(rho[i]);
irho[i] = 0;//No imaginary part
}
int mdag = m / 2 + 1, mdagbar = mdag * mdag;
double isqrtMbar = 1 / sqrt(mbar);
double *a = malloc(mbar * sizeof(double)),
*ia = malloc(mbar * sizeof(double)),
*gp = malloc(nbar * sizeof(double));
GetRNGstate();
for (int i=*nObs;i--;){
int nKO = nbar;
double poisson = 0;
while (nKO){
poisson += exp_rand();
double ipoisson = 1 / poisson,
thresh = *uBound * ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp);
nKO = nbar;
for (int j=nbar;j--;){
double dummy = R_pow(fmax2(gp[j], 0), *DoF) * ipoisson;
ans[j + i * nbar] = fmax2(dummy, ans[j + i * nbar]);
nKO -= (thresh <= ans[j + i * nbar]);
}
}
}
PutRNGstate();
//Lastly we multiply by the normalizing constant
const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) /
gammafn(0.5 * (*DoF + 1));
for (i=(nbar * *nObs);i--;)
ans[i] *= imean;
free(a); free(ia); free(gp);
return;
}
void rextremalttbm(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *nugget, double *range,
double *smooth, double *DoF, double *uBound, int *nlines,
double *ans){
/* This function generates random fields from the Extremal-t model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
DoF: the degree of freedom
blockSize: simulated field is the maximum over blockSize ind. replicates
nlines: the number of lines used for the TBM algo
ans: the generated random field */
int i, neffSite, lagi = 1, lagj = 1;
double sill = 1 - *nugget;
const double irange = 1 / *range;
//rescale the coordinates
for (i=(*nSite * *dim);i--;)
coord[i] = coord[i] * irange;
double *lines = malloc(3 * *nlines * sizeof(double));
if ((*covmod == 3) && (*smooth == 2))
//This is the gaussian case
*covmod = 5;
//Generate lines
vandercorput(nlines, lines);
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *gp = malloc(neffSite * sizeof(double));
GetRNGstate();
for (i=*nObs;i--;){
int nKO = neffSite;
double poisson = 0;
while (nKO){
/* ------- Random rotation of the lines ----------*/
double u = unif_rand() - 0.5,
v = unif_rand() - 0.5,
w = unif_rand() - 0.5,
angle = runif(0, M_2PI),
inorm = 1 / sqrt(u * u + v * v + w * w);
u *= inorm;
v *= inorm;
w *= inorm;
rotation(lines, nlines, &u, &v, &w, &angle);
/* -------------- end of rotation ---------------*/
poisson += exp_rand();
double ipoisson = 1 / poisson,
thresh = *uBound * ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (int j=neffSite;j--;)
gp[j] = 0;
tbmcore(nSite, &neffSite, dim, covmod, grid, coord, nugget,
&sill, range, smooth, nlines, lines, gp);
nKO = neffSite;
for (int j=neffSite;j--;){
double dummy = R_pow(fmax2(0, gp[j]), *DoF) * ipoisson;
ans[j * lagj + i * lagi] = fmax2(dummy, ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
//Lastly we multiply by the normalizing constant
const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) /
gammafn(0.5 * (*DoF + 1));
for (i=(neffSite * *nObs);i--;)
ans[i] *= imean;
free(lines); free(gp);
return;
}
double Por2double(int len, char* text){
int sign=1;
int exp_sign = 0;
int exponent=0;
int l_charact = len;
char *t_mant = NULL;
int l_mant = 0;
char *t_exp = NULL;
int l_exp = 0;
char *end = text + len;
char *tmp = text;
double result = 0;
#ifdef DEBUG
Rprintf("\nPor2double ----------------------------");
Rprintf("\n input = %s\n",text);
#endif
if(*text == '*') return NA_REAL;
if(*text == '+') {
text++;
l_charact--;
}
if(*text == '-'){
sign = -1;
text++;
l_charact--;
}
for(tmp = text; tmp < end; tmp++){
if(*tmp == '.'){
l_charact = (int)(tmp - text);
tmp++;
t_mant = tmp;
l_mant = (int)(end - tmp);
break;
}
if(*tmp == '+' || *tmp == '-'){
l_charact = (int)(tmp - text);
if(*tmp == '+')
exp_sign = 1;
if(*tmp == '-')
exp_sign = -1;
tmp++;
t_exp = tmp;
l_exp = (int)(end - tmp);
exponent = Por2int(l_exp,t_exp);
if(exp_sign == -1){ /** "un-normalize" **/
if(exponent >= l_charact){
l_mant = l_charact;
l_charact = 0;
exponent -= l_mant;
exponent = -exponent;
t_mant = text;
}
else {
l_mant = exponent;
l_charact -= exponent;
t_mant = text + l_charact;
exponent = 0;
}
}
break;
}
}
if(l_charact)
result += (double)Por2int(l_charact,text);
if(l_mant){
result += Por2mantissa(l_mant, t_mant);
}
if(exponent != 0){
#ifdef DEBUG
Rprintf("\n ####### Por2double ");
Rprintf(" input = %s",text);
Rprintf(" exponent = %d",exponent);
Rprintf(" result = %f",result*R_pow_di(30,exponent));
#endif
result *= R_pow_di(30,exponent);
}
#ifdef DEBUG
Rprintf("\nresult = %f",result);
#endif
if(sign == -1)
return -result;
else
return result;
}
