Example #1
0
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);
}
Example #2
0
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;
	INTEGER(attr)[1] = ncs;
	setAttrib(result, R_DimSymbol, attr);
	UNPROTECT(1);
    }

    /* The matrix elements have been transferred.  Now we need to */
    /* transfer the attributes.	 Most importantly, we need to subset */
    /* the dimnames of the returned value. */

    if (nrs >= 0 && ncs >= 0) {
	SEXP dimnames, dimnamesnames, newdimnames;
	dimnames = getAttrib(x, R_DimNamesSymbol);
	PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
	if (!isNull(dimnames)) {
	    PROTECT(newdimnames = allocVector(VECSXP, 2));
	    if (TYPEOF(dimnames) == VECSXP) {
	      SET_VECTOR_ELT(newdimnames, 0,
		    ExtractSubset(VECTOR_ELT(dimnames, 0),
				  allocVector(STRSXP, nrs), sr, call));
	      SET_VECTOR_ELT(newdimnames, 1,
		    ExtractSubset(VECTOR_ELT(dimnames, 1),
				  allocVector(STRSXP, ncs), sc, call));
	    }
	    else {
	      SET_VECTOR_ELT(newdimnames, 0,
		    ExtractSubset(CAR(dimnames),
				  allocVector(STRSXP, nrs), sr, call));
	      SET_VECTOR_ELT(newdimnames, 1,
		    ExtractSubset(CADR(dimnames),
				  allocVector(STRSXP, ncs), sc, call));
	    }
	    setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
	    setAttrib(result, R_DimNamesSymbol, newdimnames);
	    UNPROTECT(1); /* newdimnames */
	}
	UNPROTECT(1); /* dimnamesnames */
    }
    /*  Probably should not do this:
    copyMostAttrib(x, result); */
    if (drop)
	DropDims(result);
    UNPROTECT(3);
    return result;
}
Example #3
0
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;
}
Example #4
0
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;
}
Example #5
0
/**  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)]));
}
Example #6
0
// TODO: implement 'lookup' for 'gaps' and 'overlaps' arguments
SEXP lookup(SEXP ux, SEXP xlen, SEXP indices, SEXP gaps, SEXP overlaps, SEXP multArg, SEXP typeArg, SEXP verbose) {
    
    SEXP vv, tt, lookup, type_lookup;
    R_len_t i,j,k,*idx,*len1,*len2,xrows=INTEGER(xlen)[0],uxrows=LENGTH(VECTOR_ELT(ux, 0)),uxcols=LENGTH(ux);
    int *from = (int *)INTEGER(VECTOR_ELT(indices, 0));
    int *to   = (int *)INTEGER(VECTOR_ELT(indices, 1));
    clock_t pass1, pass2, pass3, start;
    enum {ALL, FIRST, LAST} mult = ALL;
    enum {ANY, WITHIN, START, END, EQUAL} type = ANY;
    
    if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "all"))  mult = ALL;
    else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "first")) mult = FIRST;
    else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "last")) mult = LAST;
    else error("Internal error: invalid value for 'mult'; this should have been caught before. Please report to datatable-help");

    if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "any"))  type = ANY;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "within")) type = WITHIN;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "start")) type = START;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "end")) type = END;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "equal")) type = EQUAL;
    else error("Internal error: invalid value for 'type'; this should have been caught before. Please report to datatable-help");
    
    // For reference: uxcols-1 = type_count, uxcols-2 = count, uxcols-3 = type_lookup, uxcols-4 = lookup
    // first pass: calculate lengths first
    start = clock();
    len1 = (int *)INTEGER(VECTOR_ELT(ux, uxcols-2));
    len2 = (int *)INTEGER(VECTOR_ELT(ux, uxcols-1));
    switch (mult) {
        case FIRST: 
        for (i=0; i<xrows; i++) {
            for (j=from[i]; j<=to[i]; j++) {
                len1[j-1]++;
            }
        }
        if (type != WITHIN) {
            for (i=0; i<uxrows-1; i++)                      // TODO: this allocation can be avoided if we take care of FIRST/LAST accordingly in 'overlaps'
                if (len1[i]) len2[i] = 1;
        }
        break;
        
        case LAST :
        switch (type) {
            case ANY:
            for (i=0; i<xrows; i++) {
                for (j=from[i]; j<=to[i]; j++) {
                    len1[j-1]++;
                    if (from[i]==j && !len2[j-1]) len2[j-1]++;
                }
            }
            break;
            case START: case END: case EQUAL: case WITHIN:
            for (i=0; i<xrows; i++) {
                for (j=from[i]; j<=to[i]; j++) {
                    len1[j-1]++;
                }
            }
            if (type != WITHIN) {
                for (i=0; i<uxrows-1; i++)              // TODO: this allocation can be avoided if we take care of FIRST/LAST accordingly in 'overlaps'
                    if (len1[i]) len2[i] = 1;                    
            }
            break;
        }
        break;
        
        case ALL : 
            switch (type) {
                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;
        }
        break;
    }
    Free(idx);
    // generate type_lookup
    if (type != WITHIN) {
        switch (mult) {
            case FIRST :
            for (i=0; i<uxrows; i++) {
                if (!len1[i]) continue;
                vv = VECTOR_ELT(lookup, i);
                tt = VECTOR_ELT(type_lookup, i);
                INTEGER(tt)[0] = INTEGER(vv)[0];
            }
            break;

            case LAST :
            for (i=0; i<uxrows; i++) {
                if (!len1[i]) continue;
                vv = VECTOR_ELT(lookup, i);
                tt = VECTOR_ELT(type_lookup, i);
                INTEGER(tt)[0] = INTEGER(vv)[len1[i]-1];
            }
        
            case ALL :
            switch (type) {
                case START: case END: case EQUAL:
                for (i=0; i<uxrows; i++)
                    SET_VECTOR_ELT(type_lookup, i, VECTOR_ELT(lookup, i));
                break;
            
                case ANY :
                for (i=0; i<uxrows-1; i++) {
                    vv = VECTOR_ELT(lookup, i);
                    tt = VECTOR_ELT(type_lookup, i);
                    k=0;
                    for (j=len1[i]-len2[i]; j<len1[i]; j++)
                        INTEGER(tt)[k++] = INTEGER(vv)[j];
                }
                break;
            
                case WITHIN :
                // for (i=0; i<uxrows-1; i++) {
                //     vv = VECTOR_ELT(lookup, i);
                //     tt = VECTOR_ELT(type_lookup, i);
                //     for (j=0; j<len2[i]; j++)
                //         INTEGER(tt)[j] = INTEGER(vv)[j];
                // }
                break;
            }
        break;
        }
    }
    pass3 = clock() - start;
    if (LOGICAL(verbose)[0])
        Rprintf("Final step in generating lookup ... done in %8.3f seconds\n", 1.0*(pass3)/CLOCKS_PER_SEC);    
    return(R_NilValue);
}
Example #7
0
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;
}
Example #8
0
	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);
		}
	}
Example #9
0
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*/

/* complete a prior as per Castelo & Siebes. */
SEXP castelo_completion(SEXP prior, SEXP nodes)  {

    int i = 0, k = 0, cur = 0, narcs1 = 0, narcs2 = 0, nnodes = LENGTH(nodes);
    int *m1 = NULL, *m2 = NULL, *und = NULL, *aid = NULL, *poset = NULL, *id = NULL;
    double *d1 = NULL, *d2 = NULL, *p = NULL;
    SEXP df, arc_id, undirected, a1, a2, match1, match2, prob;
    SEXP result, colnames, from, to, nid, dir1, dir2;

    /* compute numeric IDs for the arcs. */
    a1 = VECTOR_ELT(prior, 0);
    a2 = VECTOR_ELT(prior, 1);
    narcs1 = LENGTH(a1);
    PROTECT(match1 = match(nodes, a1, 0));
    PROTECT(match2 = match(nodes, a2, 0));
    m1 = INTEGER(match1);
    m2 = INTEGER(match2);
    PROTECT(arc_id = allocVector(INTSXP, narcs1));
    aid = INTEGER(arc_id);

    c_arc_hash(&narcs1, &nnodes, m1, m2, aid, NULL, TRUE);

    /* duplicates correspond to undirected arcs. */
    PROTECT(undirected = dupe(arc_id));
    und = INTEGER(undirected);

    /* extract the components from the prior. */
    prob = VECTOR_ELT(prior, 2);
    p = REAL(prob);

    /* count output arcs. */
    for (i = 0; i < narcs1; i++)
        narcs2 += 2 - und[i];
    narcs2 /= 2;

    /* allocate the columns of the return value. */
    PROTECT(from = allocVector(STRSXP, narcs2));
    PROTECT(to = allocVector(STRSXP, narcs2));
    PROTECT(nid = allocVector(INTSXP, narcs2));
    id = INTEGER(nid);
    PROTECT(dir1 = allocVector(REALSXP, narcs2));
    d1 = REAL(dir1);
    PROTECT(dir2 = allocVector(REALSXP, narcs2));
    d2 = REAL(dir2);

    /* sort the strength coefficients. */
    poset = alloc1dcont(narcs1);
    for (k = 0; k < narcs1; k++)
        poset[k] = k;
    R_qsort_int_I(aid, poset, 1, narcs1);

    for (i = 0, k = 0; i < narcs1; i++) {

        cur = poset[i];

#define ASSIGN(A1, A2, D1, D2) \
  SET_STRING_ELT(from,  k, STRING_ELT(A1, cur)); \
  SET_STRING_ELT(to,  k, STRING_ELT(A2, cur)); \
  id[k] = aid[i]; \
  D1[k] = p[cur]; \
  if ((und[cur] == TRUE) && (i < narcs1 - 1)) \
    D2[k] = p[poset[++i]]; \
  else \
    D2[k] = (1 - D1[k])/2;

        /* copy the node labels. */
        if (m1[cur] < m2[cur]) {

            ASSIGN(a1, a2, d1, d2);

        }/*THEN*/
        else {

            ASSIGN(a2, a1, d2, d1);

        }/*ELSE*/

        if (d1[k] + d2[k] > 1) {

            UNPROTECT(9);

            error("the probabilities for arc %s -> %s sum to %lf.",
                  CHAR(STRING_ELT(from, k)), CHAR(STRING_ELT(to, k)), d1[k] + d2[k]);

        }/*THEN*/

        /* move to the next arc. */
        k++;

    }/*FOR*/

    /* set up the return value. */
    PROTECT(result = allocVector(VECSXP, 5));
    SET_VECTOR_ELT(result, 0, from);
    SET_VECTOR_ELT(result, 1, to);
    SET_VECTOR_ELT(result, 2, nid);
    SET_VECTOR_ELT(result, 3, dir1);
    SET_VECTOR_ELT(result, 4, dir2);
    PROTECT(colnames = allocVector(STRSXP, 5));
    SET_STRING_ELT(colnames, 0, mkChar("from"));
    SET_STRING_ELT(colnames, 1, mkChar("to"));
    SET_STRING_ELT(colnames, 2, mkChar("aid"));
    SET_STRING_ELT(colnames, 3, mkChar("fwd"));
    SET_STRING_ELT(colnames, 4, mkChar("bkwd"));
    setAttrib(result, R_NamesSymbol, colnames);
    PROTECT(df = minimal_data_frame(result));

    UNPROTECT(12);

    return df;

}/*CASTELO_COMPLETION*/
Example #10
0
SEXP Rgraphviz_ScalarLogicalFromRbool(Rboolean v)
{
    SEXP  ans = allocVector(LGLSXP, 1);
    LOGICAL(ans)[0] = v;
    return(ans);
}
Example #11
0
      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 }
    }};


