Esempio n. 1
0
void in_Rsockwrite(int *sockp, char **buf, int *start, int *end, int *len)
{
    ssize_t n;
    if (*end > *len)
	*end = *len;
    if (*start < 0)
	*start = 0;
    if (*end < *start) {
	*len = -1;
	return;
    }
    check_init();
#ifdef DEBUG
    printf("writing %s to %d", *buf, *sockp);
#endif
    perr.error = 0;
    n = Sock_write(*sockp, *buf + *start, *end - *start, &perr);
    *len = (int) n;
    if(perr.error) REprintf("socket error: %s\n", strerror(perr.error));
}
Esempio n. 2
0
SEXP dbExistsTable(SEXP dbi_conn_sexp, SEXP tableName_sexp) {
  SEXP ans;

 if(TYPEOF(dbi_conn_sexp) != EXTPTRSXP || dbi_conn_sexp == R_NilValue) {
    return R_NilValue;
  }

  DatabaseConnection* conn = reinterpret_cast<DatabaseConnection*>(R_ExternalPtrAddr(dbi_conn_sexp));
  if(!conn) {
    // throw bad_connection_object
    REprintf("bad database connection.\n");
    return R_NilValue;
  }

  const char* tableName = CHAR(STRING_ELT(tableName_sexp,0));
  PROTECT(ans = allocVector(LGLSXP,1));
  LOGICAL(ans)[0] = static_cast<int>(conn->existsTable(tableName));
  UNPROTECT(1);
  return ans;
}
Esempio n. 3
0
/* This does *not* work: gives *empty* .Data slot [bug in NEW_OBJECT()? ] */
SEXP d2mpfr(SEXP x, SEXP prec)
{
    int i_prec = asInteger(prec),
	nx = LENGTH(x), np = LENGTH(prec),
	n = (nx == 0 || np == 0) ? 0 : imax2(nx, np),
	nprot = 1;
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("mpfr"))),
	lis = ALLOC_SLOT(val, Rmpfr_Data_Sym, VECSXP, n);
    double *dx;

    if(!isReal(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; }
    REprintf("d2mpfr(x, prec): length(x) = %d, prec = %d -> length(lis) = %d\n",
	     nx, i_prec, LENGTH(lis));
    dx = REAL(x);
    for(int i = 0; i < n; i++) {
	SET_VECTOR_ELT(lis, i, duplicate(d2mpfr1_(dx [i % nx],
						  i_prec [i % np])));
    }
    UNPROTECT(nprot);
    return val;
}
Esempio n. 4
0
void nvimcom_Stop()
{
#ifndef WIN32
    if(ih){
        removeInputHandler(&R_InputHandlers, ih);
        close(ifd);
        close(ofd);
    }
#endif

    if(nvimcom_initialized){
        Rf_removeTaskCallbackByName("NVimComHandler");
#ifdef WIN32
        closesocket(sfd);
        WSACleanup();
#else
        close(sfd);
        pthread_cancel(tid);
        pthread_join(tid, NULL);
#endif
        ListStatus *tmp = firstList;
        while(tmp){
            firstList = tmp->next;
            free(tmp->key);
            free(tmp);
            tmp = firstList;
        }
        for(int i = 0; i < 64; i++){
            free(loadedlibs[i]);
            loadedlibs[i] = NULL;
        }
        if(obbrbuf1)
            free(obbrbuf1);
        if(obbrbuf2)
            free(obbrbuf2);
        if(verbose)
            REprintf("nvimcom stopped\n");
    }
    nvimcom_initialized = 0;
}
Esempio n. 5
0
  void setColnames(const std::vector<std::string> &cnames) {
    int protect_count(0);

    if (static_cast<R_len_t>(cnames.size()) != Rf_ncols(Robject)) {
      REprintf("setColnames: colnames size does not match ncols(Robject).");
      return;
    }

    // check if we have existing dimnames
    SEXP dimnames = Rf_getAttrib(Robject, R_DimNamesSymbol);
    if (dimnames == R_NilValue) {
      PROTECT(dimnames = Rf_allocVector(VECSXP, 2));
      ++protect_count;
      SET_VECTOR_ELT(dimnames, 0, R_NilValue);
    }
    SEXP cnames_sexp = PROTECT(Rf_allocVector(STRSXP, cnames.size()));
    ++protect_count;
    for (size_t i = 0; i < cnames.size(); ++i) { SET_STRING_ELT(cnames_sexp, i, Rf_mkChar(cnames[i].c_str())); }
    SET_VECTOR_ELT(dimnames, 1, cnames_sexp);
    Rf_setAttrib(Robject, R_DimNamesSymbol, dimnames);
    UNPROTECT(protect_count);
  }
Esempio n. 6
0
/* Poll related. */
SEXP R_zmq_poll(SEXP R_socket, SEXP R_type, SEXP R_timeout){
	int C_ret = -1, C_errno, i;

	PBD_POLLITEM_LENGTH = LENGTH(R_socket);
	if(PBD_POLLITEM_LENGTH > PBD_POLLITEM_MAXSIZE){
		REprintf("Too many sockets (%d) are asked.\n", PBD_POLLITEM_LENGTH);
	}

	PBD_POLLITEM = (zmq_pollitem_t *) malloc(PBD_POLLITEM_LENGTH * sizeof(zmq_pollitem_t));
	for(i = 0; i < PBD_POLLITEM_LENGTH; i++){
		PBD_POLLITEM[i].socket = R_ExternalPtrAddr(VECTOR_ELT(R_socket, i));
		PBD_POLLITEM[i].events = (short) INTEGER(R_type)[i];
	}

	C_ret = zmq_poll(PBD_POLLITEM, PBD_POLLITEM_LENGTH, (long) INTEGER(R_timeout)[0]);
	if(C_ret == -1){
		C_errno = zmq_errno();
		warning("R_zmq_poll: %d strerror: %s\n",
			C_errno, zmq_strerror(C_errno));
	}
	return(AsInt(C_ret));
} /* End of R_zmq_poll(). */
Esempio n. 7
0
void RangeList::filterGeneName(const char* inclusionGeneFileName, const char* geneTableFileName){
  // require user input gene list file
  if (strlen(geneTableFileName) == 0 && strlen(inclusionGeneFileName) != 0) {
    REprintf("Please provide gene list file (e.g. refFlat) until we are able to process gene\n");
    return;
    //exit(1);
  }

  // if not specify any gene, return whole range.
  if (strlen(inclusionGeneFileName) == 0) {
    return;
  }

  // store which gene do we want if specified
  std::set< std::string > inclusionSet;
  LineReader lr(inclusionGeneFileName);
  std::string gene;
  while(lr.readLine(&gene)) {
    inclusionSet.insert(gene);
  }

  std::vector<std::string> fields;
  std::string chr;
  std::string geneNameTbl;

  LineReader geneTable(geneTableFileName);
  while (geneTable.readLineBySep(&fields, "\t ")) {
    geneNameTbl = fields[0];
    if (inclusionSet.find(geneNameTbl) != inclusionSet.end()){ // store gene range
      chr = chopChr(fields[2].c_str());
      this->rangeCollection.addRange(chr,
                                     atoi(fields[4].c_str()),   // start
                                     atoi(fields[5].c_str()));   // end
    }
  }
  if (this->rangeCollection.size() == 0){
    Rprintf("We cannot find given gene in your geneListFile, so all sites will be outputed\n");
  }
}
Esempio n. 8
0
File: ncdf.c Progetto: cran/ncdf
void R_nc_get_vara_double( int *ncid, int *varid, int *start, 
	int *count, double *data, int *retval )
{
	int	i, err, ndims;
	size_t	s_start[MAX_NC_DIMS], s_count[MAX_NC_DIMS];
	char	vn[2048];

	err = nc_inq_varndims(*ncid, *varid, &ndims );
	if( err != NC_NOERR ) 
		REprintf( "Error in R_nc_get_vara_double while getting ndims: %s\n", 
			nc_strerror(*retval) );

	for( i=0; i<ndims; i++ ) {
		s_start[i] = (size_t)start[i];
		s_count[i] = (size_t)count[i];
		}
		
	*retval = nc_get_vara_double(*ncid, *varid, s_start, s_count, data );
	if( *retval != NC_NOERR ) {
		nc_inq_varname( *ncid, *varid, vn );
		REprintf( "Error in R_nc_get_vara_double: %s\n", 
			nc_strerror(*retval) );
		REprintf( "Var: %s  Ndims: %d   Start: ", vn, ndims );
		for( i=0; i<ndims; i++ ) {
			REprintf( "%u", (unsigned int)s_start[i] );
			if( i < ndims-1 )
				REprintf( "," );
			}
		REprintf( "Count: " );
		for( i=0; i<ndims; i++ ) {
			REprintf( "%u", (unsigned int)s_count[i] );
			if( i < ndims-1 )
				REprintf( "," );
			}
		}
}
Esempio n. 9
0
/* This is not used in R and in no header */
void
Rf_callToplevelHandlers(SEXP expr, SEXP value, Rboolean succeeded,
			Rboolean visible)
{
    R_ToplevelCallbackEl *h, *prev = NULL;
    Rboolean again;

    if(Rf_RunningToplevelHandlers == TRUE)
	return;

    h = Rf_ToplevelTaskHandlers;
    Rf_RunningToplevelHandlers = TRUE;
    while(h) {
	again = (h->cb)(expr, value, succeeded, visible, h->data);
	if(R_CollectWarnings) {
	    REprintf(_("warning messages from top-level task callback '%s'\n"),
		     h->name);
	    PrintWarnings();
	}
	if(again) {
	    prev = h;
	    h = h->next;
	} else {
	    R_ToplevelCallbackEl *tmp;
	    tmp = h;
	    if(prev)
		prev->next = h->next;
	    h = h->next;
	    if(tmp == Rf_ToplevelTaskHandlers)
		Rf_ToplevelTaskHandlers = h;
	    if(tmp->finalizer)
		tmp->finalizer(tmp->data);
	    free(tmp);
	}
    }

    Rf_RunningToplevelHandlers = FALSE;
}
Esempio n. 10
0
void show_family(Family *f) {
  Offspring *child;
  if (f) {
    REprintf(" %d: %d + %d / ", 
	    f->pedigree, f->father_id, f->mother_id);
    for (child=f->children; child; child=child->next) {
      REprintf(" %d", child->id);
      if (child->affected==2) 
	REprintf("*");
      if (child->next) 
	REprintf(",");
    }
    REprintf("\n");
  }
  else {
    REprintf("*** empty family ***\n");
  }
}
Esempio n. 11
0
attribute_hidden
double R_pretty(double *lo, double *up, int *ndiv, int min_n,
		double shrink_sml, double high_u_fact[],
		int eps_correction, int return_bounds)
{
/* From version 0.65 on, we had rounding_eps := 1e-5, before, r..eps = 0
 * then, 1e-7 was consistent with seq.default() and seq.int() till 2010-02-03,
 * where it was changed to 1e-10 for seq*(), and in 2017-08-14 for pretty(): */
#define rounding_eps 1e-10

#define h  high_u_fact[0]
#define h5 high_u_fact[1]

    double dx, cell, unit, base, U;
    double ns, nu;
    int k;
    Rboolean i_small;

    dx = *up - *lo;
    /* cell := "scale"	here */
    if(dx == 0 && *up == 0) { /*  up == lo == 0	 */
	cell = 1;
	i_small = TRUE;
    } else {
	cell = fmax2(fabs(*lo),fabs(*up));
	/* U = upper bound on cell/unit */
	U = 1 + ((h5 >= 1.5*h+.5) ? 1/(1+h) : 1.5/(1+h5));
	U *= imax2(1,*ndiv) * DBL_EPSILON; // avoid overflow for large ndiv
	/* added times 3, as several calculations here */
	i_small = dx < cell * U * 3;
    }

    /*OLD: cell = FLT_EPSILON+ dx / *ndiv; FLT_EPSILON = 1.192e-07 */
    if(i_small) {
	if(cell > 10)
	    cell = 9 + cell/10;
	cell *= shrink_sml;
	if(min_n > 1) cell /= min_n;
    } else {
	cell = dx;
	if(*ndiv > 1) cell /= *ndiv;
    }

    if(cell < 20*DBL_MIN) {
      warning(_("Internal(pretty()): very small range.. corrected"));
      cell = 20*DBL_MIN;
    } else if(cell * 10 > DBL_MAX) {
      warning(_("Internal(pretty()): very large range.. corrected"));
      cell = .1*DBL_MAX;
    }
    /* NB: the power can be negative and this relies on exact
       calculation, which glibc's exp10 does not achieve */
    base = pow(10.0, floor(log10(cell))); /* base <= cell < 10*base */

    /* unit : from { 1,2,5,10 } * base
     *	 such that |u - cell| is small,
     * favoring larger (if h > 1, else smaller)  u  values;
     * favor '5' more than '2'  if h5 > h  (default h5 = .5 + 1.5 h) */
    unit = base;
    if((U = 2*base)-cell <  h*(cell-unit)) { unit = U;
    if((U = 5*base)-cell < h5*(cell-unit)) { unit = U;
    if((U =10*base)-cell <  h*(cell-unit)) unit = U; }}
    /* Result: c := cell,  u := unit,  b := base
     *	c in [	1,	      (2+ h) /(1+h) ] b ==> u=  b
     *	c in ( (2+ h)/(1+h),  (5+2h5)/(1+h5)] b ==> u= 2b
     *	c in ( (5+2h)/(1+h), (10+5h) /(1+h) ] b ==> u= 5b
     *	c in ((10+5h)/(1+h),	         10 ) b ==> u=10b
     *
     *	===>	2/5 *(2+h)/(1+h)  <=  c/u  <=  (2+h)/(1+h)	*/

    ns = floor(*lo/unit+rounding_eps);
    nu = ceil (*up/unit-rounding_eps);
#ifdef DEBUGpr
    REprintf("pretty(lo=%g,up=%g,ndiv=%d,min_n=%d,shrink=%g,high_u=(%g,%g),"
	     "eps=%d)\n\t dx=%g; is.small:%d. ==> cell=%g; unit=%g\n",
	     *lo, *up, *ndiv, min_n, shrink_sml, h, h5,
	      eps_correction,	dx, (int)i_small, cell, unit);
#endif
    if(eps_correction && (eps_correction > 1 || !i_small)) {
	if(*lo != 0.) *lo *= (1- DBL_EPSILON); else *lo = -DBL_MIN;
	if(*up != 0.) *up *= (1+ DBL_EPSILON); else *up = +DBL_MIN;
    }

#ifdef DEBUGpr
    if(ns*unit > *lo)
	REprintf("\t ns= %.0f -- while(ns*unit > *lo) ns--;\n", ns);
#endif
    while(ns*unit > *lo + rounding_eps*unit) ns--;

#ifdef DEBUGpr
    if(nu*unit < *up)
	REprintf("\t nu= %.0f -- while(nu*unit < *up) nu++;\n", nu);
#endif
    while(nu*unit < *up - rounding_eps*unit) nu++;

    k = (int)(0.5 + nu - ns);
    if(k < min_n) {
	/* ensure that	nu - ns	 == min_n */
#ifdef DEBUGpr
	REprintf("\tnu-ns=%.0f-%.0f=%d SMALL -> ensure nu-ns= min_n=%d\n",
		 nu,ns, k, min_n);
#endif
	k = min_n - k;
	if(ns >= 0.) {
	    nu += k/2;
	    ns -= k/2 + k%2;/* ==> nu-ns = old(nu-ns) + min_n -k = min_n */
	} else {
	    ns -= k/2;
	    nu += k/2 + k%2;
	}
	*ndiv = min_n;
    }
    else {
	*ndiv = k;
    }
    if(return_bounds) { /* if()'s to ensure that result covers original range */
	if(ns * unit < *lo) *lo = ns * unit;
	if(nu * unit > *up) *up = nu * unit;
    } else {
	*lo = ns;
	*up = nu;
    }
#ifdef DEBUGpr
    REprintf("\t ns=%.0f ==> lo=%g\n", ns, *lo);
    REprintf("\t nu=%.0f ==> up=%g  ==> ndiv = %d\n", nu, *up, *ndiv);
#endif
    return unit;
#undef h
#undef h5
}
Esempio n. 12
0
File: do_mrdwt.c Progetto: cran/rwt
/*
 * Public
 */
