void distance(double *coord, int *nDim, int *nSite,
int *vec, double *dist){
//This function computes either the euclidean distance or the
//distance vector between each pair of locations
const int nPair = *nSite * (*nSite - 1) / 2;
if (*vec){
#pragma omp parallel for
for (int pair=0;pair<nPair;pair++){
int i, j;
getSiteIndex(pair, *nSite, &i, &j);
for (int k=0;k<*nDim;k++)
dist[k * nPair + pair] = coord[k * *nSite + j] - coord[k * *nSite + i];
}
}
else{
#pragma omp parallel for
for (int pair=0;pair<nPair;pair++){
int i, j;
getSiteIndex(pair, *nSite, &i, &j);
dist[pair] = 0;
for (int k=0;k<*nDim;k++)
dist[pair] += (coord[i + k * *nSite] - coord[j + k * *nSite]) *
(coord[i + k * *nSite] - coord[j + k * *nSite]);
dist[pair] = sqrt(dist[pair]);
}
}
}
void empiricalBootConcProb(double *data, int *nSite, int *nObs, int *blockSize,
double *concProb){
const double normCst = lchoose(*nObs, *blockSize);
const int nPair = *nSite * (*nSite - 1) / 2;
#pragma omp parallel for
for (int currentPair=0;currentPair<nPair;currentPair++){
int i, j;
getSiteIndex(currentPair, *nSite, &i, &j);
// For each pair compute the estimator
concProb[currentPair] = 0;
for (int k=0;k<*nObs;k++){
int d = 0;
for (int l=0;l<*nObs;l++)
d += (data[l + i * *nObs] < data[k + i * *nObs]) && (data[l + j * *nObs] < data[k + j * *nObs]);
concProb[currentPair] += exp(lchoose(d, *blockSize - 1) - normCst);
}
}
return;
}
double fbm(double *coord, double *dist, int dim, int nSite, double sill, double range,
double smooth, double *rho){
/* This function computes the covariance function related to a
fractional Brownian motion. When ans != 0.0, the parameters are
ill-defined. */
const int nPairs = nSite * (nSite - 1) / 2;
const double irange = 1 / range;
double *distOrig = malloc(nSite * sizeof(double));
//Some preliminary steps: Valid points?
if (smooth < EPS)
return (1 - smooth + EPS) * (1 - smooth + EPS) * MINF;
else if (smooth > 2)
return (smooth - 1) * (smooth - 1) * MINF;
if (range <= 0)
return (1 - range) * (1 - range) * MINF;
if (sill <= 0)
return (1 - sill) * (1 - sill) * MINF;
distance2orig(coord, nSite, dim, distOrig, 0);
/* Rmk: 0.5 Var[Z(x)] = \gamma(||x||) as Z(o) = 0, where \gamma is
the semi-variogram */
#pragma omp parallel for
for (int i=0;i<nSite;i++)
distOrig[i] = pow(distOrig[i] * irange, smooth);
#pragma omp parallel for
for (int currentPair=0;currentPair<nPairs;currentPair++){
int i, j;
getSiteIndex(currentPair, nSite, &i, &j);
rho[currentPair] = sill * (distOrig[i] + distOrig[j] -
pow(dist[currentPair] * irange, smooth));
}
free(distOrig);
return 0;
}
void concProbKendall(double *data, int *nSite, int *nObs, double *concProb,
double *jackKnife, int *computeStdErr){
const int nPair = *nSite * (*nSite - 1) / 2;
if (!*computeStdErr){
#pragma omp parallel for
for (int currentPair=0;currentPair<nPair;currentPair++){
int i,j;
getSiteIndex(currentPair, *nSite, &i, &j);
concProb[currentPair]=0;
int nEffObs = 0;//the number of effective contribution (because of possible missing values)
for (int k=0;k<(*nObs-1);k++){
if (ISNA(data[k + i * *nObs]) || ISNA(data[k + j * *nObs]))
continue;
for (int l=k+1;l<*nObs;l++){
if (ISNA(data[l + i * *nObs]) || ISNA(data[l + j * *nObs]))
continue;
nEffObs++;
concProb[currentPair] += sign(data[k + i * *nObs] - data[l + i * *nObs]) *
sign(data[k + j * *nObs] - data[l + j * *nObs]);
}
}
concProb[currentPair] *= nEffObs == 0 ? NA_REAL : 1.0 / ((double) nEffObs);
}
}
else {
//the number of effective observation for the jackknife estimates
int *nEffObsJack = malloc(*nObs * sizeof(int));
for (int currentPair=0;currentPair<nPair;currentPair++){
int i,j;
getSiteIndex(currentPair, *nSite, &i, &j);
// Reinitialization for the new pair
//the number of effective contribution (because of possible missing values)
int nEffObs = 0;
for (int k=0;k<*nObs;k++){
nEffObsJack[k] = 0;
if (ISNA(data[k + i * *nObs]) || ISNA(data[k + j * *nObs])){
// If the discarded observation is missing, jackknife
// estimate is meaningless...
jackKnife[k + currentPair * *nObs] = NA_REAL;
continue;
}
for (int l=0;l<*nObs;l++){
if ((k == l) || ISNA(data[l + i * *nObs]) || ISNA(data[l + j * *nObs]))
continue;
nEffObs++; nEffObsJack[k]++;
double tmp = sign(data[k + i * *nObs] - data[l + i * *nObs]) *
sign(data[k + j * *nObs] - data[l + j * *nObs]);
concProb[currentPair] += tmp;
jackKnife[k + currentPair * *nObs] += tmp;
}
}
/*
Rmk: To compute the jackknife estimates (for a given pair of
stations), we will use the following formula
tau_(-k) = 2 / ((n - 1) (n-2)) * (n (n-1) / 2 * tau - sum_{l=1}^n
sign(data_l(s_1) - data_k(s_1)) * sign(data_l(s_2) -
data_k(s_2))
*/
for (int k = 0; k<*nObs; k++)
jackKnife[k + currentPair * *nObs] = nEffObsJack[k] == 0 ? NA_REAL :
(concProb[currentPair] - 2.0 * jackKnife[k + currentPair * *nObs]) /
((double) (nEffObs - 2 * nEffObsJack[k]));
concProb[currentPair] *= nEffObs == 0 ? NA_REAL : 1.0 / ((double) nEffObs);
}
free(nEffObsJack);
}
return;
}
void buildcovmat(int *nSite, int *grid, int *covmod, double *coord, int *dim,
double *nugget, double *sill, double *range,
double *smooth, double *covMat){
int nPairs, effnSite = *nSite, zero = 0;
const double one = 1, dzero = 0;
double flag = 0;
if (*grid)
effnSite = R_pow_di(effnSite, *dim);
nPairs = effnSite * (effnSite - 1) / 2;
double *dist = malloc(nPairs * sizeof(double)),
*rho = malloc(nPairs * sizeof(double)),
*coordGrid = malloc(effnSite * *dim * sizeof(double));
if (*grid){
//Coord specify a grid
for (int i = 0; i < *nSite; i++)
for (int j = 0; j < *nSite; j++){
coordGrid[j + i * *nSite] = coord[i];
coordGrid[*nSite * (*nSite + i) + j] = coord[j];
}
distance(coordGrid, dim, &effnSite, &zero, dist);
}
else
//Coord don't specify a grid
distance(coord, dim, nSite, &zero, dist);
switch (*covmod){
case 1:
flag = whittleMatern(dist, nPairs, dzero, one, *range, *smooth, rho);
break;
case 2:
flag = cauchy(dist, nPairs, dzero, one, *range, *smooth, rho);
break;
case 3:
flag = powerExp(dist, nPairs, dzero, one, *range, *smooth, rho);
break;
case 4:
flag = bessel(dist, nPairs, *dim, dzero, one, *range, *smooth, rho);
break;
case 6:
if (*grid)
flag = fbm(coordGrid, dist, *dim, effnSite, one, *range, *smooth, rho);
else
flag = fbm(coord, dist, *dim, effnSite, one, *range, *smooth, rho);
break;
}
if (flag != 0.0)
error("The covariance parameters seem to be ill-defined. Please check\n");
//Fill the non-diagonal elements of the covariance matrix
//#pragma omp parallel for
for (int currentPair=0;currentPair<nPairs;currentPair++){
int i = 0, j = 0;
getSiteIndex(currentPair, effnSite, &i, &j);
covMat[effnSite * i + j] = covMat[effnSite * j + i] = *sill * rho[currentPair];
}
//Fill the diagonal elements of the covariance matrix
if (*covmod == 6){
//Fractional brownian
double irange2 = 1 / (*range * *range);
if (*grid){
for (int i = 0; i < effnSite;i++){
covMat[i * (effnSite + 1)] = 0;
for (int j= 0; j < *dim; j++)
covMat[i * (effnSite + 1)] += coordGrid[i + j * effnSite] * coordGrid[i + j * effnSite];
covMat[i * (effnSite + 1)] = 2 * pow(covMat[i * (effnSite + 1)] * irange2, 0.5 * *smooth);
}
}
else {
for (int i = 0; i < effnSite; i++){
covMat[i * (effnSite + 1)] = 0;
for (int j = 0; j < *dim; j++)
covMat[i * (effnSite + 1)] += coord[i + j * effnSite] * coord[i + j * effnSite];
covMat[i * (effnSite + 1)] = 2 * pow(covMat[i * (effnSite + 1)] * irange2, 0.5 * *smooth);
}
}
}
else
for (int i = 0; i < effnSite; i++)
covMat[i * (effnSite + 1)] = *sill + *nugget;
free(dist); free(rho); free(coordGrid);
return;
}