/*
Example #12
0
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;
}
Example #13
0
/* 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++) {
	    	switch (commonType) {
	    	case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
	    	case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
	    	case INTSXP:  INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
	    	case LGLSXP:  LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
	    	case RAWSXP:  RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
	    	case STRSXP:  SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
	    	case VECSXP:  SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
	    	default:
	    	    error(_("type '%s' is not supported"), type2char(commonType));
	    	}
	    }
	    UNPROTECT(1);
	}
	UNPROTECT(3);
    }

    if (commonLen != 1) {
	SEXP dim;
	rnk_v = array_value ? LENGTH(dim_v) : 1;
	PROTECT(dim = allocVector(INTSXP, rnk_v+1));
	if(array_value)
	    for(int j = 0; j < rnk_v; j++)
		INTEGER(dim)[j] = INTEGER(dim_v)[j];
	else
	    INTEGER(dim)[0] = commonLen;
	INTEGER(dim)[rnk_v] = int( n);  // checked above
	setAttrib(ans, R_DimSymbol, dim);
	UNPROTECT(1);
    }

    if (useNames) {
	if (commonLen == 1) {
	    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
	} else {
	    if (!isNull(names) || !isNull(rowNames)) {
		SEXP dimnames;
		PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
		if(array_value && !isNull(rowNames)) {
		    if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
			// should never happen ..
			error(_("dimnames(<value>) is neither NULL nor list of length %d"),
			      rnk_v);
		    for(int j = 0; j < rnk_v; j++)
			SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
		} else
		    SET_VECTOR_ELT(dimnames, 0, rowNames);

		SET_VECTOR_ELT(dimnames, rnk_v, names);
		setAttrib(ans, R_DimNamesSymbol, dimnames);
		UNPROTECT(1);
	    }
	}
    }
    UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
    return ans;
}
Example #14
0
SEXP df_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
            SEXP sWhat, SEXP sColNames, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
    char sep;
    int nsep, use_ncol, resilient, ncol;
    long i, j, k, m, len, nmsep_flag, skip, quoteLen;
    unsigned long nrow;
    char num_buf[48];
    const char *c, *c2, *sraw = 0, *send = 0, *quoteChars;
    long nlines = asLong(sNlines, -1);

    SEXP sOutput, tmp, sOutputNames, st, clv;

    /* Parse inputs */
    sep = CHAR(STRING_ELT(sSep, 0))[0];
    nsep = (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) ? ((int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0))) : -1;

    nmsep_flag = (nsep > 0);
    use_ncol = asInteger(sNcol);
    resilient = asInteger(sResilient);
    ncol = use_ncol; /* NOTE: "character" is prepended by the R code if nmsep is TRUE,
                        so ncol *does* include the key column */
    skip = asLong(sSkip, 0);

    /* parse quote information */
    quoteChars = CHAR(STRING_ELT(sQuote, 0));
    quoteLen = strlen(quoteChars);

    /* count non-NA columns */
    for (i = 0; i < use_ncol; i++)
	if (TYPEOF(VECTOR_ELT(sWhat,i)) == NILSXP) ncol--;

    /* check input */
    if (TYPEOF(s) == RAWSXP) {
	nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
	sraw = (const char*) RAW(s);
	send = sraw + XLENGTH(s);
	if (nrow >= skip) {
	    unsigned long slen = XLENGTH(s);
	    nrow = nrow - skip;
	    i = 0;
	    while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
	} else {
	    nrow = 0;
	    sraw = send;
	}
    } else if (TYPEOF(s) == STRSXP) {
	nrow = XLENGTH(s);
	if (nrow >= skip) {
	    nrow -= skip;
	} else {
	    skip = nrow;
	    nrow = 0;
	}
    } else
	Rf_error("invalid input to split - must be a raw or character vector");

    if (nlines >= 0 && nrow > nlines) nrow = nlines;

    /* allocate result */
    PROTECT(sOutput = allocVector(VECSXP, ncol));

    /* set names */
    setAttrib(sOutput, R_NamesSymbol, sOutputNames = allocVector(STRSXP, ncol));

    if (nrow > INT_MAX)
	Rf_warning("R currently doesn't support large data frames, but we have %lu rows, returning a named list instead", nrow);
    else {
	/* set automatic row names */
	PROTECT(tmp = allocVector(INTSXP, 2));
	INTEGER(tmp)[0] = NA_INTEGER;
	INTEGER(tmp)[1] = -nrow;
	setAttrib(sOutput, R_RowNamesSymbol, tmp);
	UNPROTECT(1);

	/* set class */
	classgets(sOutput, mkString("data.frame"));
    }

    /* Create SEXP for each element of the output */
    j = 0;
    for (i = 0; i < use_ncol; i++) {
      if (TYPEOF(VECTOR_ELT(sWhat,i)) != NILSXP) /* copy col.name */
        SET_STRING_ELT(sOutputNames, j, STRING_ELT(sColNames, i));

      switch (TYPEOF(VECTOR_ELT(sWhat,i))) {
      case LGLSXP:
      case INTSXP:
      case REALSXP:
      case CPLXSXP:
      case STRSXP:
      case RAWSXP:
        SET_VECTOR_ELT(sOutput, j++, allocVector(TYPEOF(VECTOR_ELT(sWhat,i)), nrow));
        break;

      case VECSXP:
        SET_VECTOR_ELT(sOutput, j++, st = allocVector(REALSXP, nrow));
        clv = PROTECT(allocVector(STRSXP, 2));
        SET_STRING_ELT(clv, 0, mkChar("POSIXct"));
        SET_STRING_ELT(clv, 1, mkChar("POSIXt"));
        setAttrib(st, R_ClassSymbol, clv);
        /* this is somewhat a security precaution such that users
           don't get surprised -- if there is no TZ R will
           render it in local time - which is correct but
           may confuse people that didn't use GMT to start with */
        setAttrib(st, install("tzone"), mkString("GMT"));
        UNPROTECT(1);
        break;

      case NILSXP:
        break;

      default:
        Rf_error("Unsupported input to what %u.", TYPEOF(VECTOR_ELT(sWhat,i)));
        break;
      }
    }

    /* Cycle through the rows and extract the data */
    for (k = 0; k < nrow; k++) {
      const char *l = 0, *le;
      if (TYPEOF(s) == RAWSXP) {
          l = sraw;
          le = memchr(l, '\n', send - l);
          if (!le) le = send;
          sraw = le + 1;
          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;
          COMPLEX(VECTOR_ELT(sOutput, j))[k] = strtoc(num_buf, TRUE);
          j++;
          break;

        case STRSXP:
          c2 = c;
          if (quoteLen) {
            for (m = 0; m < quoteLen; m++) {
              if (*l == quoteChars[m]) {
                l++;
                if (!(c2 = memchr(l, quoteChars[m], le - l))) {
                  Rf_error("End of line within quoted string.");
                } else {
                  if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
                    c = le;
                }
              }
            }
          }
          SET_STRING_ELT(VECTOR_ELT(sOutput, j), k, Rf_mkCharLen(l, c2 - l));
          j++;
          break;

        case RAWSXP:
          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;
          RAW(VECTOR_ELT(sOutput, j))[k] = strtoraw(num_buf);
          j++;
          break;

        case VECSXP:
          REAL(VECTOR_ELT(sOutput, j))[k] = parse_ts(l, c);
          j++;
        }

        l = c + 1;
        i++;
      }

      /* fill-up unused columns */
      while (i < use_ncol) {
          switch (TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
          case LGLSXP:
            LOGICAL(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
            break;

          case INTSXP:
            INTEGER(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
            break;

          case REALSXP:
          case VECSXP:
            REAL(VECTOR_ELT(sOutput, j++))[k] = NA_REAL;
            break;

          case CPLXSXP:
            COMPLEX(VECTOR_ELT(sOutput, j))[k].r = NA_REAL;
            COMPLEX(VECTOR_ELT(sOutput, j++))[k].i = NA_REAL;
            break;

          case STRSXP:
            SET_STRING_ELT(VECTOR_ELT(sOutput, j++), k, R_NaString);
            break;

          case RAWSXP:
            RAW(VECTOR_ELT(sOutput, j))[k] = (Rbyte) 0;
            break;
          }
          i++;
      }
    }

    UNPROTECT(1); /* sOutput */
    return(sOutput);
}
Example #15
0
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
        fileWoA << "\n";
    }
    //Rprintf("C\n");
    fileWoA.close();

    //Rprintf("oooo!" );
    //for (int i=0; i<10; i++) Rprintf("%d ",sex[i]);
    //Rprintf("oooo!\n" );

    sex.clear();

    for(int i=0; i<nids; i++) {
        delete [] gtMatrix[i];
    }
    delete [] gtMatrix;

    delete [] gtint;

    return R_NilValue;
}
Example #16
0
SEXP between(SEXP x, SEXP lower, SEXP upper, SEXP bounds) {

  R_len_t nx = length(x), nl = length(lower), nu = length(upper);
  if (!nx || !nl || !nu)
    return (allocVector(LGLSXP, 0));
  const int longest = MAX(MAX(nx, nl), nu);
  if ((nl!=1 && nl!=longest) ||
      (nu!=1 && nu!=longest) ||
      (nx!=1 && nx!=longest)) {
    error("Incompatible vector lengths: length(x)==%d length(lower)==%d length(upper)==%d. Each should be either length 1 or the length of the longest.", nx, nl, nu);
  }
  if (!isLogical(bounds) || LOGICAL(bounds)[0] == NA_LOGICAL)
    error("incbounds must be logical TRUE/FALSE.");  // # nocov

  int nprotect = 0;
  bool integer=true;
  if (isReal(x) || isReal(lower) || isReal(upper)) {
    if (inherits(x,"integer64") || inherits(lower,"integer64") || inherits(upper,"integer64")) {
      error("Internal error: one or more of x, lower and upper is type integer64 but this should have been caught by between() at R level.");  // # nocov
    }
    integer=false;
    lower = PROTECT(coerceVector(lower, REALSXP));  // these coerces will convert NA appropriately
    upper = PROTECT(coerceVector(upper, REALSXP));
    x     = PROTECT(coerceVector(x, REALSXP));
    nprotect += 3;
  }
  // TODO: sweep through lower and upper ensuring lower<=upper (inc bounds) and no lower>upper or lower==INT_MAX

  const bool recycleX =   nx==1;
  const bool recycleLow = nl==1;
  const bool recycleUpp = nu==1;
  const bool open = !LOGICAL(bounds)[0];
  SEXP ans = PROTECT(allocVector(LGLSXP, longest)); nprotect++;
  int *restrict ansp = LOGICAL(ans);
  if (integer) {
    const int *lp = INTEGER(lower);
    const int *up = INTEGER(upper);
    const int *xp = INTEGER(x);
    if (!recycleX && recycleLow && recycleUpp) {
      const int l = lp[0] + open;  // +open so we can always use >= and <=.  NA_INTEGER+1 == -INT_MAX == INT_MIN+1 (so NA limit handled by this too)
      const int u = up[0]==NA_INTEGER ? INT_MAX : up[0] - open;
      #pragma omp parallel for num_threads(getDTthreads())
      for (int i=0; i<longest; i++) {
        int elem = xp[i];
        ansp[i] = elem==NA_INTEGER ? NA_LOGICAL : (l<=elem && elem<=u);
      }
    }
    else {
      const int xMask = recycleX ? 0 : INT_MAX;
      const int lowMask = recycleLow ? 0 : INT_MAX;
      const int uppMask = recycleUpp ? 0 : INT_MAX;
      #pragma omp parallel for num_threads(getDTthreads())
      for (int i=0; i<longest; i++) {
        int elem = xp[i & xMask];
        int l = lp[i & lowMask] +open;
        int u = up[i & uppMask];
        u = (u==NA_INTEGER) ? INT_MAX : u-open;
        ansp[i] = elem==NA_INTEGER ? NA_LOGICAL : (l<=elem && elem<=u);
      }
    }
  } else {
    // type real
    const double *lp = REAL(lower);
    const double *up = REAL(upper);
    const double *xp = REAL(x);
    if (!recycleX && recycleLow && recycleUpp) {
      const double l = isnan(lp[0]) ? -INFINITY : lp[0];
      const double u = isnan(up[0]) ?  INFINITY : up[0];
      if (open) {
        #pragma omp parallel for num_threads(getDTthreads())
        for (int i=0; i<longest; i++) {
          double elem = xp[i];
          ansp[i] = isnan(elem) ? NA_LOGICAL : (l<elem && elem<u);
        }
      } else {
        #pragma omp parallel for num_threads(getDTthreads())
        for (int i=0; i<longest; i++) {
          double elem = xp[i];
          ansp[i] = isnan(elem) ? NA_LOGICAL : (l<=elem && elem<=u);
        }
      }
    }
    else {
      const int xMask = recycleX ? 0 : INT_MAX;
      const int lowMask = recycleLow ? 0 : INT_MAX;
      const int uppMask = recycleUpp ? 0 : INT_MAX;
      #pragma omp parallel for num_threads(getDTthreads())
      for (int i=0; i<longest; i++) {
        double elem = xp[i & xMask];
        double l = lp[i & lowMask];
        double u = up[i & uppMask];
        if (isnan(l)) l=-INFINITY;
        if (isnan(u)) u= INFINITY;
        ansp[i] = isnan(elem) ? NA_LOGICAL : (open ? l<elem && elem<u : l<=elem && elem<=u);
      }
    }
  }
  UNPROTECT(nprotect);
  return(ans);
}
Example #17
0
SEXP overlaps(SEXP ux, SEXP imatches, SEXP multArg, SEXP typeArg, SEXP nomatchArg, SEXP verbose) {

    R_len_t i,j,k,m,uxcols=LENGTH(ux),rows=length(VECTOR_ELT(imatches,0));
    int nomatch = INTEGER(nomatchArg)[0], totlen=0, len, thislen, wlen=0;
    int *from   = (int *)INTEGER(VECTOR_ELT(imatches, 0));
    int *to     = (int *)INTEGER(VECTOR_ELT(imatches, 1));
    int *len1   = (int *)INTEGER(VECTOR_ELT(ux, uxcols-2));
    int *len2   = (int *)INTEGER(VECTOR_ELT(ux, uxcols-1));
    SEXP lookup = VECTOR_ELT(ux, uxcols-4);
    SEXP type_lookup = VECTOR_ELT(ux, uxcols-3);
    SEXP ans, f1__, f2__, tmp1, tmp2;
    clock_t end1, end2, start;
    enum {ALL, FIRST, LAST} mult = ALL;
    enum {ANY, WITHIN, START, END, EQUAL} type = ANY;
    
    if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "all"))  mult = ALL;
    else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "first")) mult = FIRST;
    else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "last")) mult = LAST;
    else error("Internal error: invalid value for 'mult'; this should have been caught before. Please report to datatable-help");

    if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "any"))  type = ANY;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "within")) type = WITHIN;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "start")) type = START;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "end")) type = END;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "equal")) type = EQUAL;
    else error("Internal error: invalid value for 'type'; this should have been caught before. Please report to datatable-help");

    // As a first pass get the final length, so that we can allocate up-front and not deal with Calloc + Realloc + size calculation hassle
    // Checked the time for this loop on realisitc data (81m reads) and took 0.27 seconds! No excuses ;).
    start = clock();
    if (mult == ALL) {
        totlen=0;
        switch (type) {
            case START: case END: 
            for (i=0; i<rows; i++)
                totlen += (from[i] > 0 && len2[from[i]-1]) ? len2[from[i]-1] : 1;
            break;

            case EQUAL:
            for (i=0; i<rows; i++) {
                len = totlen; wlen=0, j=0, m=0;
                k = (from[i]>0) ? from[i] : 1;
                if (k == to[i]) {
                    wlen = len1[k-1];
                } else if (k < to[i]) {
                    tmp1 = VECTOR_ELT(lookup, k-1);
                    tmp2 = VECTOR_ELT(type_lookup, to[i]-1);
                    while (j<len1[k-1] && m<len2[to[i]-1]) {
                        if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                            ++wlen; ++j; ++m;
                        } else if ( INTEGER(tmp1)[j] > INTEGER(tmp2)[m] ) {
                            break;
                        } else ++j;
                    }
                }
                totlen += wlen;
                if (len == totlen) 
                    ++totlen;
            }
            break;
                        
            case ANY:
            for (i=0; i<rows; i++) {
                len = totlen;
                // k = (from[i] > 0) ? from[i] : 1;
                k = from[i];
                if (k<=to[i])
                    totlen += len1[k-1];
                for (j=k+1; j<=to[i]; j++)
                    totlen += len2[j-1];
                if (len == totlen) 
                    ++totlen;
            }
            break;
            
            case WITHIN:
            for (i=0; i<rows; i++) {
                len = totlen; j=0; m=0;
                k = from[i];
                if (k > 0) {
                    if (k == to[i]) {
                        totlen += len1[k-1];
                    } else if (k < to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(lookup, to[i]-1);
                        while (j<len1[k-1] && m<len1[to[i]-1]) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                ++totlen; ++j; ++m;
                            } else if ( INTEGER(tmp1)[j] > INTEGER(tmp2)[m] ) {
                                ++m;
                            } else ++j;
                        }
                    }
                }
                if (len == totlen) 
                    ++totlen;
            }
            break;
        }
    } else totlen = rows;
    end1 = clock() - start;
    if (LOGICAL(verbose)[0])
        Rprintf("First pass on calculating lengths in overlaps ... done in %8.3f seconds\n", 1.0*(end1)/CLOCKS_PER_SEC);
    
    // ans[0] is the the position of 'query' and ans[1] is that of 'subject'
    // allocate f1__ and f2__ and assign 'nomatch' to f2__
    ans = PROTECT(allocVector(VECSXP, 2));
    f1__ = allocVector(INTSXP, totlen);
    SET_VECTOR_ELT(ans, 0, f1__);
    f2__ = allocVector(INTSXP, totlen);
    SET_VECTOR_ELT(ans, 1, f2__);
    thislen=0;
    start = clock();

    // switching mult=ALL,FIRST,LAST separately to
    //   - enhance performance for special cases, and 
    //   - easy to fix any bugs in the future
    switch (mult) {
        case ALL:
        switch (type) {
            case START : case END :
            for (i=0; i<rows; i++) {
                len = thislen;
                if (from[i] > 0) {
                    k = from[i];
                    tmp2 = VECTOR_ELT(type_lookup, k-1);
                    for (j=0; j<len2[k-1]; j++) {
                        INTEGER(f1__)[thislen] = i+1;
                        INTEGER(f2__)[thislen] = INTEGER(tmp2)[j];
                        ++thislen;
                    }
                }
                if (len == thislen) {
                    INTEGER(f1__)[thislen] = i+1;
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen;
                }
            }
            break;
            
            case EQUAL :
            for (i=0; i<rows; i++) {
                len = thislen;
                if (from[i] > 0 && to[i] > 0) {
                    k = from[i];
                    if (k == to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(type_lookup, to[i]-1);
                        for (j=0; j<len1[k-1]; j++) {
                            INTEGER(f1__)[thislen] = i+1;
                            INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                            ++thislen;
                        }
                    } else if (k < to[i]) {
                        j=0; m=0;
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(type_lookup, to[i]-1);
                        while (j<len1[k-1] && m<len2[to[i]-1]) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                INTEGER(f1__)[thislen] = i+1;
                                INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                                 ++thislen; ++j; ++m;
                             } else if ( INTEGER(tmp1)[j] > INTEGER(tmp2)[m] ) {
                                 ++m;
                             } else ++j;
                         }
                     }
                 }
                 if (len == thislen) {
                     INTEGER(f1__)[thislen] = i+1;
                     INTEGER(f2__)[thislen] = nomatch;
                     ++thislen;
                 }
            }
            break;
            
            case ANY :
            for (i=0; i<rows; i++) {
                len = thislen;
                // k = (from[i]>0) ? from[i] : 1;
                k = from[i];
                if (k<=to[i]) {
                    tmp1 = VECTOR_ELT(lookup, k-1);
                    for (m=0; m<len1[k-1]; m++) {
                        INTEGER(f1__)[thislen] = i+1;
                        INTEGER(f2__)[thislen] = INTEGER(tmp1)[m];
                        ++thislen;
                    }
                }
                for (j=k+1; j<=to[i]; j++) {
                    tmp2 = VECTOR_ELT(type_lookup, j-1);
                    for (m=0; m<len2[j-1]; m++) {
                        INTEGER(f1__)[thislen] = i+1;
                        INTEGER(f2__)[thislen] = INTEGER(tmp2)[m];
                        ++thislen;
                    }
                }
                // dint go through any loops above
                if (len == thislen) {
                    INTEGER(f1__)[thislen] = i+1;
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen; 
                }
            }
            break;
            
            case WITHIN :
            for (i=0; i<rows; i++) {
                len = thislen;
                k=from[i];
                if (k > 0) {
                    if (k == to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        for (j=0; j<len1[k-1]; j++) {
                            INTEGER(f1__)[thislen] = i+1;
                            INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                            ++thislen;
                        }
                    } else if (k < to[i]) {
                        j=0; m=0;
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(lookup, to[i]-1);
                        while (j<len1[k-1] && m<len1[to[i]-1]) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                INTEGER(f1__)[thislen] = i+1;
                                INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                                 ++thislen; ++j; ++m;
                             } else if ( INTEGER(tmp1)[j] > INTEGER(tmp2)[m] ) {
                                 ++m;
                             } else ++j;
                         }
                     }
                 }
                 if (len == thislen) {
                     INTEGER(f1__)[thislen] = i+1;
                     INTEGER(f2__)[thislen] = nomatch;
                     ++thislen;
                 }
            }
            break;
        }
        break;
        
        case FIRST:
        switch (type) {
            case START: case END:
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                k = (from[i]>0) ? from[i] : 1;
                if (k <= to[i]) { // len1[k-1] is equal to len2[k-1] and will always be >0, so no length check necessary.
                    tmp1 = VECTOR_ELT(lookup, k-1);
                    INTEGER(f2__)[thislen] = INTEGER(tmp1)[0];
                    ++thislen;
                }
                if (len == thislen) {
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen;
                }
            }
            break;
            
            case EQUAL :
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                if (from[i] > 0 && to[i] > 0) {
                    k = from[i];
                    if (k == to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        INTEGER(f2__)[thislen] = INTEGER(tmp1)[0];
                        ++thislen;
                    } else if (k < to[i]) {
                        j=0; m=0;
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(type_lookup, to[i]-1);
                        while (j<len1[k-1] && m<len2[to[i]-1]) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                                 ++thislen; ++j; ++m;
                                 break;
                             } else if ( INTEGER(tmp1)[j] > INTEGER(tmp2)[m] ) {
                                 ++m;
                             } else ++j;
                         }
                     }
                 }
                 if (len == thislen) {
                     INTEGER(f2__)[thislen] = nomatch;
                     ++thislen;
                 }
            }
            break;

            case ANY:
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                // k = (from[i]>0) ? from[i] : 1;
                k = from[i];
                for (j=k; j<=to[i]; j++) {
                    if (len2[j-1]) {
                        tmp2 = VECTOR_ELT(type_lookup, j-1);
                        INTEGER(f2__)[thislen] = INTEGER(tmp2)[0];
                        ++thislen;
                        break;
                    }
                }
                if (len == thislen) {
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen;
                }
            }
            break;

            case WITHIN:
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                k = from[i];
                if (k > 0) {
                    if (k == to[i] && len1[k-1]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        INTEGER(f2__)[thislen] = INTEGER(tmp1)[0];
                        ++thislen;
                    } else if (k < to[i]) {
                        j=0; m=0;
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(lookup, to[i]-1);
                        while (j<len1[k-1] && m<len1[to[i]-1]) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                                 ++thislen; ++j; ++m;
                                 break;
                             } else if ( INTEGER(tmp1)[j] > INTEGER(tmp2)[m] ) {
                                 ++m;;
                             } else ++j;
                         }
                     }
                }
                if (len == thislen) {
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen;
                }
            }
            break;
        }
        break;

        case LAST:
        switch (type) {
            case START: case END:
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                k = (from[i]>0) ? from[i] : 1;
                if (k <= to[i]) { // len1[k-1] is equal to len2[k-1] and will always be >0, so no length check necessary.
                    tmp1 = VECTOR_ELT(lookup, k-1);
                    INTEGER(f2__)[thislen] = INTEGER(tmp1)[len1[k-1]-1];
                    ++thislen;
                }
                if (len == thislen) {
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen;
                }
            }
            break;
            
            case EQUAL :
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                if (from[i] > 0 && to[i] > 0) {
                    k = from[i];
                    if (k == to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        INTEGER(f2__)[thislen] = INTEGER(tmp1)[len1[k-1]-1];
                        ++thislen;
                    } else if (k < to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(type_lookup, to[i]-1);
                        j=len1[k-1]-1; m=len2[k-1]-1;
                        while (j>=0 && m>=0) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                                 ++thislen; --j; --m;
                                 break;
                             } else if ( INTEGER(tmp1)[j] < INTEGER(tmp2)[m] ) {
                                 --m;
                             } else --j;
                         }
                     }
                 }
                 if (len == thislen) {
                     INTEGER(f2__)[thislen] = nomatch;
                     ++thislen;
                 }
            }
            break;

            // OLD logic for 'any,last' which had to check for maximum for each 'i'. Better logic below.
            // for 'first' we need to just get the minimum of first non-zero-length element, but not the same case for 'last'.
            // We've to loop over from[i]:to[i] and get maximum of all tmp2 values (each is of length 1 already conveniently set uo) in that range
            // case ANY:
            // for (i=0; i<rows; i++) {
            //     len = thislen;
            //     INTEGER(f1__)[thislen] = i+1;
            //     INTEGER(f2__)[thislen] = 0;
            //     // k = (from[i]>0) ? from[i] : 1;
            //     k = from[i];
            //     for (j=k; j<=to[i]; j++) {
            //         if (len2[j-1]) {
            //             tmp2 = VECTOR_ELT(type_lookup, j-1);
            //             INTEGER(f2__)[thislen] = (INTEGER(f2__)[thislen] < INTEGER(tmp2)[len2[j-1]-1]) ? INTEGER(tmp2)[len2[j-1]-1] : INTEGER(f2__)[thislen];
            //         }
            //     }
            //     if (INTEGER(f2__)[thislen] == 0)
            //         INTEGER(f2__)[thislen] = nomatch;
            //     ++thislen;
            // }
            // break;

            case ANY:
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                // k = (from[i]>0) ? from[i] : 1;
                k = from[i];
                if (k <= to[i]) {
                    if (k==to[i] && len1[k-1]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        INTEGER(f2__)[thislen] = INTEGER(tmp1)[len1[k-1]-1];
                        ++thislen;
                    } else {
                        for (j=to[i]; j>k; j--) {
                            if (len2[j-1]) {
                                tmp2 = VECTOR_ELT(type_lookup, j-1);
                                INTEGER(f2__)[thislen] = INTEGER(tmp2)[0]; // tmp2 will be length 1
                                ++thislen; break;
                            }
                        }
                        if (len == thislen && len1[k-1]) {
                            tmp1 = VECTOR_ELT(lookup, k-1);
                            INTEGER(f2__)[thislen] = INTEGER(tmp1)[len1[k-1]-1];
                            ++thislen;
                        }
                    }
                }
                if (len == thislen) {
                    INTEGER(f2__)[thislen] = nomatch;
                    ++thislen;
                }
            }
            break;
            
            case WITHIN:
            for (i=0; i<rows; i++) {
                len = thislen;
                INTEGER(f1__)[thislen] = i+1;
                k = from[i];
                if (k > 0) {
                    if (k == to[i] && len1[k-1]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        INTEGER(f2__)[thislen] = INTEGER(tmp1)[len1[k-1]-1];
                        ++thislen;
                    } else if (k < to[i]) {
                        tmp1 = VECTOR_ELT(lookup, k-1);
                        tmp2 = VECTOR_ELT(lookup, to[i]-1);
                        j=len1[k-1]-1; m=len1[to[i]-1]-1;
                        while (j>=0 && m>=0) {
                            if ( INTEGER(tmp1)[j] == INTEGER(tmp2)[m] ) {
                                INTEGER(f2__)[thislen] = INTEGER(tmp1)[j];
                                 ++thislen; --j; --m;
                                 break;
                             } else if ( INTEGER(tmp1)[j] < INTEGER(tmp2)[m] ) {
                                 --m;
                             } else --j;
                         }
                     }
                 }
                 if (len == thislen) {
                     INTEGER(f2__)[thislen] = nomatch;
                     ++thislen;
                 }
            }
            break;
        }
        break;
    }
    end2 = clock() - start;
    if (LOGICAL(verbose)[0])
        Rprintf("Final step, fetching indices in overlaps ... done in %8.3f seconds\n", 1.0*(end2)/CLOCKS_PER_SEC);
    UNPROTECT(1);
    return(ans);
}
/* an Ide-Cozman alternative for 2-nodes graphs. */
static SEXP ic_2nodes(SEXP nodes, SEXP num, SEXP burn_in, SEXP max_in_degree,
    SEXP max_out_degree, SEXP max_degree, SEXP connected, SEXP debug) {

int i = 0, *n = INTEGER(num), *a = NULL;
int *debuglevel = LOGICAL(debug);
double u = 0;
SEXP list, resA, resB, arcsA, arcsB, cachedA, cachedB;
SEXP amatA, amatB, args, argnames, false;

  /* the list of optional arguments. */
  PROTECT(argnames = allocVector(STRSXP, 4));
  SET_STRING_ELT(argnames, 0, mkChar("burn.in"));
  SET_STRING_ELT(argnames, 1, mkChar("max.in.degree"));
  SET_STRING_ELT(argnames, 2, mkChar("max.out.degree"));
  SET_STRING_ELT(argnames, 3, mkChar("max.degree"));

  PROTECT(args = allocVector(VECSXP, 4));
  setAttrib(args, R_NamesSymbol, argnames);
  SET_VECTOR_ELT(args, 0, burn_in);
  SET_VECTOR_ELT(args, 1, max_in_degree);
  SET_VECTOR_ELT(args, 2, max_out_degree);
  SET_VECTOR_ELT(args, 3, max_degree);

  /* allocate a FALSE variable. */
  PROTECT(false = allocVector(LGLSXP, 1));
  LOGICAL(false)[0] = FALSE;

  /* allocate and initialize the tow adjacency matrices. */
  PROTECT(amatA = allocMatrix(INTSXP, 2, 2));
  a = INTEGER(amatA);
  memset(a, '\0', sizeof(int) * 4);
  a[2] = 1;
  PROTECT(amatB = allocMatrix(INTSXP, 2, 2));
  a = INTEGER(amatB);
  memset(a, '\0', sizeof(int) * 4);
  a[1] = 1;
  /* generates the arc sets. */
  PROTECT(arcsA = amat2arcs(amatA, nodes));
  PROTECT(arcsB = amat2arcs(amatB, nodes));
  /* generate the cached node information. */
  PROTECT(cachedA = cache_structure(nodes, amatA, false));
  PROTECT(cachedB = cache_structure(nodes, amatB, false));
  /* generate the two "bn" structures. */
  PROTECT(resA = bn_base_structure(nodes, args, arcsA, cachedA, 0, "none", "empty"));
  PROTECT(resB = bn_base_structure(nodes, args, arcsB, cachedB, 0, "none", "empty"));

  if (*debuglevel > 0)
    Rprintf("* no burn-in required.\n");

  GetRNGstate();

  /* return a list if more than one bn is generated. */
  if (*n > 1) {

    PROTECT(list = allocVector(VECSXP, *n));
    for (i = 0; i < *n; i++) {

      if (*debuglevel > 0)
        Rprintf("* current model (%d):\n", i + 1);

      /* sample which graph to return. */
      u = unif_rand();

      if (u <= 0.5) {

        /* pick the graph with A -> B. */
        SET_VECTOR_ELT(list, i, resA);

        /* print the model string to allow a sane debugging experience. */
        if (*debuglevel > 0)
          print_modelstring(resA);

      }/*THEN*/
      else {

        /* pick the graph with B -> A. */
        SET_VECTOR_ELT(list, i, resB);

        /* print the model string to allow a sane debugging experience. */
        if (*debuglevel > 0)
          print_modelstring(resB);

      }/*ELSE*/

    }/*FOR*/

    PutRNGstate();

    UNPROTECT(12);
    return list;

  }/*THEN*/
  else {

    if (*debuglevel > 0)
      Rprintf("* current model (1):\n");

    /* sample which graph to return. */
    u = unif_rand();

    PutRNGstate();

    UNPROTECT(11);

    if (u <= 0.5) {

      /* print the model string to allow a sane debugging experience. */
      if (*debuglevel > 0)
        print_modelstring(resA);

      /* return the graph with A -> B. */
      return resA;

    }/*THEN*/
    else {

      /* print the model string to allow a sane debugging experience. */
      if (*debuglevel > 0)
        print_modelstring(resB);

      /* return the graph with B -> A. */
      return resB;

    }/*ELSE*/

  }/*ELSE*/

}/*IC_2NODES*/
Example #19
0
SEXP scdd_f(SEXP m, SEXP h, SEXP roworder, SEXP adjacency,
    SEXP inputadjacency, SEXP incidence, SEXP inputincidence)
{
    int i, j, k;

    GetRNGstate();
    if (! isMatrix(m))
        error("'m' must be matrix");
    if (! isLogical(h))
        error("'h' must be logical");
    if (! isString(roworder))
        error("'roworder' must be character");
    if (! isLogical(adjacency))
        error("'adjacency' must be logical");
    if (! isLogical(inputadjacency))
        error("'inputadjacency' must be logical");
    if (! isLogical(incidence))
        error("'incidence' must be logical");
    if (! isLogical(inputincidence))
        error("'inputincidence' must be logical");

    if (LENGTH(h) != 1)
        error("'h' must be scalar");
    if (LENGTH(roworder) != 1)
        error("'roworder' must be scalar");
    if (LENGTH(adjacency) != 1)
        error("'adjacency' must be scalar");
    if (LENGTH(inputadjacency) != 1)
        error("'inputadjacency' must be scalar");
    if (LENGTH(incidence) != 1)
        error("'incidence' must be scalar");
    if (LENGTH(inputincidence) != 1)
        error("'inputincidence' 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);

#ifdef BLATHER
    printf("nrow = %d\n", nrow);
    printf("ncol = %d\n", ncol);
#endif /* BLATHER */

    if ((! LOGICAL(h)[0]) && nrow <= 0)
        error("no rows in 'm', not allowed for V-representation");
    if (ncol <= 2)
        error("no cols in m[ , - c(1, 2)]");

    for (i = 0; i < nrow * ncol; i++)
        if (! R_finite(REAL(m)[i]))
            error("'m' not finite-valued");

    for (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 (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 (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 (j = 1, k = nrow; j < ncol; j++)
        for (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_RowOrderType strategy = ddf_LexMin;
    const char *row_str = CHAR(STRING_ELT(roworder, 0));
    if(strcmp(row_str, "maxindex") == 0)
        strategy = ddf_MaxIndex;
    else if(strcmp(row_str, "minindex") == 0)
        strategy = ddf_MinIndex;
    else if(strcmp(row_str, "mincutoff") == 0)
        strategy = ddf_MinCutoff;
    else if(strcmp(row_str, "maxcutoff") == 0)
        strategy = ddf_MaxCutoff;
    else if(strcmp(row_str, "mixcutoff") == 0)
        strategy = ddf_MixCutoff;
    else if(strcmp(row_str, "lexmin") == 0)
        strategy = ddf_LexMin;
    else if(strcmp(row_str, "lexmax") == 0)
        strategy = ddf_LexMax;
    else if(strcmp(row_str, "randomrow") == 0)
        strategy = ddf_RandomRow;
    else
        error("roworder not recognized");

    ddf_ErrorType err = ddf_NoError;
    ddf_PolyhedraPtr poly = ddf_DDMatrix2Poly2(mf, strategy, &err);

    if (poly->child != NULL && poly->child->CompStatus == ddf_InProgress) {
        ddf_FreeMatrix(mf);
        ddf_FreePolyhedra(poly);
        ddf_clear(value);
        ddf_free_global_constants();
        error("Computation failed, floating-point arithmetic problem\n");
    }

    if (err != ddf_NoError) {
        rrf_WriteErrorMessages(err);
        ddf_FreeMatrix(mf);
        ddf_FreePolyhedra(poly);
        ddf_clear(value);
        ddf_free_global_constants();
        error("failed");
    }

    ddf_MatrixPtr aout = NULL;
    if (poly->representation == ddf_Inequality)
        aout = ddf_CopyGenerators(poly);
    else if (poly->representation == ddf_Generator)
        aout = ddf_CopyInequalities(poly);
    else
        error("Cannot happen!  poly->representation no good\n");
    if (aout == NULL)
        error("Cannot happen!  aout no good\n");

    int mrow = aout->rowsize;
    int mcol = aout->colsize;

    if (mcol + 1 != ncol)
        error("Cannot happen!  computed matrix has wrong number of columns");

#ifdef BLATHER
    printf("mrow = %d\n", mrow);
    printf("mcol = %d\n", mcol);
#endif /* BLATHER */

    SEXP bar;
    PROTECT(bar = allocMatrix(REALSXP, mrow, ncol));

    /* linearity output */
    for (i = 0; i < mrow; i++)
        if (set_member(i + 1, aout->linset))
            REAL(bar)[i] = 1.0;
        else
            REAL(bar)[i] = 0.0;
    /* note conversion from zero-origin to one-origin indexing */

    /* matrix output */
    for (j = 1, k = mrow; j < ncol; j++)
        for (i = 0; i < mrow; i++, k++) {
            double ax = ddf_get_d(aout->matrix[i][j - 1]);
            /* note our matrix has one more column than Fukuda's */
            REAL(bar)[k] = ax;
        }

    int nresult = 1;

    SEXP baz_adj = NULL;
    if (LOGICAL(adjacency)[0]) {
        ddf_SetFamilyPtr sout = ddf_CopyAdjacency(poly);
        PROTECT(baz_adj = rrf_WriteSetFamily(sout));
        ddf_FreeSetFamily(sout);
        nresult++;
    }

    SEXP baz_inp_adj = NULL;
    if (LOGICAL(inputadjacency)[0]) {
        ddf_SetFamilyPtr sout = ddf_CopyInputAdjacency(poly);
        PROTECT(baz_inp_adj = rrf_WriteSetFamily(sout));
        ddf_FreeSetFamily(sout);
        nresult++;
    }

    SEXP baz_inc = NULL;
    if (LOGICAL(incidence)[0]) {
        ddf_SetFamilyPtr sout = ddf_CopyIncidence(poly);
        PROTECT(baz_inc = rrf_WriteSetFamily(sout));
        ddf_FreeSetFamily(sout);
        nresult++;
    }

    SEXP baz_inp_inc = NULL;
    if (LOGICAL(inputincidence)[0]) {
        ddf_SetFamilyPtr sout = ddf_CopyInputIncidence(poly);
        PROTECT(baz_inp_inc = rrf_WriteSetFamily(sout));
        ddf_FreeSetFamily(sout);
        nresult++;
    }

    SEXP result, resultnames;
    PROTECT(result = allocVector(VECSXP, nresult));
    PROTECT(resultnames = allocVector(STRSXP, nresult));

    SET_STRING_ELT(resultnames, 0, mkChar("output"));
    SET_VECTOR_ELT(result, 0, bar);

    int iresult = 1;

    if (baz_adj) {
        SET_STRING_ELT(resultnames, iresult, mkChar("adjacency"));
        SET_VECTOR_ELT(result, iresult, baz_adj);
        iresult++;
    }
    if (baz_inp_adj) {
        SET_STRING_ELT(resultnames, iresult, mkChar("inputadjacency"));
        SET_VECTOR_ELT(result, iresult, baz_inp_adj);
        iresult++;
    }
    if (baz_inc) {
        SET_STRING_ELT(resultnames, iresult, mkChar("incidence"));
        SET_VECTOR_ELT(result, iresult, baz_inc);
        iresult++;
    }
    if (baz_inp_inc) {
        SET_STRING_ELT(resultnames, iresult, mkChar("inputincidence"));
        SET_VECTOR_ELT(result, iresult, baz_inp_inc);
        iresult++;
    }
    namesgets(result, resultnames);

    if (aout->objective != ddf_LPnone)
        error("Cannot happen! aout->objective != ddf_LPnone\n");

    ddf_FreeMatrix(aout);
    ddf_FreeMatrix(mf);
    ddf_FreePolyhedra(poly);
    ddf_clear(value);
    ddf_free_global_constants();

    UNPROTECT(2 + nresult);
    PutRNGstate();
    return result;
}
static SEXP c_ide_cozman(SEXP nodes, SEXP num, SEXP burn_in, SEXP max_in_degree,
    SEXP max_out_degree, SEXP max_degree, SEXP connected, SEXP debug) {

int i = 0, k = 0, nnodes = LENGTH(nodes), *n = INTEGER(num);
int changed = 0, *work = NULL, *arc = NULL, *a = NULL, *burn = INTEGER(burn_in);
int *degree = NULL, *in_degree = NULL, *out_degree = NULL;
int *debuglevel = LOGICAL(debug), *cozman = LOGICAL(connected);
double *max_in = REAL(max_in_degree), *max_out = REAL(max_out_degree),
  *max = REAL(max_degree);
SEXP list, res, args, argnames, amat, arcs, cached, debug2, null, temp;
char *label = (*cozman > 0) ? "ic-dag" : "melancon";

  /* a fake debug argument (set to FALSE) for cache_structure(). */
  PROTECT(debug2 = allocVector(LGLSXP, 1));
  LOGICAL(debug2)[0] = FALSE;

  /* the list of optional arguments. */
  PROTECT(argnames = allocVector(STRSXP, 4));
  SET_STRING_ELT(argnames, 0, mkChar("burn.in"));
  SET_STRING_ELT(argnames, 1, mkChar("max.in.degree"));
  SET_STRING_ELT(argnames, 2, mkChar("max.out.degree"));
  SET_STRING_ELT(argnames, 3, mkChar("max.degree"));

  PROTECT(args = allocVector(VECSXP, 4));
  setAttrib(args, R_NamesSymbol, argnames);
  SET_VECTOR_ELT(args, 0, burn_in);
  SET_VECTOR_ELT(args, 1, max_in_degree);
  SET_VECTOR_ELT(args, 2, max_out_degree);
  SET_VECTOR_ELT(args, 3, max_degree);

  /* allocate and initialize the adjacency matrix. */
  PROTECT(amat = allocMatrix(INTSXP, nnodes, nnodes));
  a = INTEGER(amat);
  memset(a, '\0', nnodes * nnodes * sizeof(int));

  /* initialize a simple ordered tree with n nodes, where all nodes
   * have just one parent, except the first one that does not have
   * any parent. */
  for (i = 1; i < nnodes; i++)
    a[CMC(i - 1, i, nnodes)] = 1;

  /* allocate the arrays needed by SampleNoReplace. */
  arc = alloc1dcont(2);
  work = alloc1dcont(nnodes);

  /* allocate and initialize the degree arrays. */
  degree = alloc1dcont(nnodes);
  in_degree = alloc1dcont(nnodes);
  out_degree = alloc1dcont(nnodes);

  for (i = 0; i < nnodes; i++) {

    in_degree[i] = out_degree[i] = 1;
    degree[i] = 2;

  }/*FOR*/
  in_degree[0] = out_degree[nnodes - 1] = 0;
  degree[0] = degree[nnodes - 1] = 1;

  GetRNGstate();

  /* wait for the markov chain monte carlo simulation to reach stationarity. */
  for (k = 0; k < *burn; k++) {

    if (*debuglevel > 0)
      Rprintf("* current model (%d):\n", k + 1);

    changed = ic_logic(a, nodes, &nnodes, arc, work, degree, max, in_degree, max_in,
                out_degree, max_out, cozman, debuglevel);

    /* print the model string to allow a sane debugging experience; note that this
     * has a huge impact on performance, so use it with care. */
    if ((*debuglevel > 0) && (changed)) {

      PROTECT(null = allocVector(NILSXP, 1));
      PROTECT(res = bn_base_structure(nodes, args, null, null, 0, "none", label));
      PROTECT(arcs = amat2arcs(amat, nodes));
      PROTECT(cached = cache_structure(nodes, amat, debug2));
      SET_VECTOR_ELT(res, 1, cached);
      SET_VECTOR_ELT(res, 2, arcs);
      print_modelstring(res);
      UNPROTECT(4);

    }/*THEN*/

  }/*FOR*/

#define UPDATE_NODE_CACHE(cur) \
          if (*debuglevel > 0) \
            Rprintf("  > updating cached information about node %s.\n", NODE(cur)); \
          memset(work, '\0', nnodes * sizeof(int)); \
          PROTECT(temp = c_cache_partial_structure(cur, nodes, amat, work, debug2)); \
          SET_VECTOR_ELT(cached, cur, temp); \
          UNPROTECT(1);

  /* return a list if more than one bn is generated. */
  if (*n > 1) {

    if (*debuglevel > 0)
      Rprintf("* end of the burn-in iterations.\n");

    PROTECT(list = allocVector(VECSXP, *n));
    PROTECT(null = allocVector(NILSXP, 1));

    /* generate the "bn" structure, with dummy NULLs for the "arcs" and
     * "nodes" elements (which will be initialized later on). */
    PROTECT(res = bn_base_structure(nodes, args, null, null, 0, "none", label));

    for (k = 0; k < *n; k++) {

      if (*debuglevel > 0)
        Rprintf("* current model (%d):\n", *burn + k + 1);

      changed = ic_logic(a, nodes, &nnodes, arc, work, degree, max, in_degree,
                  max_in, out_degree, max_out, cozman, debuglevel);

      if (changed || (k == 0)) {

        /* generate the arc set and the cached information from the adjacency
         * matrix. */
        if (k > 0) {

          /* if a complete "bn" object is available, we can retrieve the cached
           * information about the nodes from the structure stored in the last
           * iteration and update only the elements that really need it. */
          temp = VECTOR_ELT(VECTOR_ELT(list, k - 1), 1);
          PROTECT(cached = duplicate(temp));

          /* update the first sampled nodes; both of them gain/lose either
           * a parent or a child.  */
          UPDATE_NODE_CACHE(arc[0] - 1);
          UPDATE_NODE_CACHE(arc[1] - 1);

          /* all the parents of the second sampled node gain/lose a node in
           * the markov blanket (the first sampled node, which shares a child
           * with all of them). */
          for (i = 0; i < nnodes; i++) {

            if ((i != arc[0] - 1) && (a[CMC(i, arc[1] - 1, nnodes)] == 1)) {

              UPDATE_NODE_CACHE(i);

            }/*THEN*/

          }/*FOR*/

        }/*THEN*/
        else {

          PROTECT(cached = cache_structure(nodes, amat, debug2));

        }/*ELSE*/

        PROTECT(arcs = amat2arcs(amat, nodes));
        SET_VECTOR_ELT(res, 1, cached);
        SET_VECTOR_ELT(res, 2, arcs);

        /* print the model string to allow a sane debugging experience. */
        if (*debuglevel > 0)
          print_modelstring(res);

        /* save the structure in the list. */
        PROTECT(temp = duplicate(res));
        SET_VECTOR_ELT(list, k, temp);

        UNPROTECT(3);

      }/*THEN*/
      else {

        /* the adjacency matrix is unchanged; so we can just copy the bayesian
         * network from the previous iteration in the k-th slot of the list. */
        SET_VECTOR_ELT(list, k, VECTOR_ELT(list, k - 1));

      }/*ELSE*/

    }/*FOR*/

    PutRNGstate();

    UNPROTECT(7);
    return list;

  }/*THEN*/
  else {

    if (*debuglevel > 0)
      Rprintf("* end of the burn-in.\n* current model (%d):\n", *burn + 1);

    ic_logic(a, nodes, &nnodes, arc, work, degree, max, in_degree,
      max_in, out_degree, max_out, cozman, debuglevel);

    /* generate the arc set and the cached information form the adjacency
     * matrix. */
    PROTECT(arcs = amat2arcs(amat, nodes));
    PROTECT(cached = cache_structure(nodes, amat, debug2));

    /* generate the "bn" structure. */
    PROTECT(res = bn_base_structure(nodes, args, arcs, cached, 0, "none", label));

    /* print the model string to allow a sane debugging experience. */
    if (*debuglevel > 0)
      print_modelstring(res);

    PutRNGstate();

    UNPROTECT(7);
    return res;

  }/*ELSE*/

}/*C_IDE_COZMAN*/
bool RKStructureGetter::callSimpleBool (SEXP fun, SEXP arg, SEXP env) {
	SEXP res = callSimpleFun (fun, arg, env);
	RK_ASSERT (TYPEOF (res) == LGLSXP);
	return ((bool) LOGICAL (res)[0]);
}
/* generate a graph with given node ordering and arc probability. */
SEXP ordered_graph(SEXP nodes, SEXP num, SEXP prob) {

int i = 0, j = 0, k = 0, nnodes = LENGTH(nodes), *a = NULL, *n = INTEGER(num);
double *p = REAL(prob);
SEXP list, res, args, argnames, amat, arcs, cached, debug2, null, temp;

  /* a fake debug argument (set to FALSE) for cache_structure(). */
  PROTECT(debug2 = allocVector(LGLSXP, 1));
  LOGICAL(debug2)[0] = FALSE;

  /* the list of optional arguments. */
  PROTECT(argnames = allocVector(STRSXP, 1));
  SET_STRING_ELT(argnames, 0, mkChar("prob"));

  PROTECT(args = allocVector(VECSXP, 1));
  setAttrib(args, R_NamesSymbol, argnames);
  SET_VECTOR_ELT(args, 0, prob);

  /* allocate and initialize the adjacency matrix. */
  PROTECT(amat = allocMatrix(INTSXP, nnodes, nnodes));
  a = INTEGER(amat);
  memset(a, '\0', nnodes * nnodes * sizeof(int));

  GetRNGstate();

#define ORDERED_AMAT(prob) \
      for (i = 0; i < nnodes; i++) \
        for (j = i + 1; j < nnodes; j++) \
          if (unif_rand() < prob) \
            a[CMC(i, j, nnodes)] = 1; \
          else \
            a[CMC(i, j, nnodes)] = 0; \

  /* return a list if more than one bn is generated. */
  if (*n > 1) {

    PROTECT(list = allocVector(VECSXP, *n));
    PROTECT(null = allocVector(NILSXP, 1));

    /* generate the "bn" structure, with dummy NULLs for the "arcs" and
     * "nodes" elements (which will be initialized later on). */
    PROTECT(res = bn_base_structure(nodes, args, null, null, 0, "none", "ordered"));

    for (k = 0; k < *n; k++) {

      /* sample each arc in the upper-triangular portion of the adjacency matrix
       * (so that node ordering is conserved) with the specified probability. */
      ORDERED_AMAT(*p);

      /* generate the arc set and the cached information form the adjacency
       * matrix. */
      PROTECT(arcs = amat2arcs(amat, nodes));
      PROTECT(cached = cache_structure(nodes, amat, debug2));
      SET_VECTOR_ELT(res, 1, cached);
      SET_VECTOR_ELT(res, 2, arcs);

      /* save the structure in the list. */
      PROTECT(temp = duplicate(res));
      SET_VECTOR_ELT(list, k, temp);

      UNPROTECT(3);

    }/*FOR*/

    PutRNGstate();

    UNPROTECT(7);
    return list;

  }/*THEN*/
  else {

    /* sample each arc in the upper-triangular portion of the adjacency matrix
     * (so that node ordering is conserved) with the specified probability. */
    ORDERED_AMAT(*p);

    /* generate the arc set and the cached information form the adjacency
     * matrix. */
    PROTECT(arcs = amat2arcs(amat, nodes));
    PROTECT(cached = cache_structure(nodes, amat, debug2));

    /* generate the "bn" structure. */
    PROTECT(res = bn_base_structure(nodes, args, arcs, cached, 0, "none", "ordered"));

    PutRNGstate();

    UNPROTECT(7);
    return res;

  }/*ELSE*/

}/*ORDERED_GRAPH*/
Example #23
0
SEXP attribute_hidden do_sprintf(SEXP call, SEXP op, SEXP args, SEXP env)
{
    int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;
    /* fmt2 is a copy of fmt with '*' expanded.
       bit will hold numeric formats and %<w>s, so be quite small. */
    char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
	*outputString;
    const char *formatString;
    size_t n, cur, chunk;

    SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue;
    int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
    static R_StringBuffer outbuff = {NULL, 0, MAXELTSIZE};
    Rboolean has_star, use_UTF8;

#define _my_sprintf(_X_)						\
    {									\
	int nc = snprintf(bit, MAXLINE+1, fmtp, _X_);			\
	if (nc > MAXLINE)						\
	    error(_("required resulting string length %d is greater than maximal %d"), \
		  nc, MAXLINE);						\
    }

    nargs = length(args);
    /* grab the format string */
    format = CAR(args);
    if (!isString(format))
	error(_("'fmt' is not a character vector"));
    nfmt = length(format);
    if (nfmt == 0) return allocVector(STRSXP, 0);
    args = CDR(args); nargs--;
    if(nargs >= MAXNARGS)
	error(_("only %d arguments are allowed"), MAXNARGS);

    /* record the args for possible coercion and later re-ordering */
    for(i = 0; i < nargs; i++, args = CDR(args)) {
	SEXPTYPE t_ai;
	a[i] = CAR(args);
	if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */
	    error(_("invalid type of argument[%d]: '%s'"),
		  i+1, CHAR(type2str(t_ai)));
	lens[i] = length(a[i]);
	if(lens[i] == 0) return allocVector(STRSXP, 0);
    }

#define CHECK_maxlen							\
    maxlen = nfmt;							\
    for(i = 0; i < nargs; i++)						\
	if(maxlen < lens[i]) maxlen = lens[i];				\
    if(maxlen % nfmt)							\
	error(_("arguments cannot be recycled to the same length"));	\
    for(i = 0; i < nargs; i++)						\
	if(maxlen % lens[i])						\
	    error(_("arguments cannot be recycled to the same length"))

    CHECK_maxlen;

    outputString = R_AllocStringBuffer(0, &outbuff);

    /* We do the format analysis a row at a time */
    for(ns = 0; ns < maxlen; ns++) {
	outputString[0] = '\0';
	use_UTF8 = getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8;
	if (!use_UTF8) {
	    for(i = 0; i < nargs; i++) {
		if (!isString(a[i])) continue;
		if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) {
		    use_UTF8 = TRUE; break;
		}
	    }
	}

	formatString = TRANSLATE_CHAR(format, ns % nfmt);
	n = strlen(formatString);
	if (n > MAXLINE)
	    error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
	/* process the format string */
	for (cur = 0, cnt = 0; cur < n; cur += chunk) {
	    const char *curFormat = formatString + cur, *ss;
	    char *starc;
	    ss = NULL;
	    if (formatString[cur] == '%') { /* handle special format command */

		if (cur < n - 1 && formatString[cur + 1] == '%') {
		    /* take care of %% in the format */
		    chunk = 2;
		    strcpy(bit, "%");
		}
		else {
		    /* recognise selected types from Table B-1 of K&R */
		    /* NB: we deal with "%%" in branch above. */
		    /* This is MBCS-OK, as we are in a format spec */
		    chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2;
		    if (cur + chunk > n)
			error(_("unrecognised format specification '%s'"), curFormat);

		    strncpy(fmt, curFormat, chunk);
		    fmt[chunk] = '\0';

		    nthis = -1;
		    /* now look for %n$ or %nn$ form */
		    if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
			v = fmt[1] - '0';
			if(fmt[2] == '$') {
			    if(v > nargs)
				error(_("reference to non-existent argument %d"), v);
			    nthis = v-1;
			    memmove(fmt+1, fmt+3, strlen(fmt)-2);
			} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
			    v = 10*v + fmt[2] - '0';
			    if(v > nargs)
				error(_("reference to non-existent argument %d"), v);
			    nthis = v-1;
			    memmove(fmt+1, fmt+4, strlen(fmt)-3);
			}
		    }

		    starc = Rf_strchr(fmt, '*');
		    if (starc) { /* handle  *  format if present */
			nstar = -1;
			if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') {
			    v = starc[1] - '0';
			    if(starc[2] == '$') {
				if(v > nargs)
				    error(_("reference to non-existent argument %d"), v);
				nstar = v-1;
				memmove(starc+1, starc+3, strlen(starc)-2);
			    } else if(starc[2] >= '0' && starc[2] <= '9'
				      && starc[3] == '$') {
				v = 10*v + starc[2] - '0';
				if(v > nargs)
				    error(_("reference to non-existent argument %d"), v);
				nstar = v-1;
				memmove(starc+1, starc+4, strlen(starc)-3);
			    }
			}

			if(nstar < 0) {
			    if (cnt >= nargs) error(_("too few arguments"));
			    nstar = cnt++;
			}

			if (Rf_strchr(starc+1, '*'))
			    error(_("at most one asterisk '*' is supported in each conversion specification"));

			_this = a[nstar];
			if(ns == 0 && TYPEOF(_this) == REALSXP) {
			    _this = coerceVector(_this, INTSXP);
			    PROTECT(a[nstar] = _this);
			    nprotect++;
			}
			if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 ||
			   INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER)
			    error(_("argument for '*' conversion specification must be a number"));
			star_arg = INTEGER(_this)[ns % LENGTH(_this)];
			has_star = TRUE;
		    }
		    else
			has_star = FALSE;

		    if (fmt[strlen(fmt) - 1] == '%') {
			/* handle % with formatting options */
			if (has_star)
			    snprintf(bit, MAXLINE+1, fmt, star_arg);
			else
			    strcpy(bit, fmt);
			/* was sprintf(..)  for which some compiler warn */
		    } else {
			Rboolean did_this = FALSE;
			if(nthis < 0) {
			    if (cnt >= nargs) error(_("too few arguments"));
			    nthis = cnt++;
			}
			_this = a[nthis];
			if (has_star) {
			    size_t nf; char *p, *q = fmt2;
			    for (p = fmt; *p; p++)
				if (*p == '*') q += sprintf(q, "%d", star_arg);
				else *q++ = *p;
			    *q = '\0';
			    nf = strlen(fmt2);
			    if (nf > MAXLINE)
				error(_("'fmt' length exceeds maximal format length %d"),
				      MAXLINE);
			    fmtp = fmt2;
			} else fmtp = fmt;

#define CHECK_this_length						\
			PROTECT(_this);					\
			thislen = length(_this);			\
			if(thislen == 0)				\
			    error(_("coercion has changed vector length to 0"))

			/* Now let us see if some minimal coercion
			   would be sensible, but only do so once, for ns = 0: */
			if(ns == 0) {
			    SEXP tmp; Rboolean do_check;
			    switch(*findspec(fmtp)) {
			    case 'd':
			    case 'i':
			    case 'o':
			    case 'x':
			    case 'X':
				if(TYPEOF(_this) == REALSXP) {
				    double r = REAL(_this)[0];
				    if((double)((int) r) == r)
					_this = coerceVector(_this, INTSXP);
				    PROTECT(a[nthis] = _this);
				    nprotect++;
				}
				break;
			    case 'a':
			    case 'A':
			    case 'e':
			    case 'f':
			    case 'g':
			    case 'E':
			    case 'G':
				if(TYPEOF(_this) != REALSXP &&
				   /* no automatic as.double(<string>) : */
				   TYPEOF(_this) != STRSXP) {
				    PROTECT(tmp = lang2(install("as.double"), _this));
#define COERCE_THIS_TO_A						\
				    _this = eval(tmp, env);		\
				    UNPROTECT(1);			\
				    PROTECT(a[nthis] = _this);		\
				    nprotect++;				\
				    did_this = TRUE;			\
				    CHECK_this_length;			\
				    do_check = (lens[nthis] == maxlen);	\
				    lens[nthis] = thislen; /* may have changed! */ \
				    if(do_check && thislen < maxlen) {	\
					CHECK_maxlen;			\
				    }

				    COERCE_THIS_TO_A
				}
				break;
			    case 's':
				if(TYPEOF(_this) != STRSXP) {
				    /* as.character method might call sprintf() */
				    size_t nc = strlen(outputString);
				    char *z = Calloc(nc+1, char);
				    strcpy(z, outputString);
				    PROTECT(tmp = lang2(install("as.character"), _this));

				    COERCE_THIS_TO_A
				    strcpy(outputString, z);
				    Free(z);
				}
				break;
			    default:
				break;
			    }
			} /* ns == 0 (first-time only) */

			if(!did_this)
			    CHECK_this_length;

			switch(TYPEOF(_this)) {
			case LGLSXP:
			    {
				int x = LOGICAL(_this)[ns % thislen];
				if (checkfmt(fmtp, "di"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d or %i for logical objects"));
				if (x == NA_LOGICAL) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
			case INTSXP:
			    {
				int x = INTEGER(_this)[ns % thislen];
				if (checkfmt(fmtp, "dioxX"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d, %i, %o, %x or %X for integer objects"));
				if (x == NA_INTEGER) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
Example #24
0
SAFEARRAY*
createRDCOMArray(SEXP obj, VARIANT *var)
{
  VARTYPE type;
  unsigned int cDims = 1, len;
  SAFEARRAYBOUND bounds[1];
  SAFEARRAY *arr;
  void *data;

  len = Rf_length(obj);
  bounds[0].lLbound = 0;
  bounds[0].cElements = len;

  type = getDCOMType(obj);
  arr = SafeArrayCreate(type, cDims, bounds);

  HRESULT hr = SafeArrayAccessData(arr, (void**) &data);
  if(hr != S_OK) {
    //std::cerr <<"Problems accessing data" << std::endl;
    REprintf("Problems accessing data\n");
    SafeArrayDestroy(arr);
    return(NULL);
  }

  switch(TYPEOF(obj)) {
    case REALSXP:
      memcpy(data, REAL(obj), sizeof(double) * len);
      break;
    case INTSXP:
      memcpy(data, INTEGER(obj), sizeof(LOGICAL(obj)[0]) * len);
      break;
    case LGLSXP:
      for(unsigned int i = 0 ; i < len ; i++)
	((bool *) data)[i] = LOGICAL(obj)[i];
      break;
    case STRSXP:
      for(unsigned int i = 0 ; i < len ; i++)
	((BSTR *) data)[i] = AsBstr(getRString(obj, i));
      break;
    case VECSXP:
      for(unsigned int i = 0 ; i < len ; i++) {
	VARIANT *v = &(((VARIANT *) data)[i]);
	VariantInit(v);
	R_convertRObjectToDCOM(VECTOR_ELT(obj, i), v);
      }
      break;

    default:
      //std::cerr <<"Array case not handled yet for R type " << TYPEOF(obj) << std::endl;
      REprintf("Array case not handled yet for R type %d\n", TYPEOF(obj));
    break;
  }

 SafeArrayUnaccessData(arr);

  if(var) {
    V_VT(var) = VT_ARRAY | type;
    V_ARRAY(var) = arr;
  }

  return(arr);
}
Example #25
0
SEXP freadR(
  // params passed to freadMain
  SEXP inputArg,
  SEXP sepArg,
  SEXP decArg,
  SEXP quoteArg,
  SEXP headerArg,
  SEXP nrowLimitArg,
  SEXP skipArg,
  SEXP NAstringsArg,
  SEXP stripWhiteArg,
  SEXP skipEmptyLinesArg,
  SEXP fillArg,
  SEXP showProgressArg,
  SEXP nThreadArg,
  SEXP verboseArg,
  SEXP warnings2errorsArg,
  SEXP logical01Arg,

  // extras needed by callbacks from freadMain
  SEXP selectArg,
  SEXP dropArg,
  SEXP colClassesArg,
  SEXP integer64Arg,
  SEXP encodingArg
) {
  verbose = LOGICAL(verboseArg)[0];
  warningsAreErrors = LOGICAL(warnings2errorsArg)[0];

  freadMainArgs args;
  ncol = 0;
  dtnrows = 0;
  const char *ch, *ch2;
  if (!isString(inputArg) || LENGTH(inputArg)!=1)
    error("fread input must be a single character string: a filename or the data itself");
  ch = ch2 = (const char *)CHAR(STRING_ELT(inputArg,0));
  while (*ch2!='\n' && *ch2!='\r' && *ch2!='\0') ch2++;
  args.input = (*ch2=='\0') ? R_ExpandFileName(ch) : ch; // for convenience so user doesn't have to call path.expand()

  ch = args.input;
  while (*ch!='\0' && *ch!='\n' && *ch!='\r') ch++;
  if (*ch!='\0' || args.input[0]=='\0') {
    if (verbose) DTPRINT("Input contains a \\n or is \"\". Taking this to be text input (not a filename)\n");
    args.filename = NULL;
  } else {
    if (verbose) DTPRINT("Input contains no \\n. Taking this to be a filename to open\n");
    args.filename = args.input;
    args.input = NULL;
  }

  if (!isString(sepArg) || LENGTH(sepArg)!=1 || strlen(CHAR(STRING_ELT(sepArg,0)))>1)
    error("CfreadR: sep must be 'auto' or a single character ('\\n' is an acceptable single character)");
  args.sep = CHAR(STRING_ELT(sepArg,0))[0];   // '\0' when default "auto" was replaced by "" at R level

  if (!(isString(decArg) && LENGTH(decArg)==1 && strlen(CHAR(STRING_ELT(decArg,0)))==1))
    error("CfreadR: dec must be a single character such as '.' or ','");
  args.dec = CHAR(STRING_ELT(decArg,0))[0];

  if (!isString(quoteArg) || LENGTH(quoteArg)!=1 || strlen(CHAR(STRING_ELT(quoteArg,0))) > 1)
    error("CfreadR: quote must be a single character or empty \"\"");
  args.quote = CHAR(STRING_ELT(quoteArg,0))[0];

  // header is the only boolean where NA is valid and means 'auto'.
  // LOGICAL in R is signed 32 bits with NA_LOGICAL==INT_MIN, currently.
  args.header = false;
  if (LOGICAL(headerArg)[0]==NA_LOGICAL) args.header = NA_BOOL8;
  else if (LOGICAL(headerArg)[0]==TRUE) args.header = true;

  args.nrowLimit = INT64_MAX;
  // checked at R level
  if (isReal(nrowLimitArg)) {
    if (R_FINITE(REAL(nrowLimitArg)[0]) && REAL(nrowLimitArg)[0]>=0.0) args.nrowLimit = (int64_t)(REAL(nrowLimitArg)[0]);
  } else {
    if (INTEGER(nrowLimitArg)[0]>=1) args.nrowLimit = (int64_t)INTEGER(nrowLimitArg)[0];
  }

  args.logical01 = LOGICAL(logical01Arg)[0];
  args.skipNrow=-1;
  args.skipString=NULL;
  if (isString(skipArg)) {
    args.skipString = CHAR(STRING_ELT(skipArg,0));  // LENGTH==1 was checked at R level
  } else if (isInteger(skipArg)) {
    args.skipNrow = (int64_t)INTEGER(skipArg)[0];
  } else error("Internal error: skip not integer or string in freadR.c"); // # nocov

  if (!isNull(NAstringsArg) && !isString(NAstringsArg))
    error("'na.strings' is type '%s'.  Must be either NULL or a character vector.", type2char(TYPEOF(NAstringsArg)));
  int nnas = length(NAstringsArg);
  const char **NAstrings = (const char **)R_alloc((nnas + 1), sizeof(char*));  // +1 for the final NULL to save a separate nna variable
  for (int i=0; i<nnas; i++)
    NAstrings[i] = CHAR(STRING_ELT(NAstringsArg,i));
  NAstrings[nnas] = NULL;
  args.NAstrings = NAstrings;

  // here we use _Bool and rely on fread at R level to check these do not contain NA_LOGICAL
  args.stripWhite = LOGICAL(stripWhiteArg)[0];
  args.skipEmptyLines = LOGICAL(skipEmptyLinesArg)[0];
  args.fill = LOGICAL(fillArg)[0];
  args.showProgress = LOGICAL(showProgressArg)[0];
  if (INTEGER(nThreadArg)[0]<1) error("nThread(%d)<1", INTEGER(nThreadArg)[0]);
  args.nth = (uint32_t)INTEGER(nThreadArg)[0];
  args.verbose = verbose;
  args.warningsAreErrors = warningsAreErrors;

  // === extras used for callbacks ===
  if (!isString(integer64Arg) || LENGTH(integer64Arg)!=1) error("'integer64' must be a single character string");
  const char *tt = CHAR(STRING_ELT(integer64Arg,0));
  if (strcmp(tt, "integer64")==0) {
    readInt64As = CT_INT64;
  } else if (strcmp(tt, "character")==0) {
    readInt64As = CT_STRING;
  } else if (strcmp(tt,"double")==0 || strcmp(tt,"numeric")==0) {
    readInt64As = CT_FLOAT64;
  } else STOP("Invalid value integer64='%s'. Must be 'integer64', 'character', 'double' or 'numeric'", tt);

  colClassesSxp = colClassesArg;   // checked inside userOverride where it is used.

  if (!isNull(selectArg) && !isNull(dropArg)) STOP("Use either select= or drop= but not both.");
  selectSxp = selectArg;
  dropSxp = dropArg;

  // Encoding, #563: Borrowed from do_setencoding from base R
  // https://github.com/wch/r-source/blob/ca5348f0b5e3f3c2b24851d7aff02de5217465eb/src/main/util.c#L1115
  // Check for mkCharLenCE function to locate as to where where this is implemented.
  tt = CHAR(STRING_ELT(encodingArg, 0));
  if (strcmp(tt, "unknown")==0) ienc = CE_NATIVE;
  else if (strcmp(tt, "Latin-1")==0) ienc = CE_LATIN1;
  else if (strcmp(tt, "UTF-8")==0) ienc = CE_UTF8;
  else STOP("encoding='%s' invalid. Must be 'unknown', 'Latin-1' or 'UTF-8'", tt);
  // === end extras ===

  RCHK = PROTECT(allocVector(VECSXP, 2));
  // see kalibera/rchk#9 and Rdatatable/data.table#2865.  To avoid rchk false positives.
  // allocateDT() assigns DT to position 0. userOverride() assigns colNamesSxp to position 1; colNamesSxp is used in allocateDT()
  freadMain(args);
  UNPROTECT(1);
  return DT;
}
Example #26
0
SEXP
R_create2DArray(SEXP obj)
{
  SAFEARRAYBOUND bounds[2] =  {{0, 0}, {0, 0}};;
  SAFEARRAY *arr;
  void *data, *el;
  VARTYPE type = VT_R8;
  SEXP dim = GET_DIM(obj);
  int integer;
  double real;
  BSTR bstr;


  bounds[0].cElements = INTEGER(dim)[0];
  bounds[1].cElements = INTEGER(dim)[1];

  type = getDCOMType(obj);

  arr = SafeArrayCreate(type, 2, bounds);
  SafeArrayAccessData(arr, (void**) &data);

  long indices[2];
  UINT i, j, ctr = 0;
  for(j = 0 ; j < bounds[1].cElements; j++) {
    indices[1] = j;
    for(i = 0; i < bounds[0].cElements; i++, ctr++) {
      indices[0] = i;
      switch(TYPEOF(obj)) {
        case LGLSXP:
	  integer =  (LOGICAL(obj)[ctr] ? 1:0);
          el = &integer;
	  break;
        case REALSXP:
	  real = REAL(obj)[ctr];
          el = &real;
	  break;
        case INTSXP:
	  integer = INTEGER(obj)[ctr];
          el = &integer;
	  break;
        case STRSXP:
	  bstr = AsBstr(CHAR(STRING_ELT(obj, ctr)));
          el = (void*) bstr;
	  break;
        default:
	  continue;
	  break;
      }

      SafeArrayPutElement(arr, indices, el);
    }
  }
  SafeArrayUnaccessData(arr);

  VARIANT *var;
  var = (VARIANT*) malloc(sizeof(VARIANT));
  VariantInit(var);
  V_VT(var) = VT_ARRAY | type;
  V_ARRAY(var) = arr;

  SEXP ans;
  PROTECT(ans = R_MakeExternalPtr((void*) var, Rf_install("R_VARIANT"), R_NilValue));
  R_RegisterCFinalizer(ans, RDCOM_SafeArray_finalizer);  
  UNPROTECT(1);
  return(ans);
}
Example #27
0
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
{
    int k, mode;
    SEXP dimnames, dimnamesnames, p, q, r, result, xdims;
    const void *vmaxsave = vmaxget();

    mode = TYPEOF(x);
    xdims = getAttrib(x, R_DimSymbol);
    k = length(xdims);

    /* k is now the number of dims */
    int **subs = (int**)R_alloc(k, sizeof(int*));
    int *indx = (int*)R_alloc(k, sizeof(int));
    int *bound = (int*)R_alloc(k, sizeof(int));
    R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t));

    /* Construct a vector to contain the returned values. */
    /* Store its extents. */

    R_xlen_t n = 1;
    r = s;
    for (int i = 0; i < k; i++) {
	SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call));
	bound[i] = LENGTH(CAR(r));
	n *= bound[i];
	r = CDR(r);
    }
    PROTECT(result = allocVector(mode, n));
    r = s;
    for (int i = 0; i < k; i++) {
	indx[i] = 0;
	subs[i] = INTEGER(CAR(r));
	r = CDR(r);
    }
    offset[0] = 1;
    for (int i = 1; i < k; i++)
	offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];

    /* Transfer the subset elements from "x" to "a". */

    for (R_xlen_t i = 0; i < n; i++) {
	R_xlen_t ii = 0;
	for (int j = 0; j < k; j++) {
	    int jj = subs[j][indx[j]];
	    if (jj == NA_INTEGER) {
		ii = NA_INTEGER;
		goto assignLoop;
	    }
	    if (jj < 1 || jj > INTEGER(xdims)[j])
		errorcall(call, R_MSG_subs_o_b);
	    ii += (jj - 1) * offset[j];
	}

      assignLoop:
	switch (mode) {
	case LGLSXP:
	    if (ii != NA_INTEGER)
		LOGICAL(result)[i] = LOGICAL(x)[ii];
	    else
		LOGICAL(result)[i] = NA_LOGICAL;
	    break;
	case INTSXP:
	    if (ii != NA_INTEGER)
		INTEGER(result)[i] = INTEGER(x)[ii];
	    else
		INTEGER(result)[i] = NA_INTEGER;
	    break;
	case REALSXP:
	    if (ii != NA_INTEGER)
		REAL(result)[i] = REAL(x)[ii];
	    else
		REAL(result)[i] = NA_REAL;
	    break;
	case CPLXSXP:
	    if (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 (ii != NA_INTEGER)
		SET_STRING_ELT(result, i, STRING_ELT(x, ii));
	    else
		SET_STRING_ELT(result, i, NA_STRING);
	    break;
	case VECSXP:
	    if (ii != NA_INTEGER)
		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
	    else
		SET_VECTOR_ELT(result, i, R_NilValue);
	    break;
	case RAWSXP:
	    if (ii != NA_INTEGER)
		RAW(result)[i] = RAW(x)[ii];
	    else
		RAW(result)[i] = (Rbyte) 0;
	    break;
	default:
	    errorcall(call, _("array subscripting not handled for this type"));
	    break;
	}
	if (n > 1) {
	    int j = 0;
	    while (++indx[j] >= bound[j]) {
		indx[j] = 0;
		j = (j + 1) % k;
	    }
	}
    }

    PROTECT(xdims = allocVector(INTSXP, k));
    for(int i = 0 ; i < k ; i++)
	INTEGER(xdims)[i] = bound[i];
    setAttrib(result, R_DimSymbol, xdims);
    UNPROTECT(1); /* xdims */

    /* The array elements have been transferred. */
    /* Now we need to transfer the attributes. */
    /* Most importantly, we need to subset the */
    /* dimnames of the returned value. */

    dimnames = getAttrib(x, R_DimNamesSymbol);
    PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
    if (dimnames != R_NilValue) {
	int j = 0;
	PROTECT(xdims = allocVector(VECSXP, k));
	if (TYPEOF(dimnames) == VECSXP) {
	    r = s;
	    for (int i = 0; i < k ; i++) {
		if (bound[i] > 0) {
		  SET_VECTOR_ELT(xdims, j++,
			ExtractSubset(VECTOR_ELT(dimnames, i),
				      allocVector(STRSXP, bound[i]),
				      CAR(r), call));
		} else { /* 0-length dims have NULL dimnames */
		    SET_VECTOR_ELT(xdims, j++, R_NilValue);
		}
		r = CDR(r);
	    }
	}
	else {
	    p = dimnames;
	    q = xdims;
	    r = s;
	    for(int i = 0 ; i < k; i++) {
		SETCAR(q, allocVector(STRSXP, bound[i]));
		SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call));
		p = CDR(p);
		q = CDR(q);
		r = CDR(r);
	    }
	}
	setAttrib(xdims, R_NamesSymbol, dimnamesnames);
	setAttrib(result, R_DimNamesSymbol, xdims);
	UNPROTECT(1); /* xdims */
    }
    /* This was removed for matrices in 1998
       copyMostAttrib(x, result); */
    /* Free temporary memory */
    vmaxset(vmaxsave);
    if (drop)
	DropDims(result);
    UNPROTECT(2); /* dimnamesnames, result */
    return result;
}
Example #28
0
SEXP export_plink_tped(SEXP Snpnames, SEXP Chromosomes, SEXP Map,
                       SEXP Snpdata, SEXP Nsnps, SEXP Nids, SEXP Coding,
                       SEXP Pedfilename, SEXP ExportNumeric)
{
    std::vector<std::string> snpName;
    for(unsigned int i=0; i<((unsigned int) length(Snpnames)); i++)
        snpName.push_back(CHAR(STRING_ELT(Snpnames,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)));

    std::vector<std::string> chromosome;
    for(unsigned int i=0; i<((unsigned int) length(Chromosomes)); i++)
        chromosome.push_back(CHAR(STRING_ELT(Chromosomes,i)));

    std::vector<double> position;
    for(unsigned int i=0; i<((unsigned int) length(Map)); i++)
        position.push_back(REAL(Map)[i]);

    //Rprintf("0\n");
    unsigned int nsnps = INTEGER(Nsnps)[0];
    int nids = INTEGER(Nids)[0];
    bool exportNumeric = LOGICAL(ExportNumeric)[0];
    std::string filename = CHAR(STRING_ELT(Pedfilename,0));
    std::ofstream fileWoA;
    int ieq1 = 1;
    char * snpdata = (char *) RAW(Snpdata);

    //	int gtint[nids];
    int *gtint = new (std::nothrow) int[nids];

    //Rprintf("nsnps=%d\n",nsnps);
    //Rprintf("nids=%d\n",nids);

    //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 = nids/4;
    }
    else {
        nbytes = ceil(1.*nids/4.);
    }

    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, &nids, &ieq1, gtint);
        Genotype = getGenotype(coding[csnp], sep);
        fileWoA << chromosome[csnp] << " " << snpName[csnp]
                << " 0 " << (unsigned long int) position[csnp];

        if (!exportNumeric) {
            for (int i=0; i<nids; i++) {
                fileWoA << " " << Genotype[gtint[i]];
            }
        } else {
            for (int i=0; i<nids; i++) {
                if (gtint[i]==0)
                    fileWoA << " NA";
                else
                    fileWoA << " " << (gtint[i]-1);
            }
        }
        fileWoA << "\n";
    delete [] Genotype;
        //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]];
       //fileWoA << " x" << Letter0 << Letter1 << Genotype[0] << Genotype[1] << Genotype[2] << Genotype[3];
       }
       // end unwrap
       fileWoA << "\n";
       }
    **/
    //Rprintf("C\n");
    fileWoA.close();

    //Rprintf("oooo!" );
    //for (int i=0; i<10; i++) Rprintf("%d ",sex[i]);
    //Rprintf("oooo!\n" );

    delete [] gtint;

    return R_NilValue;
}
Example #29
0
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, ax, px, x, subs;
    int drop, i, nsubs, type;

    /* By default we drop extents of length 1 */

    /* Handle cases of extracting a single element from a simple vector
       or matrix directly to improve speed for these simple cases. */
    SEXP cdrArgs = CDR(args);
    SEXP cddrArgs = CDR(cdrArgs);
    if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
	TAG(cdrArgs) == R_NilValue) {
	/* one index, not named */
	SEXP x = CAR(args);
	if (ATTRIB(x) == R_NilValue) {
	    SEXP s = CAR(cdrArgs);
	    R_xlen_t i = scalarIndex(s);
	    switch (TYPEOF(x)) {
	    case REALSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarReal( REAL(x)[i-1] );
		break;
	    case INTSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarInteger( INTEGER(x)[i-1] );
		break;
	    case LGLSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarLogical( LOGICAL(x)[i-1] );
		break;
//	    do the more rare cases as well, since we've already prepared everything:
	    case CPLXSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarComplex( COMPLEX(x)[i-1] );
		break;
	    case RAWSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarRaw( RAW(x)[i-1] );
		break;
	    default: break;
	    }
	}
    }
    else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
	     TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
	/* two indices, not named */
	SEXP x = CAR(args);
	SEXP attr = ATTRIB(x);
	if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
	    /* only attribute of x is 'dim' */
	    SEXP dim = CAR(attr);
	    if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
		/* x is a matrix */
		SEXP si = CAR(cdrArgs);
		SEXP sj = CAR(cddrArgs);
		R_xlen_t i = scalarIndex(si);
		R_xlen_t j = scalarIndex(sj);
		int nrow = INTEGER(dim)[0];
		int ncol = INTEGER(dim)[1];
		if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
		    /* indices are legal scalars */
		    R_xlen_t k = i - 1 + nrow * (j - 1);
		    switch (TYPEOF(x)) {
		    case REALSXP:
			if (k < LENGTH(x))
			    return ScalarReal( REAL(x)[k] );
			break;
		    case INTSXP:
			if (k < LENGTH(x))
			    return ScalarInteger( INTEGER(x)[k] );
			break;
		    case LGLSXP:
			if (k < LENGTH(x))
			    return ScalarLogical( LOGICAL(x)[k] );
			break;
		    case CPLXSXP:
			if (k < LENGTH(x))
			    return ScalarComplex( COMPLEX(x)[k] );
			break;
		    case RAWSXP:
			if (k < LENGTH(x))
			    return ScalarRaw( RAW(x)[k] );
			break;
		    default: break;
		    }
		}
	    }
	}
    }

    PROTECT(args);

    drop = 1;
    ExtractDropArg(args, &drop);
    x = CAR(args);

    /* This was intended for compatibility with S, */
    /* but in fact S does not do this. */
    /* FIXME: replace the test by isNull ... ? */

    if (x == R_NilValue) {
	UNPROTECT(1);
	return x;
    }
    subs = CDR(args);
    nsubs = length(subs); /* Will be short */
    type = TYPEOF(x);

    /* Here coerce pair-based objects into generic vectors. */
    /* All subsetting takes place on the generic vector form. */

    ax = x;
    if (isVector(x))
	PROTECT(ax);
    else if (isPairList(x)) {
	SEXP dim = getAttrib(x, R_DimSymbol);
	int ndim = length(dim);
	if (ndim > 1) {
	    PROTECT(ax = allocArray(VECSXP, dim));
	    setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
	    setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
	}
	else {
	    PROTECT(ax = allocVector(VECSXP, length(x)));
	    setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
	}
	for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
	    SET_VECTOR_ELT(ax, i++, CAR(px));
    }
    else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));

    /* This is the actual subsetting code. */
    /* The separation of arrays and matrices is purely an optimization. */

    if(nsubs < 2) {
	SEXP dim = getAttrib(x, R_DimSymbol);
	int ndim = length(dim);
	PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
				   call));
	/* one-dimensional arrays went through here, and they should
	   have their dimensions dropped only if the result has
	   length one and drop == TRUE
	*/
	if(ndim == 1) {
	    SEXP attr, attrib, nattrib;
	    int len = length(ans);

	    if(!drop || len > 1) {
		// must grab these before the dim is set.
		SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
		PROTECT(attr = allocVector(INTSXP, 1));
		INTEGER(attr)[0] = length(ans);
		setAttrib(ans, R_DimSymbol, attr);
		if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
		    /* reinstate dimnames, include names of dimnames */
		    PROTECT(nattrib = duplicate(attrib));
		    SET_VECTOR_ELT(nattrib, 0, nm);
		    setAttrib(ans, R_DimNamesSymbol, nattrib);
		    setAttrib(ans, R_NamesSymbol, R_NilValue);
		    UNPROTECT(1);
		}
		UNPROTECT(2);
	    }
	}
    } else {
	if (nsubs != length(getAttrib(x, R_DimSymbol)))
	    errorcall(call, _("incorrect number of dimensions"));
	if (nsubs == 2)
	    ans = MatrixSubset(ax, subs, call, drop);
	else
	    ans = ArraySubset(ax, subs, call, drop);
	PROTECT(ans);
    }

    /* Note: we do not coerce back to pair-based lists. */
    /* They are "defunct" in this version of R. */

    if (type == LANGSXP) {
	ax = ans;
	PROTECT(ans = allocList(LENGTH(ax)));
	if ( LENGTH(ax) > 0 )
	    SET_TYPEOF(ans, LANGSXP);
	for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
	    SETCAR(px, VECTOR_ELT(ax, i++));
	setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
	setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
	setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
	SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
    }
    else {
	PROTECT(ans);
    }
    if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
	setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
	if(!IS_S4_OBJECT(x))