SEXP do_mrdwt(SEXP vntX, SEXP vntH, SEXP vntL)
{
    SEXP vntOut;
    SEXP vntYl;
    SEXP vntYh;
    SEXP vntLr;
    double *x, *h, *yl, *yh;
    int m, n, lh, L;

#ifdef DEBUG_RWT
    REprintf("In do_mrdwt(x, h, L)...\n");
#endif

    /*
     * Handle first parameter (numeric matrix)
     */
#ifdef DEBUG_RWT
    REprintf("\tfirst param 'x'\n");
#endif
    if (GetMatrixDimen(vntX, &m, &n) != 2)
    {
        error("'x' is not a two dimensional matrix");
        /*NOTREACHED*/
    }
    PROTECT(vntX = AS_NUMERIC(vntX));
    x = NUMERIC_POINTER(vntX);
#ifdef DEBUG_RWT
    REprintf("x[%d][%d] = 0x%p\n", m, n, x);
#endif

    /*
     * Handle second parameter (numeric vector)
     */
#ifdef DEBUG_RWT
    REprintf("\tsecond param 'h'\n");
#endif
    PROTECT(vntH = AS_NUMERIC(vntH));
    h = NUMERIC_POINTER(vntH);
    lh = GET_LENGTH(vntH);
#ifdef DEBUG_RWT
    REprintf("h[%d] = 0x%p\n", GET_LENGTH(vntH), h);
#endif

    /*
     * Handle third parameter (integer scalar)
     */
#ifdef DEBUG_RWT
    REprintf("\tthird param 'L'\n");
#endif
    {
        PROTECT(vntL = AS_INTEGER(vntL));
        {
            int *piL = INTEGER_POINTER(vntL);
            L = piL[0];
        }
        UNPROTECT(1);
    }
#ifdef DEBUG_RWT
    REprintf("L = %d\n", L);
#endif

#ifdef DEBUG_RWT
    REprintf("\tcheck number of levels\n");
#endif
    if (L < 0)
    {
        error("The number of levels, L, must be a non-negative integer");
        /*NOTREACHED*/
    }

#ifdef DEBUG_RWT
    REprintf("\tcheck dimen prereqs\n");
#endif
    /* Check the ROW dimension of input */
    if (m > 1)
    {
        double mtest = (double) m / pow(2.0, (double) L);
        if (!isint(mtest))
        {
            error("The matrix row dimension must be of size m*2^(L)");
            /*NOTREACHED*/
        }
    }

    /* Check the COLUMN dimension of input */
    if (n > 1)
    {
        double ntest = (double) n / pow(2.0, (double) L);
        if (!isint(ntest))
        {
            error("The matrix column dimension must be of size n*2^(L)");
            /*NOTREACHED*/
        }
    }

#ifdef DEBUG_RWT
    REprintf("\tcreating value objects\n");
#endif

    /* Create yl value object */
    {
#ifdef DEBUG_RWT
        REprintf("\tcreating 'yl' value object\n");
#endif
        PROTECT(vntYl = NEW_NUMERIC(m*n));
        yl = NUMERIC_POINTER(vntYl);

        /* Add dimension attribute to value object */
#ifdef DEBUG_RWT
        REprintf("\tconvert 'yl' value object to matrix\n");
#endif
        {
            SEXP vntDim;

            PROTECT(vntDim = NEW_INTEGER(2));
            INTEGER(vntDim)[0] = m;
            INTEGER(vntDim)[1] = n;
            SET_DIM(vntYl, vntDim);
            UNPROTECT(1);
        }
    }

    /* Create yh value object */
    {
        int cols = (min(m,n) == 1) ? (L * n) : (3 * L * n);

#ifdef DEBUG_RWT
        REprintf("\tcreating 'yh' value object\n");
#endif
        PROTECT(vntYh = NEW_NUMERIC(m*cols));
        yh = NUMERIC_POINTER(vntYh);

        /* Add dimension attribute to value object */
#ifdef DEBUG_RWT
        REprintf("\tconvert 'yh' value object to matrix\n");
#endif
        {
            SEXP vntDim;

            PROTECT(vntDim = NEW_INTEGER(2));
            INTEGER(vntDim)[0] = m;
            INTEGER(vntDim)[1] = cols;
            SET_DIM(vntYh, vntDim);
            UNPROTECT(1);
        }
    }

    /* Create Lr value object */
    {
#ifdef DEBUG_RWT
        REprintf("\tcreating 'Lr' value object\n");
#endif
        PROTECT(vntLr = NEW_INTEGER(1));
        INTEGER_POINTER(vntLr)[0] = L;
    }

#ifdef DEBUG_RWT
    REprintf("\tcompute redundant discrete wavelet transform\n");
#endif
    MRDWT(x, m, n, h, lh, L, yl, yh);

    /* Unprotect params */
    UNPROTECT(2);

#ifdef DEBUG_RWT
    REprintf("\tcreate list output object\n");
#endif
    PROTECT(vntOut = NEW_LIST(3));

#ifdef DEBUG_RWT
    REprintf("\tassigning value objects to list\n");
#endif
    SET_VECTOR_ELT(vntOut, 0, vntYl);
    SET_VECTOR_ELT(vntOut, 1, vntYh);
    SET_VECTOR_ELT(vntOut, 2, vntLr);

    /* Unprotect value objects */
    UNPROTECT(3);

    {
        SEXP vntNames;

#ifdef DEBUG_RWT
        REprintf("\tassigning names to value objects in list\n");
#endif
        PROTECT(vntNames = NEW_CHARACTER(3));
        SET_STRING_ELT(vntNames, 0, CREATE_STRING_VECTOR("yl"));
        SET_STRING_ELT(vntNames, 1, CREATE_STRING_VECTOR("yh"));
        SET_STRING_ELT(vntNames, 2, CREATE_STRING_VECTOR("L"));
        SET_NAMES(vntOut, vntNames);
        UNPROTECT(1);
    }

    /* Unprotect output object */
    UNPROTECT(1);

#ifdef DEBUG_RWT
    REprintf("\treturning output...\n");
#endif

    return vntOut;
}
Esempio n. 13
0
double qnorm5(double p, double mu, double sigma, int lower_tail, int log_p)
{
    double p_, q, r, val;

#ifdef IEEE_754
    if (ISNAN(p) || ISNAN(mu) || ISNAN(sigma))
	return p + mu + sigma;
#endif
    R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);

    if(sigma  < 0)	ML_ERR_return_NAN;
    if(sigma == 0)	return mu;

    p_ = R_DT_qIv(p);/* real lower_tail prob. p */
    q = p_ - 0.5;

