C++ REprintf函数代码示例

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

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

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

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

/* 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(). */

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

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( "," );
			}
		}
}

/* 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;
}

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

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",
//.........这里部分代码省略.........

/*
 * 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");
//.........这里部分代码省略.........

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

/* 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);
       }
//.........这里部分代码省略.........

void mypause() {
  REprintf("--------------------------------------------------\n");
}

void attribute_hidden Rstd_ShowMessage(const char *s)
{
    REprintf("%s\n", s);
}