double levunif(double limit, double min, double max, double order, int give_log)
{
#ifdef IEEE_754
if (ISNAN(limit) || ISNAN(min) || ISNAN(max) || ISNAN(order))
return limit + min + max + order;
#endif
if (!R_FINITE(min) ||
!R_FINITE(max) ||
min >= max)
return R_NaN;
if (limit <= min)
return R_pow(limit, order);
if (limit >= max)
return munif(order, min, max, give_log);
if (order == -1.0)
return (log(fabs(limit)) - log(fabs(min))) / (max - min) +
(max - limit) / (limit * (max - min));
double tmp = order + 1;
return (R_pow(limit, tmp) - R_pow(min, tmp)) / ((max - min) * tmp) +
R_pow(limit, order) * (max - limit) / (max - min);
}
double levinvparalogis(double limit, double shape, double scale, double order,
int give_log)
{
double u, tmp1, tmp2, tmp3;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape * shape)
return R_PosInf;
tmp1 = order / shape;
tmp2 = shape + tmp1;
tmp3 = 1.0 - tmp1;
u = exp(-log1pexp(shape * (log(scale) - log(limit))));
return R_pow(scale, order) * gammafn(tmp2) * gammafn(tmp3)
* pbeta(u, tmp2, tmp3, 1, 0) / gammafn(shape)
+ ACT_DLIM__0(limit, order) * (0.5 - R_pow(u, shape) + 0.5);
}
/* produces standard Frechet margins */
void rbvalog_shi(int *n, double *alpha, double *asy, double *sim)
{
double v1_1,v2_2,v1_12,v2_12,u,z;
int i;
RANDIN;
if(*alpha == 1)
for(i=0;i<2*(*n);i++) sim[i] = 1/EXP;
else {
for(i=0;i<*n;i++)
{
v1_1 = (1-asy[0]) / EXP;
v2_2 = (1-asy[1]) / EXP;
u = UNIF;
if(UNIF < *alpha) z = EXP+EXP;
else z = EXP;
v1_12 = asy[0] / (z * R_pow(u,*alpha));
v2_12 = asy[1] / (z * R_pow(1-u,*alpha));
sim[2*i] = fmax2(v1_1,v1_12);
sim[2*i+1] = fmax2(v2_2,v2_12);
}
}
RANDOUT;
}
void Cfunc(double *xvec, int *xlen, int *M, double *beta0, double *alpha, double *res) {
// double qt(double p, double ndf, int lower_tail,int log_p);
// double runif(double a, double b);
int d = 0, m, i, n = xlen[0];
double *yvec;
yvec = new double[n];
double meanxy = 0.0, meanx = 0.0, meany = 0.0, meanx2 = 0.0, meany2 = 0.0;
double thresh, num = 0.0, denom = 0.0, tobs, beta1hat, beta0hat, sighat, sighatbeta1hat;
thresh = qt(1.0 - alpha[0] / 2.0, (double)(n - 2), 1, 0);
// Rprintf("Value of thresh: %g", thresh);
// Rprintf("\n");
for (i = 0; i < n; i++) {
meanx = meanx + xvec[i];
meanx2 = meanx2 + R_pow(xvec[i], 2.0);
}
meanx = meanx / (double)n;
meanx2 = meanx2 / (double)n;
GetRNGstate();
for (m = 0; m < M[0]; m++) {
meany = 0;
meany2 = 0;
meanxy = 0;
for (i = 0; i < n; i++) {
yvec[i] = beta0[0] + runif(0.0, 1.0);
meany = meany + yvec[i];
meany2 = meany2 + R_pow(yvec[i], 2.0);
meanxy = meanxy + xvec[i] * yvec[i];
}
meany = meany / (double)n;
meany2 = meany2 / (double)n;
meanxy = meanxy / (double)n;
num = meanxy - meanx * meany;
denom = meanx2 - meanx * meanx;
beta1hat = num / denom;
beta0hat = meany - beta1hat * meanx;
sighat = sqrt((double)n * (meany2 + beta0hat * beta0hat + beta1hat * beta1hat * meanx2 - 2.0 * beta0hat * meany
- 2.0 * beta1hat * meanxy + 2.0 * beta0hat * beta1hat * meanx) / (double)(n - 2));
sighatbeta1hat = sighat / sqrt((double)n * denom);
tobs = beta1hat / sighatbeta1hat;
if (fabs(tobs) > thresh) d = d + 1;
}
PutRNGstate();
res[0] = (double)d / (double)M[0];
delete[] yvec;
} // End of Cfunc
/* The function to integrate in the limited moment */
static void fn(double *x, int n, void *ex)
{
int i;
double *pars = (double *) ex, shape, scale, order;
shape = pars[0];
scale = pars[1];
order = pars[2];
for(i = 0; i < n; i++)
x[i] = R_pow(x[i], shape + order - 1) * R_pow(1 - x[i], -order);
}
double rinvparalogis(double shape, double scale)
{
double tmp;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;;
tmp = -1.0 / shape;
return scale * R_pow(R_pow(unif_rand(), tmp) - 1.0, tmp);
}
double dcppos(double y, double mu, double phi, double p) {
double a, a1, logz, drop = 37, jmax, j, cc, wmax, estlogw;
double wm = -1.0E16, sum_ww = 0, *ww, ld;
int k, lo_j, hi_j;
a = (2-p)/(1-p);
a1 = 1 - a ;
logz = -a*log(y)+a*log(p-1)-a1*log(phi)-log(2-p);
jmax = R_pow(y,2-p)/(phi*(2-p));
jmax = Rf_fmax2(1.0,jmax);
j = jmax;
cc = logz+a1+a*log(-a);
wmax = a1*jmax;
estlogw = wmax;
while(estlogw > (wmax - drop)) {
j += 2.0;
estlogw = j*(cc-a1*log(j)) ;
}
hi_j = ceil(j);
j = jmax;
estlogw = wmax;
while((estlogw > (wmax - drop)) && (j >= 2)) {
j = Rf_fmax2(1,j-2);
estlogw = j*(cc-a1*log(j));
}
lo_j = Rf_imax2(1,floor(j));
ww = Calloc(hi_j-lo_j+1, double);
for(k=lo_j; k<hi_j+1; k++) {
ww[k-lo_j] = k*logz-lgamma(1+k)-lgamma(-a*k);
wm = Rf_fmax2(wm,ww[k-lo_j]);
}
for(k=lo_j; k<hi_j+1; k++)
sum_ww += exp(ww[k-lo_j]-wm);
ld = -y/(phi*(p-1)*R_pow(mu, p-1))-
(R_pow(mu, 2-p)/(phi*(2-p)))-log(y)+
log(sum_ww)+wm;
Free(ww);
return ld;
}
/* produces uniform margins */
void rbvamix(int *n, double *alpha, double *beta, double *sim)
{
double delta,eps,llim,midpt,ulim,ilen,lval,midval,uval;
int i,j;
for(i=0;i<*n;i++)
{
delta = eps = llim = R_pow(DOUBLE_EPS, 0.5);
ulim = 1 - llim;
ilen = 1;
midpt = 0.5;
lval = ccbvamix(llim, sim[2*i+1], sim[2*i+0], *alpha, *beta);
uval = ccbvamix(ulim, sim[2*i+1], sim[2*i+0], *alpha, *beta);
if(!(sign(lval) != sign(uval)))
error("values at end points are not of opposite sign");
for(j=0;j<DOUBLE_DIGITS;j++) {
ilen = ilen/2;
midpt = llim + ilen;
midval = ccbvamix(midpt, sim[2*i+1], sim[2*i+0], *alpha, *beta);
if(fabs(midval) < eps || fabs(ilen) < delta)
break;
if(sign(lval) != sign(midval)) {
ulim = midpt;
uval = midval;
}
else {
llim = midpt;
lval = midval;
}
if(j == DOUBLE_DIGITS-1)
error("numerical problem in root finding algorithm");
}
sim[2*i+0] = midpt;
}
}
double levgamma(double limit, double shape, double scale, double order,
int give_log)
{
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape)
return R_PosInf;
if (limit <= 0.0)
return 0.0;
double u, tmp;
tmp = order + shape;
u = exp(log(limit) - log(scale));
return R_pow(scale, order) * gammafn(tmp) *
pgamma(u, tmp, 1.0, 1, 0) / gammafn(shape) +
ACT_DLIM__0(limit, order) * pgamma(u, shape, 1.0, 0, 0);
}
/* produces standard Frechet margins */
void rbvlog_shi(int *n, double *alpha, double *sim)
{
double u,z;
int i;
RANDIN;
for(i=0;i<*n;i++)
{
u = UNIF;
if(UNIF < *alpha) z = EXP+EXP;
else z = EXP;
sim[2*i] = 1/(z * R_pow(u,*alpha));
sim[2*i+1] = 1/(z * R_pow(1-u,*alpha));
}
RANDOUT;
}
double powerExp(double *dist, int n, double nugget, double sill, double range,
double smooth, double *rho){
//This function computes the powered exponential covariance function
//between each pair of locations.
//When ans != 0.0, the powered exponential parameters are ill-defined.
const double irange = 1 / range;
//Some preliminary steps: Valid points?
if ((smooth < 0) || (smooth > 2))
return (1 - smooth) * (1 - smooth) * MINF;
if (range <= 0)
return (1 - range) * (1 - range) * MINF;
if (sill <= 0)
return (1 - sill) * (1 - sill) * MINF;
if (nugget < 0)
return (1 - nugget) * (1 - nugget) * MINF;
#pragma omp parallel for
for (int i=0;i<n;i++){
if (dist[i] == 0)
rho[i] = nugget + sill;
else
rho[i] = sill * exp(-R_pow(dist[i] * irange, smooth));
}
return 0.0;
}
double minkowski(t_index i1, t_index i2) const {
double dev, dist;
int count, j;
count= 0;
dist = 0;
double * p1 = x+i1*nc;
double * p2 = x+i2*nc;
for(j = 0 ; j < nc ; ++j) {
if(both_non_NA(*p1, *p2)) {
dev = (*p1 - *p2);
if(!ISNAN(dev)) {
dist += R_pow(fabs(dev), p);
++count;
}
}
++p1;
++p2;
}
if(count == 0) return NA_REAL;
if(count != nc) dist /= (static_cast<double>(count)/static_cast<double>(nc));
//return R_pow(dist, 1.0/p);
// raise to the (1/p)-th power later
return dist;
}
double bessel(double *dist, int n, int dim, double nugget, double sill,
double range, double smooth, double *rho){
//This function computes the bessel covariance function
//between each pair of locations.
//When ans != 0.0, the powered exponential parameters are ill-defined.
const double irange = 1 / range, cst = sill * R_pow(2, smooth) * gammafn(smooth + 1);
//Some preliminary steps: Valid points?
if (smooth < (0.5 * (dim - 2)))
return (1 + 0.5 * (dim - 2) - smooth) * (1 + 0.5 * (dim - 2) - smooth) * MINF;
/* else if (smooth > 100)
//Require as bessel_j will be numerically undefined
return (smooth - 99) * (smooth - 99) * MINF; */
if (range <= 0)
return (1 - range) * (1 - range) * MINF;
if (sill <= 0)
return (1 - sill) * (1 - sill) * MINF;
if (nugget < 0)
return (1 - nugget) * (1 - nugget) * MINF;
#pragma omp parallel for
for (int i=0;i<n;i++){
double cst2 = dist[i] * irange;
if (cst2 == 0)
rho[i] = nugget + sill;
else if (cst2 <= 1e5)
rho[i] = cst * R_pow(cst2, -smooth) * bessel_j(cst2, smooth);
else
// approximation of the besselJ function for large x
rho[i] = cst * R_pow(cst2, -smooth) * M_SQRT_2dPI *
cos(cst2 - smooth * M_PI_2 - M_PI_4);
/*if (!R_FINITE(rho[i]))
return MINF;*/
}
return 0.0;
}
void pplik(double *data, int *n, double *loc, double *scale,
double *shape, double *thresh, double *noy, double *dns)
{
int i;
double *dvec, preg;
dvec = (double *)R_alloc(*n, sizeof(double));
if(*scale <= 0) {
*dns = -1e6;
return;
}
preg = (*thresh - *loc) / *scale;
if (*shape == 0)
preg = - *noy * exp(-preg);
else {
preg = 1 + *shape * preg;
if ((preg <= 0) && (*shape > 0)){
*dns = -1e6;
return;
}
else {
preg = fmax2(preg, 0);
preg = - *noy * R_pow(preg, -1 / *shape);
}
}
for(i=0;i<*n;i++) {
data[i] = (data[i] - *loc) / *scale;
if(*shape == 0)
dvec[i] = log(1 / *scale) - data[i];
else {
data[i] = 1 + *shape * data[i];
if(data[i] <= 0) {
*dns = -1e6;
return;
}
dvec[i] = log(1 / *scale) - (1 / *shape + 1) * log(data[i]);
}
}
for(i=0;i<*n;i++)
*dns = *dns + dvec[i];
*dns = *dns + preg;
}
double qinvparalogis(double p, double shape, double scale, int lower_tail,
int log_p)
{
double tmp;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;;
ACT_Q_P01_boundaries(p, 0, R_PosInf);
p = ACT_D_qIv(p);
tmp = -1.0 / shape;
return scale * R_pow(R_pow(ACT_D_Lval(p), tmp) - 1.0, tmp);
}
double munif(double order, double min, double max, int give_log)
{
#ifdef IEEE_754
if (ISNAN(order) || ISNAN(min) || ISNAN(max))
return order + min + max;
#endif
if (!R_FINITE(min) ||
!R_FINITE(max) ||
min >= max)
return R_NaN;
if (order == -1.0)
return (log(fabs(max)) - log(fabs(min))) / (max - min);
double tmp = order + 1;
return (R_pow(max, tmp) - R_pow(min, tmp)) / ((max - min) * tmp);
}
double rpareto1(double shape, double min)
{
if (!R_FINITE(shape) ||
!R_FINITE(min) ||
shape <= 0.0 ||
min <= 0.0)
return R_NaN;
return min / R_pow(unif_rand(), 1.0 / shape);
}
double rinvpareto(double shape, double scale)
{
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;;
return scale / (R_pow(unif_rand(), -1.0 / shape) - 1.0);
}
double levinvpareto(double limit, double shape, double scale, double order,
int give_log)
{
double u;
double ex[3], lower, upper, epsabs, epsrel, result, abserr, *work;
int neval, ier, subdiv, lenw, last, *iwork;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape)
return R_PosInf;
if (limit <= 0.0)
return 0.0;
/* Parameters for the integral are pretty much fixed here */
ex[0] = shape; ex[1] = scale; ex[2] = order;
lower = 0.0; upper = limit / (limit + scale);
subdiv = 100;
epsabs = R_pow(DOUBLE_EPS, 0.25);
epsrel = epsabs;
lenw = 4 * subdiv; /* as instructed in WRE */
iwork = (int *) R_alloc(subdiv, sizeof(int)); /* idem */
work = (double *) R_alloc(lenw, sizeof(double)); /* idem */
Rdqags(fn, (void *) &ex,
&lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &subdiv, &lenw, &last, iwork, work);
if (ier == 0)
{
u = exp(-log1pexp(log(scale) - log(limit)));
return R_pow(scale, order) * shape * result
+ ACT_DLIM__0(limit, order) * (0.5 - R_pow(u, shape) + 0.5);
}
else
error(_("integration failed"));
}
double whittleMatern(double *dist, int n, double nugget, double sill, double range,
double smooth, double *rho){
//This function computes the whittle-matern covariance function
//between each pair of locations.
//When ans != 0.0, the whittle-matern parameters are ill-defined.
const double cst = sill * R_pow(2, 1 - smooth) / gammafn(smooth),
irange = 1 / range;
//Some preliminary steps: Valid points?
if (smooth < EPS)
return (1 - smooth + EPS) * (1 - smooth + EPS) * MINF;
else if (smooth > 100)
/* Not really required but larger smooth parameters are unlikely
to occur */
return (smooth - 99) * (smooth - 99) * MINF;
if (range <= 0)
return (1 - range) * (1 - range) * MINF;
if (sill <= 0)
return (1 - sill) * (1 - sill) * MINF;
if (nugget < 0)
return (1 - nugget) * (1 - nugget) * MINF;
#pragma omp parallel for
for (int i=0;i<n;i++){
double cst2 = dist[i] * irange;
if (cst2 == 0)
rho[i] = sill + nugget;
else
rho[i] = cst * R_pow(cst2, smooth) * bessel_k(cst2, smooth, 1);
}
return 0.0;
}
double minvexp(double order, double scale, int give_log)
{
if (!R_FINITE(scale) ||
!R_FINITE(order) ||
scale <= 0.0)
return R_NaN;
if (order >= 1.0)
return R_PosInf;
return R_pow(scale, order) * gammafn(1.0 - order);
}
double caugen(double *dist, int n, double nugget, double sill, double range,
double smooth, double smooth2, double *rho){
/*This function computes the generalized cauchy covariance function
between each pair of locations. When ans != 0.0, the parameters
are ill-defined. */
const double irange = 1 / range, ratioSmooth = -smooth / smooth2;
//Some preliminary steps: Valid points?
if (smooth < 0)
return (1 - smooth) * (1 - smooth) * MINF;
/*else if (smooth1 > 500)
return (smooth1 - 499) * (smooth1 - 499) * MINF; */
if ((smooth2 > 2) || (smooth2 <= 0))
return (1 - smooth2) * (1 - smooth2) * MINF;
if (range <= 0)
return (1 - range) * (1 - range)* MINF;
if (sill <= 0)
return (1 - sill) * (1 - sill) * MINF;
if (nugget < 0)
return (1 - nugget) * (1 - nugget) * MINF;
#pragma omp parallel for
for (int i=0;i<n;i++){
if (dist[i] == 0)
rho[i] = nugget + sill;
else
rho[i] = sill * R_pow(1 + R_pow(dist[i] * irange, smooth2),
ratioSmooth);
}
return 0.0;
}
double levpareto1(double limit, double shape, double min, double order,
int give_log)
{
#ifdef IEEE_754
if (ISNAN(limit) || ISNAN(shape) || ISNAN(min) || ISNAN(order))
return limit + shape + min + order;
#endif
if (!R_FINITE(shape) ||
!R_FINITE(min) ||
!R_FINITE(order) ||
shape <= 0.0 ||
min <= 0.0)
return R_NaN;
if (limit <= min)
return 0.0;
double tmp = shape - order;
return shape * R_pow(min, order) / tmp
- order * R_pow(min, shape) / (tmp * R_pow(limit, tmp));
}
Real geoRmatern(Real uphi, Real kappa)
{
/*
WARNING: THIS FUNCTION IS COPIED IN geoRglmm
NOTIFY OLE ABOUT ANY CHANGE
*/
Real ans,cte;
if (uphi==0) return 1;
else{
if (kappa==0.5)
ans = exp(-uphi);
else {
cte = R_pow(2, (-(kappa-1)))/gammafn(kappa);
ans = cte * R_pow(uphi, kappa) * bessel_k(uphi, kappa, 1);
}
}
/* Rprintf(" ans=%d ", ans); */
return ans;
}
static double R_minkowski(double *x, int nr, int nc, int i1, int i2, double p)
{
double dev, dist;
int count, j;
count= 0;
dist = 0;
for(j = 0 ; j < nc ; j++) {
if(both_non_NA(x[i1], x[i2])) {
dev = (x[i1] - x[i2]);
if(!ISNAN(dev)) {
dist += R_pow(fabs(dev), p);
count++;
}
}
i1 += nr;
i2 += nr;
}
if(count == 0) return NA_REAL;
if(count != nc) dist /= ((double)count/nc);
return R_pow(dist, 1.0/p);
}
static double minkowski(double *x, double *y, int nx, int ny, int nc)
{
double dev, dist;
int count, j;
count = 0;
dist = 0;
for (j = 0; j < nc; j++) {
if (both_non_NA(*x, *y)) {
dev = (*x - *y);
if (!ISNAN(dev)) {
dist += R_pow(fabs(dev), dfp);
count++;
}
}
x += nx;
y += ny;
}
if (count == 0) return NA_REAL;
if (count != nc) dist /= ((double)count/nc);
return R_pow(dist, 1.0/dfp);
}
double R_pow_di(double x, int n)
{
double pow = 1.0;
if (ISNAN(x)) return x;
if (n != 0) {
if (!R_FINITE(x)) return R_pow(x, (double)n);
if (n < 0) { n = -n; x = 1/x; }
for(;;) {
if(n & 01) pow *= x;
if(n >>= 1) x *= x; else break;
}
}
double gev2unifTrend(double *data, int nObs, int nSite, double *locs,
double *scales, double *shapes, double *trendlocs,
double *trendscales, double *trendshapes, double *unif,
double *logdens){
/* This function transforms the GEV observations to U(0,1) ones with
a temporal trend.
When ans > 0.0, the GEV parameters are invalid. */
for (int i=0;i<nSite;i++){
for (int j=0;j<nObs;j++){
double loc = locs[i] + trendlocs[j], scale = scales[i] + trendscales[j],
shape = shapes[i] + trendshapes[j], iscale = 1 / scale,
logIscale = log(iscale), ishape = 1 / shape;
if (shape == 0.0){
unif[i * nObs + j] = (data[i * nObs + j] - loc) * iscale;
logdens[i * nObs + j] = logIscale - unif[i * nObs + j] -
exp(-unif[i * nObs + j]);
unif[i * nObs + j] = exp(-exp(-unif[i * nObs + j]));
}
else {
unif[i * nObs + j] = 1 + shape * (data[i * nObs + j] - loc) * iscale;
if (unif[i * nObs + j] <= 0)
return MINF;
logdens[i * nObs + j] = logIscale - (1 + ishape) * log(unif[i * nObs + j]) -
R_pow(unif[i * nObs + j], -ishape);
unif[i * nObs + j] = exp(-R_pow(unif[i * nObs + j], -ishape));
}
}
}
return 0.0;
}
double brownResnick(double *dist, int n, double range, double smooth,
double *rho){
const double halfSmooth = 0.5 * smooth, irange = 1 / range;
if ((smooth <= 0) || (smooth > 2))
return (smooth - 1) * (smooth - 1) * MINF;
#pragma omp parallel for
for (int i=0;i<n;i++)
rho[i] = M_SQRT2 * R_pow(dist[i] * irange, halfSmooth);
return 0;
}
double mgamma(double order, double shape, double scale, int give_log)
{
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape)
return R_PosInf;
return R_pow(scale, order) * gammafn(order + shape) / gammafn(shape);
}