#ifdef DEBUG_qnorm
    REprintf("qnorm(p=%10.7g, m=%g, s=%g, l.t.= %d, log= %d): q = %g\n",
	     p,mu,sigma, lower_tail, log_p, q);
#endif


/*-- use AS 241 --- */
/* double ppnd16_(double *p, long *ifault)*/
/*      ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3

        Produces the normal deviate Z corresponding to a given lower
        tail area of P; Z is accurate to about 1 part in 10**16.

        (original fortran code used PARAMETER(..) for the coefficients
         and provided hash codes for checking them...)
*/
    if (fabs(q) <= .425) {/* 0.075 <= p <= 0.925 */
        r = .180625 - q * q;
	val =
            q * (((((((r * 2509.0809287301226727 +
                       33430.575583588128105) * r + 67265.770927008700853) * r +
                     45921.953931549871457) * r + 13731.693765509461125) * r +
                   1971.5909503065514427) * r + 133.14166789178437745) * r +
                 3.387132872796366608)
            / (((((((r * 5226.495278852854561 +
                     28729.085735721942674) * r + 39307.89580009271061) * r +
                   21213.794301586595867) * r + 5394.1960214247511077) * r +
                 687.1870074920579083) * r + 42.313330701600911252) * r + 1.);
    }
    else { /* closer than 0.075 from {0,1} boundary */

	/* r = min(p, 1-p) < 0.075 */
	if (q > 0)
	    r = R_DT_CIv(p);/* 1-p */
	else
	    r = p_;/* = R_DT_Iv(p) ^=  p */

	r = sqrt(- ((log_p &&
		     ((lower_tail && q <= 0) || (!lower_tail && q > 0))) ?
		    p : /* else */ log(r)));
        /* r = sqrt(-log(r))  <==>  min(p, 1-p) = exp( - r^2 ) */
#ifdef DEBUG_qnorm
	REprintf("\t close to 0 or 1: r = %7g\n", r);
#endif

        if (r <= 5.) { /* <==> min(p,1-p) >= exp(-25) ~= 1.3888e-11 */
            r += -1.6;
            val = (((((((r * 7.7454501427834140764e-4 +
                       .0227238449892691845833) * r + .24178072517745061177) *
                     r + 1.27045825245236838258) * r +
                    3.64784832476320460504) * r + 5.7694972214606914055) *
                  r + 4.6303378461565452959) * r +
                 1.42343711074968357734)
                / (((((((r *
                         1.05075007164441684324e-9 + 5.475938084995344946e-4) *
                        r + .0151986665636164571966) * r +
                       .14810397642748007459) * r + .68976733498510000455) *
                     r + 1.6763848301838038494) * r +
                    2.05319162663775882187) * r + 1.);
        }
        else { /* very close to  0 or 1 */
            r += -5.;
            val = (((((((r * 2.01033439929228813265e-7 +
                       2.71155556874348757815e-5) * r +
                      .0012426609473880784386) * r + .026532189526576123093) *
                    r + .29656057182850489123) * r +
                   1.7848265399172913358) * r + 5.4637849111641143699) *
                 r + 6.6579046435011037772)
                / (((((((r *
                         2.04426310338993978564e-15 + 1.4215117583164458887e-7)*
                        r + 1.8463183175100546818e-5) * r +
                       7.868691311456132591e-4) * r + .0148753612908506148525)
                     * r + .13692988092273580531) * r +
                    .59983220655588793769) * r + 1.);
        }

	if(q < 0.0)
	    val = -val;
        /* return (q >= 0.)? r : -r ;*/
    }
    return mu + sigma * val;
}
Esempio n. 14
0
/* Convert an R value to a GenericValue based on the type expected, given by type. */
bool
convertRToGenericValue(llvm::GenericValue *rv, SEXP rval, const llvm::Type *type)
{
   llvm::Type::TypeID ty;

   if(!type) {
       REprintf("var arg %d\n", TYPEOF(rval));
       rv->IntVal = INTEGER(rval)[0];
//       rv->IntVal = llvm::APInt((unsigned) 32, INTEGER(rval)[0]); 
       return(true);
   }

// FIX - enhance to cover more situations.
    if(type->isPointerTy()) {
      const llvm::Type *elType = ((const llvm::PointerType*) type)->getElementType();
       ty = elType->getTypeID();       
       bool ok = true;
       switch(ty) {
          case llvm::Type::IntegerTyID: 
              if(elType->isIntegerTy(8)) {
                  if(TYPEOF(rval) == STRSXP) {
                      rv->PointerVal = Rf_length(rval) ? (void*) CHAR(STRING_ELT(rval, 0)) : (void *) NULL;
                  } else if(TYPEOF(rval) == NILSXP) {
                      rv->PointerVal = (void*) NULL;
                  } else
                      ok = false;
              } else if(TYPEOF(rval) == INTSXP) 
                rv->PointerVal = INTEGER(rval);
              else
                 ok = false;
            break;
          case llvm::Type::DoubleTyID: 
              if(TYPEOF(rval) == REALSXP)
                 rv->PointerVal = REAL(rval);
              else
                 ok = false;
           break;
          case llvm::Type::PointerTyID: 
              if(TYPEOF(rval) == STRSXP) {
                  rv->PointerVal = Rf_length(rval) ? (void*) CHAR(STRING_ELT(rval, 0)) : (void *) NULL;
              } if(TYPEOF(rval) == NILSXP || rval == R_NilValue) {
                   rv->PointerVal = (void*) NULL;
              } else if(TYPEOF(rval) == RAWSXP)
                  rv->PointerVal = (void*) RAW(rval);
              else
                   ok = false;
              break;

          case llvm::Type::VoidTyID: 
              if(rval == R_NilValue)
                  rv->PointerVal = (void*) NULL;
              else if(TYPEOF(rval) == RAWSXP)
                  rv->PointerVal = (void*) RAW(rval);
              break;
          default:
            ok = false;
       }

       if(ok == false) {
	  int rtype = isSEXPType(type);
	  if(rtype > 0) {
             rv->PointerVal = rval;
             ok = true;
          } 
       }

       if(ok == false && TYPEOF(rval) == EXTPTRSXP) {
           rv->PointerVal = R_ExternalPtrAddr(rval);
           ok = true;
       }

       /* See if this is an S4 object with a "ref" slot that is an external pointer */
       SEXP refRVal = NULL;
       if(ok == false && IS_S4_OBJECT(rval) && (refRVal = GET_SLOT(rval, Rf_install("ref"))) 
               && refRVal != R_NilValue && TYPEOF(refRVal) == EXTPTRSXP) {
           rv->PointerVal = R_ExternalPtrAddr(refRVal);
           ok = true;
       }

 
	if(ok == false) {
            PROBLEM "no method to convert R object of R type %d to LLVM pointer to type %d", TYPEOF(rval), ty
            WARN;         
        }
        return(ok);
     }

    ty = type->getTypeID();
    switch(ty) {
       case llvm::Type::IntegerTyID: {
           uint64_t val = asInteger(rval);
           unsigned BitWidth = llvm::cast<llvm::IntegerType>(type)->getBitWidth();
           rv->IntVal = llvm::APInt(BitWidth, val); 
           return rv;
       }
       break;
       case llvm::Type::DoubleTyID: {
           rv->DoubleVal = Rf_asReal(rval);
       }
       break;
       case llvm::Type::FloatTyID: {
           rv->FloatVal = Rf_asReal(rval);
       }
       break;
       default:
           PROBLEM "no code yet for converting R to GV for type %d", (int) ty
               ERROR;

    }
    
    return(true);
}
Esempio n. 15
0
void mypause() {
  REprintf("--------------------------------------------------\n");
}
Esempio n. 16
0
void attribute_hidden Rstd_ShowMessage(const char *s)
{
    REprintf("%s\n", s);
}
Esempio n. 17
0
void attribute_hidden Rstd_Suicide(const char *s)
{
    REprintf("Fatal error: %s\n", s);
    /* Might be called before translation is running */
    R_CleanUp(SA_SUICIDE, 2, 0);
}
Esempio n. 18
0
double qgamma(double p, double alpha, double scale, int lower_tail, int log_p)
/*			shape = alpha */
{
#define C7	4.67
#define C8	6.66
#define C9	6.73
#define C10	13.32

#define EPS1 1e-2
#define EPS2 5e-7/* final precision */
#define MAXIT 1000/* was 20 */

#define pMIN 1e-100    /* was 0.000002 = 2e-6 */
#define pMAX (1-1e-12)/* was 0.999998 = 1 - 2e-6 */

    const double
	i420  = 1./ 420.,
	i2520 = 1./ 2520.,
	i5040 = 1./ 5040;

    double p_, a, b, c, ch, g, p1, v;
    double p2, q, s1, s2, s3, s4, s5, s6, t, x;
    int i;

    /* test arguments and initialise */

#ifdef IEEE_754
    if (ISNAN(p) || ISNAN(alpha) || ISNAN(scale))
	return p + alpha + scale;
#endif
    R_Q_P01_check(p);
    if (alpha <= 0) ML_ERR_return_NAN;

    /* FIXME: This (cutoff to {0, +Inf}) is far from optimal when log_p: */
    p_ = R_DT_qIv(p);/* lower_tail prob (in any case) */
    if (/* 0 <= */ p_ < pMIN) return 0;
    if (/* 1 >= */ p_ > pMAX) return BOOM::infinity();

    v = 2*alpha;

    c = alpha-1;
    g = lgammafn(alpha);/* log Gamma(v/2) */


/*----- Phase I : Starting Approximation */

#ifdef DEBUG_qgamma
    REprintf("qgamma(p=%7g, alpha=%7g, scale=%7g, l.t.=%2d, log_p=%2d): ",
	     p,alpha,scale, lower_tail, log_p);
#endif

    if(v < (-1.24)*R_DT_log(p)) {	/* for small chi-squared */

#ifdef DEBUG_qgamma
	REprintf(" small chi-sq.\n");
#endif
	/* FIXME: Improve this "if (log_p)" :
	 *	  (A*exp(b)) ^ 1/al */
	ch = pow(p_* alpha*exp(g+alpha*M_LN2), 1/alpha);
	if(ch < EPS2) {/* Corrected according to AS 91; MM, May 25, 1999 */
	    goto END;
	}

    } else if(v > 0.32) {	/*  using Wilson and Hilferty estimate */

	x = qnorm(p, 0, 1, lower_tail, log_p);
	p1 = 0.222222/v;
	ch = v*pow(x*sqrt(p1)+1-p1, 3);

#ifdef DEBUG_qgamma
	REprintf(" v > .32: Wilson-Hilferty; x = %7g\n", x);
#endif
	/* starting approximation for p tending to 1 */

	if( ch > 2.2*v + 6 )
	    ch = -2*(R_DT_Clog(p) - c*log(0.5*ch) + g);

    } else { /* for v <= 0.32 */

	ch = 0.4;
	a = R_DT_Clog(p) + g + c*M_LN2;
#ifdef DEBUG_qgamma
	REprintf(" v <= .32: a = %7g\n", a);
#endif
	do {
	    q = ch;
	    p1 = 1. / (1+ch*(C7+ch));
	    p2 = ch*(C9+ch*(C8+ch));
	    t = -0.5 +(C7+2*ch)*p1 - (C9+ch*(C10+3*ch))/p2;
	    ch -= (1- exp(a+0.5*ch)*p2*p1)/t;
	} while(fabs(q - ch) > EPS1*fabs(ch));
    }

#ifdef DEBUG_qgamma
    REprintf("\t==> ch = %10g:", ch);
#endif

/*----- Phase II: Iteration
 *	Call pgamma() [AS 239]	and calculate seven term taylor series
 */
    for( i=1 ; i <= MAXIT ; i++ ) {
	q = ch;
	p1 = 0.5*ch;
	p2 = p_ - pgamma(p1, alpha, 1, /*lower_tail*/true, /*log_p*/false);
#ifdef IEEE_754
	if(!R_FINITE(p2))
#else
	if(errno != 0)
#endif
		return numeric_limits<double>::quiet_NaN();

	t = p2*exp(alpha*M_LN2+g+p1-c*log(ch));
	b = t/ch;
	a = 0.5*t - b*c;
	s1 = (210+a*(140+a*(105+a*(84+a*(70+60*a))))) * i420;
	s2 = (420+a*(735+a*(966+a*(1141+1278*a)))) * i2520;
	s3 = (210+a*(462+a*(707+932*a))) * i2520;
	s4 = (252+a*(672+1182*a)+c*(294+a*(889+1740*a))) * i5040;
	s5 = (84+2264*a+c*(1175+606*a)) * i2520;
	s6 = (120+c*(346+127*c)) * i5040;
	ch += t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
	if(fabs(q - ch) < EPS2*ch)
	    goto END;
    }
    ML_ERROR(ME_PRECISION);/* no convergence in MAXIT iterations */
 END:
    return 0.5*scale*ch;
}
Esempio n. 19
0
SEXP readBGEN2List(BGenFile* bin) {
  // Rprintf("vcfColumn.size() = %u\n", FLAG_vcfColumn.size());
  // Rprintf("vcfInfo.size() = %u\n", FLAG_infoTag.size());
  // Rprintf("vcfIndv.size() = %u\n", FLAG_indvTag.size());
  // also append sample names at the end
  // 7: chrom, pos, varId, rsId, alleles, isPhased, prob, sampleId
  int retListLen = 8;
  if (retListLen == 0) {
    return R_NilValue;
  }

  int numAllocated =
      0;  // record how many times we allocate (using PROTECT in R);
  SEXP ret;
  PROTECT(ret = allocVector(VECSXP, retListLen));
  numAllocated++;

  //  store results
  std::vector<std::string> idVec;
  std::vector<std::string> chrom;
  std::vector<int> pos;
  std::vector<std::string> varId;
  std::vector<std::string> rsId;
  std::vector<std::string> alleles;
  // std::vector<std::vector<bool> > missing;
  std::vector<bool> isPhased;
  std::vector<std::vector<double> >
      prob;  // prob[variant][each_sample * (prob1, prob2, ...)]

  // std::map<std::string, std::vector<std::string> > infoMap;

  // std::map<std::string, std::vector<std::string> > indvMap;
  /// int nRow = 0;  // # of positions that will be outputed

  // get effective sample names
  const int N = bin->getNumSample();
  std::vector<std::string> sm = bin->getSampleIdentifier();  // all sample names
  std::vector<std::string>& names = idVec;
  if (!sm.size()) {
    char buf[1024];
    for (int i = 0; i < N; ++i) {
      sprintf(buf, "sample_%d", i);
      sm.push_back(buf);
    }
  }

  const size_t sampleSize = bin->getNumEffectiveSample();
  for (size_t i = 0; i != sampleSize; ++i) {
    names.push_back(sm[bin->getEffectiveIndex(i)]);
  }

  // real working part
  int nRecord = 0;
  const int numProbValues =
      3;  // if multi-allelic/multi-haploid, this value can be different
  int maxProbValues = -1;
  while (bin->readRecord()) {
    // REprintf("read a record\n");
    const BGenVariant& var = bin->getVariant();
    const size_t sampleSize = bin->getNumEffectiveSample();

    // store results here
    nRecord++;
    chrom.push_back(var.chrom);
    pos.push_back(var.pos);
    varId.push_back(var.varid);
    rsId.push_back(var.rsid);
    alleles.push_back(toString(var.alleles, ","));
    isPhased.push_back(var.isPhased);
    prob.resize(nRecord);

    std::vector<double>& p = prob[nRecord - 1];
    p.reserve(sampleSize * numProbValues);

    for (size_t i = 0; i != sampleSize; ++i) {
      int beg = var.index[bin->getEffectiveIndex(i)];
      int end = var.index[bin->getEffectiveIndex(i) + 1];
      if (end - beg > maxProbValues) {
        maxProbValues = end - beg;
      }
      for (int j = 0; j < numProbValues; ++j) {
        if (j < numProbValues) {
          p.push_back(var.prob[beg + j]);
        } else {
          p.push_back(-9);
        }
      }
      // REprintf("beg = %d, end = %d, prob[%d][%d] len = %d\n", beg,end,
      // nRecord - 1, i, p[i].size());
    }

    // Rprintf("Done add indv\n");
  }  // end while
  if (maxProbValues > numProbValues) {
    REprintf("some sample has more than %d > %d probabilities per variant!\n",
             maxProbValues, numProbValues);
  }

  // pass value back to R (see Manual Chapter 5)
  std::vector<std::string> listNames;
  int retListIdx = 0;
  storeResult(chrom, ret, retListIdx++);
  storeResult(pos, ret, retListIdx++);
  storeResult(varId, ret, retListIdx++);
  storeResult(rsId, ret, retListIdx++);
  storeResult(alleles, ret, retListIdx++);
  storeResult(isPhased, ret, retListIdx++);
  storeResult(prob, ret, retListIdx);
  for (size_t i = 0; i != prob.size(); ++i) {
    SEXP s = VECTOR_ELT(VECTOR_ELT(ret, retListIdx), i);
    setDim(numProbValues, sampleSize, s);
  }

  retListIdx++;
  listNames.push_back("chrom");
  listNames.push_back("pos");
  listNames.push_back("varid");
  listNames.push_back("rsid");
  listNames.push_back("alleles");
  listNames.push_back("isPhased");
  listNames.push_back("probability");

  // store sample ids
  // Rprintf("set sample id");
  listNames.push_back("sampleId");
  storeResult(idVec, ret, retListIdx++);

  // Rprintf("set list names\n");
  SEXP sListNames;
  PROTECT(sListNames = allocVector(STRSXP, listNames.size()));
  numAllocated++;
  for (unsigned int i = 0; i != listNames.size(); ++i) {
    SET_STRING_ELT(sListNames, i, mkChar(listNames[i].c_str()));
  }
  setAttrib(ret, R_NamesSymbol, sListNames);

  // finish up
  UNPROTECT(numAllocated);
  // Rprintf("Unprotected: %d\n", (retListLen + 1));
  return (ret);
}
Esempio n. 20
0
// for now still *export*  M_Matrix_check_class_etc()
int M_Matrix_check_class_etc(SEXP x, const char **valid)
{
    REprintf("M_Matrix_check_class_etc() is deprecated; use R_check_class_etc() instead");
    return R_check_class_etc(x, valid);
}
Esempio n. 21
0
double pnchisq_raw(double x, double f, double theta,
		   double errmax, double reltol, int itrmax)
{
    double ans, lam, u, v, x2, f2, t, term, bound, f_x_2n, f_2n, lt;
    double lu = -1., l_lam = -1., l_x = -1.; /* initialized for -Wall */
    int n;
    Rboolean lamSml, tSml, is_r, is_b, is_it;

    static const double _dbl_min_exp = M_LN2 * DBL_MIN_EXP;
    /*= -708.3964 for IEEE double precision */

    if (x <= 0.)	return 0.;
    if(!R_FINITE(x))	return 1.;

#ifdef DEBUG_pnch
    REprintf("pnchisq(x=%g, f=%g, theta=%g): ",x,f,theta);
#endif
    lam = .5 * theta;
    lamSml = (-lam < _dbl_min_exp);
    if(lamSml) {
	/* MATHLIB_ERROR(
	   "non centrality parameter (= %g) too large for current algorithm",
	   theta) */
        u = 0;
        lu = -lam;/* == ln(u) */
        l_lam = log(lam);
    } else {
	u = exp(-lam);
    }

    /* evaluate the first term */
    v = u;
    x2 = .5 * x;
    f2 = .5 * f;
    f_x_2n = f - x;

#ifdef DEBUG_pnch
    REprintf("-- v=exp(-th/2)=%g, x/2= %g, f/2= %g\n",v,x2,f2);
#endif

    if(f2 * DBL_EPSILON > 0.125 && /* very large f and x ~= f: probably needs */
       fabs(t = x2 - f2) <         /* other algorithm anyway */
       sqrt(DBL_EPSILON) * f2) {
	/* evade cancellation error */
	/* t = exp((1 - t)*(2 - t/(f2 + 1))) / sqrt(2*M_PI*(f2 + 1));*/
        lt = (1 - t)*(2 - t/(f2 + 1)) - 0.5 * log(2*M_PI*(f2 + 1));
#ifdef DEBUG_pnch
	REprintf(" (case I) ==> ");
#endif
    }
    else {
	/* Usual case 2: careful not to overflow .. : */
	lt = f2*log(x2) -x2 - lgammafn(f2 + 1);
    }
#ifdef DEBUG_pnch
    REprintf(" lt= %g", lt);
#endif

    tSml = (lt < _dbl_min_exp);
    if(tSml) {
	if (x > f + theta +  5* sqrt( 2*(f + 2*theta))) {
	    /* x > E[X] + 5* sigma(X) */
	    return 1.; /* better than 0 --- but definitely "FIXME" */
	} /* else */
	l_x = log(x);
	ans = term = t = 0.;
    }
    else {
	t = exp(lt);
#ifdef DEBUG_pnch
 	REprintf(", t=exp(lt)= %g\n", t);
#endif
	ans = term = v * t;
    }

    for (n = 1, f_2n = f + 2., f_x_2n += 2.;  ; n++, f_2n += 2, f_x_2n += 2) {
#ifdef DEBUG_pnch
	REprintf("\n _OL_: n=%d",n);
#endif
	/* f_2n    === f + 2*n
	 * f_x_2n  === f - x + 2*n   > 0  <==> (f+2n)  >   x */
	if (f_x_2n > 0) {
	    /* find the error bound and check for convergence */

	    bound = t * x / f_x_2n;
#ifdef DEBUG_pnch
	    REprintf("\n L10: n=%d; term= %g; bound= %g",n,term,bound);
#endif
	    is_r = is_it = FALSE;
	    /* convergence only if BOTH absolute and relative error < 'bnd' */
	    if (((is_b = (bound <= errmax)) &&
                 (is_r = (term <= reltol * ans))) || (is_it = (n > itrmax)))
            {
#ifdef DEBUG_pnch
                REprintf("BREAK n=%d %s; bound= %g %s, rel.err= %g %s\n",
			 n, (is_it ? "> itrmax" : ""),
			 bound, (is_b ? "<= errmax" : ""),
			 term/ans, (is_r ? "<= reltol" : ""));
#endif
		break; /* out completely */
            }

	}

	/* evaluate the next term of the */
	/* expansion and then the partial sum */

        if(lamSml) {
            lu += l_lam - log(n); /* u = u* lam / n */
            if(lu >= _dbl_min_exp) {
		/* no underflow anymore ==> change regime */
#ifdef DEBUG_pnch
                REprintf(" n=%d; nomore underflow in u = exp(lu) ==> change\n",
			 n);
#endif
                v = u = exp(lu); /* the first non-0 'u' */
                lamSml = FALSE;
            }
        } else {
	    u *= lam / n;
	    v += u;
	}
	if(tSml) {
            lt += l_x - log(f_2n);/* t <- t * (x / f2n) */
            if(lt >= _dbl_min_exp) {
		/* no underflow anymore ==> change regime */
#ifdef DEBUG_pnch
                REprintf("  n=%d; nomore underflow in t = exp(lt) ==> change\n",
			 n);
#endif
                t = exp(lt); /* the first non-0 't' */
                tSml = FALSE;
            }
        } else {
	    t *= x / f_2n;
	}
        if(!lamSml && !tSml) {
	    term = v * t;
	    ans += term;
	}

    } /* for(n ...) */

    if (is_it) {
	MATHLIB_WARNING2(_("pnchisq(x=%g, ..): not converged in %d iter."),
			 x, itrmax);
    }
#ifdef DEBUG_pnch
    REprintf("\n == L_End: n=%d; term= %g; bound=%g\n",n,term,bound);
#endif
    return (ans);
}
////////////////////////////////////////
// getHists - Get Histograms	   
SEXP getHistsR(SEXP fileForHists, SEXP histNames, SEXP directoryR)
{
  TFile* f = checkForFileForHistsWrapper(fileForHists);

  const char* oldDirectory = setFileDirectory(f, directoryR);

  // Make the return list
  SEXP ans, ansNames;
  PROTECT( ans = NEW_LIST( GET_LENGTH(histNames) ) );
  PROTECT( ansNames = NEW_STRING( GET_LENGTH(histNames) ) );

  // Loop over the names
  for ( unsigned int i = 0; i < GET_LENGTH(histNames); ++i ) {

    // Get the name of the object
		std::string name = CHAR( STRING_ELT(histNames, i) );
    
    // Set the list name
    SET_STRING_ELT( ansNames, i, mkChar(name.c_str()) );

    // What is this thing?
    TKey* key = gDirectory->FindKey(name.c_str());

    // If not found, then skip
    if ( ! key ) continue;

    // The object is real! - Get the class name
    const char* className = key->GetClassName();

    // Do certain things depending on the class name

    // For right now, we'll just do TH1F's and TH1D's. Maybe do more later.
    if ( strcmp(className, "TH1F") == 0 || strcmp(className, "TH1D") == 0 ) {

      // Get the histogram
      TH1* hist;
      gDirectory->GetObject(name.c_str(), hist);
      
      // For TH1F, there are 6 elements to the list (name, type, title,
      //    breaks, counts, 
      //    uncert, 
      //    mids, xname, underOverFlows, mean, rms, yname)
      SET_ELEMENT( ans, i, NEW_LIST(12) );
      SEXP data = VECTOR_ELT(ans, i);
      SEXP dataNames;
      PROTECT( dataNames = NEW_STRING(12) );

      // Add the type
      unsigned int j = 0;
      SEXP type = addCharVector(data, dataNames, j++, 1, "type");
      SET_STRING_ELT(type, 0, mkChar(className));
      
      // Add the name
      SEXP theName = addCharVector(data, dataNames, j++, 1, "name");
      SET_STRING_ELT(theName, 0, mkChar(name.c_str()));

      // Add basic histogram information
      j = addHistInfo(data, dataNames, j, hist);
      
      // Add the x-axis information
      j = addXAxis(data, dataNames, j, hist);

      // Add the x-contents information
      j = addXContents(data, dataNames, j, hist);

      // Add Y-axis name
      SEXP yname = addCharVector(data, dataNames, j++, 1, "yname");
      SET_STRING_ELT(yname, 0, mkChar( hist->GetYaxis()->GetTitle() ) );
      
      // Done
      SET_NAMES(data, dataNames);
      UNPROTECT(1);  // unprotect dataNames
    }

    else {
      REprintf("!! Do not know how to handle %s of class %s !!\n", 
	       name.c_str(), className);
      continue;
    }

  } // For over names
	
  // Restore the root old directory
  if ( ! f->cd(oldDirectory) ) {
    error("namesMatchingClass: cd to old directory failed");
  }

  // return the results
  SET_NAMES(ans, ansNames);
  UNPROTECT(2);
  
  return ans;
}      
Esempio n. 23
0
//     rhyper(NR, NB, n) -- NR 'red', NB 'blue', n drawn, how many are 'red'
double rhyper(double nn1in, double nn2in, double kkin)
{
    /* extern double afc(int); */

    int nn1, nn2, kk;
    int ix; // return value (coerced to double at the very end)
    Rboolean setup1, setup2;

    /* These should become 'thread_local globals' : */
    static int ks = -1, n1s = -1, n2s = -1;
    static int m, minjx, maxjx;
    static int k, n1, n2; // <- not allowing larger integer par
    static double tn;

    // II :
    static double w;
    // III:
    static double a, d, s, xl, xr, kl, kr, lamdl, lamdr, p1, p2, p3;

    /* check parameter validity */

    if(!R_FINITE(nn1in) || !R_FINITE(nn2in) || !R_FINITE(kkin))
	ML_ERR_return_NAN;

    nn1in = R_forceint(nn1in);
    nn2in = R_forceint(nn2in);
    kkin  = R_forceint(kkin);

    if (nn1in < 0 || nn2in < 0 || kkin < 0 || kkin > nn1in + nn2in)
	ML_ERR_return_NAN;
    if (nn1in >= INT_MAX || nn2in >= INT_MAX || kkin >= INT_MAX) {
	/* large n -- evade integer overflow (and inappropriate algorithms)
	   -------- */
        // FIXME: Much faster to give rbinom() approx when appropriate; -> see Kuensch(1989)
	// Johnson, Kotz,.. p.258 (top) mention the *four* different binomial approximations
	if(kkin == 1.) { // Bernoulli
	    return rbinom(kkin, nn1in / (nn1in + nn2in));
	}
	// Slow, but safe: return  F^{-1}(U)  where F(.) = phyper(.) and  U ~ U[0,1]
	return qhyper(unif_rand(), nn1in, nn2in, kkin, FALSE, FALSE);
    }
    nn1 = (int)nn1in;
    nn2 = (int)nn2in;
    kk  = (int)kkin;

    /* if new parameter values, initialize */
    if (nn1 != n1s || nn2 != n2s) {
	setup1 = TRUE;	setup2 = TRUE;
    } else if (kk != ks) {
	setup1 = FALSE;	setup2 = TRUE;
    } else {
	setup1 = FALSE;	setup2 = FALSE;
    }
    if (setup1) {
	n1s = nn1;
	n2s = nn2;
	tn = nn1 + nn2;
	if (nn1 <= nn2) {
	    n1 = nn1;
	    n2 = nn2;
	} else {
	    n1 = nn2;
	    n2 = nn1;
	}
    }
    if (setup2) {
	ks = kk;
	if (kk + kk >= tn) {
	    k = (int)(tn - kk);
	} else {
	    k = kk;
	}
    }
    if (setup1 || setup2) {
	m = (int) ((k + 1.) * (n1 + 1.) / (tn + 2.));
	minjx = imax2(0, k - n2);
	maxjx = imin2(n1, k);
#ifdef DEBUG_rhyper
	REprintf("rhyper(nn1=%d, nn2=%d, kk=%d), setup: floor(mean)= m=%d, jx in (%d..%d)\n",
		 nn1, nn2, kk, m, minjx, maxjx);
#endif
    }
    /* generate random variate --- Three basic cases */

    if (minjx == maxjx) { /* I: degenerate distribution ---------------- */
#ifdef DEBUG_rhyper
	REprintf("rhyper(), branch I (degenerate)\n");
#endif
	ix = maxjx;
	goto L_finis; // return appropriate variate

    } else if (m - minjx < 10) { // II: (Scaled) algorithm HIN (inverse transformation) ----
	const static double scale = 1e25; // scaling factor against (early) underflow
	const static double con = 57.5646273248511421;
					  // 25*log(10) = log(scale) { <==> exp(con) == scale }
	if (setup1 || setup2) {
	    double lw; // log(w);  w = exp(lw) * scale = exp(lw + log(scale)) = exp(lw + con)
	    if (k < n2) {
		lw = afc(n2) + afc(n1 + n2 - k) - afc(n2 - k) - afc(n1 + n2);
	    } else {
		lw = afc(n1) + afc(     k     ) - afc(k - n2) - afc(n1 + n2);
	    }
	    w = exp(lw + con);
	}
	double p, u;
#ifdef DEBUG_rhyper
	REprintf("rhyper(), branch II; w = %g > 0\n", w);
#endif
      L10:
	p = w;
	ix = minjx;
	u = unif_rand() * scale;
#ifdef DEBUG_rhyper
	REprintf("  _new_ u = %g\n", u);
#endif
	while (u > p) {
	    u -= p;
	    p *= ((double) n1 - ix) * (k - ix);
	    ix++;
	    p = p / ix / (n2 - k + ix);
#ifdef DEBUG_rhyper
	    REprintf("       ix=%3d, u=%11g, p=%20.14g (u-p=%g)\n", ix, u, p, u-p);
#endif
	    if (ix > maxjx)
		goto L10;
	    // FIXME  if(p == 0.)  we also "have lost"  => goto L10
	}
    } else { /* III : H2PE Algorithm --------------------------------------- */

	double u,v;

	if (setup1 || setup2) {
	    s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);

	    /* remark: d is defined in reference without int. */
	    /* the truncation centers the cell boundaries at 0.5 */

	    d = (int) (1.5 * s) + .5;
	    xl = m - d + .5;
	    xr = m + d + .5;
	    a = afc(m) + afc(n1 - m) + afc(k - m) + afc(n2 - k + m);
	    kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
		     - afc((int) (k - xl))
		     - afc((int) (n2 - k + xl)));
	    kr = exp(a - afc((int) (xr - 1))
		     - afc((int) (n1 - xr + 1))
		     - afc((int) (k - xr + 1))
		     - afc((int) (n2 - k + xr - 1)));
	    lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) / (k - xl + 1));
	    lamdr = -log((n1 - xr + 1) * (k - xr + 1) / xr / (n2 - k + xr));
	    p1 = d + d;
	    p2 = p1 + kl / lamdl;
	    p3 = p2 + kr / lamdr;
	}
