Exemplo n.º 1
0
Arquivo: ks.c Projeto: sjewo/ks
void massdist3d(double *x1, double *x2,	double *x3, int *n, 
		double *a1, double *a2, double *a3, 
		double *b1, double *b2, double *b3,
		int *M1, int *M2, int *M3, double *weight, double *est)
{
  double fx1, fx2, fx3, xdelta1, xdelta2, xdelta3, xpos1, xpos2, xpos3, wi;   
  int i, ix1, ix2, ix3, ixmax1, ixmin1, ixmax2, ixmax3, ixmin2, ixmin3, MM1, MM2, MM3;
  
  MM1 = M1[0];
  MM2 = M2[0];
  MM3 = M3[0];
  ixmin1 = 0;
  ixmax1 = MM1 - 2;
  ixmin2 = 0;
  ixmax2 = MM2 - 2;
  ixmin3 = 0;
  ixmax3 = MM3 - 2;
  xdelta1 = (b1[0] - a1[0]) / (MM1 - 1);
  xdelta2 = (b2[0] - a2[0]) / (MM2 - 1);
  xdelta3 = (b3[0] - a3[0]) / (MM3 - 1);
 
  // set all est = 0 
  for (i=0; i < MM1*MM2*MM3; i++)  
    est[i] = 0.0;

  // assign linear binning weights
  for(i=0; i < n[0]; i++) {
    if(R_FINITE(x1[i]) && R_FINITE(x2[i]) && R_FINITE(x3[i])) {
      xpos1 = (x1[i] - a1[0]) / xdelta1;
      xpos2 = (x2[i] - a2[0]) / xdelta2;
      xpos3 = (x3[i] - a3[0]) / xdelta3;
      ix1 = floor(xpos1);
      ix2 = floor(xpos2);
      ix3 = floor(xpos3);
      fx1 = xpos1 - ix1;
      fx2 = xpos2 - ix2;
      fx3 = xpos3 - ix3;
      wi = weight[i];   
      
      if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3) {
	est[ix3*MM1*MM2 + ix2*MM1 + ix1]             += wi*(1-fx1)*(1-fx2)*(1-fx3);   
	est[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1]         += wi*fx1*(1-fx2)*(1-fx3);
	est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1]         += wi*(1-fx1)*fx2*(1-fx3);   
	est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1]     += wi*fx1*fx2*(1-fx3);
	est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1]         += wi*(1-fx1)*(1-fx2)*fx3;   
	est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1]     += wi*fx1*(1-fx2)*fx3;
	est[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1]     += wi*(1-fx1)*fx2*fx3;   
	est[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*fx3;
      }
    }
  }
}
Exemplo n.º 2
0
Arquivo: fprec.cpp Projeto: Hkey1/boom
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 double max10e = numeric_limits<double>::max_exponent * 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) {
	    p10 =  std::pow(10., e10-max10e);
	    e10 = static_cast<int>(max10e);
	} else if(e10 < - max10e) {
	    p10 =  std::pow(10., e10+max10e);
	    e10 = static_cast<int>(-max10e);	
	}
	pow10 = std::pow(10., e10);
	return(sgn*(FLOOR((x*pow10)*p10+0.5)/pow10)/p10);
    } else { /* -- LARGE or small -- */
	do_round = max10e - l10	 >= std::pow(10., -dig);
	e2 = dig + ((e10>0)? 1 : -1) * MAX_DIGITS;
	p10 = std::pow(10., e2);	x *= p10;
	P10 = std::pow(10., e10-e2);	x *= P10;
	/*-- p10 * P10 = 10 ^ e10 */
	if(do_round) x += 0.5;
	x = FLOOR(x) / p10;
	return(sgn*x/P10);
    }
}
Exemplo n.º 3
0
double qsignrank(double x, double n, int lower_tail, int log_p)
{
    double f, p;

#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(n))
	return(x + n);
#endif
    if (!R_FINITE(x) || !R_FINITE(n))
	ML_ERR_return_NAN;
    R_Q_P01_check(x);

    n = floor(n + 0.5);
    if (n <= 0)
	ML_ERR_return_NAN;

    if (x == R_DT_0)
	return(0);
    if (x == R_DT_1)
	return(n * (n + 1) / 2);

    if(log_p || !lower_tail)
	x = R_DT_qIv(x); /* lower_tail,non-log "p" */

    int nn = (int) n;
    w_init_maybe(nn);
    f = exp(- n * M_LN2);
    p = 0;
    int q = 0;
    if (x <= 0.5) {
	x = x - 10 * DBL_EPSILON;
	for (;;) {
	    p += csignrank(q, nn) * f;
	    if (p >= x)
		break;
	    q++;
	}
    }
    else {
	x = 1 - x + 10 * DBL_EPSILON;
	for (;;) {
	    p += csignrank(q, nn) * f;
	    if (p > x) {
		q = (int)(n * (n + 1) / 2 - q);
		break;
	    }
	    q++;
	}
    }

    return(q);
}
Exemplo n.º 4
0
double qunif(double p, double a, double b, int lower_tail, int log_p)
{
#ifdef IEEE_754
    if (ISNAN(p) || ISNAN(a) || ISNAN(b))
	return p + a + b;
#endif
    R_Q_P01_check(p);
    if (!R_FINITE(a) || !R_FINITE(b)) ML_ERR_return_NAN;
    if (b < a) ML_ERR_return_NAN;
    if (b == a) return a;

    return a + R_DT_qIv(p) * (b - a);
}
Exemplo n.º 5
0
double pnchisq(double x, double f, double theta, int lower_tail, int log_p)
{
#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(f) || ISNAN(theta))
	return x + f + theta;
    if (!R_FINITE(f) || !R_FINITE(theta))
	ML_ERR_return_NAN;
#endif

    if (f < 0. || theta < 0.) ML_ERR_return_NAN;

    return (R_DT_val(pnchisq_raw(x, f, theta, 1e-12, 8*DBL_EPSILON, 1000000)));
}
Exemplo n.º 6
0
double beta(double a, double b)
{
#ifdef NOMORE_FOR_THREADS
    static double xmin, xmax = 0;/*-> typically = 171.61447887 for IEEE */
    static double lnsml = 0;/*-> typically = -708.3964185 */

    if (xmax == 0) {
	    gammalims(&xmin, &xmax);
	    lnsml = log(d1mach(1));
    }
#else
/* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 :
 *   xmin, xmax : see ./gammalims.c
 *   lnsml = log(DBL_MIN) = log(2 ^ -1022) = -1022 * log(2)
*/
# define xmin  -170.5674972726612
# define xmax   171.61447887182298
# define lnsml -708.39641853226412
#endif


#ifdef IEEE_754
    /* NaNs propagated correctly */
    if(ISNAN(a) || ISNAN(b)) return a + b;
#endif

    if (a < 0 || b < 0)
	ML_ERR_return_NAN
    else if (a == 0 || b == 0)
	return ML_POSINF;
    else if (!R_FINITE(a) || !R_FINITE(b))
	return 0;

    if (a + b < xmax) {/* ~= 171.61 for IEEE */
//	return gammafn(a) * gammafn(b) / gammafn(a+b);
	/* All the terms are positive, and all can be large for large
	   or small arguments.  They are never much less than one.
	   gammafn(x) can still overflow for x ~ 1e-308, 
	   but the result would too. 
	*/
	return (1 / gammafn(a+b)) * gammafn(a) * gammafn(b);
    } else {
	double val = lbeta(a, b);
	if (val < lnsml) {
	    /* a and/or b so big that beta underflows */
	    ML_ERROR(ME_UNDERFLOW, "beta");
	    /* return ML_UNDERFLOW; pointless giving incorrect value */
	}
	return exp(val);
    }
}
Exemplo n.º 7
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);
}
Exemplo n.º 8
0
double mgfgamma(double x, double shape, double scale, int give_log)
{
    if (!R_FINITE(shape) ||
        !R_FINITE(scale) ||
        shape <= 0.0 ||
        scale <= 0.0 ||
        scale * x > 1.)
        return R_NaN;

    if (x == 0.0)
        return ACT_D_exp(0.0);

    return ACT_D_exp(-shape * log1p(-scale * x));
}
Exemplo n.º 9
0
double qcauchy(double p, double location, double scale,
               int lower_tail, int log_p)
{
#ifdef IEEE_754
    if (ISNAN(p) || ISNAN(location) || ISNAN(scale))
        return p + location + scale;
#endif
    if(!R_FINITE(p) || !R_FINITE(location) || !R_FINITE(scale))
        ML_ERR_return_NAN;
    R_Q_P01_check(p);
    if (scale <= 0) ML_ERR_return_NAN;

    return location + scale * tan(M_PI * (R_DT_qIv(p) - 0.5));
}
Exemplo n.º 10
0
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);
}
Exemplo n.º 11
0
double runif(rng_t unif_rand, double a, double b)
{
    if (!R_FINITE(a) || !R_FINITE(b) || b < a)	ML_ERR_return_NAN;

    if (a == b)
	return a;
    else {
	double u;
	/* This is true of all builtin generators, but protect against
	   user-supplied ones */
	do {u = unif_rand();} while (u <= 0 || u >= 1);
	return a + (b - a) * u;
    }
}
Exemplo n.º 12
0
double qinvpareto(double p, double shape, double scale, int lower_tail,
                  int log_p)
{
    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);

    return scale / (R_pow(ACT_D_Lval(p), -1.0 / shape) - 1.0);
}
Exemplo n.º 13
0
SEXP mom_calc_int2(SEXP is, SEXP m, SEXP nb, SEXP weights, SEXP card) {
    SEXP Omega;
    int hm = INTEGER_POINTER(m)[0];
    int n = length(card);
    double *eta, *zeta, *omega, sum, res;
    int i, ii, j, k1, k2, k3;
    int iis = length(is);

    omega = (double *) R_alloc((size_t) hm, sizeof(double));
    eta = (double *) R_alloc((size_t) n, sizeof(double));
    zeta = (double *) R_alloc((size_t) n, sizeof(double));
    for (j=0; j<hm; j++) omega[j] = 0.0;

    for (ii=0; ii<iis; ii++) {
        R_CheckUserInterrupt();
        i = INTEGER_POINTER(is)[ii]-ROFFSET;
        for (j=0; j<n; j++) eta[j] = 0.0;
        eta[i] = 1.0;
        for (j=1; j<hm; j=j+2) {
            for (k1=0; k1<n; k1++) {
                k3 = INTEGER_POINTER(card)[k1];
                if (k3 == 0) {
                    zeta[k1] = 0.0;
                } else {
                    sum = 0.0;
                    for (k2=0; k2<k3; k2++) {
                        sum += eta[INTEGER_POINTER(VECTOR_ELT(nb, k1))[k2]
                            - ROFFSET] * NUMERIC_POINTER(VECTOR_ELT(weights,
                            k1))[k2];
                    }
                    zeta[k1] = sum;
                }
            }
            res = F77_CALL(ddot)(&n, zeta, &c__1, eta, &c__1);
            if (R_FINITE(res)) omega[(j-1)] += res;
            else error("non-finite dot product %d, %d", i, j);
            res = F77_CALL(ddot)(&n, zeta, &c__1, zeta, &c__1);
            if (R_FINITE(res)) omega[j] += res;
            else error("non-finite dot product %d, %d", i, j);
            for (k1=0; k1<n; k1++) eta[k1] = zeta[k1];
        }
    }

    PROTECT(Omega = NEW_NUMERIC(hm));
    for (j=0; j<hm; j++) NUMERIC_POINTER(Omega)[j] = omega[j];

    UNPROTECT(1);
    return(Omega);
}
Exemplo n.º 14
0
//compute the observed hands
// r[i] is the number of hands with i+1 (different) value(s)
void pokerTest(int *hands, int nbh, int d, int *res)
{
        int i, j; //loop indexes
        int nbzero; //zero counter
        
        int * temp = (int *) R_alloc(d, sizeof(int) );
	
        if (!R_FINITE(nbh) || !R_FINITE(d))
                error(_("non finite argument"));
            
        //init
        for(j = 0; j < d; j++)
                res[j] = 0;
                   
        for(i = 0; i < nbh; i++) 
        {
                //erase previous line
                for(j = 0; j < d; j++)
                        temp[j] = 0;
            
                //browse the i+1th hand
                for(j = 0; j < d; j++)
                { 
                        //if(hands[i + j * nb] > -1 && hands[i + j * nb] <d)
                            temp[ hands[i + j * nbh] ] ++;
                        //else
                            //error(_("internal error in pokertest"));
                }
            /*
            Rprintf("temp : ");
            for(j = 0; j < d; j++)
                Rprintf(" %d\t", temp[j]);
            Rprintf("\n");
            */
                
                nbzero = 0;
            
                //find the i+1 th hand
                for(j = 0; j < d; j++)
                {
                        if(temp[j] == 0)
                                nbzero++;
                }
            //nb of different value is d-nbzero
            res[d - nbzero - 1] ++;
                    
        }
      
}
Exemplo n.º 15
0
double rnchisq(double df, double lambda)
{
    if (!R_FINITE(df) || !R_FINITE(lambda) || df < 0. || lambda < 0.)
	ML_ERR_return_NAN;

    if(lambda == 0.) {
	return (df == 0.) ? 0. : rgamma(df / 2., 2.);
    }
    else {
	double r = rpois( lambda / 2.);
	if (r > 0.)  r = rchisq(2. * r);
	if (df > 0.) r += rgamma(df / 2., 2.);
	return r;
    }
}
Exemplo n.º 16
0
/* winProgressBar(width, title, label, min, max, initial) */
SEXP winProgressBar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP tmp, ptr;
    int width, iv;
    double d;
    const char *title, *label;
    winprogressbar *pbar;
    Rboolean haveLabel;

    args = CDR(args);
    pbar = Calloc(1, winprogressbar);
    width = asInteger(CAR(args)); args = CDR(args);
    if(width == NA_INTEGER || width < 0) width = 200;
    tmp = CAR(args); args = CDR(args);
    if(!isString(tmp) || length(tmp) < 1 || STRING_ELT(tmp, 0) == NA_STRING)
	errorcall(call, "invalid '%s' argument", "title");
    title = translateChar(STRING_ELT(tmp, 0));
    tmp = CAR(args); args = CDR(args);
    if(!isString(tmp) || length(tmp) < 1 || STRING_ELT(tmp, 0) == NA_STRING)
	errorcall(call, "invalid '%s' argument", "Label");
    label = translateChar(STRING_ELT(tmp, 0));
    haveLabel = strlen(label) > 0;
    d = asReal(CAR(args)); args = CDR(args);
    if (!R_FINITE(d)) errorcall(call, "invalid '%s' argument", "min");
    pbar->min = d;
    d = asReal(CAR(args)); args = CDR(args);
    if (!R_FINITE(d)) errorcall(call, "invalid '%s' argument", "max");
    pbar->max = d;
    d = asReal(CAR(args)); args = CDR(args);
    if (!R_FINITE(d)) errorcall(call, "invalid '%s' argument", "initial");
    pbar->val = d;

    pbar->width = width;
    pbar->wprog = newwindow(title, rect(0, 0, width+40, haveLabel ? 100: 80),
			    Titlebar | Centered);
    setbackground(pbar->wprog, dialog_bg());
    if(haveLabel)
	pbar->lab = newlabel(label, rect(10, 15, width+20, 25), AlignCenter);
    pbar->pb = newprogressbar(rect(20, haveLabel ? 50 : 30, width, 20),
			      0, width, 1, 1);
    iv = pbar->width * (pbar->val - pbar->min)/(pbar->max - pbar->min);
    setprogressbar(pbar->pb, iv);
    show(pbar->wprog);
    ptr = R_MakeExternalPtr(pbar, install("winProgressBar"), R_NilValue);
    R_RegisterCFinalizerEx(ptr, pbarFinalizer, TRUE);

    return ptr;
}
Exemplo n.º 17
0
JNIEXPORT jboolean JNICALL Java_r_ext_SystemLibs_fmod
  (JNIEnv *jenv, jclass jcls, jdoubleArray xArg, jdoubleArray yArg, jdoubleArray resArg, jint size) {
  
  double *x = (*jenv)->GetPrimitiveArrayCritical(jenv, xArg, 0);
  double *y = (*jenv)->GetPrimitiveArrayCritical(jenv, yArg, 0);
  double *res = (*jenv)->GetPrimitiveArrayCritical(jenv, resArg, 0);
  int i;
  int lostAccuracy = 0;

  for (i = 0; i < size; i++) {
    double a = x[i];
    double b = y[i];

    if (b == 0) {  // LICENSE: transcribed from GNU-R, which is licensed under GPL
      res[i] = R_NaN;
    } else {
      double q = a / b;
      double tmp = a - floor(q) * b;
      if ((fabs(q) > 1/DBL_EPSILON ) && R_FINITE(q)) {   // R_AccuracyInfo.eps
        lostAccuracy = 1;
      }
      res[i] = tmp - floor(tmp/b) * b;  
    }    
  }
   
  (*jenv)->ReleasePrimitiveArrayCritical(jenv, xArg, x, 0);
  (*jenv)->ReleasePrimitiveArrayCritical(jenv, yArg, y, 0);
  (*jenv)->ReleasePrimitiveArrayCritical(jenv, resArg, res, 0);  
  
  return lostAccuracy ? JNI_TRUE : JNI_FALSE;
}
Exemplo n.º 18
0
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;
    }
}
Exemplo n.º 19
0
double logspaceAdd(const double loga, const double logb) {
    if (!R_FINITE(loga))
        return logb;
    if (loga > logb)
        return logspaceAdd(logb, loga);
    return logb + log1p(exp(loga - logb));
}
Exemplo n.º 20
0
double psignrank(double x, double n, int lower_tail, int log_p)
{
    int i;
    double f, p;

#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(n))
    return(x + n);
#endif
    if (!R_FINITE(n)) ML_ERR_return_NAN;
    n = floor(n + 0.5);
    if (n <= 0) ML_ERR_return_NAN;

    x = floor(x + 1e-7);
    if (x < 0.0)
	return(R_DT_0);
    if (x >= n * (n + 1) / 2)
	return(R_DT_1);

    w_init_maybe(n);
    f = exp(- n * M_LN2);
    p = 0;
    if (x <= (n * (n + 1) / 4)) {
	for (i = 0; i <= x; i++)
	    p += csignrank(i, n) * f;
    }
    else {
	x = n * (n + 1) / 2 - x;
	for (i = 0; i < x; i++)
	    p += csignrank(i, n) * f;
	lower_tail = !lower_tail; /* p = 1 - p; */
    }

    return(R_DT_val(p));
} /* psignrank() */
Exemplo n.º 21
0
double rlnorm(double meanlog, double sdlog)
{
    if(ISNAN(meanlog) || !R_FINITE(sdlog) || sdlog < 0.)
	ML_ERR_return_NAN;

    return exp(rnorm(meanlog, sdlog));
}
Exemplo n.º 22
0
Rboolean tmean<double>(double *x, index_type n, double *value, Rboolean narm,
               double NA_VALUE)
{
  LDOUBLE s = 0.0, t = 0.0;
  index_type i;
  index_type naCount=0;
  Rboolean updated = (Rboolean)TRUE;

  for (i = 0; i < n; i++) {
    if (!ISNAN(x[i])) s += x[i];
    else if (!narm) {
      *value = NA_REAL;
      return((Rboolean)TRUE);
    }
    else ++naCount;
  }
  if (n-naCount < 1)
  {
    *value=NA_REAL;
    return(updated);
  }
  s /= (LDOUBLE)(n-naCount);
  if (R_FINITE((double)s)) {
    for (i = 0; i < n; i++) 
    {
      if (!ISNAN(x[i])) t += (x[i] - s);
    }
    s += t / ((LDOUBLE)n);
  }
  *value = (double) s;
  return(updated);
}
Exemplo n.º 23
0
static void genptry(int n, double *p, double *ptry, double scale, void *ex)
{
    SEXP s, x;
    int i;
    OptStruct OS = (OptStruct) ex;
    PROTECT_INDEX ipx;

    if (!isNull(OS->R_gcall)) {
	/* user defined generation of candidate point */
	PROTECT(x = allocVector(REALSXP, n));
	for (i = 0; i < n; i++) {
	    if (!R_FINITE(p[i]))
		error(_("non-finite value supplied by 'optim'"));
	    REAL(x)[i] = p[i] * (OS->parscale[i]);
	}
	SETCADR(OS->R_gcall, x);
	PROTECT_WITH_INDEX(s = eval(OS->R_gcall, OS->R_env), &ipx);
	REPROTECT(s = coerceVector(s, REALSXP), ipx);
	if(LENGTH(s) != n)
	    error(_("candidate point in 'optim' evaluated to length %d not %d"),
		  LENGTH(s), n);
	for (i = 0; i < n; i++)
	    ptry[i] = REAL(s)[i] / (OS->parscale[i]);
	UNPROTECT(2);
    }
    else {  /* default Gaussian Markov kernel */
	for (i = 0; i < n; i++)
	    ptry[i] = p[i] + scale * norm_rand();  /* new candidate point */
    }
}
Exemplo n.º 24
0
//*************************************************************************
// Calculate Preistley-Taylor evaporation..
// Uses procedures from Allen et al
// Arguments:
//
// Returns: double Potential evaporation calced as Preistly-Taylor
//*************************************************************************
double CalculatePTEvaporation(const double arg_d_T,   // mean temp
                              const double arg_d_Z,      // altitude METRES
                              const double arg_d_Rn)  // net radiation
{
	double d_P; // pressure
	double d_esT;   // sat vap pressure
	double d_lambda; //lat heat vap water
	double d_gamma; // Psychometric constant
	double d_Delta; // slope of sat vp curve
	double d_E_pot; // potential evaporation
	//Pressure
	d_P=101.38*pow(((293-0.0065*arg_d_Z)/293),5.26);
	//Saturation Vapour Pressure
	d_esT=0.6108*exp(17.27*arg_d_T/ (arg_d_T+273.3));
	//Latent heat of vapourisation of water
	d_lambda=2.501-0.002361*arg_d_T;
	//Psychometric constant
	d_gamma=0.0016286*d_P/d_lambda;
	//Slope of saturation vapour pressure curve
	d_Delta=4098*d_esT/pow((arg_d_T+237.3),2);
	//Potential Evapotranspiration store to array
	d_E_pot=1.26*arg_d_Rn/(d_lambda*(1+d_gamma/d_Delta));
	
	if (!R_FINITE(d_E_pot)) Rprintf ("arg_d_T -- %f, arg_d_Z -- %f, arg_d_Rn -- %f, d_P -- %f, d_esT -- %f, d_lambda -- %f, d_gamma -- %f, d_Delta -- %f, d_E_pot -- %f\n", arg_d_T, arg_d_Z, arg_d_Rn, d_P, d_esT, d_lambda, d_gamma, d_Delta,d_E_pot );
		
	
	// all done, return
	return (d_E_pot);
}// end func Calc PT Evaporation
Exemplo n.º 25
0
  double rexp_mt(ENG & eng, double scale)
  {
    if (!R_FINITE(scale) || scale <= 0.0)
      ML_ERR_return_NAN;

    return scale * exp_rand(eng);
  }
