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); }