#ifdef DEBUG_rhyper
	REprintf("rhyper(), branch III {accept/reject}: (xl,xr)= (%g,%g); (lamdl,lamdr)= (%g,%g)\n",
		 xl, xr, lamdl,lamdr);
	REprintf("-------- p123= c(%g,%g,%g)\n", p1,p2, p3);
#endif
	int n_uv = 0;
      L30:
	u = unif_rand() * p3;
	v = unif_rand();
	n_uv++;
	if(n_uv >= 10000) {
	    REprintf("rhyper() branch III: giving up after %d rejections", n_uv);
	    ML_ERR_return_NAN;
        }
#ifdef DEBUG_rhyper
	REprintf(" ... L30: new (u=%g, v ~ U[0,1])[%d]\n", u, n_uv);
#endif

	if (u < p1) {		/* rectangular region */
	    ix = (int) (xl + u);
	} else if (u <= p2) {	/* left tail */
	    ix = (int) (xl + log(v) / lamdl);
	    if (ix < minjx)
		goto L30;
	    v = v * (u - p1) * lamdl;
	} else {		/* right tail */
	    ix = (int) (xr - log(v) / lamdr);
	    if (ix > maxjx)
		goto L30;
	    v = v * (u - p2) * lamdr;
	}

	/* acceptance/rejection test */
	Rboolean reject = TRUE;

	if (m < 100 || ix <= 50) {
	    /* explicit evaluation */
	    /* The original algorithm (and TOMS 668) have
		   f = f * i * (n2 - k + i) / (n1 - i) / (k - i);
	       in the (m > ix) case, but the definition of the
	       recurrence relation on p134 shows that the +1 is
	       needed. */
	    int i;
	    double f = 1.0;
	    if (m < ix) {
		for (i = m + 1; i <= ix; i++)
		    f = f * (n1 - i + 1) * (k - i + 1) / (n2 - k + i) / i;
	    } else if (m > ix) {
		for (i = ix + 1; i <= m; i++)
		    f = f * i * (n2 - k + i) / (n1 - i + 1) / (k - i + 1);
	    }
	    if (v <= f) {
		reject = FALSE;
	    }
	} else {

	    const static double deltal = 0.0078;
	    const static double deltau = 0.0034;

	    double e, g, r, t, y;
	    double de, dg, dr, ds, dt, gl, gu, nk, nm, ub;
	    double xk, xm, xn, y1, ym, yn, yk, alv;

#ifdef DEBUG_rhyper
	    REprintf(" ... accept/reject 'large' case v=%g\n", v);
#endif
	    /* squeeze using upper and lower bounds */
	    y = ix;
	    y1 = y + 1.0;
	    ym = y - m;
	    yn = n1 - y + 1.0;
	    yk = k - y + 1.0;
	    nk = n2 - k + y1;
	    r = -ym / y1;
	    s = ym / yn;
	    t = ym / yk;
	    e = -ym / nk;
	    g = yn * yk / (y1 * nk) - 1.0;
	    dg = 1.0;
	    if (g < 0.0)
		dg = 1.0 + g;
	    gu = g * (1.0 + g * (-0.5 + g / 3.0));
	    gl = gu - .25 * (g * g * g * g) / dg;
	    xm = m + 0.5;
	    xn = n1 - m + 0.5;
	    xk = k - m + 0.5;
	    nm = n2 - k + xm;
	    ub = y * gu - m * gl + deltau
		+ xm * r * (1. + r * (-0.5 + r / 3.0))
		+ xn * s * (1. + s * (-0.5 + s / 3.0))
		+ xk * t * (1. + t * (-0.5 + t / 3.0))
		+ nm * e * (1. + e * (-0.5 + e / 3.0));
	    /* test against upper bound */
	    alv = log(v);
	    if (alv > ub) {
		reject = TRUE;
	    } else {
				/* test against lower bound */
		dr = xm * (r * r * r * r);
		if (r < 0.0)
		    dr /= (1.0 + r);
		ds = xn * (s * s * s * s);
		if (s < 0.0)
		    ds /= (1.0 + s);
		dt = xk * (t * t * t * t);
		if (t < 0.0)
		    dt /= (1.0 + t);
		de = nm * (e * e * e * e);
		if (e < 0.0)
		    de /= (1.0 + e);
		if (alv < ub - 0.25 * (dr + ds + dt + de)
		    + (y + m) * (gl - gu) - deltal) {
		    reject = FALSE;
		}
		else {
		    /* * Stirling's formula to machine accuracy
		     */
		    if (alv <= (a - afc(ix) - afc(n1 - ix)
				- afc(k - ix) - afc(n2 - k + ix))) {
			reject = FALSE;
		    } else {
			reject = TRUE;
		    }
		}
	    }
	} // else
	if (reject)
	    goto L30;
    }