Exemplo n.º 26
0
/* NB: this only works in the lower half of y, but pads with zeros. */
SEXP BinDist(SEXP sx, SEXP sw, SEXP slo, SEXP shi, SEXP sn)
{
    PROTECT(sx = coerceVector(sx, REALSXP)); 
    PROTECT(sw = coerceVector(sw, REALSXP));
    int n = asInteger(sn);
    if (n == NA_INTEGER || n <= 0) error("invalid '%s' argument", "n");
    SEXP ans = allocVector(REALSXP, 2*n);
    PROTECT(ans);
    double xlo = asReal(slo), xhi = asReal(shi);
    double *x = REAL(sx), *w = REAL(sw), *y = REAL(ans);

    int ixmin = 0, ixmax = n - 2;
    double xdelta = (xhi - xlo) / (n - 1);

    for(int i = 0; i < 2*n ; i++) y[i] = 0;

    for(R_xlen_t i = 0; i < XLENGTH(sx) ; i++) {
	if(R_FINITE(x[i])) {
	    double xpos = (x[i] - xlo) / xdelta;
	    int ix = (int) floor(xpos);
	    double fx = xpos - ix;
	    double wi = w[i];
	    if(ixmin <= ix && ix <= ixmax) {
		y[ix] += (1 - fx) * wi;
		y[ix + 1] += fx * wi;
	    }
	    else if(ix == -1) y[0] += fx * wi;
	    else if(ix == ixmax + 1) y[ix] += (1 - fx) * wi;
	}
    }
    UNPROTECT(3);
    return ans;
}
Exemplo n.º 27
0
attribute_hidden
const char *EncodeReal2(double x, int w, int d, int e)
{
    static char buff[NB];
    char fmt[20];

    /* IEEE allows signed zeros (yuck!) */
    if (x == 0.0) x = 0.0;
    if (!R_FINITE(x)) {
	if(ISNA(x)) snprintf(buff, NB, "%*s", w, CHAR(R_print.na_string));
	else if(ISNAN(x)) snprintf(buff, NB, "%*s", w, "NaN");
	else if(x > 0) snprintf(buff, NB, "%*s", w, "Inf");
	else snprintf(buff, NB, "%*s", w, "-Inf");
    }
    else if (e) {
	if(d) {
	    sprintf(fmt,"%%#%d.%de", min(w, (NB-1)), d);
	    snprintf(buff, NB, fmt, x);
	}
	else {
	    sprintf(fmt,"%%%d.%de", min(w, (NB-1)), d);
	    snprintf(buff, NB, fmt, x);
	}
    }
    else { /* e = 0 */
	sprintf(fmt,"%%#%d.%df", min(w, (NB-1)), d);
	snprintf(buff, NB, fmt, x);
    }
    buff[NB-1] = '\0';
    return buff;
}
Exemplo n.º 28
0
double punif(double x, double a, double b, int lower_tail, int log_p)
{
#ifdef IEEE_754
    if (ISNAN(x) || ISNAN(a) || ISNAN(b))
	return x + a + b;
#endif
    if (b < a) ML_ERR_return_NAN;
    if (!R_FINITE(a) || !R_FINITE(b)) ML_ERR_return_NAN;

    if (x >= b)
	return R_DT_1;
    if (x <= a)
	return R_DT_0;
    if (lower_tail) return R_D_val((x - a) / (b - a));
    else return R_D_val((b - x) / (b - a));
}
Exemplo n.º 29
0
static double fcn1(double x, struct callinfo *info)
{
    SEXP s, sx;
    PROTECT(sx = ScalarReal(x));
    SETCADR(info->R_fcall, sx);
    s = eval(info->R_fcall, info->R_env);
    UNPROTECT(1);
    switch(TYPEOF(s)) {
    case INTSXP:
	if (length(s) != 1) goto badvalue;
	if (INTEGER(s)[0] == NA_INTEGER) {
	    warning(_("NA replaced by maximum positive value"));
	    return DBL_MAX;
	}
	else return INTEGER(s)[0];
	break;
    case REALSXP:
	if (length(s) != 1) goto badvalue;
	if (!R_FINITE(REAL(s)[0])) {
	    warning(_("NA/Inf replaced by maximum positive value"));
	    return DBL_MAX;
	}
	else return REAL(s)[0];
	break;
    default:
	goto badvalue;
    }
 badvalue:
    error(_("invalid function value in 'optimize'"));
    return 0;/* for -Wall */
}
Exemplo n.º 30
0
// TODO: NEED TO DEAL WITH Inf/NA/NaN
void rtexpon_rate(double *x, double *left, double *right, double *rate, int *num)
{
  RNG r;

  #ifdef USE_R
  GetRNGstate();
  #endif

  for(int i=0; i < *num; ++i){
    #ifdef USE_R
    if (i%SAMPCHECK==0) R_CheckUserInterrupt();

    if (ISNAN(left[i]) || ISNAN(right[i]) || ISNAN(rate[i]) || !R_FINITE(left[i]) ||
	ISNA(left[i])  || ISNA(right[i])  || ISNA(rate[i]) ) 
      {
	x[i] = R_NaN; 
	fprintf(stderr, "rtexpon_rate: caught non finite left value: %g; x[i] = %g.\n", left[i], x[i]);
      }

    #endif

    // TODO: Really, I need to check if it is +/- Inf.
    if (MYFINITE(right[i]))
      x[i] = r.texpon_rate(left[i], right[i], rate[i]);
    else 
      x[i] = r.texpon_rate(left[i], rate[i]);

  }

  #ifdef USE_R
  PutRNGstate();
  #endif
}