#endif
	    setAttrib(ans, R_ClassSymbol, R_NilValue);
    }
    UNPROTECT(4);
    return ans;
}
Example #30
0
File: hbin.c Project: nikko/hexbin
SEXP hbin(SEXP x, SEXP y, SEXP swts, SEXP shape, 
          SEXP size, SEXP rx, SEXP ry, SEXP bnd, SEXP n,
	  SEXP doCellid){
/*	Copyright 1991
	Version Date:	September 16, 1994
	Programmer:	Dan Carr, Conversion to C, triangulation, 
                        and Rapi Nicholas Lewin-Koh (2010)
	Indexing:	Left to right, bottom to top
			bnd[0] rows, bnd[2] columns
        Input Vars:
	   x,y       the values of x and y
           xcm,ycm   vectors for the center of mass of the returned hexagons
           shape     the shape parameter for the hexagons
           cell
           cnt 
	Output:	     
                     cell ids for non empty cells, revised bnd(1)
                     optionally also return cellid(1:n), and wcnt
      Copyright (2004) Nicholas Lewin-Koh and Martin Maechler */


  int nc, nn;
  int i, i1, i2, iinc;
  int j1, j2, jinc;
  int L, ll, lmax, lat, tcell;
  double c1, c2, con1, con2, dist1, fsize;
  double sx, sy, xmin, ymin, xr, yr;
  uint keepID=0, doWeights=0;
  int prcnt=0;
  SEXP ans;
  SEXP cnt, cell, wcnt, cellid,  xcm,  ycm;
	
        

	if(LOGICAL(doCellid)[0]>0) keepID = 1;
	if(length(swts) > 0 || swts != R_NilValue) doWeights = 1;
       /*_______Alloc and protect the necessary result vectors, then set to 0_____________*/
        lmax=INTEGER(bnd)[0]*INTEGER(bnd)[1];
    
	PROTECT(cnt = allocVector(INTSXP, lmax));
        prcnt++;
	PROTECT(cell = allocVector(INTSXP, lmax));
        prcnt++;
	PROTECT(xcm = allocVector(REALSXP, lmax));
        prcnt++;
	PROTECT(ycm = allocVector(REALSXP, lmax));
        prcnt++;	 
	if(keepID > 0) PROTECT(cellid = allocVector(INTSXP, INTEGER(n)[0]));
	else PROTECT(cellid = allocVector(NILSXP, 1));
	prcnt++;
	  
	if(doWeights > 0)PROTECT(wcnt = allocVector(REALSXP, lmax));
	else PROTECT(wcnt = allocVector(NILSXP, 1));
	prcnt++;	


	memset(INTEGER(cell),0,lmax*sizeof(int));
	memset(INTEGER(cnt),0,lmax*sizeof(int));
        memset(REAL(xcm),0,lmax*sizeof(double));
        memset(REAL(ycm),0,lmax*sizeof(double));

	if(doWeights>0) memset(REAL(wcnt),0,lmax*sizeof(double));

       /*_______Constants for scaling the data_____________________________*/
	fsize=INTEGER(size)[0];
        nn=INTEGER(n)[0];
	xmin = REAL(rx)[0];
	ymin = REAL(ry)[0];
	xr = REAL(rx)[1]-xmin;
	yr = REAL(ry)[1]-ymin;
        
	c1 = fsize/xr;
	c2 = (fsize*REAL(shape)[0])/(yr*sqrt(3.0));

	jinc= INTEGER(bnd)[1];
	lat=jinc+1;
	iinc= 2*jinc;
	con1 = 0.25;
	con2 = 1.0/3.0;
        
	/*_______Binning loop______________________________________________*/
	
	for(i=0; i<nn; i++){
	  sx = c1 * (REAL(x)[i] - xmin);
	  sy = c2 * (REAL(y)[i] - ymin);
	  j1 = sx+.5;
	  i1 = sy+.5;
	  dist1 = (sx-j1)*(sx-j1)+ 3.0*(sy-i1)*(sy-i1);
	  /* need floor in C for this, same effect as trunc*/
	  if(dist1 < con1) L = i1*iinc + j1 + 1;
	  else if(dist1 > con2) L = floor(sy)*iinc + floor(sx) + lat;
	  else{
	    j2 = sx;
	    i2 = sy;
	    if(dist1 <= ((sx - j2 - 0.5)*(sx - j2 - 0.5)) + 3.0*((sy - i2 - 0.5)*(sy - i2 - 0.5))) L = i1*iinc + j1 + 1;
	    else L=i2*iinc+ j2+lat;
	  }
	  ll=L-1;
	  INTEGER(cnt)[ll]++;
	  if(doWeights > 0) REAL(wcnt)[ll] = REAL(wcnt)[ll] + REAL(swts)[i];
	  if (keepID > 0) INTEGER(cellid)[i] = L;
	  REAL(xcm)[ll] = REAL(xcm)[ll] + (REAL(x)[i]-REAL(xcm)[ll])/INTEGER(cnt)[ll];
	  REAL(ycm)[ll] = REAL(ycm)[ll]+ (REAL(y)[i]-REAL(ycm)[ll])/INTEGER(cnt)[ll];
	}

/*_______Compression of output________________________________________*/

        nc=-1;
        for(L=0;L<lmax;L++){
	  if(INTEGER(cnt)[L] > 0){
	    nc=nc+1;
	    INTEGER(cell)[nc]=L+1;
	    INTEGER(cnt)[nc]=INTEGER(cnt)[L];	    
	    REAL(xcm)[nc]=REAL(xcm)[L];
	    REAL(ycm)[nc]=REAL(ycm)[L];
	  }
	}

       INTEGER(n)[0]=nc+1;
       INTEGER(bnd)[0]=(INTEGER(cell)[nc]-1)/INTEGER(bnd)[1]+1;
       /* Output constructor */
       PROTECT(ans = allocVector(VECSXP, 6));
       prcnt++;
       SET_VECTOR_ELT(ans, 0, n);
       SET_VECTOR_ELT(ans, 1, cell);
       SET_VECTOR_ELT(ans, 2, cnt);
       SET_VECTOR_ELT(ans, 3, wcnt);
       SET_VECTOR_ELT(ans, 4, xcm);
       SET_VECTOR_ELT(ans, 5, ycm);       

       UNPROTECT(prcnt);
       return(ans);
}