L_finis:
    /* return appropriate variate */

    if (kk + kk >= tn) {
	if (nn1 > nn2) {
	    ix = kk - nn2 + ix;
	} else {
	    ix = nn1 - ix;
	}
    } else {
	if (nn1 > nn2)
	    ix = kk - ix;
    }
    return ix;
}
Esempio n. 24
0
static void *DBFReadAttribute(DBFHandle psDBF, int hEntity, int iField,
			      char chReqType )

{
    int		nRecordOffset;
    unsigned char	*pabyRec;
    void	*pReturnField = NULL;

    static double dDoubleField;

/* -------------------------------------------------------------------- */
/*      Verify selection.                                               */
/* -------------------------------------------------------------------- */
    if( hEntity < 0 || hEntity >= psDBF->nRecords )
	return( NULL );

    if( iField < 0 || iField >= psDBF->nFields )
	return( NULL );

/* -------------------------------------------------------------------- */
/*	Have we read the record?					*/
/* -------------------------------------------------------------------- */
    if( psDBF->nCurrentRecord != hEntity )
    {
	DBFFlushRecord( psDBF );

	nRecordOffset = psDBF->nRecordLength * hEntity + psDBF->nHeaderLength;

	if( fseek( psDBF->fp, nRecordOffset, 0 ) != 0 )
	{
	    REprintf("fseek(%d) failed on DBF file", nRecordOffset);
	    return NULL;
	}

	if( fread( psDBF->pszCurrentRecord, psDBF->nRecordLength,
		   1, psDBF->fp ) != 1 )
	{
	    REprintf("fread(%d) failed on DBF file", psDBF->nRecordLength );
	    return NULL;
	}

	psDBF->nCurrentRecord = hEntity;
    }

    pabyRec = (unsigned char *) psDBF->pszCurrentRecord;

/* -------------------------------------------------------------------- */
/*	Ensure our field buffer is large enough to hold this buffer.	*/
/* -------------------------------------------------------------------- */
    if( psDBF->panFieldSize[iField]+1 > nStringFieldLen )
    {
	nStringFieldLen = psDBF->panFieldSize[iField]*2 + 10;
	pszStringField = (char *) SfRealloc(pszStringField,nStringFieldLen);
    }

/* -------------------------------------------------------------------- */
/*	Extract the requested field.					*/
/* -------------------------------------------------------------------- */
    strncpy( pszStringField,
	     ((const char *) pabyRec) + psDBF->panFieldOffset[iField],
	     psDBF->panFieldSize[iField] );
    pszStringField[psDBF->panFieldSize[iField]] = '\0';

    pReturnField = pszStringField;

/* -------------------------------------------------------------------- */
/*      Decode the field.                                               */
/* -------------------------------------------------------------------- */
    if( chReqType == 'N' )
    {
	dDoubleField = R_atof(pszStringField);

	pReturnField = &dDoubleField;
    }

/* -------------------------------------------------------------------- */
/*      Should we trim white space off the string attribute value?      */
/* -------------------------------------------------------------------- */
#ifdef TRIM_DBF_WHITESPACE
    else
    {
	char	*pchSrc, *pchDst;

	pchDst = pchSrc = pszStringField;
	while( *pchSrc == ' ' )
	    pchSrc++;

	while( *pchSrc != '\0' )
	    *(pchDst++) = *(pchSrc++);
	*pchDst = '\0';

	while( pchDst != pszStringField && *(--pchDst) == ' ' )
	    *pchDst = '\0';
    }
#endif

    return( pReturnField );
}
Esempio n. 25
0
double qbinom(double p, double n, double pr, int lower_tail, int log_p)
{
    double q, mu, sigma, gamma, z, y;

#ifdef IEEE_754
    if (ISNAN(p) || ISNAN(n) || ISNAN(pr))
	return p + n + pr;
#endif
    if(!R_FINITE(n) || !R_FINITE(pr))
	ML_ERR_return_NAN;
    /* if log_p is true, p = -Inf is a legitimate value */
    if(!R_FINITE(p) && !log_p)
	ML_ERR_return_NAN;

    if(n != floor(n + 0.5)) ML_ERR_return_NAN;
    if (pr < 0 || pr > 1 || n < 0)
	ML_ERR_return_NAN;

    R_Q_P01_boundaries(p, 0, n);

    if (pr == 0. || n == 0) return 0.;

    q = 1 - pr;
    if(q == 0.) return n; /* covers the full range of the distribution */
    mu = n * pr;
    sigma = sqrt(n * pr * q);
    gamma = (q - pr) / sigma;

#ifdef DEBUG_qbinom
    REprintf("qbinom(p=%7g, n=%g, pr=%7g, l.t.=%d, log=%d): sigm=%g, gam=%g\n",
	     p,n,pr, lower_tail, log_p, sigma, gamma);
#endif
    /* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
     * FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
    if(!lower_tail || log_p) {
	p = R_DT_qIv(p); /* need check again (cancellation!): */
	if (p == 0.) return 0.;
	if (p == 1.) return n;
    }
    /* temporary hack --- FIXME --- */
    if (p + 1.01*DBL_EPSILON >= 1.) return n;

    /* y := approx.value (Cornish-Fisher expansion) :  */
    z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
    y = floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5);

    if(y > n) /* way off */ y = n;

