当前位置: 首页>>代码示例>>C++>>正文


C++ LOGICAL函数代码示例

本文整理汇总了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);
}
开发者ID:cran,项目名称:data.table,代码行数:92,代码来源:transpose.c

示例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;
//.........这里部分代码省略.........
开发者ID:Maxsl,项目名称:r-source,代码行数:101,代码来源:subset.c

示例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;
}
开发者ID:Maxsl,项目名称:r-source,代码行数:93,代码来源:subset.c

示例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;
}
开发者ID:aoles,项目名称:EBImage,代码行数:99,代码来源:clahe.c

示例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)]));
}
开发者ID:agarwal,项目名称:OCaml-R,代码行数:9,代码来源:read_internal_stub.c

示例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;
开发者ID:A6111E,项目名称:data.table,代码行数:67,代码来源:ijoin.c

示例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;
}
开发者ID:jcdny,项目名称:RPostgreSQL,代码行数:66,代码来源:RS-pgsql-pqexec.c

示例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);
		}
	}
开发者ID:gitlongor,项目名称:partitions.aux,代码行数:92,代码来源:restrParts.cpp

示例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*/

//.........这里部分代码省略.........
开发者ID:spallavolu,项目名称:bnlearn,代码行数:101,代码来源:graph.priors.c

示例10: Rgraphviz_ScalarLogicalFromRbool

SEXP Rgraphviz_ScalarLogicalFromRbool(Rboolean v)
{
    SEXP  ans = allocVector(LGLSXP, 1);
    LOGICAL(ans)[0] = v;
    return(ans);
}
开发者ID:cran,项目名称:Rgraphviz,代码行数:6,代码来源:Rgraphviz.c

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


/*
开发者ID:hpc,项目名称:cce-mpi-openmpi-1.4.3,代码行数:31,代码来源:op.c

示例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;
}
开发者ID:cjgeyer,项目名称:rcdd,代码行数:98,代码来源:linearity_f.c

示例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++) {
//.........这里部分代码省略.........
开发者ID:csilles,项目名称:cxxr,代码行数:101,代码来源:apply.cpp

示例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;
开发者ID:mrkdsmith,项目名称:iotools,代码行数:67,代码来源:split_df.c

示例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
//.........这里部分代码省略.........
开发者ID:mmoisse,项目名称:GenABEL,代码行数:101,代码来源:export_plink.cpp


注:本文中的LOGICAL函数示例由纯净天空整理自Github/MSDocs等开源代码及文档管理平台,相关代码片段筛选自各路编程大神贡献的开源项目,源码版权归原作者所有,传播和使用请参考对应项目的License;未经允许,请勿转载。