本文整理汇总了C++中LOGICAL函数的典型用法代码示例。如果您正苦于以下问题：C++ LOGICAL函数的具体用法？C++ LOGICAL怎么用？C++ LOGICAL使用的例子？那么恭喜您, 这里精选的函数代码示例或许可以为您提供帮助。
在下文中一共展示了LOGICAL函数的15个代码示例，这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞，您的评价将有助于系统推荐出更棒的C++代码示例。
示例1: transpose
SEXP transpose(SEXP l, SEXP fill, SEXP ignoreArg) {
R_len_t i, j, k=0, maxlen=0, zerolen=0, anslen;
SEXP li, thisi, ans;
SEXPTYPE type, maxtype=0;
Rboolean coerce = FALSE;
if (!isNewList(l))
error("l must be a list.");
if (!length(l))
return(duplicate(l));
if (!isLogical(ignoreArg) || LOGICAL(ignoreArg)[0] == NA_LOGICAL)
error("ignore.empty should be logical TRUE/FALSE.");
if (length(fill) != 1)
error("fill must be NULL or length=1 vector.");
R_len_t ln = LENGTH(l);
Rboolean ignore = LOGICAL(ignoreArg)[0];
// preprocessing
R_len_t *len = (R_len_t *)R_alloc(ln, sizeof(R_len_t));
for (i=0; i<ln; i++) {
li = VECTOR_ELT(l, i);
if (!isVectorAtomic(li) && !isNull(li))
error("Item %d of list input is not an atomic vector", i+1);
len[i] = length(li);
if (len[i] > maxlen)
maxlen = len[i];
zerolen += (len[i] == 0);
if (isFactor(li)) {
maxtype = STRSXP;
} else {
type = TYPEOF(li);
if (type > maxtype)
maxtype = type;
}
}
// coerce fill to maxtype
fill = PROTECT(coerceVector(fill, maxtype));
// allocate 'ans'
ans = PROTECT(allocVector(VECSXP, maxlen));
anslen = (!ignore) ? ln : (ln - zerolen);
for (i=0; i<maxlen; i++) {
SET_VECTOR_ELT(ans, i, thisi=allocVector(maxtype, anslen) );
}
// transpose
for (i=0; i<ln; i++) {
if (ignore && !len[i]) continue;
li = VECTOR_ELT(l, i);
if (TYPEOF(li) != maxtype) {
coerce = TRUE;
if (!isFactor(li)) li = PROTECT(coerceVector(li, maxtype));
else li = PROTECT(asCharacterFactor(li));
}
switch (maxtype) {
case INTSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
INTEGER(thisi)[k] = (j < len[i]) ? INTEGER(li)[j] : INTEGER(fill)[0];
}
break;
case LGLSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
LOGICAL(thisi)[k] = (j < len[i]) ? LOGICAL(li)[j] : LOGICAL(fill)[0];
}
break;
case REALSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
REAL(thisi)[k] = (j < len[i]) ? REAL(li)[j] : REAL(fill)[0];
}
break;
case STRSXP :
for (j=0; j<maxlen; j++) {
thisi = VECTOR_ELT(ans, j);
SET_STRING_ELT(thisi, k, (j < len[i]) ? STRING_ELT(li, j) : STRING_ELT(fill, 0));
}
break;
default :
error("Unsupported column type '%s'", type2char(maxtype));
}
if (coerce) {
coerce = FALSE;
UNPROTECT(1);
}
k++;
}
UNPROTECT(2);
return(ans);
}示例2: MatrixSubset
static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
{
SEXP attr, result, sr, sc, dim;
int nr, nc, nrs, ncs;
R_xlen_t i, j, ii, jj, ij, iijj;
nr = nrows(x);
nc = ncols(x);
/* Note that "s" is protected on entry. */
/* The following ensures that pointers remain protected. */
dim = getAttrib(x, R_DimSymbol);
sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call));
sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));
nrs = LENGTH(sr);
ncs = LENGTH(sc);
/* Check this does not overflow: currently only possible on 32-bit */
if ((double)nrs * (double)ncs > R_XLEN_T_MAX)
error(_("dimensions would exceed maximum size of array"));
PROTECT(sr);
PROTECT(sc);
result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) ncs);
PROTECT(result);
for (i = 0; i < nrs; i++) {
ii = INTEGER(sr)[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
errorcall(call, R_MSG_subs_o_b);
ii--;
}
for (j = 0; j < ncs; j++) {
jj = INTEGER(sc)[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
errorcall(call, R_MSG_subs_o_b);
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(result)[ij] = NA_INTEGER;
break;
case REALSXP:
REAL(result)[ij] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
else {
iijj = ii + jj * nr;
switch (TYPEOF(x)) {
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
INTEGER(result)[ij] = INTEGER(x)[iijj];
break;
case REALSXP:
REAL(result)[ij] = REAL(x)[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
}
}
if(nrs >= 0 && ncs >= 0) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
//.........这里部分代码省略.........
示例3: ExtractSubset
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx, SEXP call)
{
R_xlen_t i, ii, n, nx;
int mode, mi;
SEXP tmp, tmp2;
mode = TYPEOF(x);
mi = TYPEOF(indx);
n = XLENGTH(indx);
nx = xlength(x);
tmp = result;
if (x == R_NilValue)
return x;
for (i = 0; i < n; i++) {
switch(mi) {
case REALSXP:
if(!R_FINITE(REAL(indx)[i])) ii = NA_INTEGER;
else ii = (R_xlen_t) (REAL(indx)[i] - 1);
break;
default:
ii = INTEGER(indx)[i];
if (ii != NA_INTEGER) ii--;
}
switch (mode) {
/* NA_INTEGER < 0, so some of this is redundant */
case LGLSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_INTEGER;
break;
case INTSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
} else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
case EXPRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case LISTSXP:
/* cannot happen: pairlists are coerced to lists */
case LANGSXP:
#ifdef LONG_VECTOR_SUPPORT
if (ii > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
tmp2 = nthcdr(x, (int) ii);
SETCAR(tmp, CAR(tmp2));
SET_TAG(tmp, TAG(tmp2));
}
else
SETCAR(tmp, R_NilValue);
tmp = CDR(tmp);
break;
case RAWSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
errorcall(call, R_MSG_ob_nonsub, type2char(mode));
}
}
return result;
}示例4: clahe
SEXP clahe (SEXP x, SEXP _uiNrX, SEXP _uiNrY, SEXP _uiNrBins, SEXP _fCliplimit, SEXP _keepRange) {
int nx, ny, nz, i, j;
unsigned int uiNrX, uiNrY, uiNrBins;
float fCliplimit;
int keepRange;
double *src, *tgt;
SEXP res;
kz_pixel_t min = 0, max = uiNR_OF_GREY-1;
kz_pixel_t *img;
double maxPixelValue = uiNR_OF_GREY-1;
PROTECT( res = allocVector(REALSXP, XLENGTH(x)) );
DUPLICATE_ATTRIB(res, x);
nx = INTEGER(GET_DIM(x))[0];
ny = INTEGER(GET_DIM(x))[1];
nz = getNumberOfFrames(x, 0);
uiNrX = INTEGER(_uiNrX)[0];
uiNrY = INTEGER(_uiNrY)[0];
uiNrBins = INTEGER(_uiNrBins)[0];
fCliplimit = REAL(_fCliplimit)[0];
keepRange = LOGICAL(_keepRange)[0];
img = R_Calloc(nx*ny, kz_pixel_t);
// process channels separately
for(j = 0; j < nz; j++) {
src = &(REAL(x)[j*nx*ny]);
tgt = &(REAL(res)[j*nx*ny]);
if (keepRange) {
min = uiNR_OF_GREY-1;
max = 0;
}
// convert frame to CLAHE-compatible format
for (i = 0; i < nx*ny; i++) {
double el = src[i];
// clip
if (el < 0.0) el = 0;
else if (el > 1.0) el = 1.0;
// convert to int
kz_pixel_t nel = (kz_pixel_t) round(el * maxPixelValue);
if (keepRange) {
if (nel < min) min = nel;
if (nel > max) max = nel;
}
img[i] = nel;
}
int val = CLAHE (img, (unsigned int) nx, (unsigned int) ny,
min, max, uiNrX, uiNrY, uiNrBins, fCliplimit);
// translate internal error codes
switch (val) {
case -1:
error("# of regions x-direction too large");
break;
case -2:
error("# of regions y-direction too large");
break;
case -3:
error("x-resolution no multiple of 'nx'");
break;
case -4:
error("y-resolution no multiple of 'ny'");
break;
case -5:
error("maximum too large");
break;
case -6:
error("minimum equal or larger than maximum");
break;
case -7:
error("at least 4 contextual regions required");
break;
case -8:
error("not enough memory! (try reducing 'bins')");
break;
}
// convert back to [0:1] range
for (i = 0; i < nx*ny; i++) {
tgt[i] = (double) img[i] / maxPixelValue;
}
}
R_Free(img);
UNPROTECT(1);
return res;
}示例5: ocamlr_access_lgl_vecsxp
/** Returns an element of a logical vector.
*
* @param lglsxp An R logical vector, of sexptype LGLSXP.
* @param offset An integer, offset in the R logical vector.
* @return The boolean at this offset in the R logical vector.
*/
CAMLprim value ocamlr_access_lgl_vecsxp (value lglsxp, value offset) {
return(Val_bool(LOGICAL((int *) Vecsexp_val(lglsxp))[Int_val(offset)]));
}示例6: lookup
//.........这里部分代码省略.........
case START: case END:
for (i=0; i<xrows; i++) {
for (j=from[i]; j<=to[i]; j++) {
len1[j-1]++; len2[j-1]++; // alternatively, we could simply do with len2=len1 ?
}
}
break;
case EQUAL:
for (i=0; i<xrows; i++) {
len1[from[i]-1]++; len1[to[i]-1]++;
len2[from[i]-1]++; len2[to[i]-1]++;
}
break;
case ANY :
for (i=0; i<xrows; i++) {
k = from[i];
for (j=from[i]; j<=to[i]; j++) {
len1[j-1]++;
if (k==j) len2[j-1]++;
}
}
break;
case WITHIN :
for (i=0; i<xrows; i++) {
for (j=from[i]; j<=to[i]; j++) {
len1[j-1]++;
}
}
break;
}
break;
}
pass1 = clock() - start;
if (LOGICAL(verbose)[0])
Rprintf("First pass on calculating lengths in lookup ... done in %8.3f seconds\n", 1.0*(pass1)/CLOCKS_PER_SEC);
// second pass: allocate vectors
start = clock();
lookup = VECTOR_ELT(ux, uxcols-4);
type_lookup = VECTOR_ELT(ux, uxcols-3);
for (i=0; i<uxrows; i++) {
vv = allocVector(INTSXP, len1[i]);
SET_VECTOR_ELT(lookup, i, vv);
if (type != WITHIN) {
vv = allocVector(INTSXP, len2[i]);
SET_VECTOR_ELT(type_lookup, i, vv);
}
}
pass2 = clock() - start;
if (LOGICAL(verbose)[0])
Rprintf("Second pass on allocation in lookup ... done in %8.3f seconds\n", 1.0*(pass2)/CLOCKS_PER_SEC);
// generate lookup
start = clock();
idx = Calloc(uxrows, R_len_t); // resets bits, =0
switch (type) {
case ANY: case START: case END: case WITHIN:
for (i=0; i<xrows; i++) {
for (j=from[i]; j<=to[i]; j++) {
vv = VECTOR_ELT(lookup, j-1); // cache misses - memory efficiency? but 'lookups' are tiny - takes 0.036s on A.thaliana GFF for entire process)
INTEGER(vv)[idx[j-1]++] = i+1;
}
}
break;
case EQUAL:
for (i=0; i<xrows; i++) {
INTEGER(VECTOR_ELT(lookup, from[i]-1))[idx[from[i]-1]++] = i+1;
INTEGER(VECTOR_ELT(lookup, to[i]-1))[idx[to[i]-1]++] = i+1;示例7: RS_PostgreSQL_pqexec
SEXP
RS_PostgreSQL_pqexec(Con_Handle * conHandle, s_object * statement)
{
S_EVALUATOR RS_DBI_connection * con;
SEXP retval;
RS_DBI_resultSet *result;
PGconn *my_connection;
PGresult *my_result;
Sint res_id, is_select=0;
char *dyn_statement;
con = RS_DBI_getConnection(conHandle);
my_connection = (PGconn *) con->drvConnection;
dyn_statement = RS_DBI_copyString(CHR_EL(statement, 0));
/* Here is where we actually run the query */
/* Example: PGresult *PQexec(PGconn *conn, const char *command); */
my_result = PQexec(my_connection, dyn_statement);
if (my_result == NULL) {
char *errMsg;
const char *omsg;
size_t len;
omsg = PQerrorMessage(my_connection);
len = strlen(omsg);
free(dyn_statement);
errMsg = malloc(len + 80); /* 80 should be larger than the length of "could not ..."*/
snprintf(errMsg, len + 80, "could not run statement: %s", omsg);
RS_DBI_errorMessage(errMsg, RS_DBI_ERROR);
free(errMsg);
}
if (PQresultStatus(my_result) == PGRES_TUPLES_OK) {
is_select = (Sint) TRUE;
}
if (PQresultStatus(my_result) == PGRES_COMMAND_OK) {
is_select = (Sint) FALSE;
}
if (strcmp(PQresultErrorMessage(my_result), "") != 0) {
free(dyn_statement);
char *errResultMsg;
const char *omsg;
size_t len;
omsg = PQerrorMessage(my_connection);
len = strlen(omsg);
errResultMsg = malloc(len + 80); /* 80 should be larger than the length of "could not ..."*/
snprintf(errResultMsg, len + 80, "could not Retrieve the result : %s", omsg);
RS_DBI_errorMessage(errResultMsg, RS_DBI_ERROR);
free(errResultMsg);
/* Frees the storage associated with a PGresult.
* void PQclear(PGresult *res); */
PQclear(my_result);
}
free(dyn_statement);
PROTECT(retval = allocVector(LGLSXP, 1));
LOGICAL(retval)[0] = is_select;
UNPROTECT(1);
return retval;
}示例8: restrParts
SEXP restrParts(SEXP xR, SEXP ctR, SEXP minctR, SEXP maxctR, SEXP ctallowR, SEXP valuesR, SEXP nextvalR, SEXP diffvalsR, SEXP outR, SEXP nsolsR)
{
int * x; x=INTEGER(xR);
int * ct; ct=INTEGER(ctR);
int * minct; minct=INTEGER(minctR);
int * maxct; maxct=INTEGER(maxctR);
int * ctallow; ctallow=INTEGER(ctallowR);
int * values; values=INTEGER(valuesR);
int * nextval; nextval=INTEGER(nextvalR);
int * diffvals; diffvals=INTEGER(diffvalsR);
int * out; out=INTEGER(outR);
unsigned int nsols; nsols=(unsigned int)INTEGER(nsolsR)[0];
unsigned int nvals; nvals=(unsigned int)(LENGTH(valuesR)-1);
unsigned int nsol=0;
unsigned int niter=0;
unsigned int lev = 1;
bool nextLev=true;
do{
if (nextLev){
while(values[lev] > x[lev-1] && lev < nvals){
// fastforward
ct[lev]=maxct[lev]=minct[lev]=0;
ctallow[lev]=ctallow[lev-1];
x[lev]=x[lev-1];
++lev;
}
maxct[lev] = MIN(ctallow[lev-1], (int)(x[lev-1]/values[lev]));
minct[lev] = MAX0(CEILQ( x[lev-1L]-ctallow[lev-1L]*nextval[lev], diffvals[lev] ));
nextLev = false;
ct[lev] = maxct[lev] + 1;
}
if(ct[lev] <= minct[lev]) {
--lev;
goto nextiter;
} else --ct[lev];
++niter;
x[lev] = x[lev-1] - ct[lev] * values[lev];
ctallow[lev] = ctallow[lev-1] - ct[lev];
/*
Rprintf("\nx =\n");
for(unsigned int j=1; j<=nvals; ++j) Rprintf("%d ", x[j]);
Rprintf("\ncounts =\n");
for(unsigned int j=1; j<=nvals; ++j) Rprintf("%d ", ct[j]);
Rprintf("\nmin =\n");
for(unsigned int j=1; j<=nvals; ++j) Rprintf("%d ", minct[j]);
Rprintf("\nmax =\n");
for(unsigned int j=1; j<=nvals; ++j) Rprintf("%d ", maxct[j]);
Rprintf("\n rem =\n");
for(unsigned int j=1; j<=nvals; ++j) Rprintf("%d ", ctallow[j]);
Rprintf("\nlev=%d\n", lev);
*/
if (x[lev] == 0){
// found a partition
++nsol;
for(unsigned int j=1; j<=lev; ++j)
for(int i=0; i<ct[j]; ++i)
*(out++)=values[j];
// for(int j=0; j<ctallow[lev]; ++j) *(out++)=0; // for the case when outR initialized to NA_integer_;
out += ctallow[lev]; // for the case when outR initialized to 0;
if(nsol == nsols) break;
// Rprintf("nsol=%d\n", nsol);
}else if(lev < nvals){
++lev;
nextLev = true;
}
nextiter:
while(ct[lev] == minct[lev] && !nextLev && lev>0)
--lev; // fastrewind
R_CheckUserInterrupt();
}while(lev>0);
// Rprintf("niter=%d\n", niter);
if(nsol < nsols){
SEXP ans = PROTECT(allocMatrix(INTSXP, ctallow[0], nsol));
memcpy(INTEGER(ans), INTEGER(outR), sizeof(int) * ctallow[0] * nsol);
UNPROTECT(1);
return(ans);
}else {
SEXP ans=PROTECT(allocVector(LGLSXP, 1));
(LOGICAL(ans))[0] = 1;
UNPROTECT(1);
return(ans);
}
}示例9: castelo_prior
double castelo_prior(SEXP beta, SEXP target, SEXP parents, SEXP children,
SEXP debug) {
int i = 0, k = 0, t = 0, nnodes = 0, cur_arc = 0;
int nbeta = LENGTH(VECTOR_ELT(beta, 0));
int *temp = NULL, *debuglevel = LOGICAL(debug), *aid = INTEGER(VECTOR_ELT(beta, 2));
double prior = 0, result = 0;
double *bkwd = REAL(VECTOR_ELT(beta, 4)), *fwd = REAL(VECTOR_ELT(beta, 3));
short int *adjacent = NULL;
SEXP nodes, try;
/* get the node labels. */
nodes = getAttrib(beta, install("nodes"));
nnodes = LENGTH(nodes);
/* match the target node. */
PROTECT(try = match(nodes, target, 0));
t = INT(try);
UNPROTECT(1);
/* find out which nodes are parents and which nodes are children. */
adjacent = allocstatus(nnodes);
PROTECT(try = match(nodes, parents, 0));
temp = INTEGER(try);
for (i = 0; i < LENGTH(try); i++)
adjacent[temp[i] - 1] = PARENT;
UNPROTECT(1);
PROTECT(try = match(nodes, children, 0));
temp = INTEGER(try);
for (i = 0; i < LENGTH(try); i++)
adjacent[temp[i] - 1] = CHILD;
UNPROTECT(1);
/* prior probabilities table lookup. */
for (i = t + 1; i <= nnodes; i++) {
/* compute the arc id. */
cur_arc = UPTRI3(t, i, nnodes);
/* look up the prior probability. */
for (/*k,*/ prior = ((double)1/3); k < nbeta; k++) {
/* arcs are ordered, so we can stop early in the lookup. */
if (aid[k] > cur_arc)
break;
if (aid[k] == cur_arc) {
switch(adjacent[i - 1]) {
case PARENT:
prior = bkwd[k];
break;
case CHILD:
prior = fwd[k];
break;
default:
prior = 1 - bkwd[k] - fwd[k];
}/*SWITCH*/
break;
}/*THEN*/
}/*FOR*/
if (*debuglevel > 0) {
switch(adjacent[i - 1]) {
case PARENT:
Rprintf(" > found arc %s -> %s, prior pobability is %lf.\n",
NODE(i - 1), NODE(t - 1), prior);
break;
case CHILD:
Rprintf(" > found arc %s -> %s, prior probability is %lf.\n",
NODE(t - 1), NODE(i - 1), prior);
break;
default:
Rprintf(" > no arc between %s and %s, prior probability is %lf.\n",
NODE(t - 1), NODE(i - 1), prior);
}/*SWITCH*/
}/*THEN*/
/* move to log-scale and divide by the non-informative log(1/3), so that
* the contribution of each arc whose prior has not been not specified by
* the user is zero; overflow is likely otherwise. */
result += log(prior / ((double)1/3));
}/*FOR*/
return result;
}/*CASTELO_PRIOR*/
//.........这里部分代码省略.........
示例10: Rgraphviz_ScalarLogicalFromRbool
SEXP Rgraphviz_ScalarLogicalFromRbool(Rboolean v)
{
SEXP ans = allocVector(LGLSXP, 1);
LOGICAL(ans)[0] = v;
return(ans);
}示例11: OPAL_OBJ_STATIC_INIT
TWOLOC_NULL_3BUFF }
}};
/*
* MPI_OP_LAND
*/
ompi_predefined_op_t ompi_mpi_op_land = {{
OPAL_OBJ_STATIC_INIT(opal_object_t),
"MPI_LAND",
FLAGS,
{ C_INTEGER(land),
FORTRAN_INTEGER_NULL,
FLOATING_POINT_NULL,
LOGICAL(land),
COMPLEX_NULL,
BYTE_NULL,
TWOLOC_NULL },
-1,
{ C_INTEGER_3BUFF(land),
FORTRAN_INTEGER_NULL_3BUFF,
FLOATING_POINT_NULL_3BUFF,
LOGICAL_3BUFF(land),
COMPLEX_NULL_3BUFF,
BYTE_NULL_3BUFF,
TWOLOC_NULL_3BUFF }
}};
/*示例12: impliedLinearity_f
SEXP impliedLinearity_f(SEXP m, SEXP h)
{
GetRNGstate();
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
if (! isReal(m))
error("'m' must be double");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
if (nrow <= 1)
error("no use if only one row");
if (ncol <= 3)
error("no use if only one col");
for (int i = 0; i < nrow * ncol; i++)
if (! R_finite(REAL(m)[i]))
error("'m' not finite-valued");
for (int i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (int i = nrow; i < 2 * nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column two of 'm' not zero-or-one valued");
}
ddf_set_global_constants();
myfloat value;
ddf_init(value);
ddf_MatrixPtr mf = ddf_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = ddf_Inequality;
else
mf->representation = ddf_Generator;
mf->numbtype = ddf_Real;
/* linearity */
for (int i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (foo == 1.0)
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (int j = 1, k = nrow; j < ncol; j++)
for (int i = 0; i < nrow; i++, k++) {
ddf_set_d(value, REAL(m)[k]);
ddf_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
ddf_ErrorType err = ddf_NoError;
ddf_rowset out = ddf_ImplicitLinearityRows(mf, &err);
if (err != ddf_NoError) {
rrf_WriteErrorMessages(err);
ddf_FreeMatrix(mf);
set_free(out);
ddf_clear(value);
ddf_free_global_constants();
error("failed");
}
SEXP foo;
PROTECT(foo = rrf_set_fwrite(out));
ddf_FreeMatrix(mf);
set_free(out);
ddf_clear(value);
ddf_free_global_constants();
PutRNGstate();
UNPROTECT(1);
return foo;
}示例13: do_vapply
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; // -Wall
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1));
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
val = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
bool okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
for (int j = 0; j < commonLen; j++) {
//.........这里部分代码省略.........
示例14: df_split
//.........这里部分代码省略.........
if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
} else {
l = CHAR(STRING_ELT(s, k + skip));
le = l + strlen(l); /* probably lame, but using strings is way inefficient anyway ;) */
}
if (nmsep_flag) {
c = memchr(l, nsep, le - l);
if (c) {
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, Rf_mkCharLen(l, c - l));
l = c + 1;
} else
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, R_BlankString);
}
i = nmsep_flag;
j = nmsep_flag;
while (l < le) {
if (!(c = memchr(l, sep, le - l)))
c = le;
if (i >= use_ncol) {
if (resilient) break;
Rf_error("line %lu: too many input columns (expected %u)", k, use_ncol);
}
switch(TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
len = (int) (c - l);
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
LOGICAL(VECTOR_ELT(sOutput, j))[k] = (tr || fa) ? tr : NA_INTEGER;
j++;
break;
case INTSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
INTEGER(VECTOR_ELT(sOutput, j))[k] = Strtoi(num_buf, 10);
j++;
break;
case REALSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
REAL(VECTOR_ELT(sOutput, j))[k] = R_atof(num_buf);
j++;
break;
case CPLXSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;示例15: export_plink
SEXP export_plink(SEXP Ids, SEXP Snpdata, SEXP Nsnps, SEXP NidsTotal,
SEXP Coding, SEXP From, SEXP To, SEXP Male, SEXP Traits,
SEXP Pedfilename, SEXP Plink, SEXP Append)
{
int from = INTEGER(From)[0];
int to = INTEGER(To)[0];
if(from <1 || from > to) {error("The function SEXP export_plink(SEXP Ids, SEXP Snpdata, SEXP Nsnps, SEXP NidsTotal,... reports: the variable FROM should be >=1 and less then the variable TO.");} //Maksim
std::vector<unsigned short int> sex;
sex.clear();
unsigned short int sx;
for(int i=(from - 1); i<to; i++) {
sx = INTEGER(Male)[i];
if (sx==0) sx=2;
//Rprintf("%d %d\n",i,sx);
sex.push_back(sx);
}
std::vector<std::string> ids;
for(unsigned int i=0; i<((unsigned int) length(Ids)); i++)
ids.push_back(CHAR(STRING_ELT(Ids,i)));
std::vector<std::string> coding;
for(unsigned int i=0; i<((unsigned int) length(Coding)); i++)
coding.push_back(CHAR(STRING_ELT(Coding,i)));
//Rprintf("0\n");
unsigned int nsnps = INTEGER(Nsnps)[0];
int nids = to - from + 1;
int nidsTotal = INTEGER(NidsTotal)[0];
int ntraits = INTEGER(Traits)[0];
bool append = LOGICAL(Append)[0];
bool plink = LOGICAL(Plink)[0];
std::string filename = CHAR(STRING_ELT(Pedfilename,0));
std::ofstream fileWoA;
int ieq1 = 1;
char * snpdata = (char *) RAW(Snpdata);
// int gtint[nidsTotal];
int *gtint = new (std::nothrow) int[nidsTotal];
//Rprintf("nsnps=%d\n",nsnps);
//Rprintf("nids=%d\n",nids);
//Rprintf("to=%d\n", to);
//Rprintf("from=%d\n", from);
//char gtMatrix[nids][nsnps];
char **gtMatrix = new (std::nothrow) char*[nids];
for (int i=0; i<nids; i++) {
gtMatrix[i] = new (std::nothrow) char[nsnps];
}
//Rprintf("1\n");
std::string* Genotype;
std::string sep="/";
int nbytes;
//Rprintf("nsnps=%d\n",nsnps);
//Rprintf("nids=%d\n",nids);
if ((nids % 4) == 0) {
nbytes = nidsTotal/4;
}
else {
nbytes = ceil(1.*nidsTotal/4.);
}
if (plink) sep=" ";
if (append)
fileWoA.open(filename.c_str(),std::fstream::app);
else
fileWoA.open(filename.c_str(),std::fstream::trunc);
//Rprintf("A\n");
for (unsigned int csnp=0; csnp<nsnps; csnp++) {
// collect SNP data
get_snps_many(snpdata+nbytes*csnp, &nidsTotal, &ieq1, gtint);
for (int iii=from-1; iii<to; iii++) {
//Rprintf(" %d",gtint[iii]);
gtMatrix[iii-from+1][csnp] = gtint[iii];
}
//Rprintf("\n");
}
//Rprintf("B\n");
for (int i=0; i<nids; i++) {
fileWoA << i+from << " " << ids[i] << " 0 0 " << sex[i];
for (int j=0; j<ntraits; j++) fileWoA << " " << 0;
// unwrap genotypes
for (unsigned int csnp=0; csnp<nsnps; csnp++) {
Genotype = getGenotype(coding[csnp], sep);
// figure out the coding
fileWoA << " " << Genotype[gtMatrix[i][csnp]];
delete [] Genotype;
}
// end unwrap
//.........这里部分代码省略.........