#ifdef DEBUG_qbinom
    REprintf("  new (p,1-p)=(%7g,%7g), z=qnorm(..)=%7g, y=%5g\n", p, 1-p, z, y);
#endif
    z = pbinom(y, n, pr, /*lower_tail*/TRUE, /*log_p*/FALSE);

    /* fuzz to ensure left continuity: */
    p *= 1 - 64*DBL_EPSILON;

    if(n < 1e5) return do_search(y, &z, p, n, pr, 1);
    /* Otherwise be a bit cleverer in the search */
    {
	double incr = floor(n * 0.001), oldincr;
	do {
	    oldincr = incr;
	    y = do_search(y, &z, p, n, pr, incr);
	    incr = fmax2(1, floor(incr/100));
	} while(oldincr > 1 && incr > n*1e-15);
	return y;
    }
}
Esempio n. 26
0
/* Continued fraction for calculation of
 *    scaled upper-tail F_{gamma}
 *  ~=  (y / d) * [1 +  (1-y)/d +  O( ((1-y)/d)^2 ) ]
 */
static double
pd_lower_cf (double y, double d)
{
    double f= 0.0 /* -Wall */, of, f0;
    double i, c2, c3, c4,  a1, b1,  a2, b2;

#define	NEEDED_SCALE				\
	  (b2 > scalefactor) {			\
	    a1 /= scalefactor;			\
	    b1 /= scalefactor;			\
	    a2 /= scalefactor;			\
	    b2 /= scalefactor;			\
	}

#define max_it 200000

#ifdef DEBUG_p
    REprintf("pd_lower_cf(y=%.14g, d=%.14g)", y, d);
#endif
    if (y == 0) return 0;

    f0 = y/d;
    /* Needed, e.g. for  pgamma(10^c(100,295), shape= 1.1, log=TRUE): */
    if(fabs(y - 1) < fabs(d) * DBL_EPSILON) { /* includes y < d = Inf */
#ifdef DEBUG_p
	REprintf(" very small 'y' -> returning (y/d)\n");
#endif
	return (f0);
    }

    if(f0 > 1.) f0 = 1.;
    c2 = y;
    c4 = d; /* original (y,d), *not* potentially scaled ones!*/

    a1 = 0; b1 = 1;
    a2 = y; b2 = d;

    while NEEDED_SCALE

    i = 0; of = -1.; /* far away */
    while (i < max_it) {

	i++;	c2--;	c3 = i * c2;	c4 += 2;
	/* c2 = y - i,  c3 = i(y - i),  c4 = d + 2i,  for i odd */
	a1 = c4 * a2 + c3 * a1;
	b1 = c4 * b2 + c3 * b1;

	i++;	c2--;	c3 = i * c2;	c4 += 2;
	/* c2 = y - i,  c3 = i(y - i),  c4 = d + 2i,  for i even */
	a2 = c4 * a1 + c3 * a2;
	b2 = c4 * b1 + c3 * b2;

	if NEEDED_SCALE

	if (b2 != 0) {
	    f = a2 / b2;
 	    /* convergence check: relative; "absolute" for very small f : */
	    if (fabs (f - of) <= DBL_EPSILON * fmax2(f0, fabs(f))) {
#ifdef DEBUG_p
		REprintf(" %g iter.\n", i);
#endif
		return f;
	    }
	    of = f;
	}
    }

    MATHLIB_WARNING(" ** NON-convergence in pgamma()'s pd_lower_cf() f= %g.\n",
		    f);
    return f;/* should not happen ... */
} /* pd_lower_cf() */
Esempio n. 27
0
double attribute_hidden
pnchisq_raw(double x, double f, double theta,
	    double errmax, double reltol, int itrmax, Rboolean lower_tail)
{
    double lam, x2, f2, term, bound, f_x_2n, f_2n;
    double l_lam = -1., l_x = -1.; /* initialized for -Wall */
    int n;
    Rboolean lamSml, tSml, is_r, is_b, is_it;
    LDOUBLE ans, u, v, t, lt, lu =-1;

    static const double _dbl_min_exp = M_LN2 * DBL_MIN_EXP;
    /*= -708.3964 for IEEE double precision */

    if (x <= 0.) {
	if(x == 0. && f == 0.)
	    return lower_tail ? exp(-0.5*theta) : -expm1(-0.5*theta);
	/* x < 0  or {x==0, f > 0} */
	return lower_tail ? 0. : 1.;
    }
    if(!R_FINITE(x))	return lower_tail ? 1. : 0.;

    /* This is principally for use from qnchisq */
#ifndef MATHLIB_STANDALONE
    R_CheckUserInterrupt();
#endif

    if(theta < 80) { /* use 110 for Inf, as ppois(110, 80/2, lower.tail=FALSE) is 2e-20 */
	LDOUBLE sum = 0, sum2 = 0, lambda = 0.5*theta, 
	    pr = EXP(-lambda); // does this need a feature test?
	double ans;
	int i;
	/* we need to renormalize here: the result could be very close to 1 */
	for(i = 0; i < 110;  pr *= lambda/++i) {
	    sum2 += pr;
	    sum += pr * pchisq(x, f+2*i, lower_tail, FALSE);
	    if (sum2 >= 1-1e-15) break;
	}
	ans = (double) (sum/sum2);
	return ans;
    }


#ifdef DEBUG_pnch
    REprintf("pnchisq(x=%g, f=%g, theta=%g): ",x,f,theta);
#endif
    lam = .5 * theta;
    lamSml = (-lam < _dbl_min_exp);
    if(lamSml) {
	/* MATHLIB_ERROR(
	   "non centrality parameter (= %g) too large for current algorithm",
	   theta) */
        u = 0;
        lu = -lam;/* == ln(u) */
        l_lam = log(lam);
    } else {
	u = exp(-lam);
    }

    /* evaluate the first term */
    v = u;
    x2 = .5 * x;
    f2 = .5 * f;
    f_x_2n = f - x;

#ifdef DEBUG_pnch
    REprintf("-- v=exp(-th/2)=%g, x/2= %g, f/2= %g\n",v,x2,f2);
#endif

    if(f2 * DBL_EPSILON > 0.125 && /* very large f and x ~= f: probably needs */
       FABS(t = x2 - f2) <         /* another algorithm anyway */
       sqrt(DBL_EPSILON) * f2) {
	/* evade cancellation error */
	/* t = exp((1 - t)*(2 - t/(f2 + 1))) / sqrt(2*M_PI*(f2 + 1));*/
        lt = (1 - t)*(2 - t/(f2 + 1)) - 0.5 * log(2*M_PI*(f2 + 1));
#ifdef DEBUG_pnch
	REprintf(" (case I) ==> ");
#endif
    }
    else {
	/* Usual case 2: careful not to overflow .. : */
	lt = f2*log(x2) -x2 - lgammafn(f2 + 1);
    }
#ifdef DEBUG_pnch
    REprintf(" lt= %g", lt);
#endif

    tSml = (lt < _dbl_min_exp);
    if(tSml) {
	if (x > f + theta +  5* sqrt( 2*(f + 2*theta))) {
	    /* x > E[X] + 5* sigma(X) */
	    return lower_tail ? 1. : 0.; /* FIXME: We could be more accurate than 0. */
	} /* else */
	l_x = log(x);
	ans = term = 0.; t = 0;
    }
    else {
	t = EXP(lt);
#ifdef DEBUG_pnch
 	REprintf(", t=exp(lt)= %g\n", t);
#endif
	ans = term = (double) (v * t);
    }

    for (n = 1, f_2n = f + 2., f_x_2n += 2.;  ; n++, f_2n += 2, f_x_2n += 2) {
#ifdef DEBUG_pnch
	REprintf("\n _OL_: n=%d",n);
#endif
#ifndef MATHLIB_STANDALONE
	if(n % 1000) R_CheckUserInterrupt();
#endif
	/* f_2n    === f + 2*n
	 * f_x_2n  === f - x + 2*n   > 0  <==> (f+2n)  >   x */
	if (f_x_2n > 0) {
	    /* find the error bound and check for convergence */

	    bound = (double) (t * x / f_x_2n);
#ifdef DEBUG_pnch
	    REprintf("\n L10: n=%d; term= %g; bound= %g",n,term,bound);
#endif
	    is_r = is_it = FALSE;
	    /* convergence only if BOTH absolute and relative error < 'bnd' */
	    if (((is_b = (bound <= errmax)) &&
                 (is_r = (term <= reltol * ans))) || (is_it = (n > itrmax)))
            {
#ifdef DEBUG_pnch
                REprintf("BREAK n=%d %s; bound= %g %s, rel.err= %g %s\n",
			 n, (is_it ? "> itrmax" : ""),
			 bound, (is_b ? "<= errmax" : ""),
			 term/ans, (is_r ? "<= reltol" : ""));
#endif
		break; /* out completely */
            }

	}

	/* evaluate the next term of the */
	/* expansion and then the partial sum */

        if(lamSml) {
            lu += l_lam - log(n); /* u = u* lam / n */
            if(lu >= _dbl_min_exp) {
		/* no underflow anymore ==> change regime */
#ifdef DEBUG_pnch
                REprintf(" n=%d; nomore underflow in u = exp(lu) ==> change\n",
			 n);
#endif
                v = u = EXP(lu); /* the first non-0 'u' */
                lamSml = FALSE;
            }
        } else {
	    u *= lam / n;
	    v += u;
	}
	if(tSml) {
            lt += l_x - log(f_2n);/* t <- t * (x / f2n) */
            if(lt >= _dbl_min_exp) {
		/* no underflow anymore ==> change regime */
#ifdef DEBUG_pnch
                REprintf("  n=%d; nomore underflow in t = exp(lt) ==> change\n",
			 n);
#endif
                t = EXP(lt); /* the first non-0 't' */
                tSml = FALSE;
            }
        } else {
	    t *= x / f_2n;
	}
        if(!lamSml && !tSml) {
	    term = (double) (v * t);
	    ans += term;
	}

    } /* for(n ...) */

    if (is_it) {
	MATHLIB_WARNING2(_("pnchisq(x=%g, ..): not converged in %d iter."),
			 x, itrmax);
    }
#ifdef DEBUG_pnch
    REprintf("\n == L_End: n=%d; term= %g; bound=%g\n",n,term,bound);
#endif
    return (double) (lower_tail ? ans : 1 - ans);
}
Esempio n. 28
0
/*
 * Asymptotic expansion to calculate the probability that Poisson variate
 * has value <= x.
 * Various assertions about this are made (without proof) at
 * http://members.aol.com/iandjmsmith/PoissonApprox.htm
 */
static double
ppois_asymp (double x, double lambda, int lower_tail, int log_p)
{
    static const double coefs_a[8] = {
	-1e99, /* placeholder used for 1-indexing */
	2/3.,
	-4/135.,
	8/2835.,
	16/8505.,
	-8992/12629925.,
	-334144/492567075.,
	698752/1477701225.
    };

    static const double coefs_b[8] = {
	-1e99, /* placeholder */
	1/12.,
	1/288.,
	-139/51840.,
	-571/2488320.,
	163879/209018880.,
	5246819/75246796800.,
	-534703531/902961561600.
    };

    double elfb, elfb_term;
    double res12, res1_term, res1_ig, res2_term, res2_ig;
    double dfm, pt_, s2pt, f, np;
    int i;

    dfm = lambda - x;
    /* If lambda is large, the distribution is highly concentrated
       about lambda.  So representation error in x or lambda can lead
       to arbitrarily large values of pt_ and hence divergence of the
       coefficients of this approximation.
    */
    pt_ = - log1pmx (dfm / x);
    s2pt = sqrt (2 * x * pt_);
    if (dfm < 0) s2pt = -s2pt;

    res12 = 0;
    res1_ig = res1_term = sqrt (x);
    res2_ig = res2_term = s2pt;
    for (i = 1; i < 8; i++) {
	res12 += res1_ig * coefs_a[i];
	res12 += res2_ig * coefs_b[i];
	res1_term *= pt_ / i ;
	res2_term *= 2 * pt_ / (2 * i + 1);
	res1_ig = res1_ig / x + res1_term;
	res2_ig = res2_ig / x + res2_term;
    }

    elfb = x;
    elfb_term = 1;
    for (i = 1; i < 8; i++) {
	elfb += elfb_term * coefs_b[i];
	elfb_term /= x;
    }
    if (!lower_tail) elfb = -elfb;
#ifdef DEBUG_p
    REprintf ("res12 = %.14g   elfb=%.14g\n", elfb, res12);
#endif

    f = res12 / elfb;

    np = pnorm (s2pt, 0.0, 1.0, !lower_tail, log_p);

    if (log_p) {
	double n_d_over_p = dpnorm (s2pt, !lower_tail, np);
#ifdef DEBUG_p
	REprintf ("pp*_asymp(): f=%.14g	 np=e^%.14g  nd/np=%.14g  f*nd/np=%.14g\n",
		  f, np, n_d_over_p, f * n_d_over_p);
#endif
	return np + log1p (f * n_d_over_p);
    } else {
	double nd = dnorm (s2pt, 0., 1., log_p);

#ifdef DEBUG_p
	REprintf ("pp*_asymp(): f=%.14g	 np=%.14g  nd=%.14g  f*nd=%.14g\n",
		  f, np, nd, f * nd);
#endif
	return np + f * nd;
    }
} /* ppois_asymp() */
Esempio n. 29
0
double qn0(double *x, int n)
{
/*--------------------------------------------------------------------

   Efficient algorithm for the scale estimator:

       Q*_n = { |x_i - x_j|; i<j }_(k)	[= Qn without scaling ]

		i.e. the k-th order statistic of the |x_i - x_j|

   Parameters of the function Qn :
       x  : double array containing the observations
       n  : number of observations (n >=2)
 */

    double *y	  = (double *)R_alloc(n, sizeof(double));
    double *work  = (double *)R_alloc(n, sizeof(double));
    double *a_srt = (double *)R_alloc(n, sizeof(double));
    double *a_cand = (double *)R_alloc(n, sizeof(double));

    int *left	  = (int *)R_alloc(n, sizeof(int));
    int *right	  = (int *)R_alloc(n, sizeof(int));
    int *p	  = (int *)R_alloc(n, sizeof(int));
    int *q	  = (int *)R_alloc(n, sizeof(int));
    int *weight	  = (int *)R_alloc(n, sizeof(int));

    double trial = R_NaReal;/* -Wall */
    Rboolean found;

    int h, i, j,jj,jh;
    /* Following should be `long long int' : they can be of order n^2 */
    int64_t k, knew, nl,nr, sump,sumq;

    h = n / 2 + 1;
    k = (int64_t)h * (h - 1) / 2;
    for (i = 0; i < n; ++i) {
	y[i] = x[i];
	left [i] = n - i + 1;
	right[i] = (i <= h) ? n : n - (i - h);
	/* the n - (i-h) is from the paper; original code had `n' */
    }
    R_qsort(y, 1, n); /* y := sort(x) */
    nl = (int64_t)n * (n + 1) / 2;
    nr = (int64_t)n * n;
    knew = k + nl;/* = k + (n+1 \over 2) */
    found = FALSE;
#ifdef DEBUG_qn
    REprintf("qn0(): h,k= %2d,%2d;  nl,nr= %d,%d\n", h,k, nl,nr);
#endif
/* L200: */
    while(!found && nr - nl > n) {
	j = 0;
	/* Truncation to float :
	   try to make sure that the same values are got later (guard bits !) */
	for (i = 1; i < n; ++i) {
	    if (left[i] <= right[i]) {
		weight[j] = right[i] - left[i] + 1;
		jh = left[i] + weight[j] / 2;
		work[j] = (float)(y[i] - y[n - jh]);
		++j;
	    }
	}
	trial = whimed_i(work, weight, j, a_cand, a_srt, /*iw_cand*/ p);

#ifdef DEBUG_qn
	REprintf(" ..!found: whimed(");
#  ifdef DEBUG_long
	REprintf("wrk=c(");
	for(i=0; i < j; i++) REprintf("%s%g", (i>0)? ", " : "", work[i]);
	REprintf("),\n	   wgt=c(");
	for(i=0; i < j; i++) REprintf("%s%d", (i>0)? ", " : "", weight[i]);
	REprintf("), j= %3d) -> trial= %7g\n", j, trial);
#  else
	REprintf("j=%3d) -> trial= %g:", j, trial);
#  endif
#endif
	j = 0;
	for (i = n - 1; i >= 0; --i) {
	    while (j < n && ((float)(y[i] - y[n - j - 1])) < trial)
		++j;
	    p[i] = j;
	}
#ifdef DEBUG_qn
	REprintf(" f_1: j=%2d", j);
#endif
	j = n + 1;
	for (i = 0; i < n; ++i) {
	    while ((float)(y[i] - y[n - j + 1]) > trial)
		--j;
	    q[i] = j;
	}
	sump = 0;
	sumq = 0;
	for (i = 0; i < n; ++i) {
	    sump += p[i];
	    sumq += q[i] - 1;
	}
#ifdef DEBUG_qn
	REprintf(" f_2 -> j=%2d, sump|q= %lld,%lld", j, sump,sumq);
#endif
	if (knew <= sump) {
	    for (i = 0; i < n; ++i)
		right[i] = p[i];
	    nr = sump;
#ifdef DEBUG_qn
	    REprintf("knew <= sump =: nr , new right[]\n");
#endif
	} else if (knew > sumq) {
	    for (i = 0; i < n; ++i)
		left[i] = q[i];
	    nl = sumq;
#ifdef DEBUG_qn
	    REprintf("knew > sumq =: nl , new left[]\n");
#endif
	} else { /* sump < knew <= sumq */
	    found = TRUE;
#ifdef DEBUG_qn
	    REprintf("sump < knew <= sumq ---> FOUND\n");
#endif
	}
    } /* while */

    if (found)
	return trial;
    else {
#ifdef DEBUG_qn
	REprintf(".. not fnd -> new work[]");
#endif
	j = 0;
	for (i = 1; i < n; ++i) {
	    for (jj = left[i]; jj <= right[i]; ++jj) {
		work[j] = y[i] - y[n - jj];
		j++;
	    }/* j will be = sum_{i=2}^n (right[i] - left[i] + 1)_{+}  */
	}
#ifdef DEBUG_qn
	REprintf(" of length %d; knew-nl=%d\n", j, knew-nl);
#endif

	/* return pull(work, j - 1, knew - nl)	: */
	knew -= (nl + 1); /* -1: 0-indexing */
	rPsort(work, j, knew);
	return(work[knew]);
    }
} /* qn0 */
Esempio n. 30
0
double pgamma_raw (double x, double alph, int lower_tail, int log_p)
{
/* Here, assume that  (x,alph) are not NA  &  alph > 0 . */

    double res;

#ifdef DEBUG_p
    REprintf("pgamma_raw(x=%.14g, alph=%.14g, low=%d, log=%d)\n",
	     x, alph, lower_tail, log_p);
#endif
    R_P_bounds_01(x, 0., ML_POSINF);

    if (x < 1) {
	res = pgamma_smallx (x, alph, lower_tail, log_p);
    } else if (x <= alph - 1 && x < 0.8 * (alph + 50)) {
	/* incl. large alph compared to x */
	double sum = pd_upper_series (x, alph, log_p);/* = x/alph + o(x/alph) */
	double d = dpois_wrap (alph, x, log_p);
#ifdef DEBUG_p
	REprintf(" alph 'large': sum=pd_upper*()= %.12g, d=dpois_w(*)= %.12g\n",
		 sum, d);
#endif
	if (!lower_tail)
	    res = log_p
		? R_Log1_Exp (d + sum)
		: 1 - d * sum;
	else
	    res = log_p ? sum + d : sum * d;
    } else if (alph - 1 < x && alph < 0.8 * (x + 50)) {
	/* incl. large x compared to alph */
	double sum;
	double d = dpois_wrap (alph, x, log_p);
#ifdef DEBUG_p
	REprintf(" x 'large': d=dpois_w(*)= %.14g ", d);
#endif
	if (alph < 1) {
	    if (x * DBL_EPSILON > 1 - alph)
		sum = R_D__1;
	    else {
		double f = pd_lower_cf (alph, x - (alph - 1)) * x / alph;
		/* = [alph/(x - alph+1) + o(alph/(x-alph+1))] * x/alph = 1 + o(1) */
		sum = log_p ? log (f) : f;
	    }
	} else {
	    sum = pd_lower_series (x, alph - 1);/* = (alph-1)/x + o((alph-1)/x) */
	    sum = log_p ? log1p (sum) : 1 + sum;
	}
#ifdef DEBUG_p
	REprintf(", sum= %.14g\n", sum);
#endif
	if (!lower_tail)
	    res = log_p ? sum + d : sum * d;
	else
	    res = log_p
		? R_Log1_Exp (d + sum)
		: 1 - d * sum;
    } else { /* x >= 1 and x fairly near alph. */
#ifdef DEBUG_p
	REprintf(" using ppois_asymp()\n");
#endif
	res = ppois_asymp (alph - 1, x, !lower_tail, log_p);
    }

    /*
     * We lose a fair amount of accuracy to underflow in the cases
     * where the final result is very close to DBL_MIN.	 In those
     * cases, simply redo via log space.
     */
    if (!log_p && res < DBL_MIN / DBL_EPSILON) {
	/* with(.Machine, double.xmin / double.eps) #|-> 1.002084e-292 */
#ifdef DEBUG_p
	REprintf(" very small res=%.14g; -> recompute via log\n", res);
#endif
	return exp (pgamma_raw (x, alph, lower_tail, 1));
    } else
	return res;
}